From de6809b5308b616bc43b506ae280ed69ada3bc62 Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Thu, 30 Jun 2022 20:14:17 +0800 Subject: [PATCH 1/2] Fix name clash in guard clauses (#4358) * Fix name clash in guard clauses * Minor cleanup, update changelog entry --- CHANGELOG.d/fix_4357.md | 15 +++++++++ ...internal_everywhereWithContextOnValuesM.md | 1 + src/Language/PureScript/AST/Traversals.hs | 27 ++++++++++++--- src/Language/PureScript/Linter/Wildcards.hs | 2 +- src/Language/PureScript/Sugar/Names.hs | 33 ++++++++++--------- src/Language/PureScript/Sugar/Operators.hs | 6 ++-- src/Language/PureScript/Traversals.hs | 3 ++ .../PureScript/TypeChecker/Skolems.hs | 2 +- tests/purs/passing/4357.purs | 29 ++++++++++++++++ 9 files changed, 95 insertions(+), 23 deletions(-) create mode 100644 CHANGELOG.d/fix_4357.md create mode 100644 CHANGELOG.d/internal_everywhereWithContextOnValuesM.md create mode 100644 tests/purs/passing/4357.purs diff --git a/CHANGELOG.d/fix_4357.md b/CHANGELOG.d/fix_4357.md new file mode 100644 index 0000000000..cdd2cae98d --- /dev/null +++ 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 new file mode 100644 index 0000000000..c15c461605 --- /dev/null +++ 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 index 1e76f15766..ee115297ce 100644 --- 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 index 06f1ddf6fb..f224af6860 100644 --- 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 index 288376be60..7b672025a0 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -172,7 +172,7 @@ 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) @@ -180,6 +180,7 @@ renameInModule imports (Module modSS coms mn decls exps) = 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 index dc8fac9b9b..3ce7d0986f 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -136,7 +136,7 @@ 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) @@ -144,6 +144,7 @@ rebracketFiltered !caller pred_ externs m = do (\pos -> uncurry goBinder <=< goBinder' pos) defS defS + defS goExpr :: SourceSpan -> Expr -> m (SourceSpan, Expr) goExpr _ e@(PositionedValue pos _ _) = return (pos, e) @@ -225,7 +226,7 @@ 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) @@ -233,6 +234,7 @@ rebracketModule !caller pred_ valueOpTable typeOpTable (Module ss coms mn ds ext (\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 index 25b426b15a..bdb70c5d83 100644 --- 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 index 89ba0262d8..7a11949331 100644 --- 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 new file mode 100644 index 0000000000..65678d7c48 --- /dev/null +++ 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" From 9870ec72cf74708e1b1cfaf01c23e05168f0d691 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Thu, 30 Jun 2022 15:48:44 -0500 Subject: [PATCH 2/2] Make 0.15.4 release (#4360) * Bump version to 0.15.4 * Update changelog * Trigger CI on 0.15.4-next branch --- .github/workflows/ci.yml | 4 ++-- CHANGELOG.d/fix_4357.md | 15 ------------ ...internal_everywhereWithContextOnValuesM.md | 1 - CHANGELOG.md | 24 +++++++++++++++++++ npm-package/package.json | 4 ++-- purescript.cabal | 2 +- 6 files changed, 29 insertions(+), 21 deletions(-) delete mode 100644 CHANGELOG.d/fix_4357.md delete mode 100644 CHANGELOG.d/internal_everywhereWithContextOnValuesM.md diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 39f611ac5a..ccafe01efa 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -2,9 +2,9 @@ name: "CI" on: push: - branches: [ "master" ] + branches: [ "0.15.4-next" ] pull_request: - branches: [ "master" ] + branches: [ "0.15.4-next" ] release: types: [ "published" ] diff --git a/CHANGELOG.d/fix_4357.md b/CHANGELOG.d/fix_4357.md deleted file mode 100644 index cdd2cae98d..0000000000 --- a/CHANGELOG.d/fix_4357.md +++ /dev/null @@ -1,15 +0,0 @@ -* 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 deleted file mode 100644 index c15c461605..0000000000 --- a/CHANGELOG.d/internal_everywhereWithContextOnValuesM.md +++ /dev/null @@ -1 +0,0 @@ -* Add `Guard` handler for the `everywhereWithContextOnValuesM` traversal. diff --git a/CHANGELOG.md b/CHANGELOG.md index bfd4fddf67..d6f7f5bf9c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,30 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## 0.15.4 + +Bugfixes: + +* Fix name clash in guard clauses introduced in #4293 (#4385 by @PureFunctor) + + 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 + ``` + +Internal: + +* Add `Guard` handler for the `everywhereWithContextOnValuesM` traversal. (#4385 by @PureFunctor) + ## 0.15.3 New features: diff --git a/npm-package/package.json b/npm-package/package.json index caa3e760c4..ce29f45dac 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.15.3", + "version": "0.15.4", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.15.3", + "postinstall": "install-purescript --purs-ver=0.15.4", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index c3eb68cf69..86eeea46cf 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- Note: don't add prerelease identifiers here! Add them in app/Version.hs and npm-package/package.json instead. -version: 0.15.3 +version: 0.15.4 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language