coollang/lib/interp.ml

(* 트리 워킹 인터프리터.

   여기 도달한 프로그램은 이미 타입, effect, capability, ownership 검사를
   통과했다. 그러므로 이 파일은 검사하지 않는다 — 검사기가 이미 답한 질문을
   실행 시점에 다시 묻는 것은 두 번째 진실을 만드는 일이다.

   실행 시점 오류로 남는 것은 검사기가 원리적으로 못 잡는 것뿐이다:
   0으로 나누기, 리스트 범위, 그리고 아직 없는 표준 라이브러리 이름.

   권한의 유일한 출처는 런타임이다. 소스에는 capability를 만드는 문법이 없고,
   main은 자기가 선언한 capability만 받는다. 선언하지 않은 권한은 프로그램
   어디에도 존재하지 않는다 — 보안 정리 (i)의 실행 시점 대응물이다. *)

type value =
  | VUnit
  | VInt of int
  | VBool of bool
  | VStr of string
  | VList of value list
  | VStruct of string * (string * value ref) list
  | VEnum of string * string * value list (* enum, variant, 인자 *)
  | VClosure of { params : string list; body : Ir.t; env : env }
  | VFn of Ir.fn
  | VCtor of string * string * int (* 아직 인자를 안 받은 생성자 *)
  | VBuiltin of string
  | VNative of (value list -> value)
  | VCap of string * (string * (value list -> value)) list
  | VScope of string

and env = (string * value ref) list list

exception Return_exc of value
exception Fail of Token.pos * string

let fail pos msg = raise (Fail (pos, msg))

let rec show = function
  | VUnit -> "unit"
  | VInt n -> string_of_int n
  | VBool b -> if b then "true" else "false"
  | VStr s -> s
  | VList xs -> "[" ^ String.concat ", " (List.map show xs) ^ "]"
  | VStruct (n, fs) ->
      n ^ "{"
      ^ String.concat ", " (List.map (fun (k, v) -> k ^ ": " ^ show !v) fs)
      ^ "}"
  | VEnum (_, v, []) -> v
  | VEnum (_, v, args) ->
      v ^ "(" ^ String.concat ", " (List.map show args) ^ ")"
  | VClosure _ | VFn _ | VBuiltin _ | VCtor _ | VNative _ -> "<fn>"
  | VCap (n, _) -> "<capability " ^ n ^ ">"
  | VScope n -> "<scope " ^ n ^ ">"

let rec eq a b =
  match (a, b) with
  | VInt x, VInt y -> x = y
  | VBool x, VBool y -> x = y
  | VStr x, VStr y -> x = y
  | VUnit, VUnit -> true
  | VList x, VList y -> List.length x = List.length y && List.for_all2 eq x y
  | VEnum (_, v1, a1), VEnum (_, v2, a2) ->
      v1 = v2 && List.length a1 = List.length a2 && List.for_all2 eq a1 a2
  | _ -> false

(* ------------------------------------------------------------------ *)
(* 환경                                                                *)
(* ------------------------------------------------------------------ *)

let lookup (env : env) n =
  let rec go = function
    | [] -> None
    | s :: r -> (
        match List.assoc_opt n s with Some v -> Some v | None -> go r)
  in
  go env

let bind (env : env) n v : env =
  match env with s :: r -> ((n, ref v) :: s) :: r | [] -> [ [ (n, ref v) ] ]

(* ------------------------------------------------------------------ *)
(* 런타임이 제공하는 것                                                *)
(* ------------------------------------------------------------------ *)

(* 문자열 도우미. 언어에 인덱싱 연산자가 없으므로 이 일은 런타임 몫이다. *)
let find_sub hay needle =
  let n = String.length needle and h = String.length hay in
  let rec go i =
    if i + n > h then None
    else if String.sub hay i n = needle then Some i
    else go (i + 1)
  in
  if n = 0 then Some 0 else go 0

let split_on s sep =
  if sep = "" then [ s ]
  else
    let n = String.length sep in
    let rec go s acc =
      match find_sub s sep with
      | None -> List.rev (s :: acc)
      | Some i ->
          go
            (String.sub s (i + n) (String.length s - i - n))
            (String.sub s 0 i :: acc)
    in
    go s []

let out = Buffer.create 1024

(* 프로그램 인자. 런타임이 들고 있다가 Args capability를 통해서만 준다 —
   전역 변수로 아무 데서나 읽을 수 있으면 그것이 ambient authority다. *)
let argv : string list ref = ref []

let read_whole path =
  let ic = open_in_bin path in
  let n = in_channel_length ic in
  let s = really_input_string ic n in
  close_in ic;
  s

(* IO 오류는 문자열로 돌려준다. 런타임이 사용자 정의 enum을 만들 수는 없고,
   만들 수 있게 하면 런타임이 프로그램의 타입을 알아야 한다. v0의 선은
   여기다 — Result[a, String]. *)
let root_capability name : value option =
  match name with
  | "Console" ->
      Some
        (VCap
           ( "Console",
             [
               ( "print",
                 fun args ->
                   List.iter (fun v -> Buffer.add_string out (show v)) args;
                   Buffer.add_char out '\n';
                   VUnit );
             ] ))
  | "File" ->
      Some
        (VCap
           ( "File",
             [
               ( "read",
                 fun args ->
                   match args with
                   | [ VStr path ] -> (
                       try VEnum ("Result", "Ok", [ VStr (read_whole path) ])
                       with Sys_error m -> VEnum ("Result", "Err", [ VStr m ]))
                   | _ -> VEnum ("Result", "Err", [ VStr "read: 경로가 필요합니다" ]) );
             ] ))
  | "Args" ->
      Some
        (VCap
           ( "Args",
             [ ("all", fun _ -> VList (List.map (fun s -> VStr s) !argv)) ] ))
  | "TaskScope" ->
      (* 루트 스코프. 구조적 동시성의 뿌리도 런타임이 준다 — 프로그램이
         스스로 만들 수 있으면 부모 없는 작업이 생긴다. *)
      Some (VScope "root")
  | _ -> None

(* 런타임이 구현한 이름 전부. std/*.cool의 선언과 이 목록이 어긋나면 검사는
   통과하고 실행이 죽는다 — 그 간극을 테스트가 막는다 (docs/friction.md F7).
   v1에서 std를 coollang으로 구현하면 이 목록 자체가 사라진다. *)
let implemented =
  [
    "string.len";
    "string.is_empty";
    "string.concat";
    "string.split";
    "string.join";
    "string.trim";
    "string.starts_with";
    "string.contains";
    "int.show";
    "int.abs";
    "int.parse";
    "bool.show";
    "list.len";
    "list.is_empty";
    "list.first";
    "list.nth";
    "list.push";
    "list.concat";
    "list.reverse";
    "list.enumerate";
    "list.each";
    "list.map";
    "list.filter";
    "list.fold";
    "option.is_some";
    "option.map";
    "option.unwrap_or";
    "option.ok_or";
    "result.is_ok";
    "result.map";
    "result.map_err";
    "result.unwrap_or";
  ]

let builtin pos name (args : value list) : value =
  match (name, args) with
  | "string.concat", [ VStr a; VStr b ] -> VStr (a ^ b)
  | "string.len", [ VStr a ] -> VInt (String.length a)
  | "string.is_empty", [ VStr a ] -> VBool (a = "")
  | "string.split", [ VStr s; VStr sep ] ->
      VList (List.map (fun x -> VStr x) (split_on s sep))
  | "string.trim", [ VStr s ] -> VStr (String.trim s)
  | "string.starts_with", [ VStr s; VStr p ] ->
      VBool
        (String.length s >= String.length p
        && String.sub s 0 (String.length p) = p)
  | "string.contains", [ VStr s; VStr n ] -> VBool (find_sub s n <> None)
  | "int.show", [ VInt n ] -> VStr (string_of_int n)
  | "int.abs", [ VInt n ] -> VInt (abs n)
  | "int.parse", [ VStr s ] -> (
      match int_of_string_opt (String.trim s) with
      | Some n -> VEnum ("Result", "Ok", [ VInt n ])
      | None -> VEnum ("Result", "Err", [ VStr (s ^ "은(는) 정수가 아닙니다") ]))
  | "bool.show", [ VBool b ] -> VStr (if b then "true" else "false")
  | "list.len", [ VList xs ] -> VInt (List.length xs)
  | "list.is_empty", [ VList xs ] -> VBool (xs = [])
  | "list.push", [ VList xs; x ] -> VList (xs @ [ x ])
  | "list.concat", [ VList xs; VList ys ] -> VList (xs @ ys)
  | "list.reverse", [ VList xs ] -> VList (List.rev xs)
  | "list.first", [ VList xs ] -> (
      match xs with
      | [] -> VEnum ("Option", "None", [])
      | x :: _ -> VEnum ("Option", "Some", [ x ]))
  | "list.enumerate", [ VList xs ] ->
      VList
        (List.mapi
           (fun i x ->
             VStruct ("List.Indexed", [ ("i", ref (VInt i)); ("value", ref x) ]))
           xs)
  | "list.nth", [ VList xs; VInt i ] -> (
      match List.nth_opt xs i with
      | Some x -> VEnum ("Option", "Some", [ x ])
      | None -> VEnum ("Option", "None", []))
  | "string.join", [ VStr sep; VList parts ] ->
      VStr
        (String.concat sep
           (List.map (function VStr s -> s | v -> show v) parts))
  | "option.is_some", [ VEnum ("Option", v, _) ] -> VBool (v = "Some")
  | "option.unwrap_or", [ VEnum ("Option", "Some", [ x ]); _ ] -> x
  | "option.unwrap_or", [ _; fallback ] -> fallback
  | "option.ok_or", [ VEnum ("Option", "Some", [ x ]); _ ] ->
      VEnum ("Result", "Ok", [ x ])
  | "option.ok_or", [ _; e ] -> VEnum ("Result", "Err", [ e ])
  | "result.is_ok", [ VEnum ("Result", v, _) ] -> VBool (v = "Ok")
  | "result.unwrap_or", [ VEnum ("Result", "Ok", [ x ]); _ ] -> x
  | "result.unwrap_or", [ _; fallback ] -> fallback
  | _ ->
      fail pos (Printf.sprintf "%s은(는) 런타임이 제공하지 않습니다 (표준 라이브러리가 아직 없습니다)" name)

(* ------------------------------------------------------------------ *)
(* 실행                                                                *)
(* ------------------------------------------------------------------ *)

type st = { prog : Ir.program }

let rec eval st (env : env) (e : Ir.t) : value =
  match e with
  | Ir.I_unit -> VUnit
  | Ir.I_lit (Ast.L_int n) -> VInt (int_of_string n)
  | Ir.I_lit (Ast.L_str s) -> VStr s
  | Ir.I_lit (Ast.L_bool b) -> VBool b
  | Ir.I_ref (k, pos) -> eval_ref st env k pos
  | Ir.I_list xs -> VList (List.map (eval st env) xs)
  | Ir.I_make (n, fields) ->
      VStruct (n, List.map (fun (k, e) -> (k, ref (eval st env e))) fields)
  | Ir.I_closure c -> VClosure { params = c.c_params; body = c.c_body; env }
  | Ir.I_if { cond; then_; else_ } -> (
      match eval st env cond with
      | VBool true -> eval st ([] :: env) then_
      | _ -> eval st ([] :: env) else_)
  | Ir.I_match { scrutinee; arms; pos } ->
      let v = eval st env scrutinee in
      let rec go = function
        | [] -> fail pos "match에서 어떤 팔도 맞지 않았습니다"
        | (p, body) :: rest -> (
            match match_pat v p with
            | None -> go rest
            | Some binds ->
                let env =
                  List.fold_left (fun e (n, v) -> bind e n v) ([] :: env) binds
                in
                eval st env body)
      in
      go arms
  | Ir.I_scope { name; body; _ } ->
      (* v0의 실행 의미: 자식 작업은 순차로 돈다. 블록을 나가는 것이 join이다.
         구조가 먼저고 병렬성은 그 위의 최적화다 — 순서가 반대면 취소와
         전파를 나중에 끼워 넣게 된다. *)
      let env = bind ([] :: env) name (VScope name) in
      eval st env body
  | Ir.I_seq (stmts, tail) ->
      let env = List.fold_left (fun env s -> exec st env s) ([] :: env) stmts in
      eval st env tail
  | Ir.I_call { callee; args; pos } ->
      let f = eval st env callee in
      let args = List.map (eval st env) args in
      apply st pos f args
  | Ir.I_field { obj; name; pos } -> (
      match eval st env obj with
      | VStruct (sn, fields) -> (
          match List.assoc_opt name fields with
          | Some r -> !r
          | None -> fail pos (Printf.sprintf "%s에 %s 필드가 없습니다" sn name))
      | VCap (cn, meths) -> (
          (* capability 메서드는 값을 통해서만 나온다. 여기가 권한이 코드로
             흐르는 유일한 통로다. *)
          match List.assoc_opt name meths with
          | Some f -> VNative f
          | None ->
              fail pos (Printf.sprintf "capability %s에 %s이(가) 없습니다" cn name))
      | VScope _ when name = "spawn" ->
          VNative
            (fun args ->
              match args with
              | [ f ] -> apply st pos f []
              | _ -> fail pos "spawn은 함수 하나를 받습니다")
      | other -> fail pos (Printf.sprintf "%s에는 필드가 없습니다" (show other)))
  | Ir.I_crash (msg, pos) -> (
      match eval st env msg with VStr s -> fail pos s | v -> fail pos (show v))
  | Ir.I_unary (op, e, pos) -> (
      match (op, eval st env e) with
      | Ast.U_not, VBool b -> VBool (not b)
      | Ast.U_neg, VInt n -> VInt (-n)
      | _ -> fail pos "단항 연산자의 피연산자가 맞지 않습니다")
  | Ir.I_binary (op, a, b, pos) -> eval_binary st env op a b pos

and eval_ref st env k pos =
  match k with
  | Ir.R_local n -> (
      match lookup env n with
      | Some r -> !r
      | None -> fail pos (Printf.sprintf "%s이(가) 묶여 있지 않습니다" n))
  | Ir.R_ctor (enum, name) -> (
      match Hashtbl.find_opt st.prog.Ir.ctors name with
      | Some (_, 0) -> VEnum (enum, name, [])
      | Some (_, n) -> VCtor (enum, name, n)
      | None -> VEnum (enum, name, []))
  | Ir.R_global n -> (
      match Hashtbl.find_opt st.prog.Ir.fns n with
      | Some f -> VFn f
      | None -> (
          match Hashtbl.find_opt st.prog.Ir.consts n with
          | Some e -> eval st [ [] ] e
          | None -> fail pos (Printf.sprintf "%s을(를) 찾을 수 없습니다" n)))
  | Ir.R_builtin n -> VBuiltin n

and apply st pos f args =
  match f with
  | VFn fn -> (
      let env = [ List.map2 (fun p a -> (p, ref a)) fn.Ir.fn_params args ] in
      try eval st env fn.Ir.fn_body with Return_exc v -> v)
  | VClosure { params; body; env } -> (
      let env = List.map2 (fun p a -> (p, ref a)) params args :: env in
      try eval st env body with Return_exc v -> v)
  | VCtor (enum, name, _) -> VEnum (enum, name, args)
  (* 고차 builtin은 여기서 처리한다 — apply를 다시 부를 수 있어야 하므로 *)
  | VBuiltin "list.each" -> (
      match args with
      | [ VList xs; f ] ->
          List.iter (fun x -> ignore (apply st pos f [ x ])) xs;
          VUnit
      | _ -> fail pos "list.each는 리스트와 함수를 받습니다")
  | VBuiltin "list.map" -> (
      match args with
      | [ VList xs; f ] -> VList (List.map (fun x -> apply st pos f [ x ]) xs)
      | _ -> fail pos "list.map은 리스트와 함수를 받습니다")
  | VBuiltin "list.filter" -> (
      match args with
      | [ VList xs; f ] ->
          VList
            (List.filter
               (fun x ->
                 match apply st pos f [ x ] with VBool b -> b | _ -> false)
               xs)
      | _ -> fail pos "list.filter는 리스트와 함수를 받습니다")
  | VBuiltin "option.map" -> (
      match args with
      | [ VEnum ("Option", "Some", [ x ]); f ] ->
          VEnum ("Option", "Some", [ apply st pos f [ x ] ])
      | [ o; _ ] -> o
      | _ -> fail pos "option.map은 Option과 함수를 받습니다")
  | VBuiltin "result.map" -> (
      match args with
      | [ VEnum ("Result", "Ok", [ x ]); f ] ->
          VEnum ("Result", "Ok", [ apply st pos f [ x ] ])
      | [ r; _ ] -> r
      | _ -> fail pos "result.map은 Result와 함수를 받습니다")
  | VBuiltin "result.map_err" -> (
      match args with
      | [ VEnum ("Result", "Err", [ e ]); f ] ->
          VEnum ("Result", "Err", [ apply st pos f [ e ] ])
      | [ r; _ ] -> r
      | _ -> fail pos "result.map_err는 Result와 함수를 받습니다")
  | VBuiltin "list.fold" -> (
      match args with
      | [ VList xs; init; f ] ->
          List.fold_left (fun acc x -> apply st pos f [ acc; x ]) init xs
      | _ -> fail pos "list.fold는 리스트, 초기값, 함수를 받습니다")
  | VBuiltin n -> builtin pos n args
  | VNative f -> f args
  | other -> fail pos (Printf.sprintf "%s은(는) 부를 수 없습니다" (show other))

and exec st env (s : Ir.stmt) : env =
  match s with
  | Ir.S_do e ->
      ignore (eval st env e);
      env
  | Ir.S_return (e, _) -> raise (Return_exc (eval st env e))
  | Ir.S_let (p, e, pos) -> (
      let v = eval st env e in
      match match_pat v p with
      | None -> fail pos "let 패턴이 값과 맞지 않습니다"
      | Some binds -> List.fold_left (fun e (n, v) -> bind e n v) env binds)
  | Ir.S_assign { place; value; pos } -> (
      let v = eval st env value in
      match place with
      | Ir.I_ref (Ir.R_local n, _) -> (
          match lookup env n with
          | Some r ->
              r := v;
              env
          | None -> fail pos (Printf.sprintf "%s이(가) 묶여 있지 않습니다" n))
      | Ir.I_field { obj; name; _ } -> (
          match eval st env obj with
          | VStruct (_, fields) -> (
              match List.assoc_opt name fields with
              | Some r ->
                  r := v;
                  env
              | None -> fail pos (Printf.sprintf "%s 필드가 없습니다" name))
          | _ -> fail pos "필드에 대입할 수 없습니다")
      | _ -> fail pos "대입할 수 없는 자리입니다")

and match_pat v (p : Ir.pat) : (string * value) list option =
  match (p, v) with
  | Ir.IP_wild, _ -> Some []
  | Ir.IP_bind n, _ -> Some [ (n, v) ]
  | Ir.IP_lit (Ast.L_int n), VInt m ->
      if int_of_string n = m then Some [] else None
  | Ir.IP_lit (Ast.L_str s), VStr t -> if s = t then Some [] else None
  | Ir.IP_lit (Ast.L_bool b), VBool c -> if b = c then Some [] else None
  | Ir.IP_ctor (name, ps), VEnum (_, vn, args) ->
      if name <> vn || List.length ps <> List.length args then None
      else
        List.fold_left2
          (fun acc p a ->
            match (acc, match_pat a p) with
            | Some xs, Some ys -> Some (xs @ ys)
            | _ -> None)
          (Some []) ps args
  | _ -> None

and eval_binary st env op a b pos =
  match op with
  (* 단축 평가. 오른쪽을 먼저 계산하면 && 의 의미가 달라진다 *)
  | Ast.B_and -> (
      match eval st env a with VBool false -> VBool false | _ -> eval st env b)
  | Ast.B_or -> (
      match eval st env a with VBool true -> VBool true | _ -> eval st env b)
  | _ -> (
      let x = eval st env a and y = eval st env b in
      match (op, x, y) with
      | Ast.B_eq, _, _ -> VBool (eq x y)
      | Ast.B_ne, _, _ -> VBool (not (eq x y))
      | Ast.B_lt, VInt m, VInt n -> VBool (m < n)
      | Ast.B_le, VInt m, VInt n -> VBool (m <= n)
      | Ast.B_gt, VInt m, VInt n -> VBool (m > n)
      | Ast.B_ge, VInt m, VInt n -> VBool (m >= n)
      | Ast.B_add, VInt m, VInt n -> VInt (m + n)
      | Ast.B_sub, VInt m, VInt n -> VInt (m - n)
      | Ast.B_mul, VInt m, VInt n -> VInt (m * n)
      | Ast.B_div, VInt _, VInt 0 -> fail pos "0으로 나눌 수 없습니다"
      | Ast.B_div, VInt m, VInt n -> VInt (m / n)
      | Ast.B_rem, VInt _, VInt 0 -> fail pos "0으로 나눌 수 없습니다"
      | Ast.B_rem, VInt m, VInt n -> VInt (m mod n)
      | _ -> fail pos "연산자의 피연산자 타입이 맞지 않습니다")

(* ------------------------------------------------------------------ *)
(* 진입                                                                *)
(* ------------------------------------------------------------------ *)

(* main이 선언한 capability만 런타임이 넘긴다. 선언하지 않은 권한은
   프로그램 안에 존재하지 않는다. *)
(* 실패해도 그때까지 나온 출력을 함께 돌려준다.
   print는 실제로 일어난 effect다. 일어난 일을 안 보여주면 "어디까지 갔나"를
   알 수 없고, 그게 실패했을 때 가장 먼저 보고 싶은 것이다. *)
let run ?(args = []) (prog : Ir.program) (entry : string)
    (main_params : (string * string) list) :
    string * (Token.pos * string) option =
  Buffer.clear out;
  argv := args;
  let st = { prog } in
  match Hashtbl.find_opt prog.Ir.fns (entry ^ "#main") with
  | None -> ("", Some (Token.{ line = 0; col = 0 }, "main 함수가 없습니다"))
  | Some fn -> (
      let args =
        List.map
          (fun (_, tyname) ->
            match root_capability tyname with
            | Some v -> Ok v
            | None ->
                Error (Printf.sprintf "런타임이 %s capability를 제공하지 않습니다" tyname))
          main_params
      in
      match List.find_opt Result.is_error args with
      | Some (Error m) -> ("", Some (Token.{ line = 0; col = 0 }, m))
      | _ -> (
          let args = List.map Result.get_ok args in
          try
            ignore (apply st Token.{ line = 0; col = 0 } (VFn fn) args);
            (Buffer.contents out, None)
          with
          | Fail (pos, msg) -> (Buffer.contents out, Some (pos, msg))
          | Return_exc _ -> (Buffer.contents out, None)))

(* ------------------------------------------------------------------ *)
(* 테스트 러너                                                         *)
(*                                                                     *)
(* 격리는 런타임의 일이지 언어의 일이 아니다. 언어에는 recover가 없고,   *)
(* 러너는 죽은 것을 되살리는 것이 아니라 죽었다는 사실을 관찰하고 다음   *)
(* 으로 간다 — 프로세스 경계에 가깝다.                                  *)
(*                                                                     *)
(* 테스트가 effect-free임은 검사기가 이미 보장한다. 그래서 순서에        *)
(* 의존하지 않고, 어떤 순서로 돌려도 같다.                              *)
(* ------------------------------------------------------------------ *)

type test_result = {
  t_module : string;
  t_name : string;
  t_pos : Token.pos;
  t_failure : (Token.pos * string) option;
}

let run_tests ?(filter = "") (prog : Ir.program) : test_result list =
  let st = { prog } in
  List.rev prog.Ir.tests
  |> List.filter (fun (_, name, _, _) ->
      filter = "" || find_sub name filter <> None)
  |> List.map (fun (m, name, pos, body) ->
      let failure =
        try
          ignore (eval st [ [] ] body);
          None
        with
        | Fail (p, msg) -> Some (p, msg)
        | Return_exc _ -> None
      in
      { t_module = m; t_name = name; t_pos = pos; t_failure = failure })