open Lexing open Lexer open Misc let log s = Format.ksprintf (fun s -> if !Options.verbose then Format.fprintf Format.std_formatter "%s" s) s let parse file = let ch = try open_in file with | Sys_error sys -> error "Cannot open file (%s)" sys in let lexbuf = Lexing.from_channel ch in try lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = file }; let ast = Parser.file Lexer.token lexbuf in close_in ch; ast with | Lex_error (loc, err) | Misc.Parse_error (loc, err) -> error "%a%s" Loc.print loc err | Parsing.Parse_error -> error "%aParse error" Loc.print (lexbuf_location lexbuf) let produce fake file cont = if fake then begin let fmt = Format.std_formatter in Format.fprintf fmt "---------- %s ----------@." file; cont fmt; end else begin log "Producing %s... %!" file; let ch = open_out file in let fmt = Format.formatter_of_out_channel ch in cont fmt; close_out ch; log "done.\n%!" end let file test loc poly fake file mll mly ast main = log "--------- Parsing %s ----------\n%!" file; let parsetree = parse file in log "--------- Lexedtree ----------\n%!"; let lexedtree = Lex.file parsetree in log "--------- Yacc ----------\n%!"; let grammar = Yacc.file loc lexedtree in log "--------- Types ----------\n%!"; let ntenv = try Infer.grammar lexedtree grammar with Infer.Typing_error (loc, msg) -> error "%a%s" Loc.print loc msg in log "--------- Variants ----------\n%!"; let variants = Makeast.compute_variants ntenv lexedtree in log "--------- Cycles ----------\n%!"; Typecheck.file variants ntenv lexedtree; log "--------- Produce Files ----------\n%!"; begin match lexedtree.Lexedtree.lexer.Lexedtree.kind with | Lexedtree.Custom _ -> () | Lexedtree.Default params -> produce fake (mll ^ ".mll") (Makelexer.file ast mly params); end; produce fake (mly ^ ".mly") (Makeparser.file test poly ast lexedtree grammar); produce fake ast (Makeast.file test poly file ntenv lexedtree variants); produce fake (main ^ ".mli") (Makemainmli.file file ast ntenv lexedtree); produce fake (main ^ ".ml") (Makemainml.file poly variants test ast mll mly ntenv lexedtree) let () = file !Options.test !Options.loc_style !Options.polyvar !Options.stdout !Options.file !Options.mll !Options.mly !Options.ast !Options.main