coollang/lib/ast.ml

(* 구문 트리. grammar.ebnf의 프로덕션과 일대일로 대응한다.
   모든 노드가 위치를 들고 다닌다. *)

type pos = Token.pos
type lit = L_int of string | L_str of string | L_bool of bool
type eff_name = { cap : string; meth : string }

(* eff_atom: 변수 단독 또는 리터럴 집합. 합집합은 여기 없다 —
   결과 위치에서만 eff_atom의 목록으로 나타난다. *)
type eff_atom = Eff_var of string | Eff_set of eff_name list
type eff_result = eff_atom list (* 합집합. 길이 1이면 단일 *)

type ty =
  (* modl: 다른 모듈의 타입은 별칭으로 한정한다 (Shapes.Shape).
     한정하지 않으면 이 모듈의 이름이다 — 암묵적으로 끌어오지 않는다. *)
  | T_named of {
      modl : string option;
      name : string;
      args : targ list;
      pos : pos;
    }
  | T_fn of {
      affine : bool;
      (* 파라미터마다 소유권 표시. 무표기는 빌림 *)
      params : fn_param_ty list;
      eff : eff_atom option;
      ret : ty option;
      pos : pos;
    }

(* 제네릭 인자는 타입 또는 effect다. 맨 이름은 둘 다일 수 있으므로
   파서는 타입으로 읽고 이름 해소가 판정한다. *)
and fn_param_ty = { pt_own : bool; pt_ty : ty }
and targ = TA_ty of ty | TA_eff of eff_atom

type pattern =
  | P_wild of pos
  | P_lit of lit * pos
  | P_bind of string * pos
  | P_ctor of {
      modl : string option;
      name : string;
      args : pattern list;
      pos : pos;
    }

type unop = U_not | U_neg

type binop =
  | B_or
  | B_and
  | B_eq
  | B_ne
  | B_lt
  | B_le
  | B_gt
  | B_ge
  | B_add
  | B_sub
  | B_mul
  | B_div
  | B_rem

type expr =
  | E_lit of lit * pos
  | E_ident of string * pos
  | E_list of expr list * pos
  | E_struct of { name : string; fields : (string * expr) list; pos : pos }
  | E_closure of closure
  | E_if of { cond : expr; then_ : block; else_ : expr option; pos : pos }
  | E_match of { scrutinee : expr; arms : arm list; pos : pos }
  | E_scope of { name : string; parent : string; body : block; pos : pos }
  | E_block of block
  | E_call of { callee : expr; args : expr list; pos : pos }
  | E_field of { obj : expr; name : string; pos : pos }
  | E_inst of { callee : expr; args : targ list; pos : pos }
  | E_try of { inner : expr; pos : pos }
  | E_unary of { op : unop; operand : expr; pos : pos }
  (* 복구 불가능한 실패. 타입은 Never — 돌아오지 않으므로 어떤 자리에도 놓인다 *)
  | E_crash of { msg : expr; pos : pos }
  | E_binary of { op : binop; lhs : expr; rhs : expr; pos : pos }

and closure = {
  (* (own, 이름, 타입). 타입은 기대 타입에서 읽어오지만 소유권은 리터럴이
     스스로 적는다 — move 검사가 타입을 모르기 때문이다 *)
  cl_params : cl_param list;
  cl_eff : eff_atom option;
  cl_ret : ty option;
  cl_body : block;
  cl_pos : pos;
}

and cl_param = { cp_own : bool; cp_name : string; cp_ty : ty option }
and arm = { arm_pat : pattern; arm_body : expr; arm_pos : pos }
and block = { stmts : stmt list; block_pos : pos }

and stmt =
  | S_let of {
      mut_ : bool;
      pat : pattern;
      ty : ty option;
      value : expr;
      pos : pos;
    }
  | S_return of { value : expr option; pos : pos }
  | S_assign of { place : expr; value : expr; pos : pos }
  | S_expr of expr

type gen_param = { gp_name : string; gp_effect : bool; gp_pos : pos }

type param = {
  p_own : bool;
  p_mut : bool;
  p_name : string;
  p_ty : ty;
  p_pos : pos;
}

type fn_decl = {
  fn_name : string;
  fn_gen : gen_param list;
  fn_params : param list;
  fn_eff : eff_result option;
  fn_ret : ty option;
  fn_body : block option;
  fn_pos : pos;
}

type field = { f_name : string; f_ty : ty; f_pos : pos }
type variant = { v_name : string; v_args : ty list; v_pos : pos }

type item =
  | I_import of { path : string; alias : string; pos : pos }
  | I_reexport of { name : string; pos : pos }
  | I_fn of { pub : bool; decl : fn_decl }
  | I_struct of {
      pub : bool;
      copyable : bool;
      name : string;
      gen : gen_param list;
      fields : field list;
      pos : pos;
    }
  | I_enum of {
      pub : bool;
      name : string;
      gen : gen_param list;
      variants : variant list;
      pos : pos;
    }
  | I_capability of {
      pub : bool;
      name : string;
      methods : fn_decl list;
      pos : pos;
    }
  | I_const of { pub : bool; name : string; ty : ty; value : expr; pos : pos }
  (* 테스트. 파라미터가 없으므로 capability를 받을 수 없고, 그래서
     effect-free임이 증명된다 — 관례가 아니라 검사다 *)
  | I_test of { name : string; body : block; pos : pos }

type modul = { items : item list }

(* ------------------------------------------------------------------ *)
(* 출력 — 디버깅과 테스트용 s-식                                        *)
(* ------------------------------------------------------------------ *)

let buf_lit b = function
  | L_int s -> Buffer.add_string b s
  | L_str s -> Buffer.add_string b (Printf.sprintf "%S" s)
  | L_bool v -> Buffer.add_string b (if v then "true" else "false")

let buf_list b f sep xs =
  List.iteri
    (fun i x ->
      if i > 0 then Buffer.add_string b sep;
      f x)
    xs

let buf_eff_atom b = function
  | Eff_var v -> Buffer.add_string b ("evar " ^ v)
  | Eff_set names ->
      Buffer.add_string b "eset";
      List.iter
        (fun { cap; meth } -> Buffer.add_string b (" " ^ cap ^ "." ^ meth))
        names

let rec buf_ty b = function
  | T_named { modl; name; args; _ } ->
      let name = match modl with None -> name | Some m -> m ^ "." ^ name in
      if args = [] then Buffer.add_string b name
      else (
        Buffer.add_string b ("(" ^ name);
        List.iter
          (fun a ->
            Buffer.add_char b ' ';
            buf_targ b a)
          args;
        Buffer.add_char b ')')
  | T_fn { affine; params; eff; ret; _ } ->
      Buffer.add_string b (if affine then "(affine-fn (" else "(fn (");
      buf_list b
        (fun (p : fn_param_ty) ->
          if p.pt_own then Buffer.add_string b "own ";
          buf_ty b p.pt_ty)
        " " params;
      Buffer.add_char b ')';
      (match eff with
      | None -> ()
      | Some e ->
          Buffer.add_string b " [";
          buf_eff_atom b e;
          Buffer.add_char b ']');
      (match ret with
      | None -> ()
      | Some t ->
          Buffer.add_string b " -> ";
          buf_ty b t);
      Buffer.add_char b ')'

and buf_targ b = function
  | TA_ty t -> buf_ty b t
  | TA_eff e ->
      Buffer.add_char b '[';
      buf_eff_atom b e;
      Buffer.add_char b ']'

let rec buf_pattern b = function
  | P_wild _ -> Buffer.add_char b '_'
  | P_lit (l, _) -> buf_lit b l
  | P_bind (n, _) -> Buffer.add_string b n
  | P_ctor { modl; name; args; _ } ->
      let name = match modl with None -> name | Some m -> m ^ "." ^ name in
      Buffer.add_string b ("(" ^ name);
      List.iter
        (fun p ->
          Buffer.add_char b ' ';
          buf_pattern b p)
        args;
      Buffer.add_char b ')'

let unop_name = function U_not -> "!" | U_neg -> "-"

let binop_name = function
  | B_or -> "||"
  | B_and -> "&&"
  | B_eq -> "=="
  | B_ne -> "!="
  | B_lt -> "<"
  | B_le -> "<="
  | B_gt -> ">"
  | B_ge -> ">="
  | B_add -> "+"
  | B_sub -> "-"
  | B_mul -> "*"
  | B_div -> "/"
  | B_rem -> "%"

let rec buf_expr b = function
  | E_lit (l, _) -> buf_lit b l
  | E_crash { msg; _ } ->
      Buffer.add_string b "(crash ";
      buf_expr b msg;
      Buffer.add_char b ')'
  | E_ident (n, _) -> Buffer.add_string b n
  | E_list (xs, _) ->
      Buffer.add_string b "(list";
      List.iter
        (fun e ->
          Buffer.add_char b ' ';
          buf_expr b e)
        xs;
      Buffer.add_char b ')'
  | E_struct { name; fields; _ } ->
      Buffer.add_string b ("(struct " ^ name);
      List.iter
        (fun (n, e) ->
          Buffer.add_string b (" (" ^ n ^ " ");
          buf_expr b e;
          Buffer.add_char b ')')
        fields;
      Buffer.add_char b ')'
  | E_closure c ->
      Buffer.add_string b "(closure (";
      buf_list b
        (fun (p : cl_param) ->
          if p.cp_own then Buffer.add_string b "own ";
          Buffer.add_string b p.cp_name;
          match p.cp_ty with
          | None -> ()
          | Some t ->
              Buffer.add_char b ':';
              buf_ty b t)
        " " c.cl_params;
      Buffer.add_string b ") ";
      buf_block b c.cl_body;
      Buffer.add_char b ')'
  | E_if { cond; then_; else_; _ } ->
      Buffer.add_string b "(if ";
      buf_expr b cond;
      Buffer.add_char b ' ';
      buf_block b then_;
      (match else_ with
      | None -> ()
      | Some e ->
          Buffer.add_char b ' ';
          buf_expr b e);
      Buffer.add_char b ')'
  | E_match { scrutinee; arms; _ } ->
      Buffer.add_string b "(match ";
      buf_expr b scrutinee;
      List.iter
        (fun a ->
          Buffer.add_string b " (";
          buf_pattern b a.arm_pat;
          Buffer.add_string b " => ";
          buf_expr b a.arm_body;
          Buffer.add_char b ')')
        arms;
      Buffer.add_char b ')'
  | E_scope { name; parent; body; _ } ->
      Buffer.add_string b ("(scope " ^ name ^ " = " ^ parent ^ " ");
      buf_block b body;
      Buffer.add_char b ')'
  | E_block bl -> buf_block b bl
  | E_call { callee; args; _ } ->
      Buffer.add_string b "(call ";
      buf_expr b callee;
      List.iter
        (fun e ->
          Buffer.add_char b ' ';
          buf_expr b e)
        args;
      Buffer.add_char b ')'
  | E_field { obj; name; _ } ->
      Buffer.add_string b "(. ";
      buf_expr b obj;
      Buffer.add_string b (" " ^ name ^ ")")
  | E_inst { callee; args; _ } ->
      Buffer.add_string b "(inst ";
      buf_expr b callee;
      List.iter
        (fun a ->
          Buffer.add_char b ' ';
          buf_targ b a)
        args;
      Buffer.add_char b ')'
  | E_try { inner; _ } ->
      Buffer.add_string b "(? ";
      buf_expr b inner;
      Buffer.add_char b ')'
  | E_unary { op; operand; _ } ->
      Buffer.add_string b ("(" ^ unop_name op ^ " ");
      buf_expr b operand;
      Buffer.add_char b ')'
  | E_binary { op; lhs; rhs; _ } ->
      Buffer.add_string b ("(" ^ binop_name op ^ " ");
      buf_expr b lhs;
      Buffer.add_char b ' ';
      buf_expr b rhs;
      Buffer.add_char b ')'

and buf_block b { stmts; _ } =
  Buffer.add_string b "(block";
  List.iter
    (fun s ->
      Buffer.add_char b ' ';
      buf_stmt b s)
    stmts;
  Buffer.add_char b ')'

and buf_stmt b = function
  | S_let { mut_; pat; ty; value; _ } ->
      Buffer.add_string b (if mut_ then "(let-mut " else "(let ");
      buf_pattern b pat;
      (match ty with
      | None -> ()
      | Some t ->
          Buffer.add_char b ':';
          buf_ty b t);
      Buffer.add_char b ' ';
      buf_expr b value;
      Buffer.add_char b ')'
  | S_return { value; _ } -> (
      Buffer.add_string b "(return";
      match value with
      | None -> Buffer.add_char b ')'
      | Some e ->
          Buffer.add_char b ' ';
          buf_expr b e;
          Buffer.add_char b ')')
  | S_assign { place; value; _ } ->
      Buffer.add_string b "(set ";
      buf_expr b place;
      Buffer.add_char b ' ';
      buf_expr b value;
      Buffer.add_char b ')'
  | S_expr e -> buf_expr b e

let buf_gen b gen =
  if gen <> [] then (
    Buffer.add_string b " <";
    buf_list b
      (fun g ->
        Buffer.add_string b
          (if g.gp_effect then g.gp_name ^ ":effects" else g.gp_name))
      " " gen;
    Buffer.add_char b '>')

let buf_fn b (d : fn_decl) =
  Buffer.add_string b ("(fn " ^ d.fn_name);
  buf_gen b d.fn_gen;
  Buffer.add_string b " (";
  buf_list b
    (fun p ->
      if p.p_own then Buffer.add_string b "own ";
      if p.p_mut then Buffer.add_string b "mut ";
      Buffer.add_string b (p.p_name ^ ":");
      buf_ty b p.p_ty)
    " " d.fn_params;
  Buffer.add_char b ')';
  (match d.fn_eff with
  | None -> ()
  | Some atoms ->
      Buffer.add_string b " [";
      buf_list b (fun a -> buf_eff_atom b a) " | " atoms;
      Buffer.add_char b ']');
  (match d.fn_ret with
  | None -> ()
  | Some t ->
      Buffer.add_string b " -> ";
      buf_ty b t);
  (match d.fn_body with
  | None -> Buffer.add_string b " decl"
  | Some bl ->
      Buffer.add_char b ' ';
      buf_block b bl);
  Buffer.add_char b ')'

let buf_item b = function
  | I_import { path; alias; _ } ->
      Buffer.add_string b (Printf.sprintf "(import %S as %s)" path alias)
  | I_reexport { name; _ } -> Buffer.add_string b ("(reexport " ^ name ^ ")")
  | I_fn { pub; decl } ->
      if pub then Buffer.add_string b "pub ";
      buf_fn b decl
  | I_struct { pub; copyable; name; gen; fields; _ } ->
      if pub then Buffer.add_string b "pub ";
      if copyable then Buffer.add_string b "copyable ";
      Buffer.add_string b ("(struct " ^ name);
      buf_gen b gen;
      List.iter
        (fun f ->
          Buffer.add_string b (" (" ^ f.f_name ^ " ");
          buf_ty b f.f_ty;
          Buffer.add_char b ')')
        fields;
      Buffer.add_char b ')'
  | I_enum { pub; name; gen; variants; _ } ->
      if pub then Buffer.add_string b "pub ";
      Buffer.add_string b ("(enum " ^ name);
      buf_gen b gen;
      List.iter
        (fun v ->
          Buffer.add_string b (" (" ^ v.v_name);
          List.iter
            (fun t ->
              Buffer.add_char b ' ';
              buf_ty b t)
            v.v_args;
          Buffer.add_char b ')')
        variants;
      Buffer.add_char b ')'
  | I_capability { pub; name; methods; _ } ->
      if pub then Buffer.add_string b "pub ";
      Buffer.add_string b ("(capability " ^ name);
      List.iter
        (fun m ->
          Buffer.add_char b ' ';
          buf_fn b m)
        methods;
      Buffer.add_char b ')'
  | I_const { pub; name; ty; value; _ } ->
      if pub then Buffer.add_string b "pub ";
      Buffer.add_string b ("(const " ^ name ^ ":");
      buf_ty b ty;
      Buffer.add_char b ' ';
      buf_expr b value;
      Buffer.add_char b ')'
  | I_test { name; body; _ } ->
      Buffer.add_string b ("(test \"" ^ name ^ "\" ");
      buf_block b body;
      Buffer.add_char b ')'

let show_item item =
  let b = Buffer.create 256 in
  buf_item b item;
  Buffer.contents b

let show_expr e =
  let b = Buffer.create 128 in
  buf_expr b e;
  Buffer.contents b

let show_ty t =
  let b = Buffer.create 64 in
  buf_ty b t;
  Buffer.contents b