From 6db10fdf99d373da676ce842ea25b7ac8d161b5e Mon Sep 17 00:00:00 2001
From: Paul Chiusano <paul.chiusano@gmail.com>
Date: Wed, 29 Jul 2020 09:31:38 -0400
Subject: [PATCH 1/2] Add failing test

---
 unison-src/tests/fix1640.u | 11 +++++++++++
 1 file changed, 11 insertions(+)
 create mode 100644 unison-src/tests/fix1640.u

diff --git a/unison-src/tests/fix1640.u b/unison-src/tests/fix1640.u
new file mode 100644
index 000000000..5676692c8
--- /dev/null
+++ b/unison-src/tests/fix1640.u
@@ -0,0 +1,11 @@
+
+unique type Color = Red | Black
+unique type RBTree a = Leaf | Tree Color (RBTree a) a (RBTree a)
+
+isRed = cases
+  Color.Red -> true
+  Color.Black -> false
+
+RBTree.isRed = cases
+  RBTree.Tree Color.Red _ _ _ -> true
+  _ -> false

From fae001df8098a7a922fec77faf5f69cf5e8c54eb Mon Sep 17 00:00:00 2001
From: Paul Chiusano <paul.chiusano@gmail.com>
Date: Wed, 29 Jul 2020 10:15:06 -0400
Subject: [PATCH 2/2] Fix #1640 and also fix unreported pattern parsing bug and
 add test for it

Issue was actually in the parser. A pattern like `Foo Bar a b c` was being parsed as `Foo (Bar a b c)`. The pattern parser just needed to be factored a bit differently to fix.
---
 parser-typechecker/src/Unison/TermParser.hs | 22 +++++++++++++++------
 unison-src/tests/fix1640.u                  | 14 +++++++++++++
 2 files changed, 30 insertions(+), 6 deletions(-)

diff --git a/parser-typechecker/src/Unison/TermParser.hs b/parser-typechecker/src/Unison/TermParser.hs
index a9169e2e4..2e3cb3834 100644
--- a/parser-typechecker/src/Unison/TermParser.hs
+++ b/parser-typechecker/src/Unison/TermParser.hs
@@ -144,10 +144,10 @@ matchCase = do
   pure . Term.MatchCase p (fmap (absChain boundVars') guard) $ absChain boundVars' t
 
 parsePattern :: forall v. Var v => P v (Pattern Ann, [(Ann, v)])
-parsePattern =
-  chainl1 patternCandidates patternInfixApp
+parsePattern = root
   where
-  patternCandidates = constructor <|> seqLiteral <|> leaf
+  root = chainl1 patternCandidates patternInfixApp
+  patternCandidates = constructor <|> leaf
   patternInfixApp :: P v ((Pattern Ann, [(Ann, v)])
                   -> (Pattern Ann, [(Ann, v)])
                   -> (Pattern Ann, [(Ann, v)]))
@@ -156,7 +156,11 @@ parsePattern =
     f op (l, lvs) (r, rvs) =
       (Pattern.SequenceOp (ann l <> ann r) l op r, lvs ++ rvs)
 
-  leaf = literal <|> varOrAs <|> unbound <|>
+  -- note: nullaryCtor comes before var patterns, since (for better or worse)
+  -- they can overlap (a variable could be called 'Foo' in the current grammar).
+  -- This order treats ambiguous patterns as nullary constructors if there's
+  -- a constructor with a matching name.
+  leaf = literal <|> nullaryCtor <|> varOrAs <|> unbound <|> seqLiteral <|>
          parenthesizedOrTuplePattern <|> effect
   literal = (,[]) <$> asum [true, false, number, text, char]
   true = (\t -> Pattern.Boolean (ann t) True) <$> reserved "true"
@@ -225,15 +229,21 @@ parsePattern =
     end <- closeBlock
     pure (Pattern.setLoc inner (ann start <> ann end), vs)
 
+  -- ex: unique type Day = Mon | Tue | ...
+  nullaryCtor = P.try $ do
+    tok <- ctor UnknownAbilityConstructor
+    let (ref, cid) = L.payload tok
+    pure (Pattern.Constructor (ann tok) ref cid [], [])
+
   constructor = do
     tok <- ctor UnknownDataConstructor
     let (ref,cid) = L.payload tok
         f patterns vs =
           let loc = foldl (<>) (ann tok) $ map ann patterns
           in (Pattern.Constructor loc ref cid patterns, vs)
-    unzipPatterns f <$> many patternCandidates
+    unzipPatterns f <$> many leaf
 
-  seqLiteral = Parser.seq f leaf
+  seqLiteral = Parser.seq f root
     where f loc = unzipPatterns ((,) . Pattern.SequenceLiteral loc)
 
 lam :: Var v => TermP v -> TermP v
diff --git a/unison-src/tests/fix1640.u b/unison-src/tests/fix1640.u
index 5676692c8..1e339c838 100644
--- a/unison-src/tests/fix1640.u
+++ b/unison-src/tests/fix1640.u
@@ -2,10 +2,24 @@
 unique type Color = Red | Black
 unique type RBTree a = Leaf | Tree Color (RBTree a) a (RBTree a)
 
+-- interesting, this typechecks fine
 isRed = cases
   Color.Red -> true
   Color.Black -> false
 
+-- as does this 
+RBTree.isRed1 = cases
+  RBTree.Tree _ _ _ _ -> true
+  _ -> false
+
+-- but this did not (before this fix)
 RBTree.isRed = cases
   RBTree.Tree Color.Red _ _ _ -> true
   _ -> false
+
+-- In fixing this bug, I noticed that the parser would previously reject
+-- this perfectly cromulent pattern match, so I fixed that too.
+thisIsTotallyLegit = cases
+  [RBTree.Tree _ _ _ _] -> true
+  _ -> false
+