path: root/grammar/coqpp_main.ml

(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

open Lexing
open Coqpp_ast
open Format

let fatal msg =
  let () = Format.eprintf "Error: %s@\n%!" msg in
  exit 1

let pr_loc loc =
  let file = loc.loc_start.pos_fname in
  let line = loc.loc_start.pos_lnum in
  let bpos = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in
  let epos = loc.loc_end.pos_cnum - loc.loc_start.pos_bol in
  Printf.sprintf "File \"%s\", line %d, characters %d-%d:" file line bpos epos

let parse_file f =
  let chan = open_in f in
  let lexbuf = Lexing.from_channel chan in
  let () = lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = f } in
  let ans =
    try Coqpp_parse.file Coqpp_lex.token lexbuf
    with
    | Coqpp_lex.Lex_error (loc, msg) ->
      let () = close_in chan in
      let () = Printf.eprintf "%s\n%!" (pr_loc loc) in
      fatal msg
    | Parsing.Parse_error ->
      let () = close_in chan in
      let loc = Coqpp_lex.loc lexbuf in
      let () = Printf.eprintf "%s\n%!" (pr_loc loc) in
      fatal "syntax error"
  in
  let () = close_in chan in
  ans

module StringSet = Set.Make(String)

let string_split s =
  let len = String.length s in
  let rec split n =
    try
      let pos = String.index_from s n '.' in
      let dir = String.sub s n (pos-n) in
      dir :: split (succ pos)
    with
      | Not_found -> [String.sub s n (len-n)]
  in
  if len == 0 then [] else split 0

module GramExt :
sig

val print_ast : Format.formatter -> grammar_ext -> unit

end =
struct

let is_uident s = match s.[0] with
| 'A'..'Z' -> true
| _ -> false

let is_qualified = is_uident

let get_local_entries ext =
  let global = StringSet.of_list ext.gramext_globals in
  let map e = e.gentry_name in
  let entries = List.map map ext.gramext_entries in
  let local = List.filter (fun e -> not (is_qualified e || StringSet.mem e global)) entries in
  let rec uniquize seen = function
  | [] -> []
  | id :: rem ->
    let rem = uniquize (StringSet.add id seen) rem in
    if StringSet.mem id seen then rem else id :: rem
  in
  uniquize StringSet.empty local

let print_local chan ext =
  let locals = get_local_entries ext in
  match locals with
  | [] -> ()
  | e :: locals ->
    let mk_e chan e = fprintf chan "%s.Entry.create \"%s\"" ext.gramext_name e in
    let () = fprintf chan "@[<hv 2>let %s =@ @[%a@]@]@ " e mk_e e in
    let iter e = fprintf chan "@[<hv 2>and %s =@ @[%a@]@]@ " e mk_e e in
    let () = List.iter iter locals in
    fprintf chan "in@ "

let print_string chan s = fprintf chan "\"%s\"" s

let print_list chan pr l =
  let rec prl chan = function
  | [] -> ()
  | [x] -> fprintf chan "%a" pr x
  | x :: l -> fprintf chan "%a;@ %a" pr x prl l
  in
  fprintf chan "@[<hv>[%a]@]" prl l

let print_opt chan pr = function
| None -> fprintf chan "None"
| Some x -> fprintf chan "Some@ (%a)" pr x

let print_position chan pos = match pos with
| First -> fprintf chan "Extend.First"
| Last -> fprintf chan "Extend.Last"
| Before s -> fprintf chan "Extend.Before@ \"%s\"" s
| After s -> fprintf chan "Extend.After@ \"%s\"" s
| Level s -> fprintf chan "Extend.Level@ \"%s\"" s

let print_assoc chan = function
| LeftA -> fprintf chan "Extend.LeftA"
| RightA -> fprintf chan "Extend.RightA"
| NonA -> fprintf chan "Extend.NonA"

type symb =
| SymbToken of string * string option
| SymbEntry of string * string option
| SymbSelf
| SymbNext
| SymbList0 of symb * symb option
| SymbList1 of symb * symb option
| SymbOpt of symb
| SymbRules of ((string option * symb) list * code) list

let is_token s = match string_split s with
| [s] -> is_uident s
| _ -> false

let rec parse_tokens = function
| [GSymbString s] -> SymbToken ("", Some s)
| [GSymbQualid ("SELF", None)] -> SymbSelf
| [GSymbQualid ("NEXT", None)] -> SymbNext
| [GSymbQualid ("LIST0", None); tkn] ->
  SymbList0 (parse_token tkn, None)
| [GSymbQualid ("LIST1", None); tkn] ->
  SymbList1 (parse_token tkn, None)
| [GSymbQualid ("LIST0", None); tkn; GSymbQualid ("SEP", None); tkn'] ->
  SymbList0 (parse_token tkn, Some (parse_token tkn'))
| [GSymbQualid ("LIST1", None); tkn; GSymbQualid ("SEP", None); tkn'] ->
  SymbList1 (parse_token tkn, Some (parse_token tkn'))
| [GSymbQualid ("OPT", None); tkn] ->
  SymbOpt (parse_token tkn)
| [GSymbQualid (e, None)] when is_token e -> SymbToken (e, None)
| [GSymbQualid (e, None); GSymbString s] when is_token e -> SymbToken (e, Some s)
| [GSymbQualid (e, lvl)] when not (is_token e) -> SymbEntry (e, lvl)
| [GSymbParen tkns] -> parse_tokens tkns
| [GSymbProd prds] ->
  let map p =
    let map (pat, tkns) = (pat, parse_tokens tkns) in
    (List.map map p.gprod_symbs, p.gprod_body)
  in
  SymbRules (List.map map prds)
| t ->
  let rec db_token = function
  | GSymbString s -> Printf.sprintf "\"%s\"" s
  | GSymbQualid (s, _) -> Printf.sprintf "%s" s
  | GSymbParen s -> Printf.sprintf "(%s)" (db_tokens s)
  | GSymbProd _ -> Printf.sprintf "[...]"
  and db_tokens tkns =
    let s = List.map db_token tkns in
    String.concat " " s
  in
  fatal (Printf.sprintf "Invalid token: %s" (db_tokens t))

and parse_token tkn = parse_tokens [tkn]

let print_fun chan (vars, body) =
  let vars = List.rev vars in
  let iter = function
  | None -> fprintf chan "_@ "
  | Some id -> fprintf chan "%s@ " id
  in
  let () = fprintf chan "fun@ " in
  let () = List.iter iter vars in
  (** FIXME: use Coq locations in the macros *)
  let () = fprintf chan "loc ->@ @[%s@]" body.code in
  ()

(** Meta-program instead of calling Tok.of_pattern here because otherwise
    violates value restriction *)
let print_tok chan = function
| "", s -> fprintf chan "Tok.KEYWORD %a" print_string s
| "IDENT", s -> fprintf chan "Tok.IDENT %a" print_string s
| "PATTERNIDENT", s -> fprintf chan "Tok.PATTERNIDENT %a" print_string s
| "FIELD", s -> fprintf chan "Tok.FIELD %a" print_string s
| "INT", s -> fprintf chan "Tok.INT %a" print_string s
| "STRING", s -> fprintf chan "Tok.STRING %a" print_string s
| "LEFTQMARK", _ -> fprintf chan "Tok.LEFTQMARK"
| "BULLET", s -> fprintf chan "Tok.BULLET %a" print_string s
| "EOI", _ -> fprintf chan "Tok.EOI"
| _ -> failwith "Tok.of_pattern: not a constructor"

let rec print_prod chan p =
  let (vars, tkns) = List.split p.gprod_symbs in
  let f = (vars, p.gprod_body) in
  let tkn = List.rev_map parse_tokens tkns in
  fprintf chan "@[Extend.Rule@ (@[%a@],@ @[(%a)@])@]" print_symbols tkn print_fun f

and print_symbols chan = function
| [] -> fprintf chan "Extend.Stop"
| tkn :: tkns ->
  fprintf chan "Extend.Next @[(%a,@ %a)@]" print_symbols tkns print_symbol tkn

and print_symbol chan tkn = match tkn with
| SymbToken (t, s) ->
  let s = match s with None -> "" | Some s -> s in
  fprintf chan "(Extend.Atoken (%a))" print_tok (t, s)
| SymbEntry (e, None) ->
  fprintf chan "(Extend.Aentry %s)" e
| SymbEntry (e, Some l) ->
  fprintf chan "(Extend.Aentryl (%s, %a))" e print_string l
| SymbSelf ->
  fprintf chan "Extend.Aself"
| SymbNext ->
  fprintf chan "Extend.Anext"
| SymbList0 (s, None) ->
  fprintf chan "(Extend.Alist0 %a)" print_symbol s
| SymbList0 (s, Some sep) ->
  fprintf chan "(Extend.Alist0sep (%a, %a))" print_symbol s print_symbol sep
| SymbList1 (s, None) ->
  fprintf chan "(Extend.Alist1 %a)" print_symbol s
| SymbList1 (s, Some sep) ->
  fprintf chan "(Extend.Alist1sep (%a, %a))" print_symbol s print_symbol sep
| SymbOpt s ->
  fprintf chan "(Extend.Aopt %a)" print_symbol s
| SymbRules rules ->
  let pr chan (r, body) =
    let (vars, tkn) = List.split r in
    let tkn = List.rev tkn in
    fprintf chan "Extend.Rules @[({ Extend.norec_rule = %a },@ (%a))@]" print_symbols tkn print_fun (vars, body)
  in
  let pr chan rules = print_list chan pr rules in
  fprintf chan "(Extend.Arules %a)" pr (List.rev rules)

let print_rule chan r =
  let pr_lvl chan lvl = print_opt chan print_string lvl in
  let pr_asc chan asc = print_opt chan print_assoc asc in
  let pr_prd chan prd = print_list chan print_prod prd in
  fprintf chan "@[(%a,@ %a,@ %a)@]" pr_lvl r.grule_label pr_asc r.grule_assoc pr_prd (List.rev r.grule_prods)

let print_entry chan gram e =
  let print_position_opt chan pos = print_opt chan print_position pos in
  let print_rules chan rules = print_list chan print_rule rules in
  fprintf chan "let () =@ @[%s.safe_extend@ %s@ @[(%a, %a)@]@]@ in@ "
    gram e.gentry_name print_position_opt e.gentry_pos print_rules e.gentry_rules

let print_ast chan ext =
  let () = fprintf chan "let _ = @[" in
  let () = fprintf chan "@[<v>%a@]" print_local ext in
  let () = List.iter (fun e -> print_entry chan ext.gramext_name e) ext.gramext_entries in
  let () = fprintf chan "()@]\n" in
  ()

end

let pr_ast chan = function
| Code s -> fprintf chan "%s@\n" s.code
| Comment s -> fprintf chan "%s@\n" s
| GramExt gram -> fprintf chan "%a@\n" GramExt.print_ast gram
| VernacExt -> fprintf chan "VERNACEXT@\n"
| TacticExt (id, rules) ->
  let pr_tok = function
  | ExtTerminal s -> Printf.sprintf "%s" s
  | ExtNonTerminal (s, _) -> Printf.sprintf "%s" s
  in
  let pr_tacrule r =
    let toks = String.concat " " (List.map pr_tok r.tac_toks) in
    Printf.sprintf "[%s] -> {%s}" toks r.tac_body.code
  in
  let rules = String.concat ", " (List.map pr_tacrule rules) in
  fprintf chan "TACTICEXT (%s, [%s])@\n" id rules

let () =
  let () =
    if Array.length Sys.argv <> 2 then fatal "Expected exactly one command line argument"
  in
  let file = Sys.argv.(1) in
  let output = Filename.chop_extension file ^ ".ml" in
  let ast = parse_file file in
  let chan = open_out output in
  let fmt = formatter_of_out_channel chan in
  let iter ast = Format.fprintf fmt "@[%a@]%!"pr_ast ast in
  let () = List.iter iter ast in
  let () = close_out chan in
  exit 0