update pretty-printer to use multi-guard syntax and improve tests

parser-typechecker/src/Unison/TermPrinter.hs

@@ -486,6 +486,16 @@ type MatchCase' ann tm = ([Pattern ann], Maybe tm, tm)
 arity1Branches :: [MatchCase ann tm] -> [MatchCase' ann tm]
 arity1Branches bs = [ ([pat], guard, body) | MatchCase pat guard body <- bs ]
 
+groupCases :: Ord v => [MatchCase' () (Term3 v ann)]
+           -> [([Pattern ()], [v], [(Maybe (Term3 v ann), Term3 v ann)])]
+groupCases ms = go0 ms where
+  go0 [] = []
+  go0 ms@((p1, _, AbsN' vs1 _) : _) = go2 (p1,vs1) [] ms
+  go2 (p0,vs0) acc [] = [(p0,vs0,reverse acc)]
+  go2 (p0, vs0) acc ms@((p1, g1, AbsN' vs body) : tl)
+    | p0 == p1 && vs == vs0 = go2 (p0, vs0) ((g1,body):acc) tl
+    | otherwise             = (p0,vs0,reverse acc) : go0 ms
+
 printCase
   :: Var v
   => PrettyPrintEnv
@@ -493,31 +503,46 @@ printCase
   -> DocLiteralContext
   -> [MatchCase' () (Term3 v PrintAnnotation)]
   -> Pretty SyntaxText
-printCase env im doc ms = PP.lines $ map each gridArrowsAligned where
+printCase env im doc ms0 = PP.lines $ map each gridArrowsAligned where
+  ms = groupCases ms0
   each (lhs, arrow, body) = PP.group $ (lhs <> arrow) `PP.hang` body
-  grid = go <$> ms
+  grid = go =<< ms
   gridArrowsAligned = tidy <$> zip (PP.align' (f <$> grid)) grid where
     f (a, b, _) = (a, Just b)
     tidy ((a', b'), (_, _, c)) = (a', b', c)
-  go (pats, guard, (AbsN' vs body)) =
-    (lhs, arrow, (uses [pretty0 env (ac 0 Block im' doc) body]))
+
+  patLhs vs pats = case pats of
+    [pat] -> PP.group (fst (prettyPattern env (ac 0 Block im doc) (-1) vs pat))
+    pats  -> PP.group . PP.sep ("," <> PP.softbreak) . (`evalState` vs) . for pats $ \pat -> do
+      vs <- State.get
+      let (p, rem) = prettyPattern env (ac 0 Block im doc) (-1) vs pat
+      State.put rem
+      pure p
+
+  arrow = fmt S.ControlKeyword "->"
+  goBody im' uses body = uses [pretty0 env (ac 0 Block im' doc) body]
+  printGuard (Just (ABT.AbsN' _ g)) =
+    -- strip off any Abs-chain around the guard, guard variables are rendered
+    -- like any other variable, ex: case Foo x y | x < y -> ...
+    PP.group $ PP.spaced [(fmt S.DelimiterChar " |"), pretty0 env (ac 2 Normal im doc) g]
+  printGuard Nothing  = mempty
+
+  go (pats, vs, [(guard, body)]) =
+    [(lhs, arrow, goBody im' uses body)]
     where
-    lhs = (case pats of
-            [pat] -> PP.group (fst (prettyPattern env (ac 0 Block im doc) (-1) vs pat))
-            pats  -> PP.group . PP.sep ("," <> PP.softbreak) . (`evalState` vs) . for pats $ \pat -> do
-              vs <- State.get
-              let (p, rem) = prettyPattern env (ac 0 Block im doc) (-1) vs pat
-              State.put rem
-              pure p)
-       <> printGuard guard
-    arrow = fmt S.ControlKeyword "->"
-    printGuard (Just g') = let (_, g) = ABT.unabs g' in
-      -- strip off any Abs-chain around the guard, guard variables are rendered
-      -- like any other variable, ex: case Foo x y | x < y -> ...
-      PP.group $ PP.spaced [(fmt S.DelimiterChar " |"), pretty0 env (ac 2 Normal im doc) g]
-    printGuard Nothing  = mempty
+    lhs = patLhs vs pats <> printGuard guard
     (im', uses) = calcImports im body
-  go _ = (l "error", mempty, mempty)
+  go (pats, vs, unzip -> (guards, bodies)) =
+    (patLhs vs pats, mempty, mempty)
+      : zip3 (PP.indentN 2 . printGuard <$> guards)
+             (repeat arrow)
+             (printBody <$> bodies)
+    where
+    printGuard Nothing = (fmt S.DelimiterChar " |") <> fmt S.ControlKeyword " otherwise"
+    printGuard (Just (ABT.AbsN' _ g)) =
+      PP.group $ PP.spaced [(fmt S.DelimiterChar " |"), pretty0 env (ac 2 Normal im doc) g]
+    printBody b = let (im', uses) = calcImports im b
+                  in goBody im' uses b
 
 {- Render a binding, producing output of the form
 
@@ -1069,7 +1094,6 @@ immediateChildBlockTerms = \case
     _ -> []
   where
     doCase (MatchCase _ _ (AbsN' _ body)) = [body]
-    doCase _ = error "bad match" []
     doLet (v, Ann' tm _) = doLet (v, tm)
     doLet (v, LamsNamedOpt' _ body) = if isBlank $ Var.nameStr v
                                       then []

unison-src/tests/pattern-matching.ur

@@ -1 +1 @@
-("byebye", "byebye", 1, 10)
+("byebye", "byebye", 1, 10, 0)

unison-src/transcripts/lambdacase.md

@@ -87,3 +87,22 @@ blorf = cases
 > blah F F
 > blorf T F
 ```
+
+## Patterns with multiple guards
+
+
+```unison
+merge3 : [a] -> [a] -> [a]
+merge3 = cases
+  [], ys -> ys
+  xs, [] -> xs
+  h +: t, h2 +: t2
+    | h <= h2   -> h  +: merge3 t (h2 +: t2)
+    | otherwise -> h2 +: merge3 (h +: t) t2
+```
+
+```ucm
+.> add
+.> view merge3
+```
+

unison-src/transcripts/lambdacase.output.md

@@ -160,3 +160,45 @@ blorf = cases
            F
 
 ```
+## Patterns with multiple guards
+
+
+```unison
+merge3 : [a] -> [a] -> [a]
+merge3 = cases
+  [], ys -> ys
+  xs, [] -> xs
+  h +: t, h2 +: t2
+    | h <= h2   -> h  +: merge3 t (h2 +: t2)
+    | otherwise -> h2 +: merge3 (h +: t) t2
+```
+
+```ucm
+
+  I found and typechecked these definitions in scratch.u. If you
+  do an `add` or `update`, here's how your codebase would
+  change:
+  
+    ⍟ These new definitions are ok to `add`:
+    
+      merge3 : [a] -> [a] -> [a]
+
+```
+```ucm
+.> add
+
+  ⍟ I've added these definitions:
+  
+    merge3 : [a] -> [a] -> [a]
+
+.> view merge3
+
+  merge3 : [a] -> [a] -> [a]
+  merge3 = cases
+    [], ys           -> ys
+    xs, []           -> xs
+    h +: t, h2 +: t2  
+       | h <= h2     -> h +: merge3 t (h2 +: t2)
+       | otherwise   -> h2 +: merge3 (h +: t) t2
+
+```