Fix name clash in guard clauses (#4358)

purefunctor · web-flow · commit de6809b5308b · 2022-06-30T07:14:17.000-05:00
* Fix name clash in guard clauses

* Minor cleanup, update changelog entry
diff --git a/CHANGELOG.d/fix_4357.md b/CHANGELOG.d/fix_4357.md
@@ -0,0 +1,15 @@
+* Fix name clash in guard clauses introduced in #4293
+
+  As a consequence, a problem with the compiler not being able to see
+  imported names if they're shadowed by a guard binder is also solved.
+  ```purs
+  import Data.Foldable (fold)
+  import Data.Maybe (Maybe(..))
+  import Data.Monoid.Additive (Additive(..))
+
+  test :: Maybe Int -> Int
+  test = case _ of
+    m | Just fold <- m -> fold
+      -- Previously would complain about `fold` being undefined
+      | otherwise -> case fold [] of Additive x -> x
+  ```
diff --git a/CHANGELOG.d/internal_everywhereWithContextOnValuesM.md b/CHANGELOG.d/internal_everywhereWithContextOnValuesM.md
@@ -0,0 +1 @@
+* Add `Guard` handler for the `everywhereWithContextOnValuesM` traversal.
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
@@ -4,8 +4,10 @@
 module Language.PureScript.AST.Traversals where
 
 import Prelude.Compat
+import Protolude (swap)
 
 import Control.Monad
+import Control.Monad.Trans.State
 
 import Data.Foldable (fold)
 import Data.Functor.Identity (runIdentity)
@@ -424,15 +426,17 @@ everywhereWithContextOnValues
   -> (s -> Binder            -> (s, Binder))
   -> (s -> CaseAlternative   -> (s, CaseAlternative))
   -> (s -> DoNotationElement -> (s, DoNotationElement))
+  -> (s -> Guard             -> (s, Guard))
   -> ( Declaration       -> Declaration
      , Expr              -> Expr
      , Binder            -> Binder
      , CaseAlternative   -> CaseAlternative
      , DoNotationElement -> DoNotationElement
+     , Guard             -> Guard
      )
-everywhereWithContextOnValues s f g h i j = (runIdentity . f', runIdentity . g', runIdentity . h', runIdentity . i', runIdentity . j')
+everywhereWithContextOnValues s f g h i j k = (runIdentity . f', runIdentity . g', runIdentity . h', runIdentity . i', runIdentity . j', runIdentity . k')
   where
-  (f', g', h', i', j') = everywhereWithContextOnValuesM s (wrap f) (wrap g) (wrap h) (wrap i) (wrap j)
+  (f', g', h', i', j', k') = everywhereWithContextOnValuesM s (wrap f) (wrap g) (wrap h) (wrap i) (wrap j) (wrap k)
   wrap = ((pure .) .)
 
 everywhereWithContextOnValuesM
@@ -444,13 +448,15 @@ everywhereWithContextOnValuesM
   -> (s -> Binder            -> m (s, Binder))
   -> (s -> CaseAlternative   -> m (s, CaseAlternative))
   -> (s -> DoNotationElement -> m (s, DoNotationElement))
+  -> (s -> Guard             -> m (s, Guard))
   -> ( Declaration       -> m Declaration
      , Expr              -> m Expr
      , Binder            -> m Binder
      , CaseAlternative   -> m CaseAlternative
      , DoNotationElement -> m DoNotationElement
+     , Guard             -> m Guard
      )
-everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)
+everywhereWithContextOnValuesM s0 f g h i j k = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0, k'' s0)
   where
   f'' s = uncurry f' <=< f s
 
@@ -501,7 +507,18 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
 
   i'' s = uncurry i' <=< i s
 
-  i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val
+  i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> traverse (guardedExprM' s) val
+
+  -- A specialized `guardedExprM` that keeps track of the context `s`
+  -- after traversing `guards`, such that it's also exposed to `expr`.
+  guardedExprM' :: s -> GuardedExpr -> m GuardedExpr
+  guardedExprM' s (GuardedExpr guards expr) = do
+    (guards', s') <- runStateT (traverse (StateT . goGuard) guards) s
+    GuardedExpr guards' <$> g'' s' expr
+
+  -- Like k'', but `s` is tracked.
+  goGuard :: Guard -> s -> m (Guard, s)
+  goGuard x s  = k s x >>= fmap swap . sndM' k'
 
   j'' s = uncurry j' <=< j s
 
@@ -510,6 +527,8 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
   j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds
   j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1
 
+  k'' s = uncurry k' <=< k s
+
   k' s (ConditionGuard e) = ConditionGuard <$> g'' s e
   k' s (PatternGuard b e) = PatternGuard <$> h'' s b <*> g'' s e
 
diff --git a/src/Language/PureScript/Linter/Wildcards.hs b/src/Language/PureScript/Linter/Wildcards.hs
@@ -22,7 +22,7 @@ import Language.PureScript.Types
 ignoreWildcardsUnderCompleteTypeSignatures :: Declaration -> Declaration
 ignoreWildcardsUnderCompleteTypeSignatures = onDecl
   where
-  (onDecl, _, _, _, _) = everywhereWithContextOnValues False (,) handleExpr handleBinder (,) (,)
+  (onDecl, _, _, _, _, _) = everywhereWithContextOnValues False (,) handleExpr handleBinder (,) (,) (,)
 
   handleExpr isCovered = \case
     tv@(TypedValue chk v ty)
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
@@ -172,14 +172,15 @@ renameInModule imports (Module modSS coms mn decls exps) =
   Module modSS coms mn <$> parU decls go <*> pure exps
   where
 
-  (go, _, _, _, _) =
+  (go, _, _, _, _, _) =
     everywhereWithContextOnValuesM
       (modSS, M.empty)
       (\(_, bound) d -> (\(bound', d') -> ((declSourceSpan d', bound'), d')) <$> updateDecl bound d)
       updateValue
       updateBinder
       updateCase
       defS
+      updateGuard
 
   updateDecl
     :: M.Map Ident SourcePos
@@ -303,23 +304,25 @@ renameInModule imports (Module modSS coms mn decls exps) =
     :: (SourceSpan, M.Map Ident SourcePos)
     -> CaseAlternative
     -> m ((SourceSpan, M.Map Ident SourcePos), CaseAlternative)
-  updateCase (pos, bound) c@(CaseAlternative bs gs) =
-    return ((pos, updateGuard gs `M.union` rUnionMap binderNamesWithSpans' bs `M.union` bound), c)
+  updateCase (pos, bound) c@(CaseAlternative bs _) =
+    return ((pos, rUnionMap binderNamesWithSpans' bs `M.union` bound), c)
     where
-    updateGuard :: [GuardedExpr] -> M.Map Ident SourcePos
-    updateGuard [] = M.empty
-    updateGuard (GuardedExpr g _ : xs) =
-      updateGuard xs `M.union` rUnionMap updatePatGuard g
-      where
-        updatePatGuard (PatternGuard b _) = binderNamesWithSpans' b
-        updatePatGuard _                  = M.empty
-
     rUnionMap f = foldl' (flip (M.union . f)) M.empty
 
-    binderNamesWithSpans'
-      = M.fromList
-      . fmap (second spanStart . swap)
-      . binderNamesWithSpans
+  updateGuard
+    :: (SourceSpan, M.Map Ident SourcePos)
+    -> Guard
+    -> m ((SourceSpan, M.Map Ident SourcePos), Guard)
+  updateGuard (pos, bound) g@(ConditionGuard _) =
+    return ((pos, bound), g)
+  updateGuard (pos, bound) g@(PatternGuard b _) =
+    return ((pos, binderNamesWithSpans' b `M.union` bound), g)
+
+  binderNamesWithSpans' :: Binder -> M.Map Ident SourcePos
+  binderNamesWithSpans'
+    = M.fromList
+    . fmap (second spanStart . swap)
+    . binderNamesWithSpans
 
   letBoundVariable :: Declaration -> Maybe Ident
   letBoundVariable = fmap valdeclIdent . getValueDeclaration
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
@@ -136,14 +136,15 @@ rebracketFiltered !caller pred_ externs m = do
     Module ss coms mn <$> mapM (usingPredicate pred_ f') ds <*> pure exts
     where
     (goDecl', goExpr', goBinder') = updateTypes goType
-    (f', _, _, _, _) =
+    (f', _, _, _, _, _) =
       everywhereWithContextOnValuesM
         ss
         (\_ d -> (declSourceSpan d,) <$> goDecl' d)
         (\pos -> uncurry goExpr <=< goExpr' pos)
         (\pos -> uncurry goBinder <=< goBinder' pos)
         defS
         defS
+        defS
 
     goExpr :: SourceSpan -> Expr -> m (SourceSpan, Expr)
     goExpr _ e@(PositionedValue pos _ _) = return (pos, e)
@@ -225,14 +226,15 @@ rebracketModule !caller pred_ valueOpTable typeOpTable (Module ss coms mn ds ext
     CalledByDocs -> f
     CalledByCompile -> g <=< f
 
-  (f, _, _, _, _) =
+  (f, _, _, _, _, _) =
       everywhereWithContextOnValuesM
         ss
         (\_ d -> (declSourceSpan d,) <$> goDecl d)
         (\pos -> wrap (matchExprOperators valueOpTable) <=< goExpr' pos)
         (\pos -> wrap (matchBinderOperators valueOpTable) <=< goBinder' pos)
         defS
         defS
+        defS
 
   (g, _, _) = everywhereOnValuesTopDownM pure removeBinaryNoParens pure
 
diff --git a/src/Language/PureScript/Traversals.hs b/src/Language/PureScript/Traversals.hs
@@ -6,6 +6,9 @@ import Prelude.Compat
 sndM :: (Functor f) => (b -> f c) -> (a, b) -> f (a, c)
 sndM f (a, b) = (a, ) <$> f b
 
+sndM' :: (Functor f) => (a -> b -> f c) -> (a, b) -> f (a, c)
+sndM' f (a, b) = (a, ) <$> f a b
+
 thirdM :: (Functor f) => (c -> f d) -> (a, b, c) -> f (a, b, d)
 thirdM f (a, b, c) = (a, b, ) <$> f c
 
diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs
@@ -56,7 +56,7 @@ skolemizeTypesInValue ann ident mbK sko scope =
     runIdentity . onExpr'
   where
     onExpr' :: Expr -> Identity Expr
-    (_, onExpr', _, _, _) = everywhereWithContextOnValuesM [] defS onExpr onBinder defS defS
+    (_, onExpr', _, _, _, _) = everywhereWithContextOnValuesM [] defS onExpr onBinder defS defS defS
 
     onExpr :: [Text] -> Expr -> Identity ([Text], Expr)
     onExpr sco (DeferredDictionary c ts)
diff --git a/tests/purs/passing/4357.purs b/tests/purs/passing/4357.purs
@@ -0,0 +1,29 @@
+module Main where
+
+import Prelude
+
+import Data.Foldable (fold)
+import Data.Maybe (Maybe(..))
+import Data.Monoid.Additive (Additive(..))
+import Effect.Console (log)
+
+data Foo = Foo Int | Bar Int
+
+g :: Foo -> Int
+g  =
+  case _ of
+    a
+        | Bar z <- a
+        -> z
+        | Foo z <- a
+        -> z
+        | otherwise
+        -> 42
+
+-- solved as a consequence of #4358
+test :: Maybe Int -> Int
+test = case _ of
+  m | Just fold <- m -> fold
+    | otherwise -> case fold [] of Additive x -> x
+
+main = log "Done"

Original file line number	Diff line number	Diff line change
`@@ -0,0 +1 @@`
	`1`	+* Add `Guard` handler for the `everywhereWithContextOnValuesM` traversal.