Make cosmetic improvements to nonexhaustive diagnostics

Consider the following program:

  datatype a = A1 of int * int | A2 of int | A3 of int
             | A4 of int * int | A5 of int | A6 of int
  datatype b = B1 of a | B2 of a * a

  fun f1 b =
    case b of B1 (A1 (x,_) | A2 x) => x + 1 | B2 (A3 y, A5 z) => y + z

  fun f2 b =
    case b of B1 _ => true

  fun f3 b =
    case b of (A3 y, A5 z) => y + z

Previously, the following error messages were generated:

  Warning: w.sml 6.3.
    Case is not exhaustive.
      missing pattern: (B2 ((A1 _) | (A2 _) | (A4 _) | (A5 _) | (A6 _), _))
                     | (B2 ((A3 _), (A1 _) | (A2 _) | (A3 _) | (A4 _) | (A6 _)))
                     | (B1 (A3 _) | (A4 _) | (A5 _) | (A6 _))
      in: case b of (B1 (A1 (x, _) |A2 x))   ...  y, A5 z)) => (y + z)
  Warning: w.sml 9.3.
    Case is not exhaustive.
      missing pattern: (B2 _)
      in: case b of (B1 _) => true
  Warning: w.sml 12.3.
    Case is not exhaustive.
      missing pattern: ((A1 _) | (A2 _) | (A4 _) | (A5 _) | (A6 _), _)
                     | ((A3 _), (A1 _) | (A2 _) | (A3 _) | (A4 _) | (A6 _))
      in: case b of (A3 y, A5 z) => (y + z)

In the first warning, there are insufficient parens for the or-pattern
argument to the B1 constructor and extraneous parens around some of
the AX constructors.  It is also curious that the B2 constructor
patterns are given before the B1 constructor patterns.  In the second
warning, there are extraneous parens around the B1 _ pattern.

Now, the following error messages are generated:

  Warning: w.sml 6.3.
    Case is not exhaustive.
      missing pattern: (B1 (A3 _ | A4 _ | A5 _ | A6 _)
                        | B2 (A3 _, (A1 _ | A2 _ | A3 _ | A4 _ | A6 _))
                        | B2 ((A1 _ | A2 _ | A4 _ | A5 _ | A6 _), _))
      in: case b of B1 (A1 (x, _) | A2 x) =  ...   y, A5 z) => (y + z)
  Warning: w.sml 9.3.
    Case is not exhaustive.
      missing pattern: B2 _
      in: case b of B1 _ => true
  Warning: w.sml 12.3.
    Case is not exhaustive.
      missing pattern: ((A3 _, (A1 _ | A2 _ | A3 _ | A4 _ | A6 _))
                        | ((A1 _ | A2 _ | A4 _ | A5 _ | A6 _), _))
      in: case b of (A3 y, A5 z) => (y + z)

The missing pattern examples are now pretty-printed in the same manner
as other patterns.

mlton/ast/ast-core.fun

@@ -128,7 +128,7 @@ structure Pat =
                              seq [str "as ", layoutT pat]])
              | List ps => list (Vector.toListMap (ps, layoutT))
              | Or ps =>
-                  paren (mayAlign (separateLeft (Vector.toListMap (ps, layoutT), "|")))
+                  paren (mayAlign (separateLeft (Vector.toListMap (ps, layoutT), "| ")))
              | Record {items, flexible} =>
                   seq [str "{",
                        mayAlign (separateRight
@@ -477,7 +477,7 @@ and layoutMatch m =
    end
 
 and layoutRule (pat, exp) =
-   mayAlign [seq [Pat.layoutF pat, str " =>"],
+   mayAlign [seq [Pat.layoutT pat, str " =>"],
              layoutExpF exp]
 
 and layoutDec d =

mlton/defunctorize/defunctorize.fun

@@ -314,8 +314,9 @@ fun casee {caseType: Xtype.t,
                      (region,
                       str (concat [#1 kind, " is not exhaustive"]),
                       align [seq [str "missing pattern: ",
-                                  Layout.alignPrefix
-                                     (Vector.toList es, "| ")],
+                                  if 1 = Vector.length es
+                                     then Vector.sub (es, 0)
+                                     else paren (mayAlign (separateLeft (Vector.toListRev es, "| ")))],
                              lay ()])
                end
       fun diagnoseRedundantMatch () =

mlton/match-compile/match-compile.fun

@@ -12,20 +12,39 @@ struct
 
 open S
 
-local
-   open Layout
-in
-   val wild = str "_"
-
-   fun conApp (c, p) =
-      let
-         val c = Con.layout c
-      in
-         case p of
-            NONE => c
-          | SOME p => paren (seq [c, str " ", p])
+structure Example =
+  struct
+     type t = bool -> Layout.t
+
+     fun conApp (c, ex) =
+        fn isDelimited =>
+        let
+           val c = Con.layout c
+        in
+           case ex of
+              NONE => c
+            | SOME ex =>
+                 (if isDelimited then fn x => x else Layout.paren)
+                 (Layout.seq [c, Layout.str " ", ex false])
       end
-end
+
+     fun const c = fn _ => c
+
+     val exnVar = fn _ => Layout.str "e"
+
+     fun or exs = fn isDelimited =>
+        if 1 = Vector.length exs
+           then Vector.sub (exs, 0) isDelimited
+           else Layout.paren
+                (Layout.mayAlign
+                 (Layout.separateLeft
+                  (Vector.toListMap (exs, fn ex => ex true), "| ")))
+
+     fun tuple exs = fn _ =>
+        Layout.tuple (List.map (exs, fn ex => ex true))
+
+     val wild = fn _ => Layout.str "_"
+  end
 
 structure Env = MonoEnv (structure Domain = Var
                          structure Range = Var)
@@ -53,11 +72,11 @@ structure Fact =
 
 structure Examples =
    struct
-      datatype t = T of {es: (Var.t * Layout.t) list,
+      datatype t = T of {es: (Var.t * Example.t) list,
                          isOnlyExns: bool}
 
       fun layout (T {es, ...}) =
-         List.layout (Layout.tuple2 (Var.layout, fn l => l)) es
+         List.layout (Layout.tuple2 (Var.layout, fn l => l true)) es
 
       val empty = T {es = [], isOnlyExns = true}
 
@@ -127,26 +146,26 @@ structure Facts =
                        layout, Var.layout, NestedPat.layout, Env.layout)
          bind
 
-      fun example (T facts, Examples.T {es, ...}, x: Var.t): Layout.t =
+      fun example (T facts, Examples.T {es, ...}, x: Var.t): Example.t =
          let
             val {destroy,
                  get = fact: Var.t -> Fact.t option,
                  set = setFact, ...} =
                Property.destGetSetOnce (Var.plist, Property.initConst NONE)
             val () = List.foreach (facts, fn {fact, var} =>
                                    setFact (var, SOME fact))
-            fun loop (x: Var.t): Layout.t =
+            fun loop (x: Var.t): Example.t =
                case fact x of
                   NONE =>
                      (case List.peek (es, fn (x', _) => Var.equals (x, x')) of
-                         NONE => wild
-                       | SOME (_, l) => l)
+                         NONE => Example.wild
+                       | SOME (_, ex) => ex)
                 | SOME f =>
-                     case f of
-                        Fact.Con {arg, con} =>
-                           conApp (con, Option.map (arg, loop))
-                      | Fact.Tuple xs =>
-                           Layout.tuple (Vector.toListMap (xs, loop))
+                     (case f of
+                         Fact.Con {arg, con} =>
+                            Example.conApp (con, Option.map (arg, loop))
+                       | Fact.Tuple xs =>
+                            Example.tuple (Vector.toListMap (xs, loop)))
             val res = loop x
             val () = destroy ()
          in
@@ -156,7 +175,7 @@ structure Facts =
       val example =
          Trace.trace3 
          ("MatchCompile.Facts.example", 
-          layout, Examples.layout, Var.layout, fn l => l)
+          layout, Examples.layout, Var.layout, fn ex => ex true)
          example
    end
 
@@ -225,7 +244,7 @@ structure Rule =
    struct
       datatype t =
          T of {pats: Pat.t vector,
-               rest: {examples: (Layout.t * {isOnlyExns: bool}) list ref,
+               rest: {examples: (Example.t * {isOnlyExns: bool}) list ref,
                       finish: (Var.t -> Var.t) -> Exp.t,
                       nestedPat: NestedPat.t}}
 
@@ -518,9 +537,10 @@ fun matchCompile {caseType: Type.t,
                let
                   val (e, ioe) =
                      if 0 = Vector.length cases
-                        then (wild, true)
-                     else (layoutConst (unhandledConst
-                                        (Vector.map (cases, #const))),
+                        then (Example.wild, true)
+                     else (Example.const (layoutConst
+                                          (unhandledConst
+                                           (Vector.map (cases, #const)))),
                            false)
                in
                   finish (defaults, e, ioe)
@@ -532,7 +552,9 @@ fun matchCompile {caseType: Type.t,
                   Vector.fold
                   (cases, default (), fn ({const, rules}, rest) =>
                    Exp.iff {test = Exp.equal (test, Exp.const const),
-                            thenn = finish (rules, Const.layout const, true),
+                            thenn = finish (rules,
+                                            Example.const (Const.layout const),
+                                            true),
                             elsee = rest,
                             ty = caseType})
              | SOME {size, ...} =>
@@ -551,7 +573,7 @@ fun matchCompile {caseType: Type.t,
                                   Const.Word w => w
                                 | _ => Error.bug "MatchCompile.const: caseWord type error"
                          in
-                            (w, finish (rules, layoutConst const, true))
+                            (w, finish (rules, Example.const (layoutConst const), true))
                          end)
                   in
                      Exp.casee {cases = Cases.word (size, cases),
@@ -655,9 +677,9 @@ fun matchCompile {caseType: Type.t,
                                           {isOnlyExns = isOnlyExns})))
             val default =
                if Vector.isEmpty cases
-                  then done (wild, true)
+                  then done (Example.wild, true)
                else if Tycon.equals (tycon, Tycon.exn)
-                  then done (Layout.str "e", true)
+                  then done (Example.exnVar, true)
                else
                   let
                      val cons = tyconCons tycon
@@ -672,14 +694,14 @@ fun matchCompile {caseType: Type.t,
                                if Vector.exists (cases, fn {con = con', ...} =>
                                                  Con.equals (con, con'))
                                   then NONE
-                               else SOME (conApp
+                               else SOME (Example.conApp
                                           (con,
-                                           if hasArg then SOME wild else NONE)))
+                                           if hasArg
+                                              then SOME Example.wild
+                                           else NONE)))
                            open Layout
                         in
-                           done
-                           (seq (separate (Vector.toList unhandled, " | ")),
-                            false)
+                           done (Example.or unhandled, false)
                         end
                   end
             fun normal () =
@@ -758,7 +780,10 @@ fun matchCompile {caseType: Type.t,
                 Facts.empty,
                 Examples.empty)
    in
-      (res, fn () => Vector.map (examples, fn r => Vector.fromList (!r)))
+      (res, fn () =>
+       Vector.map (examples, fn r =>
+                   Vector.fromListMap (!r, fn (ex, {isOnlyExns}) =>
+                                       (ex true, {isOnlyExns = isOnlyExns}))))
    end
 
 val matchCompile =

mlton/match-compile/nested-pat.fun

@@ -51,7 +51,7 @@ fun layout (p, isDelimited) =
                                     targs = Vector.map (targs, Type.layout)})
        | Const {const = c, ...} => Const.layout c
        | Layered (x, p) => delimit (seq [Var.layout x, str " as ", layoutT p])
-       | Or ps => paren (mayAlign (separateLeft (Vector.toListMap (ps, layoutT), "|")))
+       | Or ps => paren (mayAlign (separateLeft (Vector.toListMap (ps, layoutT), "| ")))
        | Tuple ps => tuple (Vector.toListMap (ps, layoutT))
        | Var x => Var.layout x
        | Wild => str "_"