coollang/test/test_coollang.ml

open Coollang

let failures = ref 0

let check name cond =
  if not cond then (
    incr failures;
    Printf.printf "FAIL %s\n" name)

let kinds src =
  match Lexer.lex_result src with
  | Ok ts -> List.map (fun t -> t.Token.kind) ts
  | Error e ->
      failwith
        (Printf.sprintf "예상치 못한 렉서 오류 %d:%d %s" e.pos.line e.pos.col e.msg)

let lex_error src =
  match Lexer.lex_result src with Ok _ -> None | Error e -> Some e.msg

(* --- 키워드와 이름 --- *)

let () =
  check "키워드 인식"
    (kinds "fn own affine"
    = [ Token.Kw_fn; Token.Kw_own; Token.Kw_affine; Token.Eof ]);
  check "이름은 키워드가 아니다"
    (kinds "own_er" = [ Token.Ident "own_er"; Token.Newline; Token.Eof ])

(* --- 두 글자 연산자를 먼저 본다 --- *)

let () =
  check "화살표"
    (kinds "-> => == != <= >= && ||"
    = [
        Token.Arrow;
        Token.FatArrow;
        Token.EqEq;
        Token.BangEq;
        Token.Le;
        Token.Ge;
        Token.AmpAmp;
        Token.PipePipe;
        Token.Eof;
      ]);
  check "한 글자로 갈리는 자리"
    (kinds "- = ! < > |"
    = [
        Token.Minus;
        Token.Eq;
        Token.Bang;
        Token.Lt;
        Token.Gt;
        Token.Pipe;
        Token.Eof;
      ])

(* --- NEWLINE 삽입 (grammar.ebnf 어휘 절) --- *)

let () =
  check "값으로 끝난 줄 뒤에 삽입"
    (kinds "a\nb"
    = [
        Token.Ident "a";
        Token.Newline;
        Token.Ident "b";
        Token.Newline;
        Token.Eof;
      ]);
  check "여는 괄호로 끝난 줄은 이어진다"
    (kinds "f(\na)"
    = [
        Token.Ident "f";
        Token.LParen;
        Token.Ident "a";
        Token.RParen;
        Token.Newline;
        Token.Eof;
      ]);
  check "연산자로 끝난 줄은 이어진다"
    (kinds "a +\nb"
    = [ Token.Ident "a"; Token.Plus; Token.Ident "b"; Token.Newline; Token.Eof ]
    );
  check "빈 줄은 구분자를 만들지 않는다"
    (kinds "a\n\n\nb"
    = [
        Token.Ident "a";
        Token.Newline;
        Token.Ident "b";
        Token.Newline;
        Token.Eof;
      ]);
  check "주석만 있는 줄도 마찬가지"
    (kinds "a\n// 설명\nb"
    = [
        Token.Ident "a";
        Token.Newline;
        Token.Ident "b";
        Token.Newline;
        Token.Eof;
      ]);
  check "닫는 괄호 뒤에는 삽입"
    (kinds "f()\ng()"
    = [
        Token.Ident "f";
        Token.LParen;
        Token.RParen;
        Token.Newline;
        Token.Ident "g";
        Token.LParen;
        Token.RParen;
        Token.Newline;
        Token.Eof;
      ]);
  check "? 뒤에는 삽입"
    (kinds "f()?\ng"
    = [
        Token.Ident "f";
        Token.LParen;
        Token.RParen;
        Token.Question;
        Token.Newline;
        Token.Ident "g";
        Token.Newline;
        Token.Eof;
      ]);
  check "빈 입력" (kinds "" = [ Token.Eof ])

(* --- 리터럴 --- *)

let () =
  check "정수와 밑줄"
    (kinds "1_000" = [ Token.Int "1_000"; Token.Newline; Token.Eof ]);
  check "문자열 이스케이프"
    (kinds "\"a\\nb\"" = [ Token.Str "a\nb"; Token.Newline; Token.Eof ]);
  check "밑줄 단독" (kinds "_" = [ Token.Underscore; Token.Eof ])

(* --- 오류 --- *)

let () =
  check "닫히지 않은 문자열" (lex_error "\"abc" <> None);
  check "줄바꿈 전에 닫지 않은 문자열" (lex_error "\"abc\ndef\"" <> None);
  check "알 수 없는 이스케이프" (lex_error "\"a\\qb\"" <> None);
  check "이름은 문자로 시작" (lex_error "_foo" <> None);
  check "단독 &" (lex_error "a & b" <> None);
  check "정수 뒤 글자" (lex_error "12abc" <> None);
  check "예상치 못한 문자" (lex_error "a @ b" <> None)

(* --- 오류 위치 --- *)

let () =
  match Lexer.lex_result "a\nb @ c" with
  | Ok _ -> check "위치 보고" false
  | Error e -> check "위치 보고" (e.pos.line = 2 && e.pos.col = 3)

(* --- 샘플 전체가 어휘 분석을 통과해야 한다 --- *)

let () =
  let dir = "../samples" in
  let files =
    Sys.readdir dir |> Array.to_list
    |> List.filter (fun f -> Filename.check_suffix f ".cool")
    |> List.sort compare
  in
  check "샘플이 존재한다" (List.length files >= 7);
  List.iter
    (fun f ->
      let path = Filename.concat dir f in
      match Driver.tokens path with
      | Ok ts -> check (f ^ " 어휘 분석") (List.length ts > 10)
      | Error errors ->
          List.iter
            (fun e -> Printf.printf "  %s\n" (Driver.string_of_error e))
            errors;
          check (f ^ " 어휘 분석") false)
    files

(* --- 기존 계약 --- *)

let () =
  check "버전 비어있지 않음" (String.length Version.string > 0);
  match Driver.check [] with Error [ _ ] -> () | _ -> check "빈 입력에는 오류" false

let () =
  if !failures = 0 then print_endline "ok"
  else (
    Printf.printf "%d개 실패\n" !failures;
    exit 1)

(* --- ASI 함정: effects 절이 줄 끝에 오면 } 뒤에 NEWLINE이 삽입된다.
       렉서는 이대로 두고 문법이 { NEWLINE }으로 흡수한다 (grammar.ebnf). --- *)

let () =
  check "닫는 중괄호 뒤 줄바꿈은 삽입된다"
    (kinds "effects {A.b}\n-> Int"
    = [
        Token.Kw_effects;
        Token.LBrace;
        Token.Ident "A";
        Token.Dot;
        Token.Ident "b";
        Token.RBrace;
        Token.Newline;
        Token.Arrow;
        Token.Ident "Int";
        Token.Newline;
        Token.Eof;
      ]);
  check "후행 콤마가 있으면 목록이 이어진다"
    (kinds "f(\na,\nb,\n)"
    = [
        Token.Ident "f";
        Token.LParen;
        Token.Ident "a";
        Token.Comma;
        Token.Ident "b";
        Token.Comma;
        Token.RParen;
        Token.Newline;
        Token.Eof;
      ])

(* ================================================================== *)
(* 파서                                                                *)
(* ================================================================== *)

let parse_ok src =
  match Lexer.lex_result src with
  | Error e ->
      failwith (Printf.sprintf "렉서 오류 %d:%d %s" e.pos.line e.pos.col e.msg)
  | Ok ts -> (
      match Parser.parse_result ts with
      | Ok m -> m
      | Error e ->
          failwith (Printf.sprintf "파서 오류 %d:%d %s" e.pos.line e.pos.col e.msg))

let parse_err src =
  match Lexer.lex_result src with
  | Error e -> Some e.msg
  | Ok ts -> (
      match Parser.parse_result ts with Ok _ -> None | Error e -> Some e.msg)

let one src =
  match (parse_ok src).Ast.items with
  | [ it ] -> Ast.show_item it
  | items -> Printf.sprintf "<항목 %d개>" (List.length items)

(* --- 어순: effects 절은 파라미터 뒤, 화살표 앞 --- *)

let () =
  check "함수 선언 어순"
    (one "pub fn f(a: Int) effects {A.b} -> Int {\n  a\n}"
    = "pub (fn f (a:Int) [eset A.b] -> Int (block a))");
  check "결과 위치의 effect 합집합"
    (one "fn f() effects e1 | e2" = "(fn f () [evar e1 | evar e2] decl)");
  check "함수 타입의 어순과 중첩"
    (one "fn f(g: fn(Int) effects e -> Bool) -> fn(Int) -> Int"
    = "(fn f (g:(fn (Int) [evar e] -> Bool)) -> (fn (Int) -> Int) decl)")

(* --- 대괄호 제네릭: 전위는 리터럴, 후위는 인스턴스화 --- *)

let () =
  check "타입 위치의 대괄호"
    (one "fn f(xs: List[Int]) -> Result[a, Error]"
    = "(fn f (xs:(List Int)) -> (Result a Error) decl)");
  check "식 위치의 후위 대괄호는 인스턴스화"
    (one "fn f() {\n  map[Path, Int, {A.b}](xs, g)\n}"
    = "(fn f () (block (call (inst map Path Int [eset A.b]) xs g)))");
  check "전위 대괄호는 리스트 리터럴"
    (one "fn f() {\n  let xs = [1, 2, 3]\n  xs\n}"
    = "(fn f () (block (let xs (list 1 2 3)) xs))")

(* --- 파라미터 수식어 순서 --- *)

let () =
  check "own은 이름 앞, affine은 타입 안"
    (one "fn f(own a: affine fn() effects {F.c}, mut b: Int)"
    = "(fn f (own a:(affine-fn () [eset F.c]) mut b:Int) decl)")

(* --- 선언 --- *)

let () =
  check "copyable struct"
    (one "pub copyable struct R {\n  id: Id,\n  n: Int,\n}"
    = "pub copyable (struct R (id Id) (n Int))");
  check "enum variant"
    (one "pub enum E {\n  A(Code),\n  B,\n}" = "pub (enum E (A Code) (B))");
  check "capability"
    (one "pub capability C {\n  fn m(id: Id) effects {C.m} -> R\n}"
    = "pub (capability C (fn m (id:Id) [eset C.m] -> R decl))");
  check "import와 reexport"
    (List.length (parse_ok "import \"d/p\" as P\nreexport N\n").Ast.items = 2);
  check "const" (one "pub const N: Int = 3" = "pub (const N:Int 3)")

(* --- 식 --- *)

let () =
  check "우선순위"
    (one "fn f() {\n  a + b * c == d && e\n}"
    = "(fn f () (block (&& (== (+ a (* b c)) d) e)))");
  check "postfix 연쇄"
    (one "fn f() {\n  p.q(r)?.s\n}"
    = "(fn f () (block (. (? (call (. p q) r)) s)))");
  check "if는 식"
    (one "fn f() {\n  let x = if c {\n    a\n  } else {\n    b\n  }\n  x\n}"
    = "(fn f () (block (let x (if c (block a) (block b))) x))");
  check "match"
    (one "fn f() {\n  match e {\n    A(_) => 1,\n    _ => 2,\n  }\n}"
    = "(fn f () (block (match e ((A _) => 1) (_ => 2))))");
  check "scope는 부모를 명시한다"
    (one "fn f(root: TaskScope) {\n  scope sc = root {\n    sc.spawn(g)\n  }\n}"
    = "(fn f (root:TaskScope) (block (scope sc = root (block (call (. sc \
       spawn) g)))))");
  check "struct 리터럴"
    (one "fn f() {\n  H { a: 1 }\n}" = "(fn f () (block (struct H (a 1))))")

(* --- 파서가 거부해야 하는 것 --- *)

let () =
  check "파라미터 위치의 effect 합집합"
    (parse_err "fn f(g: fn(a) effects e | {A.b})"
    = Some "파라미터 위치의 effects 절에는 합집합을 쓸 수 없습니다 (변수 단독 또는 리터럴 집합만 가능)");
  check "match 가드"
    (parse_err
       "fn f() {\n  match e {\n    A(r) if r.x => 1,\n    _ => 2,\n  }\n}"
    = Some "match 가드는 v0에 없습니다 (분기 본문에서 if를 쓰십시오)");
  check "후행 콤마 누락"
    (parse_err "fn f(\n  a: Int\n)" = Some "다중 줄 목록에는 후행 콤마가 필요합니다");
  check "if 머리의 struct 리터럴"
    (parse_err "fn f() {\n  if H { a: 1 } {\n    b\n  }\n}" <> None);
  check "대입 왼쪽 검사"
    (parse_err "fn f() {\n  g() = 1\n}" = Some "대입 왼쪽에는 변수나 필드만 올 수 있습니다");
  check "한 줄에 문 두 개" (parse_err "fn f() {\n  a b\n}" = Some "문 끝에 줄바꿈이 필요합니다")

(* --- 괄호 안에서는 struct 리터럴이 다시 허용된다 --- *)

let () =
  check "괄호로 감싸면 if 머리에서도 가능"
    (one "fn f() {\n  if (H { a: 1 }).b {\n    c\n  }\n}"
    = "(fn f () (block (if (. (struct H (a 1)) b) (block c))))")

(* --- 샘플: 01~07은 파싱되고 08은 거부되어야 한다 --- *)

let () =
  let dir = "../samples" in
  let files =
    Sys.readdir dir |> Array.to_list
    |> List.filter (fun f -> Filename.check_suffix f ".cool")
    |> List.sort compare
  in
  List.iter
    (fun f ->
      let path = Filename.concat dir f in
      let is_syntax_error_file = f = "08_syntax_errors.cool" in
      match Driver.ast path with
      | Ok m ->
          if is_syntax_error_file then check (f ^ " 는 파서가 거부해야 한다") false
          else check (f ^ " 구문 분석") (List.length m.Ast.items > 0)
      | Error errors ->
          if is_syntax_error_file then ()
          else (
            List.iter
              (fun e -> Printf.printf "  %s\n" (Driver.string_of_error e))
              errors;
            check (f ^ " 구문 분석") false))
    files

(* ================================================================== *)
(* 이름 해소                                                           *)
(* ================================================================== *)

let resolve_errs src =
  let m = parse_ok src in
  let _, errors = Resolve.resolve m in
  List.map (fun (e : Resolve.error) -> e.msg) errors

let resolve_ext src =
  let m = parse_ok src in
  let info, _ = Resolve.resolve m in
  List.map fst info.Resolve.externals

let has_err src frag =
  List.exists
    (fun m ->
      let n = String.length frag in
      let rec go i =
        i + n <= String.length m && (String.sub m i n = frag || go (i + 1))
      in
      go 0)
    (resolve_errs src)

(* --- 모듈 하나로 결정할 수 있는 것 = 오류 --- *)

let () =
  check "중복 정의" (has_err "fn f()\nfn f()" "두 번 정의");
  check "중복 파라미터" (has_err "fn f(a: Int, a: Int)" "파라미터 a");
  check "중복 제네릭" (has_err "fn f[a, a]()" "제네릭 파라미터 a");
  check "선언되지 않은 effect 변수" (has_err "fn f() effects e" "선언되지 않은 effect 변수 e");
  check "선언된 effect 변수는 통과" (resolve_errs "fn f[e: effects]() effects e" = []);
  check "파라미터 타입 안의 effect 변수도 본다"
    (has_err "fn f(g: fn() effects e)" "선언되지 않은 effect 변수 e");
  check "같은 블록의 재바인딩"
    (has_err "fn f() {\n  let a = 1\n  let a = 2\n  a\n}" "다시 묶을 수 없습니다");
  check "중첩 블록의 가림은 허용"
    (resolve_errs
       "fn f() {\n  let a = 1\n  if a {\n    let a = 2\n    a\n  }\n}"
    = []);
  check "불변 바인딩에 대입" (has_err "fn f() {\n  let a = 1\n  a = 2\n}" "불변 바인딩");
  check "mut이면 통과" (resolve_errs "fn f() {\n  let mut a = 1\n  a = 2\n}" = []);
  check "모듈에 없는 reexport" (has_err "reexport N" "이 모듈에 없습니다");
  check "모듈에 있는 reexport는 통과" (resolve_errs "enum N {\n  A,\n}\nreexport N" = [])

(* --- scope 머리는 지역 바인딩이어야 한다 --- *)

let () =
  check "부모 scope가 지역 바인딩이 아니면 오류"
    (has_err "fn f() {\n  scope s = root {\n    s\n  }\n}" "지역 바인딩이 아닙니다");
  check "파라미터로 온 부모는 통과"
    (resolve_errs "fn f(root: TaskScope) {\n  scope s = root {\n    s\n  }\n}"
    = []);
  check "자식 scope 이름은 블록 안에서만 산다"
    (resolve_ext
       "fn f(root: TaskScope) {\n  scope s = root {\n    s\n  }\n  s\n}"
    = [ "TaskScope"; "s" ])

(* --- variant는 구문이 아니라 이름 해소가 판정한다 --- *)

let () =
  let enum = "enum E {\n  A(Code),\n  B,\n}\n" in
  check "인자 없는 variant는 바인딩이 아니라 생성자"
    (resolve_errs
       (enum ^ "fn f(e: E) {\n  match e {\n    B => 1,\n    _ => 2,\n  }\n}")
    = []);
  check "variant 인자 개수"
    (has_err
       (enum ^ "fn f(e: E) {\n  match e {\n    A => 1,\n    _ => 2,\n  }\n}")
       "인자 1개가 필요합니다");
  check "패턴의 중복 바인딩"
    (has_err
       (enum ^ "fn f(e: E) {\n  match e {\n    A(x) => x,\n    _ => 0,\n  }\n}"
      ^ "\nfn g(e: E) {\n  match e {\n    A(x) => x,\n    _ => 0,\n  }\n}")
       "두 번 나옵니다"
    = false)

(* --- 결정할 수 없는 것 = 외부 참조 --- *)

let () =
  check "모르는 타입은 외부 참조" (resolve_ext "fn f(a: Widget)" = [ "Widget" ]);
  check "import한 이름은 외부 참조가 아니다"
    (resolve_ext "import \"d/p\" as P\nfn f() {\n  P.go()\n}" = []);
  check "지역 이름은 외부 참조가 아니다" (resolve_ext "fn f(a: Int) {\n  a\n}" = []);
  check "builtin은 외부 참조가 아니다"
    (resolve_ext "fn f(a: Int) -> Result[Int, Int] {\n  Ok(a)\n}" = []);
  check "effect 집합의 capability도 표면에 든다"
    (resolve_ext "fn f() effects {Gw.pay}" = [ "Gw" ])

(* --- 샘플: 01~07은 이름 해소를 통과해야 한다 --- *)

let () =
  let dir = "../samples" in
  let files =
    Sys.readdir dir |> Array.to_list
    |> List.filter (fun f -> Filename.check_suffix f ".cool")
    |> List.filter (fun f -> f <> "08_syntax_errors.cool")
    |> List.sort compare
  in
  List.iter
    (fun f ->
      let path = Filename.concat dir f in
      match Driver.resolve path with
      | Ok _ -> ()
      | Error errors ->
          List.iter
            (fun e -> Printf.printf "  %s\n" (Driver.string_of_error e))
            errors;
          check (f ^ " 이름 해소") false)
    files

(* ================================================================== *)
(* 타입 검사                                                           *)
(* ================================================================== *)

let type_errs src =
  List.map (fun (e : Typecheck.error) -> e.msg) (Typecheck.check (parse_ok src))

let type_ok src = type_errs src = []

let type_has src frag =
  List.exists
    (fun m ->
      let n = String.length frag in
      let rec go i =
        i + n <= String.length m && (String.sub m i n = frag || go (i + 1))
      in
      go 0)
    (type_errs src)

(* --- 제네릭은 호출 지점에서 지역 unification으로 풀린다 --- *)

let () =
  check "제네릭 인스턴스화" (type_ok "fn id[a](x: a) -> a\nfn f() -> Int {\n  id(1)\n}");
  check "제네릭 결과가 반환 타입과 안 맞으면 오류"
    (type_has "fn id[a](x: a) -> a\nfn f() -> String {\n  id(1)\n}" "String");
  check "명시적 인스턴스화의 인자 개수"
    (type_has "fn id[a](x: a) -> a\nfn f() -> Int {\n  id[Int, Int](1)\n}"
       "타입 인자 1개가 필요한데 2개");
  check "고차 함수의 클로저 파라미터 타입은 기대 타입에서 온다"
    (type_ok
       "fn map[a, b](xs: List[a], f: fn(a) -> b) -> List[b]\n\
        fn g(xs: List[Int]) -> List[Int] {\n\
       \  map(xs, fn(x) { x + 1 })\n\
        }");
  check "클로저 본문의 타입 오류는 잡힌다"
    (type_has
       "fn map[a, b](xs: List[a], f: fn(a) -> b) -> List[b]\n\
        fn g(xs: List[Int]) -> List[Int] {\n\
       \  map(xs, fn(x) { x + \"1\" })\n\
        }"
       "산술 연산자")

(* --- Result와 ? --- *)

let () =
  check "?는 Result를 벗긴다"
    (type_ok
       "fn f(x: Result[Int, String]) -> Result[Int, String] {\n\
       \  let a = x?\n\
       \  Ok(a)\n\
        }");
  check "?는 Result 반환 함수 안에서만"
    (type_has "fn f(x: Result[Int, String]) -> Int {\n  x?\n}"
       "Result를 반환하는 함수 안에서만")

(* --- enum과 struct --- *)

let () =
  let e = "enum E {\n  A(Int),\n  B,\n}\n" in
  check "생성자 호출" (type_ok (e ^ "fn f() -> E {\n  A(1)\n}"));
  check "생성자 인자 타입" (type_has (e ^ "fn f() -> E {\n  A(\"x\")\n}") "인자");
  check "인자 없는 생성자" (type_ok (e ^ "fn f() -> E {\n  B\n}"));
  check "match는 값을 낸다"
    (type_ok
       (e
      ^ "fn f(x: E) -> Int {\n  match x {\n    A(n) => n,\n    B => 0,\n  }\n}"
       ));
  check "제네릭 struct 필드"
    (type_ok "struct P[a] {\n  v: a,\n}\nfn f(p: P[Int]) -> Int {\n  p.v\n}");
  check "제네릭 struct 필드 타입 오류"
    (type_has "struct P[a] {\n  v: a,\n}\nfn f(p: P[Int]) -> String {\n  p.v\n}"
       "String")

(* --- capability 메서드 --- *)

let () =
  let c = "capability G {\n  fn pay(n: Int) -> Bool\n}\n" in
  check "capability 메서드 타입"
    (type_ok (c ^ "fn f(g: G) -> Bool {\n  g.pay(1)\n}"));
  check "없는 메서드"
    (type_has (c ^ "fn f(g: G) -> Bool {\n  g.nope(1)\n}") "메서드가 없습니다");
  check "메서드 인자 타입"
    (type_has (c ^ "fn f(g: G) -> Bool {\n  g.pay(\"x\")\n}") "인자")

(* --- 외부 이름은 검사를 막지 않는다 --- *)

let () =
  check "모르는 타입은 무엇과도 맞는다"
    (type_ok "fn f(w: Widget) -> Int {\n  w.anything(1, 2)\n}");
  check "모르는 것을 틀렸다고 말하지 않는다" (type_ok "fn f(w: Widget) -> Widget {\n  w\n}")

(* --- affinity는 타입 검사가 소유하지 않는다 --- *)

let () =
  check "affine fn과 fn은 타입 동등성에서 구분되지 않는다"
    (type_ok "fn f() -> affine fn() {\n  fn() {\n    unit\n  }\n}")

(* --- 샘플 --- *)

let () =
  let dir = "../samples" in
  let ok_files =
    Sys.readdir dir |> Array.to_list
    |> List.filter (fun f -> Filename.check_suffix f ".cool")
    |> List.filter (fun f ->
        f <> "08_syntax_errors.cool" && f <> "09_type_errors.cool")
    |> List.sort compare
  in
  List.iter
    (fun f ->
      match Driver.typecheck (Filename.concat dir f) with
      | Ok () -> ()
      | Error errors ->
          List.iter
            (fun e -> Printf.printf "  %s\n" (Driver.string_of_error e))
            errors;
          check (f ^ " 타입 검사") false)
    ok_files;
  match Driver.typecheck (Filename.concat dir "09_type_errors.cool") with
  | Ok () -> check "09는 타입 오류를 내야 한다" false
  | Error errors ->
      check "09의 오류를 전부 모은다 (첫 오류에서 멈추지 않는다)" (List.length errors >= 18)