[MLton] cvs commit: non-exhaustive warning now displays an example pattern
Stephen Weeks
sweeks@mlton.org
Mon, 29 Dec 2003 14:01:10 -0800
sweeks 03/12/29 14:01:10
Modified: mlton/core-ml core-ml.fun core-ml.sig
mlton/defunctorize defunctorize.fun
mlton/elaborate elaborate-core.fun type-env.fun type-env.sig
mlton/match-compile match-compile.fun match-compile.sig
nested-pat.fun nested-pat.sig
regression nonexhaustive.sml
Added: regression/fail pat.1.sml
Log:
MAIL non-exhaustive warning now displays an example pattern
The match compiler keeps track for each case of a pattern that leads
to that case, and feeds the information to the elaborator. Then, when
the elaborator discovers a nonexhaustive match, it prints out the
corresponding pattern.
One slight annoyance was that by the time the match compiler sees
things, there is no distinction between char and word8. So, I had to
add a little more information to the ILs to propagate the difference.
Added a few more examples to regression/nonexhaustive.sml. Please
try out other examples that you think of.
Added an error message for real constants in patterns.
Revision Changes Path
1.15 +4 -2 mlton/mlton/core-ml/core-ml.fun
Index: core-ml.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/core-ml.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- core-ml.fun 13 Oct 2003 22:15:12 -0000 1.14
+++ core-ml.fun 29 Dec 2003 22:01:08 -0000 1.15
@@ -155,7 +155,8 @@
ty: Type.t}
and expNode =
App of exp * exp
- | Case of {kind: string,
+ | Case of {hasExtraTuple: bool,
+ kind: string,
lay: unit -> Layout.t,
noMatch: noMatch,
region: Region.t,
@@ -358,7 +359,8 @@
else make (Case z, ty (#exp (Vector.sub (rules, 0))))
fun iff (test, thenCase, elseCase): t =
- casee {kind = "if",
+ casee {hasExtraTuple = false,
+ kind = "if",
lay = fn () => Layout.empty,
noMatch = Impossible,
region = Region.bogus,
1.14 +5 -2 mlton/mlton/core-ml/core-ml.sig
Index: core-ml.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/core-ml.sig,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- core-ml.sig 13 Oct 2003 23:24:30 -0000 1.13
+++ core-ml.sig 29 Dec 2003 22:01:08 -0000 1.14
@@ -19,6 +19,7 @@
val bool: t
val deConOpt: t -> (Tycon.t * t vector) option
val deRecord: t -> (Record.Field.t * t) vector
+ val isChar: t -> bool
val layout: t -> Layout.t
val makeHom: {con: Tycon.t * 'a vector -> 'a,
var: Tyvar.t -> 'a} -> {destroy: unit -> unit,
@@ -70,7 +71,8 @@
datatype noMatch = Impossible | RaiseAgain | RaiseBind | RaiseMatch
datatype node =
App of t * t
- | Case of {kind: string,
+ | Case of {hasExtraTuple: bool,
+ kind: string,
lay: unit -> Layout.t,
noMatch: noMatch,
region: Region.t,
@@ -97,7 +99,8 @@
| Var of (unit -> Var.t) * (unit -> Type.t vector)
val andAlso: t * t -> t
- val casee: {kind: string,
+ val casee: {hasExtraTuple: bool,
+ kind: string,
lay: unit -> Layout.t,
noMatch: noMatch,
region: Region.t,
1.7 +74 -15 mlton/mlton/defunctorize/defunctorize.fun
Index: defunctorize.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/defunctorize/defunctorize.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- defunctorize.fun 14 Nov 2003 03:48:17 -0000 1.6
+++ defunctorize.fun 29 Dec 2003 22:01:08 -0000 1.7
@@ -16,6 +16,7 @@
structure Record = Record
structure Ctype = Type
structure WordSize = WordSize
+ structure WordX = WordX
end
structure IntX = Const.IntX
@@ -46,6 +47,7 @@
end
structure NestedPat = NestedPat (open Xml)
+
structure MatchCompile =
MatchCompile (open CoreML
structure Type = Xtype
@@ -103,6 +105,7 @@
lay: (unit -> Layout.t) option,
pat: NestedPat.t} vector,
conTycon,
+ hasExtraTuple,
kind: string,
lay: unit -> Layout.t,
mayWarn: bool,
@@ -112,7 +115,8 @@
tyconCons}: Xexp.t =
let
val cases = Vector.map (cases, fn {exp, lay, pat} =>
- {exp = exp,
+ {example = ref NONE,
+ exp = exp,
isDefault = false,
lay = lay,
numUses = ref 0,
@@ -123,7 +127,8 @@
in
Vector.concat
[cases,
- Vector.new1 {exp =
+ Vector.new1 {example = ref NONE,
+ exp =
Xexp.raisee ({exn = f e,
filePos = Region.toFilePos region},
caseType),
@@ -147,7 +152,8 @@
let
val (cases, decs) =
Vector.mapAndFold
- (cases, [], fn ({exp = e, numUses, pat = p, ...}, decs) =>
+ (cases, [],
+ fn ({example, exp = e, numUses, pat = p, ...}, decs) =>
let
val args = Vector.fromList (NestedPat.varsAndTypes p)
val (vars, tys) = Vector.unzip args
@@ -170,8 +176,9 @@
{tuple = Xexp.monoVar (arg, argType),
components = vars,
body = e})})}
- fun finish rename =
+ fun finish (p, rename) =
(Int.inc numUses
+ ; example := SOME p
; (Xexp.app
{func = Xexp.monoVar (func, funcType),
arg =
@@ -252,13 +259,54 @@
val _ =
if !Control.warnNonExhaustive
andalso noMatch <> Cexp.RaiseAgain
- andalso Vector.exists (cases, fn {isDefault, numUses, ...} =>
- isDefault andalso !numUses > 0)
then
- Control.warning (region,
- Layout.str (concat
- [kind, " is not exhaustive"]),
- lay ())
+ case Vector.peek (cases, fn {isDefault, numUses, ...} =>
+ isDefault andalso !numUses > 0) of
+ NONE => ()
+ | SOME {example, ...} =>
+ let
+ open Layout
+ fun layoutPat p =
+ let
+ val char =
+ case NestedPat.node p of
+ NestedPat.Const {const, isChar} =>
+ (case const of
+ Const.Word w =>
+ if isChar
+ then SOME (WordX.toChar w)
+ else NONE
+ | _ => NONE)
+ | _ => NONE
+ in
+ case char of
+ NONE => NestedPat.layout p
+ | SOME c =>
+ seq [str "#\"",
+ Char.layout c,
+ str "\""]
+ end
+ val p = valOf (!example)
+ val (suf, p) =
+ if not hasExtraTuple
+ then ("", layoutPat p)
+ else
+ case NestedPat.node p of
+ NestedPat.Tuple ps =>
+ ("s",
+ seq (separate (Vector.toListMap
+ (ps, layoutPat),
+ " ")))
+ | _ => Error.bug "hasExtraTuple needs tuple"
+ in
+ Control.warning
+ (region,
+ str (concat [kind, " is not exhaustive"]),
+ align [seq [str (concat ["missing pattern",
+ suf, ": "]),
+ p],
+ lay ()])
+ end
else ()
val redundant =
Vector.keepAll (cases, fn {isDefault, numUses, ...} =>
@@ -320,7 +368,8 @@
val {get = conTycon, set = setConTycon, ...} =
Property.getSetOnce (Con.plist,
Property.initRaise ("conTycon", Con.layout))
- val {get = tyconCons: Tycon.t -> Con.t vector,
+ val {get = tyconCons: Tycon.t -> {con: Con.t,
+ hasArg: bool} vector,
set = setTyconCons, ...} =
Property.getSetOnce (Tycon.plist,
Property.initRaise ("tyconCons", Tycon.layout))
@@ -331,6 +380,7 @@
(* Process all the datatypes. *)
fun loopDec (d: Cdec.t) =
let
+(* Use open Cdec instead of the following due to an SML/NJ bug *)
(* datatype z = datatype Cdec.t *)
open Cdec
in
@@ -339,7 +389,11 @@
Vector.foreach
(dbs, fn {cons, tycon, tyvars} =>
let
- val _ = setTyconCons (tycon, Vector.map (cons, #con))
+ val _ =
+ setTyconCons (tycon,
+ Vector.map (cons, fn {arg, con} =>
+ {con = con,
+ hasArg = isSome arg}))
val cons =
Vector.map
(cons, fn {arg, con} =>
@@ -397,7 +451,9 @@
NestedPat.Con {arg = Option.map (arg, loopPat),
con = con,
targs = Vector.map (targs, loopTy)}
- | Const f => NestedPat.Const (f ())
+ | Const f =>
+ NestedPat.Const {const = f (),
+ isChar = Ctype.isChar t}
| Layered (x, p) => NestedPat.Layered (x, loopPat p)
| List ps =>
let
@@ -448,7 +504,7 @@
ty = Xtype.arrow (argType, bodyType),
var = var}
end)
-(* Use open Cdec instead of the following due to an SML/NJ 110.43 bug *)
+(* Use open Cdec instead of the following due to an SML/NJ bug *)
(* datatype z = datatype Cdec.t *)
open Cdec
in
@@ -479,6 +535,7 @@
lay = SOME lay,
pat = p},
conTycon = conTycon,
+ hasExtraTuple = false,
kind = "declaration",
lay = lay,
mayWarn = mayWarn,
@@ -621,13 +678,15 @@
func = #1 (loopExp e1),
ty = ty}
end
- | Case {kind, lay, noMatch, region, rules, test} =>
+ | Case {hasExtraTuple, kind, lay, noMatch, region, rules,
+ test} =>
casee {caseType = ty,
cases = Vector.map (rules, fn {exp, lay, pat} =>
{exp = #1 (loopExp exp),
lay = lay,
pat = loopPat pat}),
conTycon = conTycon,
+ hasExtraTuple = hasExtraTuple,
kind = kind,
lay = lay,
mayWarn = true,
1.58 +42 -20 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -r1.57 -r1.58
--- elaborate-core.fun 29 Dec 2003 19:34:59 -0000 1.57
+++ elaborate-core.fun 29 Dec 2003 22:01:08 -0000 1.58
@@ -382,7 +382,7 @@
align [seq [str "expects: ", l2],
seq [str "but got: ", l1],
seq [str "in: ", lay ()]]))
- fun lay () = Apat.layout p
+ fun lay () = approximate (Apat.layout p)
in
case Apat.node p of
Apat.App (c, p) =>
@@ -415,17 +415,33 @@
resultType)
end
| Apat.Const c =>
- (case Aconst.node c of
- Aconst.Bool b => if b then Cpat.truee else Cpat.falsee
- | _ =>
- let
- val ty = Aconst.ty c
- fun resolve () = resolveConst (c, ty)
- val _ = List.push (overloads, fn () =>
- (resolve (); ()))
- in
- Cpat.make (Cpat.Const resolve, ty)
- end)
+ let
+ fun doit () =
+ let
+ val ty = Aconst.ty c
+ fun resolve () = resolveConst (c, ty)
+ val _ = List.push (overloads, fn () =>
+ (resolve (); ()))
+ in
+ Cpat.make (Cpat.Const resolve, ty)
+ end
+ in
+ case Aconst.node c of
+ Aconst.Bool b => if b then Cpat.truee else Cpat.falsee
+ | Aconst.Real r =>
+ let
+ open Layout
+ val _ =
+ Control.error
+ (region,
+ seq [str "real constants are not allowed in patterns: ",
+ lay ()],
+ empty)
+ in
+ doit ()
+ end
+ | _ => doit ()
+ end
| Apat.Constraint (p, t) =>
let
val p' = loop p
@@ -1314,7 +1330,8 @@
let
val e =
Cexp.casee
- {kind = "function",
+ {hasExtraTuple = i > 1,
+ kind = "function",
lay = lay,
noMatch = Cexp.RaiseMatch,
region = region,
@@ -1445,9 +1462,10 @@
let
open Layout
in
- approximate
- (seq [str "in: ", Apat.layout pat,
- str " = ", Aexp.layout exp])
+ seq [str "in: ",
+ approximate
+ (seq [Apat.layout pat,
+ str " = ", Aexp.layout exp])]
end
in
{exp = elabExp (exp,
@@ -1535,7 +1553,8 @@
val arg = Var.newNoname ()
val body =
Cexp.enterLeave
- (Cexp.casee {kind = "function",
+ (Cexp.casee {hasExtraTuple = false,
+ kind = "function",
lay = lay,
noMatch = Cexp.RaiseMatch,
region = region,
@@ -1695,7 +1714,8 @@
align [seq [str "object type: ", l1],
seq [str "rules expect: ", l2]]))
in
- Cexp.casee {kind = "case",
+ Cexp.casee {hasExtraTuple = false,
+ kind = "case",
lay = lay,
noMatch = Cexp.RaiseMatch,
region = region,
@@ -1860,7 +1880,8 @@
(Var.newNoname (), t))
in
Cexp.casee
- {kind = "",
+ {hasExtraTuple = false,
+ kind = "",
lay = fn _ => Layout.empty,
noMatch = Cexp.Impossible,
region = Region.bogus,
@@ -2033,7 +2054,8 @@
val {argType, region, resultType, rules} =
elabMatch (m, preError, nest)
val body =
- Cexp.casee {kind = kind,
+ Cexp.casee {hasExtraTuple = false,
+ kind = kind,
lay = lay,
noMatch = noMatch,
region = region,
1.16 +5 -0 mlton/mlton/elaborate/type-env.fun
Index: type-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- type-env.fun 26 Dec 2003 23:40:22 -0000 1.15
+++ type-env.fun 29 Dec 2003 22:01:08 -0000 1.16
@@ -765,6 +765,11 @@
val unit = tuple (Vector.new0 ())
+ fun isChar t =
+ case toType t of
+ Con (c, _) => Tycon.equals (c, Tycon.char)
+ | _ => false
+
fun isUnit t =
case toType t of
Record r =>
1.9 +1 -0 mlton/mlton/elaborate/type-env.sig
Index: type-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- type-env.sig 27 Dec 2003 01:41:54 -0000 1.8
+++ type-env.sig 29 Dec 2003 22:01:08 -0000 1.9
@@ -35,6 +35,7 @@
expandOpaque: expandOpaque,
record: 'a SortedRecord.t -> 'a,
var: Tyvar.t -> 'a} -> 'a
+ val isChar: t -> bool
val isUnit: t -> bool
val layout: t -> Layout.t
val layoutPretty: t -> Layout.t
1.4 +272 -91 mlton/mlton/match-compile/match-compile.fun
Index: match-compile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/match-compile/match-compile.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- match-compile.fun 13 Oct 2003 18:49:27 -0000 1.3
+++ match-compile.fun 29 Dec 2003 22:01:09 -0000 1.4
@@ -17,7 +17,7 @@
struct
datatype t =
Any
- | Const of Const.t
+ | Const of {const: Const.t, isChar: bool}
| Con of {arg: NestedPat.t option,
con: Con.t,
targs: Type.t vector}
@@ -29,22 +29,13 @@
in
case p of
Any => str "Any"
- | Const c => Const.layout c
- | Con {con, arg, ...} => seq [Con.layout con, str " ",
- Option.layout NestedPat.layout arg]
+ | Const {const = c, ...} => Const.layout c
+ | Con {con, arg, ...} =>
+ seq [Con.layout con, str " ",
+ Option.layout NestedPat.layout arg]
| Tuple v => Vector.layout NestedPat.layout v
end
- val isRefutable =
- fn Any => false
- | Const _ => true
- | Con _ => true
- | Tuple ps => Vector.exists (ps, NestedPat.isRefutable)
-
- val isAny =
- fn Any => true
- | _ => false
-
(* get rid of Wild, Var, Layered - also remove unary tuples *)
fun flatten (var: Var.t, pat: NestedPat.t, env: Env.t): t * Env.t =
let
@@ -71,7 +62,7 @@
structure Continue =
struct
datatype t =
- Finish of (Var.t -> Var.t) -> Exp.t
+ Finish of (NestedPat.t * (Var.t -> Var.t)) -> Exp.t
| Matches of FlatPat.t vector option * t
fun layout c =
@@ -126,7 +117,7 @@
structure Finish =
struct
- type t = Info.t vector -> Exp.t
+ type t = NestedPat.t * Info.t vector -> Exp.t
fun layout (_: t) = Layout.str "<finish>"
end
@@ -152,7 +143,11 @@
inj (s,
Vector.map
(cases, fn {const, infos: Info.t list} =>
- (get const, finish (Vector.fromList infos))))))
+ (get const, finish (NestedPat.make
+ (NestedPat.Const {const = const,
+ isChar = false},
+ ty s),
+ Vector.fromList infos))))))
in
val directCases =
make (List.remove (IntSize.all, fn s => IntSize.I64 = s),
@@ -165,17 +160,127 @@
| _ => Error.bug "caseWord type error")
end
+(* unhandledConst cs returns a constant (of the appropriate type) not in cs. *)
+fun unhandledConst (cs: Const.t vector): Const.t =
+ let
+ fun search (start: 'a, next: 'a -> 'a, make: 'a -> Const.t): Const.t =
+ let
+ fun loop (a: 'a): Const.t =
+ let
+ val c = make a
+ in
+ if Vector.exists (cs, fn c' => Const.equals (c, c'))
+ then loop (next a)
+ else c
+ end
+ in
+ loop start
+ end
+ fun search {<= : 'a * 'a -> bool,
+ equals: 'a * 'a -> bool,
+ extract: Const.t -> 'a,
+ isMin: 'a -> bool,
+ make: 'a -> Const.t,
+ next: 'a -> 'a,
+ prev: 'a -> 'a} =
+ let
+ val cs = QuickSort.sortVector (Vector.map (cs, extract), op <=)
+ val c = Vector.sub (cs, 0)
+ in
+ if not (isMin c)
+ then make (prev c)
+ else
+ let
+ val n = Vector.length cs
+ fun loop (i, c) =
+ if i = n orelse not (equals (c, Vector.sub (cs, i)))
+ then make c
+ else loop (i + 1, next c)
+ in
+ loop (0, c)
+ end
+ end
+ val c = Vector.sub (cs, 0)
+ datatype z = datatype Const.t
+ in
+ case c of
+ Int i =>
+ let
+ val s = IntX.size i
+ val min = IntX.toIntInf (IntX.min s)
+ fun extract c =
+ case c of
+ Int i => IntX.toIntInf i
+ | _ => Error.bug "expected Int"
+ in
+ search {<= = op <=,
+ equals = op =,
+ extract = extract,
+ isMin = fn i => i = min,
+ make = fn i => Const.int (IntX.make (i, s)),
+ next = fn i => i + 1,
+ prev = fn i => i - 1}
+
+ end
+ | IntInf _ =>
+ let
+ fun extract c =
+ case c of
+ IntInf i => i
+ | _ => Error.bug "expected IntInf"
+ in
+ search {<= = op <=,
+ equals = op =,
+ extract = extract,
+ isMin = fn _ => false,
+ make = Const.IntInf,
+ next = fn i => i + 1,
+ prev = fn i => i - 1}
+ end
+ | Real _ => Error.bug "match on real is not allowed"
+ | Word w =>
+ let
+ val s = WordX.size w
+ fun extract c =
+ case c of
+ Word w => WordX.toLargeWord w
+ | _ => Error.bug "expected Word"
+ in
+ search {<= = op <=,
+ equals = op =,
+ extract = extract,
+ isMin = fn w => w = 0w0,
+ make = fn w => Const.word (WordX.make (w, s)),
+ next = fn w => w + 0w1,
+ prev = fn w => w - 0w1}
+ end
+ | Word8Vector _ =>
+ let
+ val max =
+ Vector.fold
+ (cs, ~1, fn (c, max) =>
+ case c of
+ Word8Vector v => Int.max (max, Vector.length v)
+ | _ => Error.bug "expected Word8Vector")
+ val w = Word8.fromChar #"a"
+ in
+ Const.Word8Vector (Vector.tabulate (max + 1, fn _ => w))
+ end
+ end
+
(*---------------------------------------------------*)
(* matchCompile *)
(*---------------------------------------------------*)
fun matchCompile {caseType: Type.t,
- cases: (NestedPat.t * ((Var.t -> Var.t) -> Exp.t)) vector,
+ cases: (NestedPat.t
+ * (NestedPat.t * (Var.t -> Var.t) -> Exp.t)) vector,
conTycon: Con.t -> Tycon.t,
region: Region.t,
test: Var.t,
testType: Type.t,
- tyconCons: Tycon.t -> Con.t vector}: Exp.t =
+ tyconCons: Tycon.t -> {con: Con.t,
+ hasArg: bool} vector}: Exp.t =
let
fun match (var: Var.t,
ty: Type.t,
@@ -192,7 +297,8 @@
info = Info.T {accum = accum,
continue = continue}}
end)
- in matchFlat (var, ty, rules, finish)
+ in
+ matchFlat (var, ty, rules, finish)
end
and matchFlat arg: Exp.t =
traceMatchFlat
@@ -200,21 +306,22 @@
ty: Type.t,
rules: FlatRule.t vector,
finish: Finish.t) =>
- let
- val test = Exp.var (var, ty)
- in
- case Vector.peek (rules, fn FlatRule.T {pat, ...} =>
- case pat of
- FlatPat.Any => false
- | _ => true) of
- NONE => finish (Vector.map (rules, FlatRule.info))
- | SOME (FlatRule.T {pat, info}) =>
+ case Vector.peek (rules, fn FlatRule.T {pat, ...} =>
+ case pat of
+ FlatPat.Any => false
+ | _ => true) of
+ NONE => finish (NestedPat.wild ty,
+ Vector.map (rules, FlatRule.info))
+ | SOME (FlatRule.T {pat, info}) =>
+ let
+ val test = Exp.var (var, ty)
+ in
case pat of
FlatPat.Any => Error.bug "matchFlat"
| FlatPat.Const _ => const (test, ty, rules, finish)
- | FlatPat.Con _ => sum (test, rules, finish)
- | FlatPat.Tuple ps => tuple (test, ty, rules, finish)
- end) arg
+ | FlatPat.Con _ => sum (test, ty, rules, finish)
+ | FlatPat.Tuple _ => tuple (test, ty, rules, finish)
+ end) arg
and matches (vars: (Var.t * Type.t) vector,
rules: {pats: NestedPat.t vector option, info: Info.t} vector,
finish: Finish.t): Exp.t =
@@ -233,15 +340,18 @@
in {pats = SOME pats,
info = Info.T {accum = accum, continue = continue}}
end)
- in matchesFlat (0, vars, rules, finish)
+ in
+ matchesFlat (0, vars, [], rules, finish)
end
and matchesFlat (i: int,
vars: (Var.t * Type.t) vector,
+ pats: NestedPat.t list,
rules: {pats: FlatPat.t vector option,
info: Info.t} vector,
finish: Finish.t): Exp.t =
if i = Vector.length vars
- then finish (Vector.map (rules, #info))
+ then finish (NestedPat.tuple (Vector.fromListRev pats),
+ Vector.map (rules, #info))
else
let
val (var, ty) = Vector.sub (vars, i)
@@ -253,18 +363,18 @@
FlatRule.T
{pat = FlatPat.Any,
info = Info.T {accum = accum,
- continue =
- Matches (NONE, continue)}}
+ continue = Matches (NONE, continue)}}
| SOME pats =>
FlatRule.T
{pat = Vector.sub (pats, i),
info =
Info.T {accum = accum,
continue = Matches (SOME pats, continue)}})
- in matchFlat
- (var, ty, rules, fn infos =>
+ in
+ matchFlat
+ (var, ty, rules, fn (pat, infos) =>
matchesFlat
- (i + 1, vars,
+ (i + 1, vars, pat :: pats,
Vector.map (infos, fn Info.T {accum, continue} =>
case continue of
Matches (pats, continue) =>
@@ -291,14 +401,14 @@
FlatPat.Any => {pats = NONE, info = info}
| FlatPat.Tuple pats => {pats = SOME pats, info = info}
| _ => Error.bug "expected tuple pattern")
- in Exp.detuple
- {tuple = test,
- body = fn vars => matches (vars, rules, finish)}
+ in
+ Exp.detuple {tuple = test,
+ body = fn vars => matches (vars, rules, finish)}
end) arg
(*------------------------------------*)
(* sum *)
(*------------------------------------*)
- and sum (test, rules: FlatRule.t vector, finish: Finish.t) =
+ and sum (test, ty: Type.t, rules: FlatRule.t vector, finish: Finish.t) =
let
datatype arg =
NoArg of Info.t list
@@ -368,16 +478,50 @@
val default =
if Vector.isEmpty cases
then
- SOME (finish defaults, region)
+ SOME (finish (NestedPat.wild ty, defaults),
+ region)
else
let
val {con, ...} = Vector.sub (cases, 0)
val tycon = conTycon con
- in if Tycon.equals (tycon, Tycon.exn)
- orelse Vector.length cases <> (Vector.length
- (tyconCons tycon))
- then SOME (finish defaults, region)
- else NONE
+ fun done defaultPat =
+ SOME (finish (defaultPat, defaults), region)
+ in
+ if Tycon.equals (tycon, Tycon.exn)
+ then done (NestedPat.make
+ (NestedPat.Var (Var.fromString "e"),
+ ty))
+ else
+ let
+ val cons = tyconCons tycon
+ in
+ if Vector.length cases = Vector.length cons
+ then NONE
+ else
+ done
+ (case (Vector.peek
+ (cons, fn {con, ...} =>
+ not (Vector.exists
+ (cases, fn {con = con', ...} =>
+ Con.equals (con, con'))))) of
+ NONE =>
+ Error.bug "unable to find default example"
+ | SOME {con, hasArg} =>
+ let
+ val arg =
+ if hasArg
+ then SOME (NestedPat.wild
+ Type.unit)
+ else NONE
+ in
+ NestedPat.make
+ (NestedPat.Con
+ {arg = arg,
+ con = con,
+ targs = Vector.new0 ()},
+ ty)
+ end)
+ end
end
fun normal () =
Exp.casee
@@ -387,15 +531,24 @@
Cases.con (Vector.map
(cases, fn {con, tys, arg} =>
let
+ fun conPat arg =
+ NestedPat.make
+ (NestedPat.Con {arg = arg,
+ con = con,
+ targs = tys},
+ ty)
val (arg, rhs) =
case arg of
NoArg infos =>
- (NONE, finish (Vector.fromList infos))
+ (NONE,
+ finish (conPat NONE,
+ Vector.fromList infos))
| Arg {var, ty, rules} =>
(SOME (var, ty),
match (var, ty,
Vector.fromList rules,
- finish))
+ fn (p, e) =>
+ finish (conPat (SOME p), e)))
in {con = con,
targs = tys,
arg = arg,
@@ -405,17 +558,25 @@
if 1 = Vector.length cases
then
let
- val {con, arg, ...} = Vector.sub (cases, 0)
+ val {arg, con, tys, ...} = Vector.sub (cases, 0)
in
case arg of
Arg {var, ty, rules} =>
if Con.equals (con, Con.reff)
- then (Exp.lett
- {var = var,
- exp = Exp.deref test,
- body = match (var, ty,
- Vector.fromList rules,
- finish)})
+ then
+ Exp.lett
+ {var = var,
+ exp = Exp.deref test,
+ body = match (var, ty,
+ Vector.fromList rules,
+ fn (p, e) =>
+ finish (NestedPat.make
+ (NestedPat.Con
+ {arg = SOME p,
+ con = Con.reff,
+ targs = tys},
+ ty),
+ e))}
else normal ()
| _ => normal ()
end
@@ -431,6 +592,13 @@
rules: FlatRule.t vector,
finish: Finish.t) =>
let
+ val isChar =
+ case Vector.peekMap (rules, fn FlatRule.T {pat, ...} =>
+ case pat of
+ FlatPat.Const {isChar, ...} => SOME isChar
+ | _ => NONE) of
+ NONE => false
+ | SOME isChar => isChar
val (cases, defaults) =
Vector.foldr
(rules, ([], []),
@@ -440,7 +608,7 @@
(List.map (cases, fn {const, infos} =>
{const = const, infos = info :: infos}),
info :: defaults)
- | FlatPat.Const c =>
+ | FlatPat.Const {const = c, ...} =>
let
fun insert (cases, ac) =
case cases of
@@ -457,47 +625,60 @@
Const.equals (c, const))
then insert (cases, [])
else {const = c, infos = info :: defaults} :: cases
- in (cases, defaults)
+ in
+ (cases, defaults)
end
| _ => Error.bug "expected Const pat")
- fun default () = finish (Vector.fromList defaults)
- fun loop ds =
- case ds of
- [] =>
- List.fold
- (cases, default (), fn ({const, infos}, rest) =>
- Exp.iff {test = Exp.equal (test, Exp.const const),
- thenn = finish (Vector.fromList infos),
- elsee = rest,
- ty = caseType})
- | (ty', cardinality, make) :: ds =>
- if Type.equals (ty, ty')
- then
- let
- val cases = Vector.fromList cases
- val default =
- if cardinality
- = IntInf.fromInt (Vector.length cases)
- then NONE
- else SOME (default (), region)
- in
- Exp.casee {cases = make (cases, finish),
- default = default,
- test = test,
- ty = caseType}
- end
- else loop ds
- in loop directCases
+ fun default () =
+ let
+ val cs = Vector.fromListMap (cases, #const)
+ val unhandled =
+ if 0 = Vector.length cs
+ then NestedPat.Wild
+ else NestedPat.Const {const = unhandledConst cs,
+ isChar = isChar}
+ in
+ finish (NestedPat.make (unhandled, ty),
+ Vector.fromList defaults)
+ end
+ in
+ case List.peek (directCases, fn (ty', _, _) =>
+ Type.equals (ty, ty')) of
+ NONE =>
+ List.fold
+ (cases, default (), fn ({const, infos}, rest) =>
+ Exp.iff {test = Exp.equal (test, Exp.const const),
+ thenn = finish (NestedPat.make
+ (NestedPat.Const {const = const,
+ isChar = false},
+ ty),
+ Vector.fromList infos),
+ elsee = rest,
+ ty = caseType})
+ | SOME (_, cardinality, make) =>
+ let
+ val cases = Vector.fromList cases
+ val default =
+ if cardinality = IntInf.fromInt (Vector.length cases)
+ then NONE
+ else SOME (default (), region)
+ in
+ Exp.casee {cases = make (cases, finish),
+ default = default,
+ test = test,
+ ty = caseType}
+ end
end) arg
(*------------------------------------*)
(* main code for match compile *)
(*------------------------------------*)
- in match (test, testType,
+ in
+ match (test, testType,
Vector.map (cases, fn (p, f) =>
Rule.T {pat = p,
info = Info.T {accum = Env.empty,
continue = Finish f}}),
- fn infos =>
+ fn (pat, infos) =>
if Vector.isEmpty infos
then Error.bug "matchRules: no default"
else
@@ -505,7 +686,7 @@
val Info.T {accum = env, continue} = Vector.sub (infos, 0)
in
case continue of
- Finish f => f (fn x => Env.lookup (env, x))
+ Finish f => f (pat, fn x => Env.lookup (env, x))
| _ => Error.bug "matchRules: expecting Finish"
end)
end
1.2 +4 -2 mlton/mlton/match-compile/match-compile.sig
Index: match-compile.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/match-compile/match-compile.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- match-compile.sig 9 Oct 2003 18:17:34 -0000 1.1
+++ match-compile.sig 29 Dec 2003 22:01:09 -0000 1.2
@@ -20,6 +20,7 @@
val equals: t * t -> bool
val int: IntSize.t -> t
val layout: t -> Layout.t
+ val unit: t
val word: WordSize.t -> t
end
structure Cases:
@@ -66,11 +67,12 @@
val matchCompile:
{caseType: Type.t, (* type of entire expression *)
- cases: (NestedPat.t * ((Var.t -> Var.t) -> Exp.t)) vector,
+ cases: (NestedPat.t
+ * (NestedPat.t * (Var.t -> Var.t) -> Exp.t)) vector,
conTycon: Con.t -> Tycon.t,
region: Region.t,
test: Var.t,
testType: Type.t,
- tyconCons: Tycon.t -> Con.t vector}
+ tyconCons: Tycon.t -> {con: Con.t, hasArg: bool} vector}
-> Exp.t
end
1.2 +12 -6 mlton/mlton/match-compile/nested-pat.fun
Index: nested-pat.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/match-compile/nested-pat.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- nested-pat.fun 9 Oct 2003 18:17:34 -0000 1.1
+++ nested-pat.fun 29 Dec 2003 22:01:09 -0000 1.2
@@ -15,7 +15,8 @@
Con of {arg: t option,
con: Con.t,
targs: Type.t vector}
- | Const of Const.t
+ | Const of {const: Const.t,
+ isChar: bool}
| Layered of Var.t * t
| Tuple of t vector
| Var of Var.t
@@ -40,11 +41,16 @@
in
case node p of
Con {arg, con, targs} =>
- Pretty.conApp {arg = Option.map (arg, layout),
- con = Con.layout con,
- targs = Vector.map (targs, Type.layout)}
- | Const c => Const.layout c
- | Layered (x, p) => seq [Var.layout x, str " as ", layout p]
+ let
+ val z =
+ Pretty.conApp {arg = Option.map (arg, layout),
+ con = Con.layout con,
+ targs = Vector.map (targs, Type.layout)}
+ in
+ if isSome arg then paren z else z
+ end
+ | Const {const = c, ...} => Const.layout c
+ | Layered (x, p) => paren (seq [Var.layout x, str " as ", layout p])
| Tuple ps => tuple (Vector.toListMap (ps, layout))
| Var x => Var.layout x
| Wild => str "_"
1.2 +2 -1 mlton/mlton/match-compile/nested-pat.sig
Index: nested-pat.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/match-compile/nested-pat.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- nested-pat.sig 9 Oct 2003 18:17:34 -0000 1.1
+++ nested-pat.sig 29 Dec 2003 22:01:09 -0000 1.2
@@ -26,7 +26,8 @@
Con of {arg: t option,
con: Con.t,
targs: Type.t vector}
- | Const of Const.t
+ | Const of {const: Const.t,
+ isChar: bool}
| Layered of Var.t * t
| Tuple of t vector
| Var of Var.t
1.2 +36 -1 mlton/regression/nonexhaustive.sml
Index: nonexhaustive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/nonexhaustive.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- nonexhaustive.sml 5 Oct 2001 19:07:42 -0000 1.1
+++ nonexhaustive.sml 29 Dec 2003 22:01:10 -0000 1.2
@@ -1,5 +1,40 @@
-(* exhaustive.sml *)
+(* nonexhaustive.sml *)
+val _ =
+ case 1 of
+ 2 => 3
+ | 3 => 4
+
+val _ =
+ case [] of
+ [] => 1
+
+val _ =
+ case [] of
+ [] => 0
+ | [_] => 1
+ | [_, _] => 2
+
+val _ =
+ case Fail "foo" of
+ Fail _ => false
+
+val _ =
+ case (1, []) of
+ (1, []) => true
+
+val _ =
+ case (1, []) of
+ (1, _) => true
+
+fun f 1 2 = 3
+
+fun f "" = ()
+
+fun f #"a" = 13
+
+fun f (0w0: Word8.word) = 13
+
(* Checks for non-exhaustive pattern matches (compiler should warn). *)
fun ord #"\000" = 0
1.1 mlton/regression/fail/pat.1.sml
Index: pat.1.sml
===================================================================
val _ =
case 13.0 of
14.0 => ()
;