open Misc open Commontree open Lexedtree open Yacctree open Format open Types let rec print_action poly fmt a = let print_action x = print_action poly x in match a.node with | Token i -> fprintf fmt "$%d" i | Unit -> fprintf fmt "()" | Tuple l -> fprintf fmt "%a" (print_tuple poly) l | Construct (name, []) -> fprintf fmt "%s%s" (if poly then "`" else "") name | Construct (name, l) -> fprintf fmt "@[(%s%s@ %a)@]" (if poly then "`" else "") name (print_tuple poly) l | Cons (a, b) -> fprintf fmt "@[(%a ::@ %a)@]" print_action a print_action b | EmptyList -> fprintf fmt "[]" | MakeSome a -> fprintf fmt "@[(Some@ %a)@]" print_action a | MakeNone -> fprintf fmt "None" | Locate a -> fprintf fmt "@[(node@ %a)@]" print_action a and print_tuple poly fmt l = let print_action x = print_action poly x in match l with | [] -> fprintf fmt "()" | [ a ] -> fprintf fmt "%a" print_action a | a :: r -> fprintf fmt "@[(%a" print_action a; List.iter (fprintf fmt ",@ %a" print_action) r; fprintf fmt ")@]" let print_token fmt = function | TerminalToken s | NonTerminalToken s -> fprintf fmt "%s" s let print_grammar poly fmt (g: grammar) = List.iter (fun (name, branches) -> fprintf fmt "@.@[%s:" name; let first = ref true in List.iter (fun (tokens, action) -> fprintf fmt "@ @["; if !first then print_if_newline (); fprintf fmt "%s" "| "; List.iter (fprintf fmt "%a@ " print_token) tokens; fprintf fmt "@[{ %a }@]" (print_action poly) action; fprintf fmt "@]"; first := false) branches; fprintf fmt ";@]@.") g let print_starts test ast fmt file = List.iter (fun n -> let name = n.node.name in if n.node.main || test = Some name then begin fprintf fmt "@.@.%%type <%s.%s> %s@.%%start %s" (module_name ast) name name name end) file.entries let print_type fmt ty = match UType.find ty with | Ident ([], s) -> fprintf fmt "%s" s | _ -> assert false (* TODO, maybe *) let print_tokens fmt file = StringMap.iter (fun name ty -> if ty = Types.unit then fprintf fmt "@.%%token %s" name else fprintf fmt "@.%%token <%a> %s" print_type ty name) file.lexer.terminal_types let print_precedences fmt precs = if precs <> [] then fprintf fmt "@."; List.iter (function | NonAssoc tokens -> fprintf fmt "@.@[%%nonassoc"; List.iter (fprintf fmt "@ %s") tokens; fprintf fmt "@]" | Left tokens -> fprintf fmt "@.@[%%left"; List.iter (fprintf fmt "@ %s") tokens; fprintf fmt "@]" | Right tokens -> fprintf fmt "@.@[%%right"; List.iter (fprintf fmt "@ %s") tokens; fprintf fmt "@]") precs let file test poly ast file yacc fmt = fprintf fmt "\ %%{ open Parsing open %s let loc () = symbol_start_pos (), symbol_end_pos () let node x = { loc = loc (); node = x; } %%} %a%a%a %%%% %a " (module_name ast) print_tokens file print_precedences file.precedences (print_starts test ast) file (print_grammar poly) yacc