coollang/lib/driver.ml

(* v0 파이프라인.
   parse -> name resolution -> type check -> effect/capability check
   -> interface artifact + hash -> (cool run 시) 얇은 typed IR -> interpreter

   현재 구현된 단계: 어휘 분석, 구문 분석. *)

type error = { file : string; line : int; col : int; message : string }

let string_of_error { file; line; col; message } =
  Printf.sprintf "%s:%d:%d: %s" file line col message

let read_file file =
  try
    let ic = open_in_bin file in
    let n = in_channel_length ic in
    let s = really_input_string ic n in
    close_in ic;
    Ok s
  with Sys_error msg -> Error { file; line = 0; col = 0; message = msg }

let lex_file file =
  match read_file file with
  | Error e -> Error e
  | Ok src -> (
      match Lexer.lex_result src with
      | Ok tokens -> Ok tokens
      | Error { pos; msg } ->
          Error { file; line = pos.line; col = pos.col; message = msg })

let tokens (file : string) : (Token.t list, error list) result =
  match lex_file file with Ok ts -> Ok ts | Error e -> Error [ e ]

let parse_file file =
  match lex_file file with
  | Error e -> Error e
  | Ok tokens -> (
      match Parser.parse_result tokens with
      | Ok m -> Ok m
      | Error { pos; msg } ->
          Error { file; line = pos.line; col = pos.col; message = msg })

let ast (file : string) : (Ast.modul, error list) result =
  match parse_file file with Ok m -> Ok m | Error e -> Error [ e ]

let resolve (file : string) : (Resolve.info, error list) result =
  match parse_file file with
  | Error e -> Error [ e ]
  | Ok m -> (
      let info, errors = Resolve.resolve m in
      match errors with
      | [] -> Ok info
      | _ ->
          Error
            (List.map
               (fun (e : Resolve.error) ->
                 { file; line = e.pos.line; col = e.pos.col; message = e.msg })
               errors))

let typecheck (file : string) : (unit, error list) result =
  match parse_file file with
  | Error e -> Error [ e ]
  | Ok m -> (
      let _, rerrors = Resolve.resolve m in
      match rerrors with
      | _ :: _ ->
          Error
            (List.map
               (fun (e : Resolve.error) ->
                 { file; line = e.pos.line; col = e.pos.col; message = e.msg })
               rerrors)
      | [] -> (
          let terrors =
            List.map
              (fun (e : Typecheck.error) ->
                { file; line = e.pos.line; col = e.pos.col; message = e.msg })
              (Typecheck.check m)
          in
          (* move/affinity는 타입·effect와 달리 별도 순회다. 소유하는 성질이
             다르고 해소를 공유할 지점도 없기 때문이다. *)
          let merrors =
            List.map
              (fun (e : Move.error) ->
                { file; line = e.pos.line; col = e.pos.col; message = e.msg })
              (Move.check m)
          in
          match
            List.sort
              (fun a b -> compare (a.line, a.col) (b.line, b.col))
              (terrors @ merrors)
          with
          | [] -> Ok ()
          | errors -> Error errors))

let check (files : string list) : (unit, error list) result =
  match files with
  | [] ->
      Error [ { file = "<none>"; line = 0; col = 0; message = "검사할 파일이 없습니다" } ]
  | _ ->
      let errors =
        List.filter_map
          (fun f -> match typecheck f with Ok _ -> None | Error es -> Some es)
          files
        |> List.concat
      in
      if errors <> [] then Error errors else Ok ()

let run (file : string) : (unit, error list) result =
  Error [ { file; line = 0; col = 0; message = "interpreter가 아직 구현되지 않았습니다" } ]