summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2016-02-07 19:59:10 -0500
committerGravatar Adam Chlipala <adam@chlipala.net>2016-02-07 19:59:10 -0500
commit5579b84a97cb942fdfd4c4898793f9de95bc03d1 (patch)
tree2fd60da2fe681fa69d712efdeb36b720c72b9820
parenta777dd13f4075418ec883f4eb42e5de1739d50d1 (diff)
Merge PVar and PWild, to get more reasonable type-class resolution
Diffstat
-rw-r--r--lib/js/urweb.js2
-rw-r--r--src/cjrize.sml3
-rw-r--r--src/core.sml3
-rw-r--r--src/core_env.sml9
-rw-r--r--src/core_print.sml3
-rw-r--r--src/core_util.sml12
-rw-r--r--src/corify.sml3
-rw-r--r--src/elab.sml3
-rw-r--r--src/elab_env.sml6
-rw-r--r--src/elab_print.sml3
-rw-r--r--src/elab_util.sml9
-rw-r--r--src/elaborate.sml22
-rw-r--r--src/expl.sml3
-rw-r--r--src/expl_env.sml3
-rw-r--r--src/expl_print.sml3
-rw-r--r--src/expl_rename.sml3
-rw-r--r--src/explify.sml3
-rw-r--r--src/iflow.sml6
-rw-r--r--src/jscomp.sml6
-rw-r--r--src/mono.sml3
-rw-r--r--src/mono_env.sml6
-rw-r--r--src/mono_print.sml3
-rw-r--r--src/mono_reduce.sml6
-rw-r--r--src/mono_util.sml3
-rw-r--r--src/monoize.sml107
-rw-r--r--src/reduce.sml9
-rw-r--r--src/reduce_local.sml9
-rw-r--r--src/source.sml3
-rw-r--r--src/source_print.sml3
-rw-r--r--src/specialize.sml3
-rw-r--r--src/termination.sml3
-rw-r--r--src/unnest.sml3
-rw-r--r--src/urweb.grm8
-rw-r--r--tests/localInstance.ur8
34 files changed, 122 insertions, 160 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-13 01:18:08 +0000