[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