coollang/lib/ebnf.ml

(* EBNF 읽기.

   docs/grammar.ebnf를 데이터로 읽어들인다. 여기서부터 문법은 사람이 읽는
   문서가 아니라 기계가 소비하는 소스가 된다.

   이 파일이 존재하는 이유: 설명서와 파서가 따로 있으면 어긋난다. 실제로
   어긋났고, 어긋난 줄 아무도 몰랐다. 문법을 읽을 수 있게 되면 파서와
   기계적으로 대조할 수 있고, 나아가 파서를 여기서 뽑아낼 수 있다.

   표기는 grammar.ebnf 머리에 적힌 그대로다:
     =  정의     |  선택     [ ]  선택적     { }  반복
     ( ) 묶음    " " 단말    (* *) 주석      -  제외 *)

type expr =
  | Ref of string (* 다른 프로덕션 또는 토큰 이름 *)
  | RefArg of string * string (* 매개변수 프로덕션 참조: primary<ok> *)
  | Term of string (* "fn" 같은 리터럴 단말 *)
  | Seq of expr list
  | Alt of expr list
  | Opt of expr
  | Rep of expr
  | Except of expr * expr (* char - '"' *)

(* 매개변수 프로덕션. expr_ns를 표현하려면 필요하다 — if/match의 머리에서만
   struct 리터럴이 금지되는데, 그 제약은 식 문법 전체를 타고 내려간다.
   매개변수가 없으면 여덟 개 프로덕션을 통째로 복제해야 하고, 그러면 사람이
   읽는 문서로서의 값이 사라진다. *)
type rule = { name : string; params : string list; body : expr; line : int }
type t = rule list
type error = { line : int; msg : string }

exception Error of error

(* ------------------------------------------------------------------ *)
(* 어휘                                                                *)
(* ------------------------------------------------------------------ *)

type tok =
  | T_ident of string
  | T_str of string
  | T_eq
  | T_semi
  | T_comma
  | T_bar
  | T_lbracket
  | T_rbracket
  | T_lbrace
  | T_rbrace
  | T_lparen
  | T_rparen
  | T_minus
  | T_lt
  | T_gt
  | T_eof

let tokenize (src : string) : (tok * int) array =
  let n = String.length src in
  let out = ref [] in
  let line = ref 1 in
  let i = ref 0 in
  let emit t = out := (t, !line) :: !out in
  while !i < n do
    let c = src.[!i] in
    if c = '\n' then (
      incr line;
      incr i)
    else if c = ' ' || c = '\t' || c = '\r' then incr i
    else if c = '(' && !i + 1 < n && src.[!i + 1] = '*' then begin
      (* 주석. 중첩을 허용한다 — 문법 파일에 설명이 길게 들어간다 *)
      let depth = ref 0 in
      let fin = ref false in
      while (not !fin) && !i < n do
        if !i + 1 < n && src.[!i] = '(' && src.[!i + 1] = '*' then (
          incr depth;
          i := !i + 2)
        else if !i + 1 < n && src.[!i] = '*' && src.[!i + 1] = ')' then (
          decr depth;
          i := !i + 2;
          if !depth = 0 then fin := true)
        else (
          if src.[!i] = '\n' then incr line;
          incr i)
      done;
      if not !fin then raise (Error { line = !line; msg = "주석이 닫히지 않았습니다" })
    end
    else if c = '"' || c = '\'' then begin
      let quote = c in
      let start = !i + 1 in
      incr i;
      while !i < n && src.[!i] <> quote do
        if src.[!i] = '\n' then raise (Error { line = !line; msg = "단말이 닫히지 않았습니다" });
        incr i
      done;
      if !i >= n then raise (Error { line = !line; msg = "단말이 닫히지 않았습니다" });
      emit (T_str (String.sub src start (!i - start)));
      incr i
    end
    else if (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c = '_' then begin
      let start = !i in
      while
        !i < n
        &&
        let d = src.[!i] in
        (d >= 'a' && d <= 'z')
        || (d >= 'A' && d <= 'Z')
        || (d >= '0' && d <= '9')
        || d = '_'
      do
        incr i
      done;
      emit (T_ident (String.sub src start (!i - start)))
    end
    else begin
      let single t =
        emit t;
        incr i
      in
      (match c with
      | '=' -> single T_eq
      | ';' -> single T_semi
      | ',' -> single T_comma
      | '|' -> single T_bar
      | '[' -> single T_lbracket
      | ']' -> single T_rbracket
      | '{' -> single T_lbrace
      | '}' -> single T_rbrace
      | '(' -> single T_lparen
      | ')' -> single T_rparen
      | '-' -> single T_minus
      | '<' -> single T_lt
      | '>' -> single T_gt
      | _ ->
          raise
            (Error
               { line = !line; msg = Printf.sprintf "알 수 없는 문자 %c" c }))
    end
  done;
  emit T_eof;
  Array.of_list (List.rev !out)

(* ------------------------------------------------------------------ *)
(* 구문                                                                *)
(* ------------------------------------------------------------------ *)

type state = { toks : (tok * int) array; mutable p : int }

let cur st = fst st.toks.(st.p)
let line st = snd st.toks.(st.p)
let adv st = if st.p < Array.length st.toks - 1 then st.p <- st.p + 1

let fail st msg = raise (Error { line = line st; msg })

let eat st t what =
  if cur st = t then adv st
  else fail st (Printf.sprintf "%s이(가) 필요합니다" what)

(* alt := seq { "|" seq } *)
let rec parse_alt st =
  let first = parse_seq st in
  if cur st <> T_bar then first
  else begin
    let acc = ref [ first ] in
    while cur st = T_bar do
      adv st;
      acc := parse_seq st :: !acc
    done;
    Alt (List.rev !acc)
  end

(* seq := factor { "," factor } *)
and parse_seq st =
  let first = parse_factor st in
  if cur st <> T_comma then first
  else begin
    let acc = ref [ first ] in
    while cur st = T_comma do
      adv st;
      acc := parse_factor st :: !acc
    done;
    Seq (List.rev !acc)
  end

(* factor := primary { "-" primary } — 제외는 여러 번 올 수 있다 *)
and parse_factor st =
  let a = ref (parse_primary st) in
  while cur st = T_minus do
    adv st;
    a := Except (!a, parse_primary st)
  done;
  !a

and parse_primary st =
  match cur st with
  | T_ident n ->
      adv st;
      if cur st = T_lt then begin
        adv st;
        let a =
          match cur st with
          | T_ident a ->
              adv st;
              a
          | _ -> fail st "매개변수 이름"
        in
        eat st T_gt ">";
        RefArg (n, a)
      end
      else Ref n
  | T_str s ->
      adv st;
      Term s
  | T_lbracket ->
      adv st;
      let e = parse_alt st in
      eat st T_rbracket "]";
      Opt e
  | T_lbrace ->
      adv st;
      let e = parse_alt st in
      eat st T_rbrace "}";
      Rep e
  | T_lparen ->
      adv st;
      let e = parse_alt st in
      eat st T_rparen ")";
      e
  | _ -> fail st "이름, 단말, 또는 묶음"

let parse (src : string) : t =
  let st = { toks = tokenize src; p = 0 } in
  let rules = ref [] in
  while cur st <> T_eof do
    let ln = line st in
    let name =
      match cur st with
      | T_ident n ->
          adv st;
          n
      | _ -> fail st "프로덕션 이름"
    in
    let params =
      if cur st = T_lt then begin
        adv st;
        let acc = ref [] in
        let rec loop () =
          (match cur st with
          | T_ident p ->
              adv st;
              acc := p :: !acc
          | _ -> fail st "매개변수 이름");
          if cur st = T_comma then (
            adv st;
            loop ())
        in
        loop ();
        eat st T_gt ">";
        List.rev !acc
      end
      else []
    in
    eat st T_eq "=";
    let body = parse_alt st in
    eat st T_semi ";";
    rules := { name; params; body; line = ln } :: !rules
  done;
  List.rev !rules

let parse_result src = match parse src with r -> Ok r | exception Error e -> Error e

(* ------------------------------------------------------------------ *)
(* 조회                                                                *)
(* ------------------------------------------------------------------ *)

let find (g : t) name = List.find_opt (fun r -> r.name = name) g

(* 정의되지 않은 채 참조된 이름. 토큰 이름일 수도 있고 빠뜨린 프로덕션일
   수도 있으므로 판정하지 않고 목록만 준다. *)
let undefined (g : t) : string list =
  let defined = List.map (fun r -> r.name) g in
  let seen = Hashtbl.create 32 in
  let rec walk = function
    | Ref n -> if not (List.mem n defined) then Hashtbl.replace seen n ()
    | RefArg (n, _) -> if not (List.mem n defined) then Hashtbl.replace seen n ()
    | Term _ -> ()
    | Seq xs | Alt xs -> List.iter walk xs
    | Opt e | Rep e -> walk e
    | Except (a, b) ->
        walk a;
        walk b
  in
  List.iter (fun r -> walk r.body) g;
  Hashtbl.fold (fun k () acc -> k :: acc) seen [] |> List.sort compare

(* 어디서도 참조되지 않는 프로덕션. 시작 기호는 제외한다. *)
let unreachable (g : t) ~(start : string) : string list =
  let used = Hashtbl.create 32 in
  let rec walk = function
    | Ref n -> Hashtbl.replace used n ()
    (* 인자로 넘어간 이름도 쓰인 것이다: brace_list<field>의 field *)
    | RefArg (n, a) ->
        Hashtbl.replace used n ();
        Hashtbl.replace used a ()
    | Term _ -> ()
    | Seq xs | Alt xs -> List.iter walk xs
    | Opt e | Rep e -> walk e
    | Except (a, b) ->
        walk a;
        walk b
  in
  List.iter (fun r -> walk r.body) g;
  List.filter_map
    (fun r -> if r.name = start || Hashtbl.mem used r.name then None else Some r.name)
    g

let rec show_expr = function
  | Ref n -> n
  | RefArg (n, a) -> n ^ "<" ^ a ^ ">"
  | Term s -> "\"" ^ s ^ "\""
  | Seq xs -> String.concat " , " (List.map show_expr xs)
  | Alt xs -> String.concat " | " (List.map show_paren xs)
  | Opt e -> "[ " ^ show_expr e ^ " ]"
  | Rep e -> "{ " ^ show_expr e ^ " }"
  | Except (a, b) -> show_paren a ^ " - " ^ show_paren b

and show_paren e =
  match e with Alt _ | Seq _ -> "( " ^ show_expr e ^ " )" | _ -> show_expr e

let show_rule r =
  let ps = if r.params = [] then "" else "<" ^ String.concat ", " r.params ^ ">" in
  r.name ^ ps ^ " = " ^ show_expr r.body ^ " ;"

(* ------------------------------------------------------------------ *)
(* 단일화                                                              *)
(*                                                                     *)
(* 매개변수 프로덕션을 실제로 쓰인 인자별로 펼친다. primary<ok>와         *)
(* primary<no>가 각각 하나의 평범한 프로덕션이 되고, 그 뒤 분석은 매개변수를 *)
(* 몰라도 된다. 문서는 짧게 유지하고 기계는 펼친 것을 본다.               *)
(* ------------------------------------------------------------------ *)

let mangle n a = n ^ "<" ^ a ^ ">"

let expand (g : t) : t =
  (* 인자를 머리에 박아 특수화한 규칙이 있으면 그것을 먼저 쓴다.
     ident_or_struct<yes>와 ident_or_struct<no>처럼 인자에 따라 몸통이
     달라지는 자리를 위한 것이다. 없으면 일반 규칙에 인자를 대입한다. *)
  let by_name_arg n a =
    match List.find_opt (fun r -> r.name = n && r.params = [ a ]) g with
    | Some r -> Some r
    | None -> List.find_opt (fun r -> r.name = n && r.params <> []) g
  in
  let out = Hashtbl.create 64 in
  let queue = ref [] in
  (* 인자를 실제 값으로 바꾸며 몸통을 복사한다 *)
  let rec subst (env : (string * string) list) e =
    match e with
    | Term _ -> e
    (* 매개변수 이름이 그대로 참조된 자리도 인자로 바꾼다: list<item>의 item *)
    | Ref n -> ( match List.assoc_opt n env with Some v -> Ref v | None -> e)
    | RefArg (n, a) ->
        let a = match List.assoc_opt a env with Some v -> v | None -> a in
        (match by_name_arg n a with
        | Some r when r.params <> [] ->
            let key = (n, a) in
            if not (Hashtbl.mem out (mangle n a)) && not (List.mem key !queue) then
              queue := key :: !queue;
            Ref (mangle n a)
        | _ -> Ref n)
    | Seq xs -> Seq (List.map (subst env) xs)
    | Alt xs -> Alt (List.map (subst env) xs)
    | Opt x -> Opt (subst env x)
    | Rep x -> Rep (subst env x)
    | Except (x, y) -> Except (subst env x, subst env y)
  in
  (* 매개변수 없는 규칙부터 *)
  List.iter
    (fun r ->
      if r.params = [] then
        Hashtbl.replace out r.name { r with body = subst [] r.body })
    g;
  while !queue <> [] do
    let n, a = List.hd !queue in
    queue := List.tl !queue;
    let key = mangle n a in
    if not (Hashtbl.mem out key) then
      match by_name_arg n a with
      | None -> ()
      | Some r ->
          let env = match r.params with p :: _ -> [ (p, a) ] | [] -> [] in
          Hashtbl.replace out key
            { name = key; params = []; body = subst env r.body; line = r.line }
  done;
  (* 원본 순서를 최대한 유지한다 — 문서와 대조하기 쉽게 *)
  let ordered =
    List.concat_map
      (fun r ->
        if r.params = [] then
          match Hashtbl.find_opt out r.name with Some x -> [ x ] | None -> []
        else
          Hashtbl.fold
            (fun k v acc ->
              if String.length k > String.length r.name
                 && String.sub k 0 (String.length r.name + 1) = r.name ^ "<"
              then v :: acc
              else acc)
            out []
          |> List.sort (fun a b -> compare a.name b.name))
      g
  in
  ordered

(* ------------------------------------------------------------------ *)
(* nullable과 FIRST                                                    *)
(*                                                                     *)
(* 여기서부터가 "다음 한 토큰만 보고 결정할 수 있는가"를 기계가 판정하는  *)
(* 근거다. 문법 첫머리의 LL(1) 주장은 지금까지 사람의 말이었다.          *)
(* ------------------------------------------------------------------ *)

(* 단말 하나의 이름. 리터럴은 그 철자, 토큰 부류는 그 이름. *)
module SS = Set.Make (String)

type analysis = {
  rules : t;
  tokens : SS.t; (* 단말로 취급할 Ref 이름 (ident, NEWLINE 등) *)
  nullable : (string, bool) Hashtbl.t;
  first : (string, SS.t) Hashtbl.t;
}

let is_token a n = SS.mem n a.tokens || find a.rules n = None

let rec nullable_expr a = function
  | Term _ -> false
  | Ref n -> if is_token a n then false else Hashtbl.find_opt a.nullable n = Some true
  | RefArg (n, x) -> nullable_expr a (Ref (mangle n x))
  | Seq xs -> List.for_all (nullable_expr a) xs
  | Alt xs -> List.exists (nullable_expr a) xs
  | Opt _ | Rep _ -> true
  | Except (x, _) -> nullable_expr a x

let rec first_expr a = function
  | Term s -> SS.singleton s
  | Ref n ->
      if is_token a n then SS.singleton n
      else ( match Hashtbl.find_opt a.first n with Some s -> s | None -> SS.empty)
  | RefArg (n, x) -> first_expr a (Ref (mangle n x))
  | Alt xs -> List.fold_left (fun acc x -> SS.union acc (first_expr a x)) SS.empty xs
  | Opt x | Rep x -> first_expr a x
  | Except (x, _) -> first_expr a x
  | Seq xs ->
      let rec go acc = function
        | [] -> acc
        | x :: rest ->
            let acc = SS.union acc (first_expr a x) in
            if nullable_expr a x then go acc rest else acc
      in
      go SS.empty xs

(* 변화가 없을 때까지 돈다. 문법은 작으므로 단순한 고정점으로 충분하다. *)
let analyze ?(tokens = []) (g : t) : analysis =
  let a =
    {
      rules = g;
      tokens = SS.of_list tokens;
      nullable = Hashtbl.create 64;
      first = Hashtbl.create 64;
    }
  in
  List.iter (fun r -> Hashtbl.replace a.nullable r.name false) g;
  List.iter (fun r -> Hashtbl.replace a.first r.name SS.empty) g;
  let changed = ref true in
  while !changed do
    changed := false;
    List.iter
      (fun r ->
        let nu = nullable_expr a r.body in
        if nu && Hashtbl.find_opt a.nullable r.name <> Some true then (
          Hashtbl.replace a.nullable r.name true;
          changed := true);
        let f = first_expr a r.body in
        let old = match Hashtbl.find_opt a.first r.name with Some s -> s | None -> SS.empty in
        if not (SS.equal f old) then (
          Hashtbl.replace a.first r.name (SS.union old f);
          changed := true))
      g
  done;
  a

let first a name =
  match Hashtbl.find_opt a.first name with Some s -> s | None -> SS.empty

let nullable a name = Hashtbl.find_opt a.nullable name = Some true

(* ------------------------------------------------------------------ *)
(* FOLLOW와 LL(1) 충돌                                                 *)
(* ------------------------------------------------------------------ *)

(* 이어지는 자리를 (올 수 있는 단말들, 규칙 끝에 닿을 수 있는가)로 나른다.
   끝에 닿을 수 있으면 그 규칙의 FOLLOW가 더해진다. *)
type follow_env = {
  a : analysis;
  fol : (string, SS.t) Hashtbl.t;
  mutable deps : (string * string) list; (* (n, owner): follow n ⊇ follow owner *)
}

let get_fol e n = match Hashtbl.find_opt e.fol n with Some s -> s | None -> SS.empty

let rec collect e owner expr (cont : SS.t) (cont_end : bool) =
  match expr with
  | Term _ -> ()
  | RefArg (n, x) -> collect e owner (Ref (mangle n x)) cont cont_end
  | Ref n ->
      if not (is_token e.a n) then begin
        Hashtbl.replace e.fol n (SS.union (get_fol e n) cont);
        if cont_end && not (List.mem (n, owner) e.deps) then
          e.deps <- (n, owner) :: e.deps
      end
  | Alt xs -> List.iter (fun x -> collect e owner x cont cont_end) xs
  | Opt x -> collect e owner x cont cont_end
  (* 반복은 자기 자신이 뒤따를 수 있다 *)
  | Rep x -> collect e owner x (SS.union cont (first_expr e.a x)) cont_end
  | Except (x, _) -> collect e owner x cont cont_end
  | Seq xs ->
      let acc_first = ref cont and acc_end = ref cont_end in
      List.iter
        (fun x ->
          collect e owner x !acc_first !acc_end;
          let f = first_expr e.a x in
          if nullable_expr e.a x then acc_first := SS.union f !acc_first
          else (
            acc_first := f;
            acc_end := false))
        (List.rev xs)

let follows ?(tokens = []) (g : t) : (string, SS.t) Hashtbl.t =
  let a = analyze ~tokens g in
  let e = { a; fol = Hashtbl.create 64; deps = [] } in
  List.iter (fun r -> collect e r.name r.body SS.empty true) g;
  (* 규칙 끝에 닿는 참조는 그 규칙의 FOLLOW를 물려받는다. 고정점. *)
  let changed = ref true in
  while !changed do
    changed := false;
    List.iter
      (fun (n, owner) ->
        let merged = SS.union (get_fol e n) (get_fol e owner) in
        if not (SS.equal merged (get_fol e n)) then (
          Hashtbl.replace e.fol n merged;
          changed := true))
      e.deps
  done;
  e.fol

type conflict = {
  c_rule : string;
  c_line : int;
  c_kind : string; (* "선택" | "선택적" | "반복" *)
  c_tokens : string list; (* 겹치는 단말 *)
  c_detail : string;
  (* greedy 규칙으로 해소되는가. [ X ]와 { X }가 "최대한 먹는다"로 정의되면,
     겹치는 토큰이 흡수 대상뿐일 때 결정이 갈린다. 어느 쪽으로 읽든 같은
     것을 뜻하는 자리에서만 쓸 수 있는 해소다 — 진짜 중의성을 덮지 않도록
     greedy 토큰 목록은 문법이 명시한다. *)
  c_greedy : bool;
}

(* 같은 단말로 시작하는 대안이 둘 이상이면 한 토큰으로 결정할 수 없다. *)
let conflicts ?(tokens = []) ?(greedy = []) (g : t) : conflict list =
  let a = analyze ~tokens g in
  let fol = follows ~tokens g in
  let out = ref [] in
  let add r kind toks detail =
    if toks <> [] then
      out :=
        {
          c_rule = r.name;
          c_line = r.line;
          c_kind = kind;
          c_tokens = toks;
          c_detail = detail;
          (* 선택/반복만 greedy로 해소된다. 대안(Alt) 충돌은 못 덮는다 *)
          c_greedy = kind <> "선택" && List.for_all (fun t -> List.mem t greedy) toks;
        }
        :: !out
  in
  let rec walk r expr (cont : SS.t) (cont_end : bool) =
    let cont_full =
      if cont_end then SS.union cont (match Hashtbl.find_opt fol r.name with Some s -> s | None -> SS.empty)
      else cont
    in
    match expr with
    | Term _ | Ref _ | RefArg _ -> ()
    | Except (x, _) -> walk r x cont cont_end
    | Alt xs ->
        let n = List.length xs in
        for i = 0 to n - 1 do
          for j = i + 1 to n - 1 do
            let fi = first_expr a (List.nth xs i) and fj = first_expr a (List.nth xs j) in
            let inter = SS.inter fi fj in
            if not (SS.is_empty inter) then
              add r "선택" (SS.elements inter)
                (Printf.sprintf "%d번째와 %d번째 대안이 같은 토큰으로 시작합니다: %s / %s"
                   (i + 1) (j + 1)
                   (show_expr (List.nth xs i))
                   (show_expr (List.nth xs j)))
          done
        done;
        let nulls = List.filter (nullable_expr a) xs in
        if List.length nulls > 1 then
          add r "선택" [ "(빈 것)" ] "비어도 되는 대안이 둘 이상입니다";
        List.iter (fun x -> walk r x cont cont_end) xs
    | Opt x ->
        let inter = SS.inter (first_expr a x) cont_full in
        if not (SS.is_empty inter) then
          add r "선택적" (SS.elements inter)
            (Printf.sprintf "[ %s ]를 넣을지 말지가 다음 토큰으로 갈리지 않습니다" (show_expr x));
        walk r x cont cont_end
    | Rep x ->
        let inter = SS.inter (first_expr a x) cont_full in
        if not (SS.is_empty inter) then
          add r "반복" (SS.elements inter)
            (Printf.sprintf "{ %s }를 더 돌지 말지가 다음 토큰으로 갈리지 않습니다" (show_expr x));
        walk r x (SS.union cont (first_expr a x)) cont_end
    | Seq xs ->
        let acc_first = ref cont and acc_end = ref cont_end in
        List.iter
          (fun x ->
            walk r x !acc_first !acc_end;
            let f = first_expr a x in
            if nullable_expr a x then acc_first := SS.union f !acc_first
            else (
              acc_first := f;
              acc_end := false))
          (List.rev xs)
  in
  List.iter (fun r -> walk r r.body SS.empty true) g;
  List.rev !out