[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 => ()
;