[MLton] cvs commit: non-exhaustive warnings now output all omitted patterns
Stephen Weeks
sweeks@mlton.org
Wed, 31 Dec 2003 01:21:30 -0800
sweeks 03/12/31 01:21:29
Modified: mlton/defunctorize defunctorize.fun
mlton/match-compile match-compile.fun match-compile.sig
regression nonexhaustive.sml
Log:
MAIL non-exhaustive warnings now output all omitted patterns
The implementation was simple enough. The caller of the match
compiler now keeps a list of example patterns that fail. The match
compiler itself uses an "or pattern" to capture all of the
constructors in a sum type that are not covered. All of the example
patterns are displayed as one big or pattern.
I used or patterns to avoid the potential exponential blowup for cases
on tuples. Also, I still only show one constant that is unhandled for
cases on constants. Finally, clausal function definitions warnings
are now slightly messier, since the clauses are displayed as a tuple
instead of with spaces.
Overall, this seems like a nice improvement to me. For example, for
datatype z = A | B | C
fun f x =
case x of
(A, B, C) => ()
we get the following warning
missing patterns: (A, B, A | B) | (A, A | C, _) | (B | C, _, _)
Revision Changes Path
1.8 +11 -41 mlton/mlton/defunctorize/defunctorize.fun
Index: defunctorize.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/defunctorize/defunctorize.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- defunctorize.fun 29 Dec 2003 22:01:08 -0000 1.7
+++ defunctorize.fun 31 Dec 2003 09:21:26 -0000 1.8
@@ -105,7 +105,7 @@
lay: (unit -> Layout.t) option,
pat: NestedPat.t} vector,
conTycon,
- hasExtraTuple,
+ hasExtraTuple: bool,
kind: string,
lay: unit -> Layout.t,
mayWarn: bool,
@@ -115,7 +115,7 @@
tyconCons}: Xexp.t =
let
val cases = Vector.map (cases, fn {exp, lay, pat} =>
- {example = ref NONE,
+ {examples = ref [],
exp = exp,
isDefault = false,
lay = lay,
@@ -127,7 +127,7 @@
in
Vector.concat
[cases,
- Vector.new1 {example = ref NONE,
+ Vector.new1 {examples = ref [],
exp =
Xexp.raisee ({exn = f e,
filePos = Region.toFilePos region},
@@ -153,7 +153,7 @@
val (cases, decs) =
Vector.mapAndFold
(cases, [],
- fn ({example, exp = e, numUses, pat = p, ...}, decs) =>
+ fn ({examples, exp = e, numUses, pat = p, ...}, decs) =>
let
val args = Vector.fromList (NestedPat.varsAndTypes p)
val (vars, tys) = Vector.unzip args
@@ -178,7 +178,7 @@
body = e})})}
fun finish (p, rename) =
(Int.inc numUses
- ; example := SOME p
+ ; List.push (examples, p)
; (Xexp.app
{func = Xexp.monoVar (func, funcType),
arg =
@@ -263,48 +263,18 @@
case Vector.peek (cases, fn {isDefault, numUses, ...} =>
isDefault andalso !numUses > 0) of
NONE => ()
- | SOME {example, ...} =>
+ | SOME {examples, ...} =>
let
+ val ps = !examples
+ val suf = if length ps > 1 then "s" else ""
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],
+ align [seq (str (concat ["missing pattern",
+ suf, ": "])
+ :: (separate (ps, " | "))),
lay ()])
end
else ()
1.5 +59 -61 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.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- match-compile.fun 29 Dec 2003 22:01:09 -0000 1.4
+++ match-compile.fun 31 Dec 2003 09:21:27 -0000 1.5
@@ -62,7 +62,7 @@
structure Continue =
struct
datatype t =
- Finish of (NestedPat.t * (Var.t -> Var.t)) -> Exp.t
+ Finish of (Layout.t * (Var.t -> Var.t)) -> Exp.t
| Matches of FlatPat.t vector option * t
fun layout c =
@@ -117,7 +117,7 @@
structure Finish =
struct
- type t = NestedPat.t * Info.t vector -> Exp.t
+ type t = Layout.t * Info.t vector -> Exp.t
fun layout (_: t) = Layout.str "<finish>"
end
@@ -143,10 +143,7 @@
inj (s,
Vector.map
(cases, fn {const, infos: Info.t list} =>
- (get const, finish (NestedPat.make
- (NestedPat.Const {const = const,
- isChar = false},
- ty s),
+ (get const, finish (Const.layout const,
Vector.fromList infos))))))
in
val directCases =
@@ -268,13 +265,21 @@
end
end
+local
+ open Layout
+in
+ val wild = str "_"
+
+ fun conApp (c, p) = paren (seq [Con.layout c, str " ", p])
+end
+
(*---------------------------------------------------*)
(* matchCompile *)
(*---------------------------------------------------*)
fun matchCompile {caseType: Type.t,
cases: (NestedPat.t
- * (NestedPat.t * (Var.t -> Var.t) -> Exp.t)) vector,
+ * (Layout.t * (Var.t -> Var.t) -> Exp.t)) vector,
conTycon: Con.t -> Tycon.t,
region: Region.t,
test: Var.t,
@@ -310,8 +315,7 @@
case pat of
FlatPat.Any => false
| _ => true) of
- NONE => finish (NestedPat.wild ty,
- Vector.map (rules, FlatRule.info))
+ NONE => finish (wild, Vector.map (rules, FlatRule.info))
| SOME (FlatRule.T {pat, info}) =>
let
val test = Exp.var (var, ty)
@@ -345,13 +349,12 @@
end
and matchesFlat (i: int,
vars: (Var.t * Type.t) vector,
- pats: NestedPat.t list,
+ pats: Layout.t list,
rules: {pats: FlatPat.t vector option,
info: Info.t} vector,
finish: Finish.t): Exp.t =
if i = Vector.length vars
- then finish (NestedPat.tuple (Vector.fromListRev pats),
- Vector.map (rules, #info))
+ then finish (Layout.tuple (rev pats), Vector.map (rules, #info))
else
let
val (var, ty) = Vector.sub (vars, i)
@@ -477,20 +480,16 @@
val defaults = Vector.fromList defaults
val default =
if Vector.isEmpty cases
- then
- SOME (finish (NestedPat.wild ty, defaults),
- region)
+ then SOME (finish (wild, defaults), region)
else
let
val {con, ...} = Vector.sub (cases, 0)
val tycon = conTycon con
- fun done defaultPat =
+ fun done (defaultPat: Layout.t) =
SOME (finish (defaultPat, defaults), region)
in
if Tycon.equals (tycon, Tycon.exn)
- then done (NestedPat.make
- (NestedPat.Var (Var.fromString "e"),
- ty))
+ then done (Layout.str "e")
else
let
val cons = tyconCons tycon
@@ -498,29 +497,22 @@
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)
+ let
+ val unhandled =
+ Vector.keepAllMap
+ (cons, fn {con, hasArg, ...} =>
+ if Vector.exists
+ (cases, fn {con = con', ...} =>
+ Con.equals (con, con'))
+ then NONE
+ else SOME (if hasArg
+ then conApp (con, wild)
+ else Con.layout con))
+ open Layout
+ in
+ done (seq (separate (Vector.toList unhandled,
+ " | ")))
+ end
end
end
fun normal () =
@@ -541,15 +533,16 @@
case arg of
NoArg infos =>
(NONE,
- finish (conPat NONE,
+ finish (Con.layout con,
Vector.fromList infos))
| Arg {var, ty, rules} =>
(SOME (var, ty),
match (var, ty,
Vector.fromList rules,
fn (p, e) =>
- finish (conPat (SOME p), e)))
- in {con = con,
+ finish (conApp (con, p), e)))
+ in
+ {con = con,
targs = tys,
arg = arg,
rhs = rhs}
@@ -570,13 +563,7 @@
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))}
+ finish (conApp (con, p), e))}
else normal ()
| _ => normal ()
end
@@ -634,12 +621,26 @@
val cs = Vector.fromListMap (cases, #const)
val unhandled =
if 0 = Vector.length cs
- then NestedPat.Wild
- else NestedPat.Const {const = unhandledConst cs,
- isChar = isChar}
+ then wild
+ else
+ let
+ val c = unhandledConst cs
+ in
+ if isChar
+ then (case c of
+ Const.Word w =>
+ let
+ open Layout
+ in
+ seq [str "#\"",
+ Char.layout (WordX.toChar w),
+ str "\""]
+ end
+ | _ => Error.bug "strange char")
+ else Const.layout c
+ end
in
- finish (NestedPat.make (unhandled, ty),
- Vector.fromList defaults)
+ finish (unhandled, Vector.fromList defaults)
end
in
case List.peek (directCases, fn (ty', _, _) =>
@@ -648,10 +649,7 @@
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),
+ thenn = finish (Const.layout const,
Vector.fromList infos),
elsee = rest,
ty = caseType})
1.3 +1 -1 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.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- match-compile.sig 29 Dec 2003 22:01:09 -0000 1.2
+++ match-compile.sig 31 Dec 2003 09:21:27 -0000 1.3
@@ -68,7 +68,7 @@
val matchCompile:
{caseType: Type.t, (* type of entire expression *)
cases: (NestedPat.t
- * (NestedPat.t * (Var.t -> Var.t) -> Exp.t)) vector,
+ * (Layout.t * (Var.t -> Var.t) -> Exp.t)) vector,
conTycon: Con.t -> Tycon.t,
region: Region.t,
test: Var.t,
1.4 +16 -1 mlton/regression/nonexhaustive.sml
Index: nonexhaustive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/nonexhaustive.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- nonexhaustive.sml 30 Dec 2003 05:43:10 -0000 1.3
+++ nonexhaustive.sml 31 Dec 2003 09:21:27 -0000 1.4
@@ -15,6 +15,21 @@
| [_] => 1
| [_, _] => 2
+fun first l =
+ case l of
+ SOME x :: _ => x
+
+fun f x =
+ case x of
+ (false, false) => ()
+ | (true, true) => ()
+
+datatype z = A | B | C
+
+fun f x =
+ case x of
+ (A, B, C) => ()
+
val _ =
case Fail "foo" of
Fail _ => false
@@ -34,7 +49,7 @@
fun f #"a" = 13
fun f (0w0: Word8.word) = 13
-
+
(* Checks for non-exhaustive pattern matches (compiler should warn). *)
fun ord #"\000" = 0