packages feed

purescript 0.15.3 → 0.15.4

raw patch · 8 files changed

+80/−24 lines, 8 files

Files

purescript.cabal view
@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               purescript-version:            0.15.3+version:            0.15.4 license:            BSD-3-Clause license-file:       LICENSE copyright:
src/Language/PureScript/AST/Traversals.hs view
@@ -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 @@   -> (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 @@   -> (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,14 +507,27 @@    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    j' s (DoNotationValue v) = DoNotationValue <$> g'' s v   j' s (DoNotationBind b v) = DoNotationBind <$> h'' s b <*> g'' s v   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
src/Language/PureScript/Linter/Wildcards.hs view
@@ -22,7 +22,7 @@ ignoreWildcardsUnderCompleteTypeSignatures :: Declaration -> Declaration ignoreWildcardsUnderCompleteTypeSignatures = onDecl   where-  (onDecl, _, _, _, _) = everywhereWithContextOnValues False (,) handleExpr handleBinder (,) (,)+  (onDecl, _, _, _, _, _) = everywhereWithContextOnValues False (,) handleExpr handleBinder (,) (,) (,)    handleExpr isCovered = \case     tv@(TypedValue chk v ty)
src/Language/PureScript/Sugar/Names.hs view
@@ -172,7 +172,7 @@   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 @@       updateBinder       updateCase       defS+      updateGuard    updateDecl     :: M.Map Ident SourcePos@@ -303,23 +304,25 @@     :: (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
src/Language/PureScript/Sugar/Operators.hs view
@@ -136,7 +136,7 @@     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 @@         (\pos -> uncurry goBinder <=< goBinder' pos)         defS         defS+        defS      goExpr :: SourceSpan -> Expr -> m (SourceSpan, Expr)     goExpr _ e@(PositionedValue pos _ _) = return (pos, e)@@ -225,12 +226,13 @@     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
src/Language/PureScript/Traversals.hs view
@@ -6,6 +6,9 @@ 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
src/Language/PureScript/TypeChecker/Skolems.hs view
@@ -56,7 +56,7 @@     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)
+ tests/purs/passing/4357.purs view
@@ -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"