From 5579b84a97cb942fdfd4c4898793f9de95bc03d1 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 7 Feb 2016 19:59:10 -0500 Subject: Merge PVar and PWild, to get more reasonable type-class resolution --- lib/js/urweb.js | 2 - src/cjrize.sml | 3 +- src/core.sml | 3 +- src/core_env.sml | 9 ++--- src/core_print.sml | 3 +- src/core_util.sml | 12 ++---- src/corify.sml | 3 +- src/elab.sml | 3 +- src/elab_env.sml | 6 +-- src/elab_print.sml | 3 +- src/elab_util.sml | 9 ++--- src/elaborate.sml | 22 +++++----- src/expl.sml | 3 +- src/expl_env.sml | 3 +- src/expl_print.sml | 3 +- src/expl_rename.sml | 3 +- src/explify.sml | 3 +- src/iflow.sml | 6 +-- src/jscomp.sml | 6 +-- src/mono.sml | 3 +- src/mono_env.sml | 6 +-- src/mono_print.sml | 3 +- src/mono_reduce.sml | 6 +-- src/mono_util.sml | 3 +- src/monoize.sml | 107 ++++++++++++++++++++++++++----------------------- src/reduce.sml | 9 ++--- src/reduce_local.sml | 9 ++--- src/source.sml | 3 +- src/source_print.sml | 3 +- src/specialize.sml | 3 +- src/termination.sml | 3 +- src/unnest.sml | 3 +- src/urweb.grm | 8 ++-- tests/localInstance.ur | 8 ++++ 34 files changed, 122 insertions(+), 160 deletions(-) create mode 100644 tests/localInstance.ur diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 14ec4612..ac469f20 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -1823,8 +1823,6 @@ function lookup(env, n) { function execP(env, p, v) { switch (p.c) { - case "w": - return env; case "v": return cons(v, env); case "c": diff --git a/src/cjrize.sml b/src/cjrize.sml index 5f6ae4d8..fbc7eba1 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -191,8 +191,7 @@ fun cifyPatCon (pc, sm) = fun cifyPat ((p, loc), sm) = case p of - L.PWild => ((L'.PWild, loc), sm) - | L.PVar (x, t) => + L.PVar (x, t) => let val (t, sm) = cifyTyp (t, sm) in diff --git a/src/core.sml b/src/core.sml index 193825bf..8f57c31f 100644 --- a/src/core.sml +++ b/src/core.sml @@ -78,8 +78,7 @@ datatype patCon = con : string, arg : con option, kind : datatype_kind} datatype pat' = - PWild - | PVar of string * con + PVar of string * con | PPrim of Prim.t | PCon of datatype_kind * patCon * con list * pat option | PRecord of (string * pat * con) list diff --git a/src/core_env.sml b/src/core_env.sml index 9a4f9ec7..7d78bdee 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -354,8 +354,7 @@ fun declBinds env (d, loc) = fun patBinds env (p, loc) = case p of - PWild => env - | PVar (x, t) => pushERel env x t + PVar (x, t) => pushERel env x t | PPrim _ => env | PCon (_, _, _, NONE) => env | PCon (_, _, _, SOME p) => patBinds env p @@ -363,8 +362,7 @@ fun patBinds env (p, loc) = fun patBindsN (p, loc) = case p of - PWild => 0 - | PVar _ => 1 + PVar _ => 1 | PPrim _ => 0 | PCon (_, _, _, NONE) => 0 | PCon (_, _, _, SOME p) => patBindsN p @@ -372,8 +370,7 @@ fun patBindsN (p, loc) = fun patBindsL (p, loc) = case p of - PWild => [] - | PVar (x, t) => [(x, t)] + PVar (x, t) => [(x, t)] | PPrim _ => [] | PCon (_, _, _, NONE) => [] | PCon (_, _, _, SOME p) => patBindsL p diff --git a/src/core_print.sml b/src/core_print.sml index f360f346..5c71e978 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -224,8 +224,7 @@ fun p_patCon env pc = fun p_pat' par env (p, _) = case p of - PWild => string "_" - | PVar (s, _) => string s + PVar (s, _) => string s | PPrim p => Prim.p_t p | PCon (_, n, _, NONE) => p_patCon env n | PCon (_, n, _, SOME p) => parenIf par (box [p_patCon env n, diff --git a/src/core_util.sml b/src/core_util.sml index 9ca85c37..57ef16f7 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -416,11 +416,7 @@ fun pcCompare (pc1, pc2) = fun pCompare ((p1, _), (p2, _)) = case (p1, p2) of - (PWild, PWild) => EQUAL - | (PWild, _) => LESS - | (_, PWild) => GREATER - - | (PVar _, PVar _) => EQUAL + (PVar _, PVar _) => EQUAL | (PVar _, _) => LESS | (_, PVar _) => GREATER @@ -712,8 +708,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = let fun pb ((p, _), ctx) = case p of - PWild => ctx - | PVar (x, t) => bind (ctx, RelE (x, t)) + PVar (x, t) => bind (ctx, RelE (x, t)) | PPrim _ => ctx | PCon (_, _, _, NONE) => ctx | PCon (_, _, _, SOME p) => pb (p, ctx) @@ -771,8 +766,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = and mfp ctx (pAll as (p, loc)) = case p of - PWild => S.return2 pAll - | PVar (x, t) => + PVar (x, t) => S.map2 (mfc ctx t, fn t' => (PVar (x, t'), loc)) diff --git a/src/corify.sml b/src/corify.sml index 5d58efcc..19cd3ec8 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -529,8 +529,7 @@ fun corifyPatCon st pc = fun corifyPat st (p, loc) = case p of - L.PWild => (L'.PWild, loc) - | L.PVar (x, t) => (L'.PVar (x, corifyCon st t), loc) + L.PVar (x, t) => (L'.PVar (x, corifyCon st t), loc) | L.PPrim p => (L'.PPrim p, loc) | L.PCon (dk, pc, ts, po) => (L'.PCon (dk, corifyPatCon st pc, map (corifyCon st) ts, Option.map (corifyPat st) po), loc) diff --git a/src/elab.sml b/src/elab.sml index 209d3307..90c14e4b 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -97,8 +97,7 @@ datatype patCon = | PConProj of int * string list * string datatype pat' = - PWild - | PVar of string * con + PVar of string * con | PPrim of Prim.t | PCon of datatype_kind * patCon * con list * pat option | PRecord of (string * pat * con) list diff --git a/src/elab_env.sml b/src/elab_env.sml index 3523b576..cb08f348 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1563,8 +1563,7 @@ fun projectConstraints env {sgn, str} = fun patBinds env (p, loc) = case p of - PWild => env - | PVar (x, t) => pushERel env x t + PVar (x, t) => pushERel env x t | PPrim _ => env | PCon (_, _, _, NONE) => env | PCon (_, _, _, SOME p) => patBinds env p @@ -1572,8 +1571,7 @@ fun patBinds env (p, loc) = fun patBindsN (p, _) = case p of - PWild => 0 - | PVar _ => 1 + PVar _ => 1 | PPrim _ => 0 | PCon (_, _, _, NONE) => 0 | PCon (_, _, _, SOME p) => patBindsN p diff --git a/src/elab_print.sml b/src/elab_print.sml index 5a41883f..06ea097f 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -289,8 +289,7 @@ fun p_patCon env pc = fun p_pat' par env (p, _) = case p of - PWild => string "_" - | PVar (s, _) => string s + PVar (s, _) => string s | PPrim p => Prim.p_t p | PCon (_, pc, _, NONE) => p_patCon env pc | PCon (_, pc, _, SOME p) => parenIf par (box [p_patCon env pc, diff --git a/src/elab_util.sml b/src/elab_util.sml index ed2e82a0..0cdb9cc1 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -346,8 +346,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = fun doVars ((p, _), ctx) = case p of - PWild => ctx - | PVar xt => bind (ctx, RelE xt) + PVar xt => bind (ctx, RelE xt) | PPrim _ => ctx | PCon (_, _, _, NONE) => ctx | PCon (_, _, _, SOME p) => doVars (p, ctx) @@ -452,8 +451,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = let fun pb ((p, _), ctx) = case p of - PWild => ctx - | PVar (x, t) => bind (ctx, RelE (x, t)) + PVar (x, t) => bind (ctx, RelE (x, t)) | PPrim _ => ctx | PCon (_, _, _, NONE) => ctx | PCon (_, _, _, SOME p) => pb (p, ctx) @@ -517,8 +515,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = and mfp ctx (pAll as (p, loc)) = case p of - PWild => S.return2 pAll - | PVar (x, t) => + PVar (x, t) => S.map2 (mfc ctx t, fn t' => (PVar (x, t'), loc)) diff --git a/src/elaborate.sml b/src/elaborate.sml index 2dfbf5b2..9765b090 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1526,8 +1526,8 @@ fun elabPat (pAll as (p, loc), (env, bound)) = let - val perror = (L'.PWild, loc) val terror = (L'.CError, loc) + val perror = (L'.PVar ("_", terror), loc) val pterror = (perror, terror) val rerror = (pterror, (env, bound)) @@ -1563,9 +1563,7 @@ fun elabPat (pAll as (p, loc), (env, bound)) = end in case p of - L.PWild => (((L'.PWild, loc), cunif env (loc, (L'.KType, loc))), - (env, bound)) - | L.PVar x => + L.PVar x => let val t = if SS.member (bound, x) then (expError env (DuplicatePatternVariable (loc, x)); @@ -1642,6 +1640,8 @@ fun elabPat (pAll as (p, loc), (env, bound)) = (* This exhaustiveness checking follows Luc Maranget's paper "Warnings for pattern matching." *) fun exhaustive (env, t, ps, loc) = let + val pwild = L'.PVar ("_", t) + fun fail n = raise Fail ("Elaborate.exhaustive: Impossible " ^ Int.toString n) fun patConNum pc = @@ -1683,7 +1683,7 @@ fun exhaustive (env, t, ps, loc) = val loc = #2 p1 fun wild () = - SOME (map (fn _ => (L'.PWild, loc)) args @ ps) + SOME (map (fn _ => (pwild, loc)) args @ ps) in case #1 p1 of L'.PPrim _ => NONE @@ -1704,9 +1704,8 @@ fun exhaustive (env, t, ps, loc) = SOME p else NONE) xpts of - NONE => (L'.PWild, loc) + NONE => (pwild, loc) | SOME p => p) args @ ps) - | L'.PWild => wild () | L'.PVar _ => wild () end) P @@ -1716,8 +1715,7 @@ fun exhaustive (env, t, ps, loc) = (fn [] => fail 2 | (p1, _) :: ps => case p1 of - L'.PWild => SOME ps - | L'.PVar _ => SOME ps + L'.PVar _ => SOME ps | L'.PPrim _ => NONE | L'.PCon _ => NONE | L'.PRecord _ => NONE) @@ -1847,8 +1845,8 @@ fun exhaustive (env, t, ps, loc) = | SOME ps => let val p = case cons of - [] => L'.PWild - | (0, _) :: _ => L'.PWild + [] => pwild + | (0, _) :: _ => pwild | _ => case IS.find (fn _ => true) unused of NONE => fail 6 @@ -1861,7 +1859,7 @@ fun exhaustive (env, t, ps, loc) = SOME (n, []) => L'.PCon (L'.Default, nameOfNum (#1 t1, n), [], NONE) | SOME (n, [_]) => - L'.PCon (L'.Default, nameOfNum (#1 t1, n), [], SOME (L'.PWild, loc)) + L'.PCon (L'.Default, nameOfNum (#1 t1, n), [], SOME (pwild, loc)) | _ => fail 7 in SOME ((p, loc) :: ps) diff --git a/src/expl.sml b/src/expl.sml index 3d784e3f..994c05cf 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -77,8 +77,7 @@ datatype patCon = | PConProj of int * string list * string datatype pat' = - PWild - | PVar of string * con + PVar of string * con | PPrim of Prim.t | PCon of datatype_kind * patCon * con list * pat option | PRecord of (string * pat * con) list diff --git a/src/expl_env.sml b/src/expl_env.sml index 5712a72d..f7f51be5 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -404,8 +404,7 @@ fun sgiBinds env (sgi, loc) = fun patBinds env (p, loc) = case p of - PWild => env - | PVar (x, t) => pushERel env x t + PVar (x, t) => pushERel env x t | PPrim _ => env | PCon (_, _, _, NONE) => env | PCon (_, _, _, SOME p) => patBinds env p diff --git a/src/expl_print.sml b/src/expl_print.sml index 22d246e2..10ea6056 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -215,8 +215,7 @@ fun p_patCon env pc = fun p_pat' par env (p, _) = case p of - PWild => string "_" - | PVar (s, _) => string s + PVar (s, _) => string s | PPrim p => Prim.p_t p | PCon (_, pc, _, NONE) => p_patCon env pc | PCon (_, pc, cs, SOME p) => diff --git a/src/expl_rename.sml b/src/expl_rename.sml index bb763a60..bdcf1aa4 100644 --- a/src/expl_rename.sml +++ b/src/expl_rename.sml @@ -99,8 +99,7 @@ fun renamePatCon st pc = fun renamePat st (all as (p, loc)) = case p of - PWild => all - | PVar (x, c) => (PVar (x, renameCon st c), loc) + PVar (x, c) => (PVar (x, renameCon st c), loc) | PPrim _ => all | PCon (dk, pc, cs, po) => (PCon (dk, renamePatCon st pc, map (renameCon st) cs, diff --git a/src/explify.sml b/src/explify.sml index f38151d2..e2a317a2 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -90,8 +90,7 @@ fun explifyPatCon pc = fun explifyPat (p, loc) = case p of - L.PWild => (L'.PWild, loc) - | L.PVar (x, t) => (L'.PVar (x, explifyCon t), loc) + L.PVar (x, t) => (L'.PVar (x, explifyCon t), loc) | L.PPrim p => (L'.PPrim p, loc) | L.PCon (dk, pc, cs, po) => (L'.PCon (dk, explifyPatCon pc, map explifyCon cs, Option.map explifyPat po), loc) | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, explifyPat p, explifyCon t)) xps), loc) diff --git a/src/iflow.sml b/src/iflow.sml index 8bde7ea3..5e8d697e 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1405,8 +1405,7 @@ fun doQuery (arg : 'a doQuery) (e as (_, loc)) = fun evalPat env e (pt, _) = case pt of - PWild => env - | PVar _ => e :: env + PVar _ => e :: env | PPrim _ => env | PCon (_, pc, NONE) => (St.assert [AReln (PCon0 (patCon pc), [e])]; env) | PCon (_, pc, SOME pt) => @@ -2045,8 +2044,7 @@ fun check (file : file) = let fun doPat (p, env) = case #1 p of - PWild => env - | PVar _ => v :: env + PVar _ => v :: env | PPrim _ => env | PCon (_, _, NONE) => env | PCon (_, _, SOME p) => doPat (p, env) diff --git a/src/jscomp.sml b/src/jscomp.sml index e5a0cb27..d8c83b94 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -458,8 +458,7 @@ fun process (file : file) = fun jsPat (p, _) = case p of - PWild => str "{c:\"w\"}" - | PVar _ => str "{c:\"v\"}" + PVar _ => str "{c:\"v\"}" | PPrim p => strcat [str "{c:\"c\",v:", jsPrim p, str "}"] @@ -1009,8 +1008,7 @@ fun process (file : file) = fun patBinds ((p, _), env) = case p of - PWild => env - | PVar (_, t) => t :: env + PVar (_, t) => t :: env | PPrim _ => env | PCon (_, _, NONE) => env | PCon (_, _, SOME p) => patBinds (p, env) diff --git a/src/mono.sml b/src/mono.sml index b05c3dcc..cdadded5 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -48,8 +48,7 @@ datatype patCon = | PConFfi of {mod : string, datatyp : string, con : string, arg : typ option} datatype pat' = - PWild - | PVar of string * typ + PVar of string * typ | PPrim of Prim.t | PCon of datatype_kind * patCon * pat option | PRecord of (string * pat * typ) list diff --git a/src/mono_env.sml b/src/mono_env.sml index 52e07893..0dd668ea 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -148,8 +148,7 @@ fun declBinds env (d, loc) = fun patBinds env (p, loc) = case p of - PWild => env - | PVar (x, t) => pushERel env x t NONE + PVar (x, t) => pushERel env x t NONE | PPrim _ => env | PCon (_, _, NONE) => env | PCon (_, _, SOME p) => patBinds env p @@ -159,8 +158,7 @@ fun patBinds env (p, loc) = fun patBindsN (p, loc) = case p of - PWild => 0 - | PVar _ => 1 + PVar _ => 1 | PPrim _ => 0 | PCon (_, _, NONE) => 0 | PCon (_, _, SOME p) => patBindsN p diff --git a/src/mono_print.sml b/src/mono_print.sml index 3e498d2c..a3b55ec0 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -105,8 +105,7 @@ fun p_patCon env pc = fun p_pat' par env (p, _) = case p of - PWild => string "_" - | PVar (s, _) => string s + PVar (s, _) => string s | PPrim p => Prim.p_t p | PCon (_, n, NONE) => p_patCon env n | PCon (_, n, SOME p) => parenIf par (box [p_patCon env n, diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 61866af7..540d396b 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -191,8 +191,7 @@ datatype result = Yes of (string * typ * exp) list | No | Maybe fun match (env, p : pat, e : exp) = case (#1 p, #1 e) of - (PWild, _) => Yes env - | (PVar (x, t), _) => Yes ((x, t, e) :: env) + (PVar (x, t), _) => Yes ((x, t, e) :: env) | (PPrim (Prim.String (_, s)), EStrcat ((EPrim (Prim.String (_, s')), _), _)) => if String.isPrefix s' s then @@ -300,8 +299,7 @@ val p_events = Print.p_list p_event fun patBinds (p, _) = case p of - PWild => 0 - | PVar _ => 1 + PVar _ => 1 | PPrim _ => 0 | PCon (_, _, NONE) => 0 | PCon (_, _, SOME p) => patBinds p diff --git a/src/mono_util.sml b/src/mono_util.sml index 5d7eb164..fc1a2bcb 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -235,8 +235,7 @@ fun mapfoldB {typ = fc, exp = fe, bind} = let fun pb ((p, _), ctx) = case p of - PWild => ctx - | PVar (x, t) => bind (ctx, RelE (x, t)) + PVar (x, t) => bind (ctx, RelE (x, t)) | PPrim _ => ctx | PCon (_, _, NONE) => ctx | PCon (_, _, SOME p) => pb (p, ctx) diff --git a/src/monoize.sml b/src/monoize.sml index 75851a48..6715290f 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -440,8 +440,7 @@ fun monoPat env (all as (p, loc)) = dummyPat) in case p of - L.PWild => (L'.PWild, loc) - | L.PVar (x, t) => (L'.PVar (x, monoType env t), loc) + L.PVar (x, t) => (L'.PVar (x, monoType env t), loc) | L.PPrim p => (L'.PPrim p, loc) | L.PCon (dk, pc, [], po) => (L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc) | L.PCon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], NONE) => @@ -1430,16 +1429,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) = string), ("2", str (Settings.mangleSql (lowercaseFirst nm2)), string)], loc)), - ((L'.PWild, loc), + ((L'.PVar ("_", string), loc), (L'.ERecord [("1", (L'.EStrcat ( str (Settings.mangleSql (lowercaseFirst nm1) ^ ", "), - (L'.EField ((L'.ERel 0, loc), "1"), loc)), + (L'.EField ((L'.ERel 1, loc), "1"), loc)), loc), string), ("2", (L'.EStrcat ( str (Settings.mangleSql (lowercaseFirst nm2) ^ ", "), - (L'.EField ((L'.ERel 0, loc), "2"), loc)), + (L'.EField ((L'.ERel 1, loc), "2"), loc)), loc), string)], loc))], {disc = string, @@ -1484,9 +1483,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ECase ((L'.EField ((L'.ERel 0, loc), fd), loc), [((L'.PPrim (Prim.String (Prim.Normal, "NO ACTION")), loc), str ""), - ((L'.PWild, loc), + ((L'.PVar ("_", string), loc), strcat [str (" ON " ^ kw ^ " "), - (L'.EField ((L'.ERel 0, loc), fd), loc)])], + (L'.EField ((L'.ERel 1, loc), fd), loc)])], {disc = string, result = string}), loc) in @@ -2013,6 +2012,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_comma"), _), _), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TRecord [("1", s), ("2", s)], loc) in ((L'.EAbs ("tab1", s, (L'.TFun (s, s), loc), (L'.EAbs ("tab2", s, s, @@ -2022,17 +2022,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ERel 0, loc)), ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 1, loc)), - ((L'.PWild, loc), - strcat [(L'.ERel 1, loc), + ((L'.PVar ("_", disc), loc), + strcat [(L'.ERel 2, loc), str ", ", - (L'.ERel 0, loc)])], - {disc = (L'.TRecord [("1", s), ("2", s)], loc), + (L'.ERel 1, loc)])], + {disc = disc, result = s}), loc)), loc)), loc), fm) end | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_inner_join"), _), _), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TRecord [("1", s), ("2", s)], loc) in ((L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc), @@ -2043,23 +2044,23 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ERel 1, loc)), ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), - ((L'.PWild, loc), + ((L'.PVar ("_", disc), loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then [str "("] else []) - @ [(L'.ERel 2, loc), + @ [(L'.ERel 3, loc), str " JOIN ", - (L'.ERel 1, loc), + (L'.ERel 2, loc), str " ON ", - (L'.ERel 0, loc)] + (L'.ERel 1, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then [str ")"] else [])))], - {disc = (L'.TRecord [("1", s), ("2", s)], loc), + {disc = disc, result = s}), loc)), loc)), loc)), loc), fm) end @@ -2067,6 +2068,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.CRecord (_, right), _)) => let val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TRecord [("1", s), ("2", s)], loc) in ((L'.EAbs ("_", outerRec right, (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), @@ -2081,23 +2083,23 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), - ((L'.PWild, loc), + ((L'.PVar ("_", disc), loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then [str "("] else []) - @ [(L'.ERel 2, loc), + @ [(L'.ERel 3, loc), str " LEFT JOIN ", - (L'.ERel 1, loc), + (L'.ERel 2, loc), str " ON ", - (L'.ERel 0, loc)] + (L'.ERel 1, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then [str ")"] else [])))], - {disc = (L'.TRecord [("1", s), ("2", s)], loc), + {disc = disc, result = s}), loc)), loc)), loc)), loc)), loc), fm) end @@ -2105,6 +2107,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TRecord [("1", s), ("2", s)], loc) in ((L'.EAbs ("_", outerRec left, (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), @@ -2119,23 +2122,23 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), - ((L'.PWild, loc), + ((L'.PVar ("_", disc), loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then [str "("] else []) - @ [(L'.ERel 2, loc), + @ [(L'.ERel 3, loc), str " RIGHT JOIN ", - (L'.ERel 1, loc), + (L'.ERel 2, loc), str " ON ", - (L'.ERel 0, loc)] + (L'.ERel 1, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then [str ")"] else [])))], - {disc = (L'.TRecord [("1", s), ("2", s)], loc), + {disc = disc, result = s}), loc)), loc)), loc)), loc)), loc), fm) end @@ -2143,6 +2146,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.CRecord (_, right), _)), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TRecord [("1", s), ("2", s)], loc) in ((L'.EAbs ("_", outerRec (left @ right), (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), @@ -2157,23 +2161,23 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), - ((L'.PWild, loc), + ((L'.PVar ("_", disc), loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then [str "("] else []) - @ [(L'.ERel 2, loc), + @ [(L'.ERel 3, loc), str " FULL JOIN ", - (L'.ERel 1, loc), + (L'.ERel 2, loc), str " ON ", - (L'.ERel 0, loc)] + (L'.ERel 1, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then [str ")"] else [])))], - {disc = (L'.TRecord [("1", s), ("2", s)], loc), + {disc = disc, result = s}), loc)), loc)), loc)), loc)), loc), fm) end @@ -2202,11 +2206,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) = [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), strcat [(L'.ERel 2, loc), (L'.ERel 1, loc)]), - ((L'.PWild, loc), - strcat [(L'.ERel 2, loc), - (L'.ERel 1, loc), + ((L'.PVar ("_", s), loc), + strcat [(L'.ERel 3, loc), + (L'.ERel 2, loc), str ", ", - (L'.ERel 0, loc)])], + (L'.ERel 1, loc)])], {disc = s, result = s}), loc)), loc)), loc)), loc)), loc), fm) end @@ -2312,13 +2316,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val s = (L'.TFfi ("Basis", "string"), loc) - val default = strcat [str "(", - (L'.ERel 1, loc), - str " ", - (L'.ERel 2, loc), - str " ", - (L'.ERel 0, loc), - str ")"] + fun default n = strcat [str "(", + (L'.ERel (n + 1), loc), + str " ", + (L'.ERel (n + 2), loc), + str " ", + (L'.ERel n, loc), + str ")"] val body = case #1 arg1 of L.CApp ((L.CFfi ("Basis", "option"), _), _) => @@ -2335,11 +2339,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) = str ") IS NULL AND (", (L'.ERel 0, loc), str ") IS NULL))"]), - ((L'.PWild, loc), - default)], + ((L'.PVar ("_", s), loc), + default 1)], {disc = s, result = s}), loc) - | _ => default + | _ => default 0 in ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), @@ -2393,6 +2397,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TFfi ("Basis", "bool"), loc) in (if #nestedRelops (Settings.currentDbms ()) then (L'.EAbs ("c", s, (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), @@ -2409,9 +2414,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = con = "True", arg = NONE}, NONE), loc), str " ALL"), - ((L'.PWild, loc), + ((L'.PVar ("_", disc), loc), str "")], - {disc = (L'.TFfi ("Basis", "bool"), loc), + {disc = disc, result = s}), loc), str " (", (L'.ERel 0, loc), @@ -2430,9 +2435,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = con = "True", arg = NONE}, NONE), loc), str " ALL"), - ((L'.PWild, loc), + ((L'.PVar ("_", disc), loc), str "")], - {disc = (L'.TFfi ("Basis", "bool"), loc), + {disc = disc, result = s}), loc), str " ", (L'.ERel 0, loc)]), loc)), loc)), loc)), loc), @@ -2773,9 +2778,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ECase ((L'.ERel 0, loc), [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), str ""), - ((L'.PWild, loc), + ((L'.PVar ("_", s), loc), strcat [str " ORDER BY ", - (L'.ERel 0, loc)])], + (L'.ERel 1, loc)])], {disc = s, result = s}), loc), str ")"] diff --git a/src/reduce.sml b/src/reduce.sml index 0762a4a1..08040ad3 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -148,8 +148,7 @@ fun match (env, p : pat, e : exp) = fun match (env, p, e) = case (#1 p, #1 e) of - (PWild, _) => Yes env - | (PVar (x, t), _) => Yes (KnownE (multiLiftExpInExp (length env - baseline) e) :: env) + (PVar (x, t), _) => Yes (KnownE (multiLiftExpInExp (length env - baseline) e) :: env) | (PPrim p, EPrim p') => if Prim.equal (p, p') then @@ -425,8 +424,7 @@ fun kindConAndExp (namedC, namedE) = fun patBinds (p, _) = case p of - PWild => 0 - | PVar _ => 1 + PVar _ => 1 | PPrim _ => 0 | PCon (_, _, _, NONE) => 0 | PCon (_, _, _, SOME p) => patBinds p @@ -763,8 +761,7 @@ fun kindConAndExp (namedC, namedE) = let fun pat (all as (p, loc)) = case p of - PWild => all - | PVar (x, t) => (PVar (x, con env t), loc) + PVar (x, t) => (PVar (x, con env t), loc) | PPrim _ => all | PCon (dk, pc, cs, po) => (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc) diff --git a/src/reduce_local.sml b/src/reduce_local.sml index 6fbc6a96..06f49fef 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -62,8 +62,7 @@ fun match (env, p : pat, e : exp) = fun match (env, p, e) = case (#1 p, #1 e) of - (PWild, _) => Yes env - | (PVar (x, t), _) => Yes (Known (multiLiftExpInExp (length env - baseline) e) :: env) + (PVar (x, t), _) => Yes (Known (multiLiftExpInExp (length env - baseline) e) :: env) | (PPrim p, EPrim p') => if Prim.equal (p, p') then @@ -313,8 +312,7 @@ fun exp env (all as (e, loc)) = fun patBinds (p, _) = case p of - PWild => 0 - | PVar _ => 1 + PVar _ => 1 | PPrim _ => 0 | PCon (_, _, _, NONE) => 0 | PCon (_, _, _, SOME p) => patBinds p @@ -322,8 +320,7 @@ fun exp env (all as (e, loc)) = fun pat (all as (p, loc)) = case p of - PWild => all - | PVar (x, t) => (PVar (x, con env t), loc) + PVar (x, t) => (PVar (x, con env t), loc) | PPrim _ => all | PCon (dk, pc, cs, po) => (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc) diff --git a/src/source.sml b/src/source.sml index 2a741dd9..9971ca93 100644 --- a/src/source.sml +++ b/src/source.sml @@ -104,8 +104,7 @@ and sgn' = | SgnProj of string * string list * string and pat' = - PWild - | PVar of string + PVar of string | PPrim of Prim.t | PCon of string list * string * pat option | PRecord of (string * pat) list * bool diff --git a/src/source_print.sml b/src/source_print.sml index db56a0db..7b657422 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -187,8 +187,7 @@ and p_name (all as (c, _)) = fun p_pat' par (p, _) = case p of - PWild => string "_" - | PVar s => string s + PVar s => string s | PPrim p => Prim.p_t p | PCon (ms, x, NONE) => p_list_sep (string ".") string (ms @ [x]) | PCon (ms, x, SOME p) => parenIf par (box [p_list_sep (string ".") string (ms @ [x]), diff --git a/src/specialize.sml b/src/specialize.sml index 5d8cef09..33545250 100644 --- a/src/specialize.sml +++ b/src/specialize.sml @@ -162,8 +162,7 @@ and specCon st = U.Con.foldMap {kind = kind, con = con} st fun pat (p, st) = case #1 p of - PWild => (p, st) - | PVar _ => (p, st) + PVar _ => (p, st) | PPrim _ => (p, st) | PCon (dk, PConVar pn, args as (_ :: _), po) => let diff --git a/src/termination.sml b/src/termination.sml index f0b21d99..f0ec46d8 100644 --- a/src/termination.sml +++ b/src/termination.sml @@ -107,8 +107,7 @@ fun declOk' env (d, loc) = | _ => foldl (fn ((_, pt', _), penv) => pat penv (Rabble, pt')) penv xps in case (p, pt) of - (_, PWild) => penv - | (_, PVar _) => p :: penv + (_, PVar _) => p :: penv | (_, PPrim _) => penv | (_, PCon (_, _, _, NONE)) => penv | (Arg (i, j, _), PCon (_, pc, _, SOME pt')) => con (i, j, pc, pt') diff --git a/src/unnest.sml b/src/unnest.sml index 3034eb6e..7469ffd4 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -256,8 +256,7 @@ fun exp ((ns, ks, ts), e as old, st : state) = fun doVars ((p, _), ts) = case p of - PWild => ts - | PVar xt => xt :: ts + PVar xt => xt :: ts | PPrim _ => ts | PCon (_, _, _, NONE) => ts | PCon (_, _, _, SOME p) => doVars (p, ts) diff --git a/src/urweb.grm b/src/urweb.grm index 50dacf21..0f499e20 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -335,7 +335,7 @@ fun applyWindow loc e window = fun patternOut (e : exp) = case #1 e of - EWild => (PWild, #2 e) + EWild => (PVar "_", #2 e) | EVar ([], x, Infer) => if Char.isUpper (String.sub (x, 0)) then (PCon ([], x, NONE), #2 e) @@ -346,7 +346,7 @@ fun patternOut (e : exp) = (PCon (xs, x, NONE), #2 e) else (ErrorMsg.errorAt (#2 e) "Badly capitalized constructor name in pattern"; - (PWild, #2 e)) + (PVar "_", #2 e)) | EPrim p => (PPrim p, #2 e) | EApp ((EVar (xs, x, Infer), _), e') => (PCon (xs, x, SOME (patternOut e')), #2 e) @@ -364,7 +364,7 @@ fun patternOut (e : exp) = | EAnnot (e', t) => (PAnnot (patternOut e', t), #2 e) | _ => (ErrorMsg.errorAt (#2 e) "This is an expression but not a pattern."; - (PWild, #2 e)) + (PVar "_", #2 e)) %% %header (functor UrwebLrValsFn(structure Token : TOKEN)) @@ -1543,7 +1543,7 @@ pat : patS (patS) pterm : SYMBOL (PVar SYMBOL, s (SYMBOLleft, SYMBOLright)) | cpath (PCon (#1 cpath, #2 cpath, NONE), s (cpathleft, cpathright)) - | UNDER (PWild, s (UNDERleft, UNDERright)) + | UNDER (PVar "_", s (UNDERleft, UNDERright)) | INT (PPrim (Prim.Int INT), s (INTleft, INTright)) | MINUS INT (PPrim (Prim.Int (~INT)), s (MINUSleft, INTright)) | STRING (PPrim (Prim.String (Prim.Normal, STRING)), s (STRINGleft, STRINGright)) diff --git a/tests/localInstance.ur b/tests/localInstance.ur new file mode 100644 index 00000000..81a65ddb --- /dev/null +++ b/tests/localInstance.ur @@ -0,0 +1,8 @@ +datatype foo = Bar + +val x = + let + val _ = mkShow (fn Bar => "Bar") + in + show Bar + end -- cgit v1.2.3