Setepenre pushed to branch master at Stefan / Typer
Commits: d5d7b301 by Pierre Delaunay at 2016-09-13T01:06:15-04:00 new function `lexp_to_pexp`
- - - - -
2 changed files:
- src/lexp.ml - tests/eval_test.ml
Changes:
===================================== src/lexp.ml ===================================== --- a/src/lexp.ml +++ b/src/lexp.ml @@ -114,6 +114,7 @@ and slookup s l v = S.lookup (fun l i -> Var (l, i)) s l v let ssink = S.sink (fun l i -> Var (l, i))
+ (**** The builtin elements ****) (* let builtins = @@ -489,6 +490,71 @@ let lexp_print e = sexp_print (pexp_unparse (lexp_unparse e)) *)
+(* ugly printing (sexp_print (pexp_unparse (lexp_to_pexp e))) *) +let rec lexp_to_pexp lxp = + match lxp with + | Susp _ as e -> lexp_to_pexp (nosusp e) + | Imm (sexp) -> Pimm (sexp) + | Builtin ((loc, name), _) -> Pvar((loc, name)) + | Var ((loc, name), _) -> Pvar((loc, name)) + | Cons (((iloc, iname), idx), ctor) -> Pcons((iloc, iname), ctor) + | Lambda (kind, vdef, ltp, body) -> + Plambda(kind, vdef, Some (lexp_to_pexp ltp), lexp_to_pexp body) + | Arrow (arg_kind, vdef, ltp1, loc, ltp2) -> + Parrow(arg_kind, vdef, lexp_to_pexp ltp1, loc, lexp_to_pexp ltp2) + + | Let (loc, ldecls, body) -> + (* (vdef * lexp * ltype) list *) + let pdecls = List.fold_left (fun acc (vdef, lxp, ltp) -> + Ptype(vdef, lexp_to_pexp ltp)::Pexpr(vdef, lexp_to_pexp lxp)::acc) [] ldecls in + Plet (loc, pdecls, lexp_to_pexp body) + + | Call(lxp, largs) -> (* (arg_kind * lexp) list *) + let pargs = List.map (fun (kind, elem) -> lexp_to_pexp elem) largs in + let sargs = List.map (fun elem -> pexp_unparse elem) pargs in + Pcall(lexp_to_pexp lxp, sargs) + + | Inductive(loc, label, lfargs, ctor) -> + (* (arg_kind * vdef * ltype) list *) + (* (arg_kind * pvar * pexp option) list *) + let pfargs = List.map (fun (kind, vdef, ltp) -> + (kind, vdef, Some (lexp_to_pexp ltp))) lfargs in + + (* ((arg_kind * vdef option * ltype) list) SMap.t *) + (* (symbol * (arg_kind * pvar option * pexp) list) list *) + let ctor = List.map (fun (str, largs) -> + let pargs = List.map (fun (kind, var, ltp) -> + match var with + | Some (loc, name) -> (kind, Some (loc, name), lexp_to_pexp ltp) + | None -> (kind, None, lexp_to_pexp ltp)) largs + in ((loc, str), pargs) + ) (SMap.bindings ctor) + in Pinductive(label, pfargs, ctor) + + | Case (loc, target, tltp, bltp, branches, default) -> + let pbranch = List.map (fun (str, (loc, args, bch)) -> + match args with + | [] -> Ppatvar (loc, str), lexp_to_pexp bch + | _ -> + let pat_args = List.map (fun (kind, vdef) -> + match vdef with + | Some vdef -> Some (kind, vdef), Ppatvar(vdef) + | None -> None, Ppatany(loc)) args + in Ppatcons ((loc, str), pat_args), lexp_to_pexp bch + ) (SMap.bindings branches) in + + let pbranch = match default with + | Some dft -> (Ppatany(loc), lexp_to_pexp dft)::pbranch + | None -> pbranch + in Pcase (loc, lexp_to_pexp target, pbranch) + + (* + | SortLevel of sort_level + | Sort of U.location * sort *) + + | _ as e -> Pimm (String(lexp_location e, "Type")) + + (* * Printing * --------------------- *) @@ -508,7 +574,7 @@ let pretty_ppctx = ref (true , 0, true, false, true, 4, true) let compact_ppctx = ref (false, 0, true, false, true, 4, false) let debug_ppctx = ref (false, 0, true, true , false, 4, true)
-let rec lexp_print e = _lexp_print (!debug_ppctx) e +let rec lexp_print e = _lexp_print (!debug_ppctx) e and _lexp_print ctx e = print_string (_lexp_to_str ctx e)
(*) @@ -539,8 +605,6 @@ let default_print_context = (* It might be better to use a Buffer. *) and lexp_to_str exp = _lexp_to_str (!debug_ppctx) exp
-(* FIXME: We don't want lexp_to_str, instead we want lexp_to_pexp (aka - * "unparse"), which we can then combine with pexp_to_sexp, etc... *) and _lexp_to_str ctx exp = (* create a string instead of printing *)
===================================== tests/eval_test.ml ===================================== --- a/tests/eval_test.ml +++ b/tests/eval_test.ml @@ -397,6 +397,23 @@ let _ = (add_test "EVAL" "Monads" (fun () -> | _ -> failure () ))
+(* +let test_eval_eqv decl run expected_result = + add_test "EVAL" dcode1 (fun () -> + + let rctx, lctx = eval_decl_str decl lctx rctx in + + let result = eval_expr_str rcode lctx rctx + let expected_result = eval_expr_str expected_result lctx rctx + + if sexp_eq_list result expected_result + then success () + else ( + value_print (List.hd s1); + value_print (List.hd s2); + failure ())) + +*)
(* run all tests *) let _ = run_all ()
View it on GitLab: https://gitlab.com/monnier/typer/commit/d5d7b3017c568ed24580c9f5e83cebea5a52...