Make Let-Pattern desugaring less brittle (purescript#3268)

kritzcreek · web-flow · commit 9e42339d4be7 · 2018-03-06T20:03:31.000+01:00
The old code relies on the Parser inserting PositionedValue wrappers in certain places, so that some patterns miss. I wrote this code a while back with @paf31, when we were trying to add SourceSpans to Binders and Exprs.
diff --git a/src/Language/PureScript/Sugar/LetPattern.hs b/src/Language/PureScript/Sugar/LetPattern.hs
@@ -6,37 +6,47 @@ module Language.PureScript.Sugar.LetPattern (desugarLetPatternModule) where
 
 import Prelude.Compat
 
+import Data.List (groupBy, concatMap)
+import Data.Function (on)
+
 import Language.PureScript.AST
+import Language.PureScript.Crash
 
--- |
--- Replace every @BoundValueDeclaration@ in @Let@ expressions with @Case@
+-- | Replace every @BoundValueDeclaration@ in @Let@ expressions with @Case@
 -- expressions.
---
 desugarLetPatternModule :: Module -> Module
 desugarLetPatternModule (Module ss coms mn ds exts) = Module ss coms mn (map desugarLetPattern ds) exts
 
--- |
--- Desugar a single let expression
---
+-- | Desugar a single let expression
 desugarLetPattern :: Declaration -> Declaration
 desugarLetPattern decl =
   let (f, _, _) = everywhereOnValues id replace id
   in f decl
   where
   replace :: Expr -> Expr
-  replace (Let ds e) = go ds e
+  replace (Let ds e) = go (partitionDecls ds) e
   replace other = other
 
-  go :: [Declaration]
+  go :: [Either [Declaration] (SourceAnn, Binder, Expr)]
      -- ^ Declarations to desugar
      -> Expr
      -- ^ The original let-in result expression
      -> Expr
   go [] e = e
-  go (BoundValueDeclaration (pos, com) binder boundE : ds) e =
+  go (Right ((pos, com), binder, boundE) : ds) e =
     PositionedValue pos com $ Case [boundE] [CaseAlternative [binder] [MkUnguarded $ go ds e]]
-  go (d:ds) e = append d $ go ds e
+  go (Left ds:dss) e = Let ds (go dss e)
+
+partitionDecls :: [Declaration] -> [Either [Declaration] (SourceAnn, Binder, Expr)]
+partitionDecls = concatMap f . groupBy ((==) `on` isBoundValueDeclaration)
+  where
+    f ds@(d:_)
+      | isBoundValueDeclaration d = map (Right . g) ds
+    f ds = [Left ds]
+
+    g (BoundValueDeclaration sa binder expr) = (sa, binder, expr)
+    g _ = internalError "partitionDecls: the impossible happened."
 
-  append :: Declaration -> Expr -> Expr
-  append d (Let ds e) = Let (d:ds) e
-  append d e = Let [d] e
+isBoundValueDeclaration :: Declaration -> Bool
+isBoundValueDeclaration BoundValueDeclaration{} = True
+isBoundValueDeclaration _ = False
