coollang/lib/ebnf_gen.ml

(* 문법에서 문장을 만든다.

   대조는 두 방향이 있다. 저장소의 .cool 파일로 하는 대조는 "사람이 쓴 코드"
   만 훑으므로, 문법이 약속했는데 파서가 못 읽는 구석은 아무도 안 밟으면
   드러나지 않는다. 여기서는 문법이 허용하는 문장을 직접 만들어 파서에
   먹인다 — 파서가 거부하면 둘 중 하나가 틀린 것이다.

   텍스트가 아니라 토큰 열을 만든다. 렉서의 줄바꿈 삽입 규칙을 거치면
   문법이 허용해도 렉서가 만들 수 없는 문장이 생기는데, 그건 파서의 잘못이
   아니다. 검사하려는 것은 문법과 파서 사이지 렉서가 아니다. *)

(* 최소 유도 길이. 깊이가 차면 가장 짧게 끝나는 가지를 고른다 —
   이게 없으면 재귀 문법에서 생성이 끝나지 않는다. *)
let min_len (g : Ebnf.t) (tokens : string list) : (string, int) Hashtbl.t =
  let tbl = Hashtbl.create 128 in
  let inf = 1_000_000 in
  List.iter (fun (r : Ebnf.rule) -> Hashtbl.replace tbl r.name inf) g;
  let get n =
    if List.mem n tokens || not (List.exists (fun (r : Ebnf.rule) -> r.name = n) g)
    then 1
    else match Hashtbl.find_opt tbl n with Some v -> v | None -> 1
  in
  let cap a b = if a >= inf || b >= inf then inf else a + b in
  let rec cost = function
    | Ebnf.Term _ -> 1
    | Ebnf.Ref n -> get n
    | Ebnf.RefArg (n, x) -> get (Ebnf.mangle n x)
    | Ebnf.Seq xs -> List.fold_left (fun a x -> cap a (cost x)) 0 xs
    | Ebnf.Alt xs -> List.fold_left (fun a x -> min a (cost x)) inf xs
    | Ebnf.Opt _ | Ebnf.Rep _ -> 0
    | Ebnf.Except (x, _) -> cost x
  in
  let changed = ref true in
  while !changed do
    changed := false;
    List.iter
      (fun (r : Ebnf.rule) ->
        let c = cost r.body in
        if c < Hashtbl.find tbl r.name then (
          Hashtbl.replace tbl r.name c;
          changed := true))
      g
  done;
  tbl

type gen = {
  rules : (string, Ebnf.rule) Hashtbl.t;
  costs : (string, int) Hashtbl.t;
  tokens : string list;
  mutable out : Token.kind list;
  (* 깊이로 제한한다. 총 확장 횟수로 세면 선언 머리에서 다 써 버려 정작
     식과 문에는 도달하지 못한다 — 재미있는 구석이 전부 그 안에 있는데. *)
  mutable depth : int;
  max_depth : int;
  (* 어느 프로덕션을 밟았는가. 퍼저가 무엇을 시험하는지 모르면 통과했다는
     말에 값이 없다 — 안 밟은 규칙은 시험되지 않은 규칙이다. *)
  visited : (string, unit) Hashtbl.t;
}

let sample_token (n : string) : Token.kind =
  match n with
  | "ident" -> Token.Ident "x"
  | "int_lit" -> Token.Int "1"
  | "string_lit" -> Token.Str "s"
  | "NEWLINE" -> Token.Newline
  | _ -> Token.Ident "x"

(* 단말 철자에서 토큰으로. 모든 토큰을 훑어 show_kind가 같은 것을 찾는다 —
   철자 표를 따로 두면 그것도 어긋난다 *)
let token_of_term (s : string) : Token.kind option =
  List.find_opt (fun k -> Token.show_kind k = s) Token.all_kinds

let emit g k = g.out <- k :: g.out

let rec cost_of g = function
  | Ebnf.Term _ -> 1
  | Ebnf.Ref n -> (
      if List.mem n g.tokens then 1
      else match Hashtbl.find_opt g.costs n with Some v -> v | None -> 1)
  | Ebnf.RefArg (n, x) -> cost_of g (Ebnf.Ref (Ebnf.mangle n x))
  | Ebnf.Seq xs -> List.fold_left (fun a x -> a + cost_of g x) 0 xs
  | Ebnf.Alt xs -> List.fold_left (fun a x -> min a (cost_of g x)) 1_000_000 xs
  | Ebnf.Opt _ | Ebnf.Rep _ -> 0
  | Ebnf.Except (x, _) -> cost_of g x

let deep g = g.depth >= g.max_depth

let rec gen_expr g (e : Ebnf.expr) =
  match e with
  | Ebnf.Term s -> (
      match token_of_term s with Some k -> emit g k | None -> emit g (Token.Ident "x"))
  | Ebnf.Ref n ->
      if List.mem n g.tokens then emit g (sample_token n)
      else (
        match Hashtbl.find_opt g.rules n with
        | Some r ->
            Hashtbl.replace g.visited n ();
            g.depth <- g.depth + 1;
            gen_expr g r.Ebnf.body;
            g.depth <- g.depth - 1
        | None -> emit g (sample_token n))
  | Ebnf.RefArg (n, x) -> gen_expr g (Ebnf.Ref (Ebnf.mangle n x))
  | Ebnf.Seq xs -> List.iter (gen_expr g) xs
  | Ebnf.Alt xs ->
      let pick =
        if deep g then begin
          (* 깊이가 차면 가장 짧게 끝나는 가지. 같은 값이 여럿이면 무작위로
             고른다 — 늘 첫 번째를 고르면 뒤쪽 가지가 영영 안 밟힌다 *)
          let best = List.fold_left (fun a x -> min a (cost_of g x)) 1_000_000 xs in
          let cands = List.filter (fun x -> cost_of g x = best) xs in
          match cands with
          | [] -> None
          | _ -> Some (List.nth cands (Random.int (List.length cands)))
        end
        else Some (List.nth xs (Random.int (List.length xs)))
      in
      Option.iter (gen_expr g) pick
  | Ebnf.Opt x -> if (not (deep g)) && Random.bool () then gen_expr g x
  | Ebnf.Rep x ->
      if not (deep g) then
        (* 얕을수록 더 돌린다. 최상위 { item }이 0번이면 빈 파일이 된다 *)
        let n = if g.depth <= 1 then 1 + Random.int 3 else Random.int 3 in
        for _ = 1 to n do
          gen_expr g x
        done
  | Ebnf.Except (x, _) -> gen_expr g x

(* start에서 시작하는 문장 하나. 토큰 열을 돌려준다 (Eof 포함) *)
let sentence ?(tokens = []) ?(start = "module") ?(max_depth = 14) ?visited
    (g : Ebnf.t) : Token.t list =
  let g' = Ebnf.expand g in
  let rules = Hashtbl.create 128 in
  List.iter (fun (r : Ebnf.rule) -> Hashtbl.replace rules r.name r) g';
  let st =
    {
      rules;
      costs = min_len g' tokens;
      tokens;
      out = [];
      depth = 0;
      max_depth;
      visited = (match visited with Some v -> v | None -> Hashtbl.create 8);
    }
  in
  gen_expr st (Ebnf.Ref start);
  let pos = Token.{ line = 1; col = 1 } in
  List.rev_map (fun k -> Token.{ kind = k; pos }) st.out
  |> fun xs -> List.rev (Token.{ kind = Token.Eof; pos } :: List.rev xs)