Stefan pushed to branch master at Stefan / Typer

Commits: 57a4f589 by Stefan Monnier at 2016-02-26T23:18:43-05:00 * src/pexp.ml: Adjust to recent changes to Pinductive

* src/main.ml (process_typer_file.process_decl): Remove Lexp use since it's not ready yet.

* src/pexp.ml (pexp_p_actual_arg, pexp_p_formal_arg) (pexp_u_formal_arg): New functions. (pexp_unparse, pexp_parse.pcases): Use them to handle the formal args of inductive types. (pexp_p_decls): Rename from pexp_decls.

* .gitignore: Ignore *.byte files.

- - - - -

3 changed files:

- .gitignore - src/main.ml - src/pexp.ml

Changes:

===================================== .gitignore ===================================== --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,6 @@ ChangeLog typer +*.byte *.elc *.annot *.cmi

===================================== src/main.ml ===================================== --- a/src/main.ml +++ b/src/main.ml @@ -24,11 +24,11 @@ this program. If not, see http://www.gnu.org/licenses/. *) open Util open Lexer open Sexp -open Elaborate -open Javascript +(* open Elaborate *) +(* open Javascript *)

(* I think they shouldn't be here, but for now I use them. *) -open Lexp +(* open Lexp *) open Prelexer open Pexp

@@ -154,15 +154,15 @@ let process_typer_file sourcename choppable_suffix venv = sexp_print sexp; print_newline(); let pdecls = pexp_p_decls sexp in sexp_print (pexp_u_decls pdecls); print_newline(); - let (decls',pnames',delayed',senv',venv') - = List.fold_left (elaborate_decl (ScopeLevel 0) (default_stt, grm)) - ([], pnames, delayed, senv, venv) - pdecls in - let pdecls = lexp_unparse_decls decls' in - sexp_print (pexp_u_decls pdecls); print_newline(); + (* let (decls',pnames',delayed',senv',venv') + * = List.fold_left (elaborate_decl (ScopeLevel 0) (default_stt, grm)) + * ([], pnames, delayed, senv, venv) + * pdecls in + * let pdecls = lexp_unparse_decls decls' in + * sexp_print (pexp_u_decls pdecls); print_newline(); *) (* print_string ": "; * sexp_print (pexp_unparse (lexp_unparse t)); print_newline(); *) - print_newline(); + (* print_newline(); *)

@@ -191,9 +191,9 @@ let process_typer_file sourcename choppable_suffix venv = match rest with | [] -> (decls, venv) | _ -> process_decl (grm, rest, - decls' @ decls, pnames', delayed', senv', venv') + pdecls @ decls, pnames, delayed, senv, venv) in process_decl (default_grammar, tokens, - [], SMap.empty, [], senv_builtin, venv) + [], SMap.empty, None, [], venv) (* ; close_out js_file *)

let process_file filename venv = @@ -202,7 +202,7 @@ let process_file filename venv = else raise (Arg.Bad ("Unknown filetype: " ^ filename))

-let (perv_decls, perv_venv) = process_file "pervasive.typer" venv_builtin +let (perv_decls, perv_venv) = process_file "pervasive.typer" None

let _ = Arg.parse [

===================================== src/pexp.ml ===================================== --- a/src/pexp.ml +++ b/src/pexp.ml @@ -92,7 +92,7 @@ let rec pexp_parse (s : sexp) : pexp = -> Phastype (start, pexp_parse e, pexp_parse t) (* let *) | Node (Symbol (start, "let_in_"), [decls; body]) - -> Plet (start, pexp_decls decls, pexp_parse body) + -> Plet (start, pexp_p_decls decls, pexp_parse body) | Node (Symbol (start, ("let_in_" | "let" | "let_")), _) -> msg_error start "Unrecognized let expression"; Pmetavar (start, "_") (* arrow *) @@ -140,7 +140,7 @@ let rec pexp_parse (s : sexp) : pexp = | _ -> msg_error (sexp_location case) "Unrecognized constructor declaration"; pcases) cases [] in - Pinductive (name, List.map pexp_parse args, pcases) + Pinductive (name, List.map pexp_p_formal_arg args, pcases) | Node (Symbol (start, "inductive_"), _) -> msg_error start "Unrecognized inductive type"; Pmetavar (start, "_") (* constructor *) @@ -165,6 +165,39 @@ let rec pexp_parse (s : sexp) : pexp = | Node (f, []) -> pexp_parse f | Node (f, args) -> Pcall (pexp_parse f, args)

+and pexp_p_actual_arg arg : (arg_kind * pvar option * pexp) = + match arg with + | Node (Symbol (_, ":≡"), [Symbol s; e]) + -> (Aerasable, Some s, pexp_parse e) + | Node (Symbol (_, ":="), [Symbol s; e]) + -> (Aimplicit, Some s, pexp_parse e) + | Node (Symbol (_, ":-"), [Symbol s; e]) + -> (Aexplicit, Some s, pexp_parse e) + | e -> (Aexplicit, None, pexp_parse e) + +and pexp_p_formal_arg arg : (arg_kind * pvar * pexp option) = + match arg with + | Node (Symbol (_, ":::"), [Symbol s; e]) + -> (Aerasable, s, Some (pexp_parse e)) + | Node (Symbol (_, "::"), [Symbol s; e]) + -> (Aimplicit, s, Some (pexp_parse e)) + | Node (Symbol (_, ":"), [Symbol s; e]) + -> (Aexplicit, s, Some (pexp_parse e)) + | Symbol s -> (Aexplicit, s, None) + | _ -> (msg_error (sexp_location arg) + "Unrecognized formal arg"; + (Aexplicit, (sexp_location arg, "{arg}"), None)) + +and pexp_u_formal_arg (arg : arg_kind * pvar * pexp option) = + match arg with + | (Aexplicit, s, None) -> Symbol s + | (ak, ((l,_) as s), t) + -> Node (Symbol (l, match ak with Aerasable -> ":::" + | Aimplicit -> "::" + | Aexplicit -> ":"), + [Symbol s; match t with Some e -> pexp_unparse e + | None -> Symbol (l, "_")]) + and pexp_p_id (x : location * string) : (location * string) option = match x with | (_, "_") -> None @@ -228,11 +261,11 @@ and pexp_u_pat (p : ppat) : sexp = match p with | Ppatvar s -> Symbol s | Ppatcons (c, args) -> Node (Symbol c, List.map pexp_u_pat_arg args)

-and pexp_decls e = +and pexp_p_decls e = match e with | Epsilon -> [] | Node (Symbol (_, ("_;_" | "_;" | ";_")), decls) - -> List.concat (List.map pexp_decls decls) + -> List.concat (List.map pexp_p_decls decls) | Node (Symbol (_, "_:_"), [Symbol s; t]) -> [(s, pexp_parse t, true)] | Node (Symbol (_, "_=_"), [Symbol s; t]) -> [(s, pexp_parse t, false)] (* | Node (Symbol (_, "_=_"), [Node (Symbol s, args); t]) -> @@ -278,7 +311,7 @@ and pexp_unparse (e : pexp) : sexp = | Pcall (f, args) -> Node (pexp_unparse f, args) | Pinductive (_, t, branches) -> Node (Symbol (dummy_location, "inductive_"), - sexp_u_list (List.map pexp_unparse t) + sexp_u_list (List.map pexp_u_formal_arg t) :: List.map (fun ((l,name) as s, types) -> Node (Symbol s, List.map pexp_u_ind_arg types))

View it on GitLab: https://gitlab.com/monnier/typer/commit/57a4f589c0c4dda04796fea8053dda038b69...