polysemy 0.5.1.0 → 0.6.0.0

raw patch · 21 files changed

+349/−367 lines, 21 filesdep +loopbreakerdep +type-errorsPVP ok

version bump matches the API change (PVP)

Dependencies added: loopbreaker, type-errors

API changes (from Hackage documentation)

Files

• ChangeLog.md +14/−0
• polysemy.cabal +18/−3
• src/Polysemy/Async.hs +2/−18
• src/Polysemy/Error.hs +4/−21
• src/Polysemy/IO.hs +31/−1
• src/Polysemy/Internal.hs +4/−24
• src/Polysemy/Internal/Combinators.hs +18/−77
• src/Polysemy/Internal/CustomErrors.hs +80/−70
• src/Polysemy/Internal/CustomErrors/Redefined.hs +73/−0
• src/Polysemy/Internal/Forklift.hs +1/−9
• src/Polysemy/Internal/TH/Common.hs +3/−2
• src/Polysemy/Internal/Tactics.hs +1/−12
• src/Polysemy/Internal/Union.hs +9/−5
• src/Polysemy/Output.hs +26/−16
• src/Polysemy/Reader.hs +1/−5
• src/Polysemy/Resource.hs +7/−32
• src/Polysemy/State.hs +1/−6
• src/Polysemy/Trace.hs +1/−1
• src/Polysemy/Writer.hs +1/−2
• test/OutputSpec.hs +18/−14
• test/TypeErrors.hs +36/−49

@@ -1,5 +1,19 @@ # Changelog for polysemy +## 0.6.0.0 (2019-07-04)++### Breaking Changes++- Changed the type of `runBatchOutput` to be more useful (thanks to @Infinisil)++### Other Changes++- **THE ERROR MESSAGES ARE SO MUCH BETTER** :party: :party: :party:+- Added `runEmbedded` to `Polysemy.IO`+- Added `runOutputAsList` to `Polysemy.Output` (thanks to @googleson78)+- Asymptotically improved the performance of `runTraceAsList` (thanks to+    @googleson78)+ ## 0.5.1.0 (2019-06-28)  - New combinators for `Polysemy.Error`: `fromEither` and `fromEitherM`

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: e2b39ec6e1f466a89ba47a4f54b80b55c0b68a694c2dd08f5c46e0f6ca85437a+-- hash: fd80d4218e2d56a0c2af9f4bd89fc79c0ebce4fe968415430a6009ee91205586  name:           polysemy-version:        0.5.1.0+version:        0.6.0.0 synopsis:       Higher-order, low-boilerplate, zero-cost free monads. description:    Please see the README on GitHub at <https://github.com/isovector/polysemy#readme> category:       Language@@ -47,6 +47,7 @@       Polysemy.Internal       Polysemy.Internal.Combinators       Polysemy.Internal.CustomErrors+      Polysemy.Internal.CustomErrors.Redefined       Polysemy.Internal.Fixpoint       Polysemy.Internal.Forklift       Polysemy.Internal.Kind@@ -80,16 +81,22 @@     , template-haskell >=2.12.0.0 && <3     , th-abstraction >=0.3.1.0 && <0.4     , transformers >=0.5.2.0 && <0.6+    , type-errors >=0.2.0.0     , unagi-chan >=0.4.0.0 && <0.5   if impl(ghc < 8.6)     default-extensions: MonadFailDesugaring TypeInType+  if impl(ghc >= 8.6)+    build-depends:+        loopbreaker >=0.1 && <0.2   if flag(dump-core)-    ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html+    ghc-options: -fplugin=DumpCore -fplugin-opt=DumpCore:core-html     build-depends:         dump-core   if impl(ghc < 8.2.2)     build-depends:         unsupported-ghc-version >1 && <1+  if impl(ghc >= 8.6)+    ghc-options: -fplugin=Loopbreaker   if flag(error-messages)     cpp-options: -DCABAL_SERIOUSLY_CMON_MATE   else@@ -132,9 +139,13 @@     , template-haskell >=2.12.0.0 && <3     , th-abstraction >=0.3.1.0 && <0.4     , transformers >=0.5.2.0 && <0.6+    , type-errors >=0.2.0.0     , unagi-chan >=0.4.0.0 && <0.5   if impl(ghc < 8.6)     default-extensions: MonadFailDesugaring TypeInType+  if impl(ghc >= 8.6)+    build-depends:+        loopbreaker >=0.1 && <0.2   default-language: Haskell2010  benchmark polysemy-bench@@ -160,7 +171,11 @@     , template-haskell >=2.12.0.0 && <3     , th-abstraction >=0.3.1.0 && <0.4     , transformers >=0.5.2.0 && <0.6+    , type-errors >=0.2.0.0     , unagi-chan >=0.4.0.0 && <0.5   if impl(ghc < 8.6)     default-extensions: MonadFailDesugaring TypeInType+  if impl(ghc >= 8.6)+    build-depends:+        loopbreaker >=0.1 && <0.2   default-language: Haskell2010

@@ -50,7 +50,7 @@         Async a -> do           ma  <- runT a           ins <- getInspectorT-          fa  <- sendM $ A.async $ lower $ runAsync_b ma+          fa  <- sendM $ A.async $ lower $ runAsync ma           pureT $ fmap (inspect ins) fa          Await a -> pureT =<< sendM (A.wait a)@@ -58,14 +58,6 @@ {-# INLINE runAsync #-}  -runAsync_b-    :: LastMember (Lift IO) r-    => Sem (Async ': r) a-    -> Sem r a-runAsync_b = runAsync-{-# NOINLINE runAsync_b #-}-- ------------------------------------------------------------------------------ -- | Run an 'Async' effect via in terms of 'A.async'. --@@ -83,18 +75,10 @@         Async a -> do           ma  <- runT a           ins <- getInspectorT-          fa  <- sendM $ A.async $ lower $ runAsyncInIO_b lower ma+          fa  <- sendM $ A.async $ lower $ runAsyncInIO lower ma           pureT $ fmap (inspect ins) fa          Await a -> pureT =<< sendM (A.wait a)     )  m {-# INLINE runAsyncInIO #-}--runAsyncInIO_b-    :: Member (Lift IO) r-    => (forall x. Sem r x -> IO x)-    -> Sem (Async ': r) a-    -> Sem r a-runAsyncInIO_b = runAsyncInIO-{-# NOINLINE runAsyncInIO_b #-} 

@@ -74,29 +74,23 @@   case decomp u of     Left x -> E.ExceptT $ k $       weave (Right ())-            (either (pure . Left) runError_b)+            (either (pure . Left) runError)             hush             x     Right (Yo (Throw e) _ _ _ _) -> E.throwE e     Right (Yo (Catch try handle) s d y _) ->       E.ExceptT $ usingSem k $ do-        ma <- runError_b $ d $ try <$ s+        ma <- runError $ d $ try <$ s         case ma of           Right a -> pure . Right $ y a           Left e -> do-            ma' <- runError_b $ d $ (<$ s) $ handle e+            ma' <- runError $ d $ (<$ s) $ handle e             case ma' of               Left e' -> pure $ Left e'               Right a -> pure . Right $ y a {-# INLINE runError #-} -runError_b-    :: Sem (Error e ': r) a-    -> Sem r (Either e a)-runError_b = runError-{-# NOINLINE runError_b #-} - ------------------------------------------------------------------------------ -- | Transform one 'Error' into another. This function can be used to aggregate -- multiple errors into a single type.@@ -169,19 +163,8 @@     is <- getInitialStateT     t  <- runT try     h  <- bindT handle-    let runIt = lower . runErrorAsExc_b lower+    let runIt = lower . runErrorAsExc lower     sendM $ X.catch (runIt t) $ \(se :: WrappedExc e) ->       runIt $ h $ unwrapExc se <$ is {-# INLINE runErrorAsExc #-}---runErrorAsExc_b-    :: ( Typeable e-       , Member (Lift IO) r-       )-    => (∀ x. Sem r x -> IO x)-    -> Sem (Error e ': r) a-    -> Sem r a-runErrorAsExc_b = runErrorAsExc-{-# NOINLINE runErrorAsExc_b #-} 

@@ -3,10 +3,13 @@ module Polysemy.IO   ( -- * Interpretations     runIO+  , runEmbedded   ) where -import Polysemy import Control.Monad.IO.Class+import Polysemy+import Polysemy.Internal+import Polysemy.Internal.Union   ------------------------------------------------------------------------------@@ -40,4 +43,31 @@     -> Sem r a runIO = interpret $ sendM . liftIO @m . unLift {-# INLINE runIO #-}+++------------------------------------------------------------------------------+-- | Given some @'MonadIO' m@, interpret all @'Lift' m@ actions in that monad+-- at once. This is useful for interpreting effects like databases, which use+-- their own monad for describing actions.+--+-- This function creates a thread, and so should be compiled with @-threaded@.+--+-- TODO(sandy): @since+runEmbedded+    :: ( LastMember (Lift IO) r+       , MonadIO m+       )+    => (forall x. m x -> IO x)  -- ^ The means of running this monad.+    -> Sem (Lift m ': r) a+    -> Sem r a+runEmbedded run_m (Sem m) = withLowerToIO $ \lower _ ->+  run_m $ m $ \u ->+    case decomp u of+      Left x -> liftIO+              . lower+              . liftSem+              $ hoist (runEmbedded run_m) x++      Right (Yo (Lift wd) s _ y _) ->+        fmap y $ fmap (<$ s) wd 

@@ -256,20 +256,15 @@ -- | Introduce an effect into 'Sem'. Analogous to -- 'Control.Monad.Class.Trans.lift' in the mtl ecosystem raise :: ∀ e r a. Sem r a -> Sem (e ': r) a-raise = hoistSem $ hoist raise_b . weaken+raise = hoistSem $ hoist raise . weaken {-# INLINE raise #-}  -raise_b :: Sem r a -> Sem (e ': r) a-raise_b = raise-{-# NOINLINE raise_b #-}-- ------------------------------------------------------------------------------ -- | Like 'raise', but introduces a new effect underneath the head of the -- list. raiseUnder :: ∀ e2 e1 r a. Sem (e1 ': r) a -> Sem (e1 ': e2 ': r) a-raiseUnder = hoistSem $ hoist raiseUnder_b . weakenUnder+raiseUnder = hoistSem $ hoist raiseUnder . weakenUnder   where     weakenUnder :: ∀ m x. Union (e1 ': r) m x -> Union (e1 ': e2 ': r) m x     weakenUnder (Union SZ a) = Union SZ a@@ -278,16 +273,11 @@ {-# INLINE raiseUnder #-}  -raiseUnder_b :: Sem (e1 ': r) a -> Sem (e1 ': e2 ': r) a-raiseUnder_b = raiseUnder-{-# NOINLINE raiseUnder_b #-}-- ------------------------------------------------------------------------------ -- | Like 'raise', but introduces two new effects underneath the head of the -- list. raiseUnder2 :: ∀ e2 e3 e1 r a. Sem (e1 ': r) a -> Sem (e1 ': e2 ': e3 ': r) a-raiseUnder2 = hoistSem $ hoist raiseUnder2_b . weakenUnder2+raiseUnder2 = hoistSem $ hoist raiseUnder2 . weakenUnder2   where     weakenUnder2 ::  ∀ m x. Union (e1 ': r) m x -> Union (e1 ': e2 ': e3 ': r) m x     weakenUnder2 (Union SZ a) = Union SZ a@@ -296,27 +286,17 @@ {-# INLINE raiseUnder2 #-}  -raiseUnder2_b :: Sem (e1 ': r) a -> Sem (e1 ': e2 ': e3 ': r) a-raiseUnder2_b = raiseUnder2-{-# NOINLINE raiseUnder2_b #-}-- ------------------------------------------------------------------------------ -- | Like 'raise', but introduces two new effects underneath the head of the -- list. raiseUnder3 :: ∀ e2 e3 e4 e1 r a. Sem (e1 ': r) a -> Sem (e1 ': e2 ': e3 ': e4 ': r) a-raiseUnder3 = hoistSem $ hoist raiseUnder3_b . weakenUnder3+raiseUnder3 = hoistSem $ hoist raiseUnder3 . weakenUnder3   where     weakenUnder3 ::  ∀ m x. Union (e1 ': r) m x -> Union (e1 ': e2 ': e3 ': e4 ': r) m x     weakenUnder3 (Union SZ a) = Union SZ a     weakenUnder3 (Union (SS n) a) = Union (SS (SS (SS (SS n)))) a     {-# INLINE weakenUnder3 #-} {-# INLINE raiseUnder3 #-}---raiseUnder3_b :: Sem (e1 ': r) a -> Sem (e1 ': e2 ': e3 ': e4 ': r) a-raiseUnder3_b = raiseUnder3-{-# NOINLINE raiseUnder3_b #-}   ------------------------------------------------------------------------------

@@ -48,7 +48,7 @@ -- | The simplest way to produce an effect handler. Interprets an effect @e@ by -- transforming it into other effects inside of @r@. interpret-    :: FirstOrder m0 e "interpret"+    :: FirstOrder e "interpret"     => (∀ x m. e m x -> Sem r x)        -- ^ A natural transformation from the handled effect to other effects        -- already in 'Sem'.@@ -72,12 +72,13 @@     -> Sem r a interpretH f (Sem m) = m $ \u ->   case decomp u of-    Left  x -> liftSem $ hoist (interpretH_b f) x+    Left  x -> liftSem $ hoist (interpretH f) x     Right (Yo e s d y v) -> do       a <- runTactics s d v $ f e       pure $ y a {-# INLINE interpretH #-} + ------------------------------------------------------------------------------ -- | A highly-performant combinator for interpreting an effect statefully. See -- 'stateful' for a more user-friendly variety of this function.@@ -92,13 +93,14 @@         Left x -> S.StateT $ \s' ->           k . fmap swap             . weave (s', ())-                    (uncurry $ interpretInStateT_b f)+                    (uncurry $ interpretInStateT f)                     (Just . snd)             $ x         Right (Yo e z _ y _) ->           fmap (y . (<$ z)) $ S.mapStateT (usingSem k) $ f e {-# INLINE interpretInStateT #-} + ------------------------------------------------------------------------------ -- | A highly-performant combinator for interpreting an effect statefully. See -- 'stateful' for a more user-friendly variety of this function.@@ -113,13 +115,14 @@         Left x -> LS.StateT $ \s' ->           k . fmap swap             . weave (s', ())-                    (uncurry $ interpretInLazyStateT_b f)+                    (uncurry $ interpretInLazyStateT f)                     (Just . snd)             $ x         Right (Yo e z _ y _) ->           fmap (y . (<$ z)) $ LS.mapStateT (usingSem k) $ f e {-# INLINE interpretInLazyStateT #-} + ------------------------------------------------------------------------------ -- | Like 'interpret', but with access to an intermediate state @s@. stateful@@ -154,7 +157,7 @@     -> Sem (e2 ': r) a reinterpretH f (Sem m) = Sem $ \k -> m $ \u ->   case decompCoerce u of-    Left x  -> k $ hoist (reinterpretH_b f) $ x+    Left x  -> k $ hoist (reinterpretH f) $ x     Right (Yo e s d y v) -> do       a <- usingSem k $ runTactics s (raiseUnder . d) v $ f e       pure $ y a@@ -168,8 +171,8 @@ -- 'Polysemy.State.runState', meaning it's free to 'reinterpret' in terms of -- the 'Polysemy.State.State' effect and immediately run it. reinterpret-    :: forall e1 e2 m0 r a-     . FirstOrder m0 e1 "reinterpret"+    :: forall e1 e2 r a+     . FirstOrder e1 "reinterpret"     => (∀ m x. e1 m x -> Sem (e2 ': r) x)        -- ^ A natural transformation from the handled effect to the new effect.     -> Sem (e1 ': r) a@@ -191,7 +194,7 @@     -> Sem (e2 ': e3 ': r) a reinterpret2H f (Sem m) = Sem $ \k -> m $ \u ->   case decompCoerce u of-    Left x  -> k $ weaken $ hoist (reinterpret2H_b f) $ x+    Left x  -> k $ weaken $ hoist (reinterpret2H f) $ x     Right (Yo e s d y v) -> do       a <- usingSem k $ runTactics s (raiseUnder2 . d) v $ f e       pure $ y a@@ -201,8 +204,8 @@ ------------------------------------------------------------------------------ -- | Like 'reinterpret', but introduces /two/ intermediary effects. reinterpret2-    :: forall e1 e2 e3 m0 r a-     . FirstOrder m0 e1 "reinterpret2"+    :: forall e1 e2 e3 r a+     . FirstOrder e1 "reinterpret2"     => (∀ m x. e1 m x -> Sem (e2 ': e3 ': r) x)        -- ^ A natural transformation from the handled effect to the new effects.     -> Sem (e1 ': r) a@@ -223,7 +226,7 @@     -> Sem (e2 ': e3 ': e4 ': r) a reinterpret3H f (Sem m) = Sem $ \k -> m $ \u ->   case decompCoerce u of-    Left x  -> k . weaken . weaken . hoist (reinterpret3H_b f) $ x+    Left x  -> k . weaken . weaken . hoist (reinterpret3H f) $ x     Right (Yo e s d y v) -> do       a <- usingSem k $ runTactics s (raiseUnder3 . d) v $ f e       pure $ y a@@ -233,8 +236,8 @@ ------------------------------------------------------------------------------ -- | Like 'reinterpret', but introduces /three/ intermediary effects. reinterpret3-    :: forall e1 e2 e3 e4 m0 r a-     . FirstOrder m0 e1 "reinterpret3"+    :: forall e1 e2 e3 e4 r a+     . FirstOrder e1 "reinterpret3"     => (∀ m x. e1 m x -> Sem (e2 ': e3 ': e4 ': r) x)        -- ^ A natural transformation from the handled effect to the new effects.     -> Sem (e1 ': r) a@@ -249,7 +252,7 @@ -- intercept other effects and insert logic around them. intercept     :: ( Member e r-       , FirstOrder m0 e "intercept"+       , FirstOrder e "intercept"        )     => (∀ x m. e m x -> Sem r x)        -- ^ A natural transformation from the handled effect to other effects@@ -277,67 +280,5 @@   case prj u of     Just (Yo e s d y v) ->       usingSem k $ fmap y $ runTactics s (raise . d) v $ f e-    Nothing -> k $ hoist (interceptH_b f) u+    Nothing -> k $ hoist (interceptH f) u {-# INLINE interceptH #-}------------------------------------------------------------------------------------ Loop breakers-interpretH_b-    :: (∀ x m . e m x -> Tactical e m r x)-    -> Sem (e ': r) a-    -> Sem r a-interpretH_b = interpretH-{-# NOINLINE interpretH_b #-}---interceptH_b-    :: Member e r-    => (∀ x m. e m x -> Tactical e m r x)-    -> Sem r a-    -> Sem r a-interceptH_b = interceptH-{-# NOINLINE interceptH_b #-}---interpretInStateT_b-    :: (∀ x m. e m x -> S.StateT s (Sem r) x)-    -> s-    -> Sem (e ': r) a-    -> Sem r (s, a)-interpretInStateT_b = interpretInStateT-{-# NOINLINE interpretInStateT_b #-}---interpretInLazyStateT_b-    :: (∀ x m. e m x -> LS.StateT s (Sem r) x)-    -> s-    -> Sem (e ': r) a-    -> Sem r (s, a)-interpretInLazyStateT_b = interpretInLazyStateT-{-# NOINLINE interpretInLazyStateT_b #-}---reinterpretH_b-    :: (∀ m x. e1 m x -> Tactical e1 m (e2 ': r) x)-    -> Sem (e1 ': r) a-    -> Sem (e2 ': r) a-reinterpretH_b = reinterpretH-{-# NOINLINE reinterpretH_b #-}---reinterpret2H_b-    :: (∀ m x. e1 m x -> Tactical e1 m (e2 ': e3 ': r) x)-    -> Sem (e1 ': r) a-    -> Sem (e2 ': e3 ': r) a-reinterpret2H_b = reinterpret2H-{-# NOINLINE reinterpret2H_b #-}---reinterpret3H_b-    :: (∀ m x. e1 m x -> Tactical e1 m (e2 ': e3 ': e4 ': r) x)-    -> Sem (e1 ': r) a-    -> Sem (e2 ': e3 ': e4 ': r) a-reinterpret3H_b = reinterpret3H-{-# NOINLINE reinterpret3H_b #-}-

@@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes  #-} {-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE TemplateHaskell      #-} {-# LANGUAGE TypeFamilies         #-} {-# LANGUAGE UndecidableInstances #-} @@ -7,20 +8,27 @@  module Polysemy.Internal.CustomErrors   ( AmbiguousSend-  , Break+  , WhenStuck   , FirstOrder   , UnhandledEffect   , DefiningModule   , DefiningModuleForEffect   ) where -import Data.Coerce import Data.Kind import Fcf import GHC.TypeLits import Polysemy.Internal.Kind+import Polysemy.Internal.CustomErrors.Redefined+import Type.Errors hiding (IfStuck, WhenStuck, UnlessStuck)  +------------------------------------------------------------------------------+-- | The module this effect was originally defined in. This type family is used+-- only for providing better error messages.+--+-- Calls to 'Polysemy.Internal.TH.Effect.makeSem' will automatically give+-- instances of 'DefiningModule'. type family DefiningModule (t :: k) :: Symbol  type family DefiningModuleForEffect (e :: k) :: Symbol where@@ -28,20 +36,38 @@   DefiningModuleForEffect e     = DefiningModule e  -data T1 m a+-- TODO(sandy): Put in type-errors+type ShowTypeBracketed t = 'Text "("+                     ':<>: 'ShowType t+                     ':<>: 'Text ")" -type family Break (c :: Constraint)-                  (rep :: Effect) :: Constraint where-  Break _ T1 = ((), ())-  Break _ c  = () +------------------------------------------------------------------------------+-- | The constructor of the effect row --- it's either completely polymorphic,+-- a nil, or a cons.+data EffectRowCtor = TyVarR | NilR | ConsR -type family IfStuck (tyvar :: k) (b :: k1) (c :: Exp k1) :: k1 where-  IfStuck T1 b c = b-  IfStuck a  b c = Eval c +------------------------------------------------------------------------------+-- | Given that @r@ isn't stuck, determine which constructor it has.+type family UnstuckRState (r :: EffectRow) :: EffectRowCtor where+  UnstuckRState '[]      = 'NilR+  UnstuckRState (_ ': _) = 'ConsR -type AmbigousEffectMessage r e t vs =++------------------------------------------------------------------------------+-- | Put brackets around @r@ if it's a cons.+type family ShowRQuoted (rstate :: EffectRowCtor) (r :: EffectRow) :: ErrorMessage where+  ShowRQuoted 'TyVarR r = 'ShowType r+  ShowRQuoted 'NilR   r = 'ShowType r+  ShowRQuoted 'ConsR  r = ShowTypeBracketed r+++type AmbigousEffectMessage (rstate :: EffectRowCtor)+                           (r :: EffectRow)+                           (e :: k)+                           (t :: Effect)+                           (vs :: [Type]) =         ( 'Text "Ambiguous use of effect '"     ':<>: 'ShowType e     ':<>: 'Text "'"@@ -49,51 +75,45 @@     ':$$: 'Text "  add (Member ("     ':<>: 'ShowType t     ':<>: 'Text ") "-    ':<>: 'ShowType r+    ':<>: ShowRQuoted rstate r     ':<>: 'Text ") to the context of "     ':$$: 'Text "    the type signature"     ':$$: 'Text "If you already have the constraint you want, instead"     ':$$: 'Text "  add a type application to specify"     ':$$: 'Text "    "-    ':<>: PrettyPrint vs+    ':<>: PrettyPrintList vs     ':<>: 'Text " directly, or activate polysemy-plugin which"     ':$$: 'Text "      can usually infer the type correctly."         ) -type family PrettyPrint (vs :: [k]) where-  PrettyPrint '[a] =-    'Text "'" ':<>: 'ShowType a ':<>: 'Text "'"-  PrettyPrint '[a, b] =-    'Text "'" ':<>: 'ShowType a ':<>: 'Text "', and "-    ':<>:-    'Text "'" ':<>: 'ShowType b ':<>: 'Text "'"-  PrettyPrint (a ': vs) =-    'Text "'" ':<>: 'ShowType a ':<>: 'Text "', "-    ':<>: PrettyPrint vs+type AmbiguousSend r e =+      (IfStuck r+        (AmbiguousSendError 'TyVarR r e)+        (Pure (AmbiguousSendError (UnstuckRState r) r e)))  -type family AmbiguousSend r e where-  AmbiguousSend r (e a b c d f) =-    TypeError (AmbigousEffectMessage r e (e a b c d f) '[a, b c d f])+type family AmbiguousSendError rstate r e where+  AmbiguousSendError rstate r (e a b c d f) =+    TypeError (AmbigousEffectMessage rstate r e (e a b c d f) '[a, b c d f]) -  AmbiguousSend r (e a b c d) =-    TypeError (AmbigousEffectMessage r e (e a b c d) '[a, b c d])+  AmbiguousSendError rstate r (e a b c d) =+    TypeError (AmbigousEffectMessage rstate r e (e a b c d) '[a, b c d]) -  AmbiguousSend r (e a b c) =-    TypeError (AmbigousEffectMessage r e (e a b c) '[a, b c])+  AmbiguousSendError rstate r (e a b c) =+    TypeError (AmbigousEffectMessage rstate r e (e a b c) '[a, b c]) -  AmbiguousSend r (e a b) =-    TypeError (AmbigousEffectMessage r e (e a b) '[a, b])+  AmbiguousSendError rstate r (e a b) =+    TypeError (AmbigousEffectMessage rstate r e (e a b) '[a, b]) -  AmbiguousSend r (e a) =-    TypeError (AmbigousEffectMessage r e (e a) '[a])+  AmbiguousSendError rstate r (e a) =+    TypeError (AmbigousEffectMessage rstate r e (e a) '[a]) -  AmbiguousSend r e =+  AmbiguousSendError rstate r e =     TypeError         ( 'Text "Could not deduce: (Member "     ':<>: 'ShowType e     ':<>: 'Text " "-    ':<>: 'ShowType r+    ':<>: ShowRQuoted rstate r     ':<>: 'Text ") "     ':$$: 'Text "Fix:"     ':$$: 'Text "  add (Member "@@ -105,37 +125,26 @@         )  ----type family FirstOrderError e (fn :: Symbol) :: k where-  FirstOrderError e fn =-    TypeError ( 'Text "'"-          ':<>: 'ShowType e-          ':<>: 'Text "' is higher-order, but '"-          ':<>: 'Text fn-          ':<>: 'Text "' can help only"-          ':$$: 'Text "with first-order effects."-          ':$$: 'Text "Fix:"-          ':$$: 'Text "  use '"-          ':<>: 'Text fn-          ':<>: 'Text "H' instead."-              )+data FirstOrderErrorFcf :: k -> Symbol -> Exp Constraint+type instance Eval (FirstOrderErrorFcf e fn) = $(te[t|+    UnlessPhantom+        (e PHANTOM)+        ( 'Text "'"+    ':<>: 'ShowType e+    ':<>: 'Text "' is higher-order, but '"+    ':<>: 'Text fn+    ':<>: 'Text "' can help only"+    ':$$: 'Text "with first-order effects."+    ':$$: 'Text "Fix:"+    ':$$: 'Text "  use '"+    ':<>: 'Text fn+    ':<>: 'Text "H' instead."+        ) |])  ------------------------------------------------------------------------------ -- | This constraint gives helpful error messages if you attempt to use a -- first-order combinator with a higher-order type.------ Note that the parameter 'm' is only required to work around supporting--- versions of GHC without QuantifiedConstraints-type FirstOrder m e fn = IfStuck e (() :: Constraint) (FirstOrderFcf m e fn)--data FirstOrderFcf-    :: (Type -> Type)-    -> Effect-    -> Symbol-    -> Exp Constraint-type instance Eval (FirstOrderFcf m e fn) = Coercible (e m) (e (FirstOrderError e fn))+type FirstOrder (e :: Effect) fn = UnlessStuck e (FirstOrderErrorFcf e fn)   ------------------------------------------------------------------------------@@ -155,12 +164,13 @@   ':<>: 'Text (DefiningModuleForEffect e)   ':<>: 'Text "'" -type family BreakSym (z :: k -> k) e (c :: Constraint)-                       (rep :: Symbol) :: k where-  BreakSym _ e _ "" =  TypeError (UnhandledEffectMsg e ':$$: CheckDocumentation e)-  BreakSym z e _ c  = z (TypeError (UnhandledEffectMsg e ':$$: CheckDocumentation e))+type family UnhandledEffect e where+  UnhandledEffect e =+    IfStuck (DefiningModule e)+            (TypeError (UnhandledEffectMsg e))+            (DoError (UnhandledEffectMsg e ':$$: CheckDocumentation e)) -type family UnhandledEffect z e where-  UnhandledEffect z e =-    BreakSym z e (TypeError (UnhandledEffectMsg e)) (DefiningModuleForEffect e)++data DoError :: ErrorMessage -> Exp k+type instance Eval (DoError a) = TypeError a 

@@ -0,0 +1,73 @@+{-# LANGUAGE ConstraintKinds #-}++------------------------------------------------------------------------------+-- | This code is copied verbatim from 'Type.Errors' due to limitations in the+-- (GHC 8.6) plugin machinery. See+-- <https://github.com/polysemy-research/polysemy/issues/152 #152> for more+-- info.+module Polysemy.Internal.CustomErrors.Redefined where++import Type.Errors hiding (IfStuck, WhenStuck, UnlessStuck)+++------------------------------------------------------------------------------+-- | @'IfStuck' expr b c@ leaves @b@ in the residual constraints whenever+-- @expr@ is stuck, otherwise it 'Eval'uates @c@.+type family IfStuck (expr :: k) (b :: k1) (c :: Exp k1) :: k1 where+  -- The type pattern @_ Foo@ is interpretered by the compiler as being of+  -- any kind. This is great and exactly what we want here, except that things+  -- like @forall s. Maybe s@ will get stuck on it.+  --+  -- So instead, we just propagate out 100 of these type variables and assume+  -- that 100 type variables ought to be enough for anyone.+  IfStuck (_ AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind+             AnythingOfAnyKind) b c = b+  IfStuck a                     b c = Eval c++data AnythingOfAnyKind+++------------------------------------------------------------------------------+-- | Like 'IfStuck', but specialized to the case when you don't want to do+-- anything if @expr@ isn't stuck.+type WhenStuck expr b   = IfStuck expr b NoErrorFcf+++------------------------------------------------------------------------------+-- | Like 'IfStuck', but leaves no residual constraint when @expr@ is stuck.+-- This can be used to ensure an expression /isn't/ stuck before analyzing it+-- further.+type UnlessStuck expr c = IfStuck expr NoError c+

@@ -40,17 +40,9 @@       mvar <- newEmptyMVar       writeChan chan $ Forklift mvar x       takeMVar mvar-    Right y -> k $ hoist (runViaForklift_b chan) y+    Right y -> k $ hoist (runViaForklift chan) y {-# INLINE runViaForklift #-} --runViaForklift_b-    :: LastMember (Lift IO) r-    => InChan (Forklift r)-    -> Sem r a-    -> Sem '[Lift IO] a-runViaForklift_b = runViaForklift-{-# NOINLINE runViaForklift_b #-}   ------------------------------------------------------------------------------

@@ -31,7 +31,8 @@ import           Language.Haskell.TH import           Language.Haskell.TH.Datatype import           Language.Haskell.TH.PprLib-import           Polysemy.Internal (Sem, Member, send)+import           Polysemy.Internal (Sem, send)+import           Polysemy.Internal.Union (MemberWithError)  #if __GLASGOW_HASKELL__ >= 804 import           Prelude hiding ((<>))@@ -66,7 +67,7 @@ -- | @'makeMemberConstraint'' r type@ will produce a @Member type r@ -- constraint. makeMemberConstraint' :: Name -> Type -> Pred-makeMemberConstraint' r eff = classPred ''Member [eff, VarT r]+makeMemberConstraint' r eff = classPred ''MemberWithError [eff, VarT r]   ------------------------------------------------------------------------------

@@ -191,7 +191,7 @@    -> Sem r a runTactics s d v (Sem m) = m $ \u ->   case decomp u of-    Left x -> liftSem $ hoist (runTactics_b s d v) x+    Left x -> liftSem $ hoist (runTactics s d v) x     Right (Yo GetInitialState s' _ y _) ->       pure $ y $ s <$ s'     Right (Yo (HoistInterpretation na) s' _ y _) -> do@@ -199,15 +199,4 @@     Right (Yo GetInspector s' _ y _) -> do       pure $ y $ Inspector v <$ s' {-# INLINE runTactics #-}---runTactics_b-   :: Functor f-   => f ()-   -> (∀ x. f (m x) -> Sem r2 (f x))-   -> (∀ x. f x -> Maybe x)-   -> Sem (Tactics f m r2 ': r) a-   -> Sem r a-runTactics_b = runTactics-{-# NOINLINE runTactics_b #-} 

@@ -15,6 +15,7 @@   ( Union (..)   , Yo (..)   , Member+  , MemberWithError   , weave   , hoist   -- * Building Unions@@ -106,12 +107,16 @@ ------------------------------------------------------------------------------ -- | A proof that the effect @e@ is available somewhere inside of the effect -- stack @r@.-type Member e r = Member' e r+type Member e r = MemberNoError e r -type Member' e r =+type MemberWithError e r =   ( MemberNoError e r #ifndef NO_ERROR_MESSAGES-  , Break (AmbiguousSend r e) (IndexOf r (Found r e))+    -- NOTE: The plugin explicitly pattern matches on+    -- `WhenStuck (IndexOf r _) _`, so if you change this, make sure to change+    -- the corresponding implementation in+    -- Polysemy.Plugin.Fundep.solveBogusError+  , WhenStuck (IndexOf r (Found r e)) (AmbiguousSend r e) #endif   ) @@ -150,7 +155,7 @@  type family Found (ts :: [k]) (t :: k) :: Nat where #ifndef NO_ERROR_MESSAGES-  Found '[]       t = UnhandledEffect 'S t+  Found '[]       t = UnhandledEffect t #endif   Found (t ': ts) t = 'Z   Found (u ': ts) t = 'S (Found ts t)@@ -258,4 +263,3 @@  instance LastMember end '[end] where   decompLast = Right-

@@ -8,13 +8,16 @@   , output      -- * Interpretations+  , runOutputAsList   , runFoldMapOutput   , runIgnoringOutput   , runBatchOutput   ) where +import Data.Bifunctor (first) import Polysemy import Polysemy.State+import Control.Monad (when)   ------------------------------------------------------------------------------@@ -27,6 +30,18 @@   ------------------------------------------------------------------------------+-- | Run an 'Output' effect by transforming it into a list of its values.+runOutputAsList+    :: forall o r a+     . Sem (Output o ': r) a+    -> Sem r ([o], a)+runOutputAsList = fmap (first reverse) . runState [] . reinterpret+  (\case+      Output o -> modify (o :)+  )+{-# INLINE runOutputAsList #-}++------------------------------------------------------------------------------ -- | Run an 'Output' effect by transforming it into a monoid. runFoldMapOutput     :: forall o m r a@@ -60,27 +75,22 @@ runBatchOutput     :: forall o r a      . Int+    -> Sem (Output o ': r) a     -> Sem (Output [o] ': r) a-    -> Sem (Output [[o]] ': r) a runBatchOutput 0 m = raise $ runIgnoringOutput m runBatchOutput size m = do-  ((_, res), a) <-+  ((c, res), a) <-     runState (0 :: Int, [] :: [o]) $ reinterpret2 (\case       Output o -> do-        (nacc, acc) <- get-        let no     = length o-            total  = mappend acc o-            ntotal = nacc + no--            emitting n ls-              | n >= size = do-                  let (emit, acc') = splitAt size ls-                  output [emit]-                  emitting (n - size) acc'-              | otherwise = pure (n, ls)-        (nacc', acc') <- emitting ntotal total-        put (nacc', acc')+        (count, acc) <- get+        let newCount = 1 + count+            newAcc = o : acc+        if newCount < size+          then put (newCount, newAcc)+          else do+            output (reverse newAcc)+            put (0 :: Int, [] :: [o])     ) m-  output [res]+  when (c > 0) $ output (reverse res)   pure a 

@@ -41,12 +41,8 @@   Ask -> pureT i   Local f m -> do     mm <- runT m-    raise $ runReader_b (f i) mm+    raise $ runReader (f i) mm {-# INLINE runReader #-}--runReader_b :: i -> Sem (Reader i ': r) a -> Sem r a-runReader_b = runReader-{-# NOINLINE runReader_b #-}   ------------------------------------------------------------------------------

@@ -94,7 +94,7 @@     u <- bindT use      let run_it :: Sem (Resource ': r) x -> IO x-        run_it = finish .@ runResourceInIO_b+        run_it = finish .@ runResourceInIO      sendM $ X.bracket (run_it a) (run_it . d) (run_it . u) @@ -104,9 +104,10 @@     u <- bindT use      let run_it :: Sem (Resource ': r) x -> IO x-        run_it = finish .@ runResourceInIO_b+        run_it = finish .@ runResourceInIO      sendM $ X.bracketOnError (run_it a) (run_it . d) (run_it . u)+{-# INLINE runResourceInIO #-}   ------------------------------------------------------------------------------@@ -123,7 +124,7 @@     d <- bindT dealloc     u <- bindT use -    let run_it = raise . runResource_b+    let run_it = raise . runResource     resource <- run_it a     result <- run_it $ u resource     _ <- run_it $ d resource@@ -134,7 +135,7 @@     d <- bindT dealloc     u <- bindT use -    let run_it = raise . runResource_b+    let run_it = raise . runResource      resource <- run_it a     result <- run_it $ u resource@@ -178,7 +179,7 @@      withLowerToIO $ \lower finish -> do       let done :: Sem (Resource ': r) x -> IO x-          done = lower . raise . runResourceBase_b+          done = lower . raise . runResourceBase       X.bracket           (done ma)           (\x -> done (mb x) >> finish)@@ -191,35 +192,9 @@      withLowerToIO $ \lower finish -> do       let done :: Sem (Resource ': r) x -> IO x-          done = lower . raise . runResourceBase_b+          done = lower . raise . runResourceBase       X.bracketOnError           (done ma)           (\x -> done (mb x) >> finish)           (done . mc) {-# INLINE runResourceBase #-}---runResource_b-    :: ∀ r a-     . Sem (Resource ': r) a-    -> Sem r a-runResource_b = runResource-{-# NOINLINE runResource_b #-}--runResourceInIO_b-    :: ∀ r a-     . Member (Lift IO) r-    => (∀ x. Sem r x -> IO x)-    -> Sem (Resource ': r) a-    -> Sem r a-runResourceInIO_b = runResourceInIO-{-# NOINLINE runResourceInIO_b #-}--runResourceBase_b-    :: forall r a-     . LastMember (Lift IO) r-    => Sem (Resource ': r) a-    -> Sem r a-runResourceBase_b = runResourceBase-{-# NOINLINE runResourceBase_b #-}-

@@ -105,15 +105,10 @@                       (\(s', m') -> fmap swap                                   $ S.runStateT m' s')                       (Just . snd)-              $ hoist hoistStateIntoStateT_b x+              $ hoist hoistStateIntoStateT x     Right (Yo Get z _ y _)     -> fmap (y . (<$ z)) $ S.get     Right (Yo (Put s) z _ y _) -> fmap (y . (<$ z)) $ S.put s {-# INLINE hoistStateIntoStateT #-}---hoistStateIntoStateT_b :: Sem (State s ': r) a -> S.StateT s (Sem r) a-hoistStateIntoStateT_b = hoistStateIntoStateT-{-# NOINLINE hoistStateIntoStateT_b #-}   {-# RULES "runState/reinterpret"

@@ -63,7 +63,7 @@ runTraceAsList     :: Sem (Trace ': r) a     -> Sem r ([String], a)-runTraceAsList = runFoldMapOutput @String (: []) . reinterpret (+runTraceAsList = runOutputAsList . reinterpret (   \case     Trace m -> output m   )

@@ -53,7 +53,7 @@         modify (`mappend` o) >>= pureT       Listen m -> do         mm <- runT m-        -- TODO(sandy): this is fucking stupid+        -- TODO(sandy): this is stupid         (o, fa) <- raise $ runWriter mm         pure $ fmap (o, ) fa       Censor f m -> do@@ -62,4 +62,3 @@         modify (`mappend` f o)         pure a   )-

@@ -10,23 +10,27 @@ spec = parallel $ do   describe "runBatchOutput" $ do     it "should return nothing at batch size 0" $ do-      let (ms, ()) = runOutput 0 $ output @[Int] [0..100]+      let (ms, _) = runOutput 0 $ traverse (output @Int) [0..99]       length ms `shouldBe` 0 -    for_ (1 : [5..13] ++ [99..101]) $ \size -> do-      it ("should batch at size " ++ show size) $ do-          let (ms, ()) = runOutput size $ do-                output @[Int] [0]-                output @[Int] [1..4]-                output @[Int] [5..10]-                output @[Int] [11..12]-                output @[Int] [13..37]-                output @[Int] [38..99]-          length ms `shouldBe` (div 100 size + 1)-          length (head ms) `shouldBe` min size 100+    for_ (1 : [5..13] ++ [99..101]) $ \size ->+      context ("Works at size " ++ show size) $ do+        let (ms, _) = runOutput size $ traverse (output @Int) [0..99]+        it "returns the correct amount of batches" $+          length ms `shouldBe` div (100 + size - 1) size -- 100 `div` size but rounding up+        it "all batches except the last one are of the specified size" $+          map length (init ms) `shouldBe` replicate (length ms - 1) size+        it "returns all original elements in the correct order" $           concat ms `shouldBe` [0..99] +  describe "runOutputAsList" $+    it "should return elements in the order they were output" $+      let (xs, ()) = runOutputAsList' $ traverse_ (output @Int) [0..100]+       in xs `shouldBe` [0..100] -runOutput :: Int -> Sem '[Output [Int]] a -> ([[Int]], a)-runOutput size = run . runFoldMapOutput id . runBatchOutput size +runOutput :: Int -> Sem '[Output Int] a -> ([[Int]], a)+runOutput size = run . runFoldMapOutput (:[]) . runBatchOutput size++runOutputAsList' :: Sem '[Output Int] a -> ([Int], a)+runOutputAsList' = run . runOutputAsList

@@ -10,6 +10,7 @@ -- >>> :m +Polysemy.Resource -- >>> :m +Polysemy.State -- >>> :m +Polysemy.Trace+-- >>> :m +Data.Maybe   --------------------------------------------------------------------------------@@ -44,14 +45,12 @@  -------------------------------------------------------------------------------- -- |--- TODO(sandy): should this mention 'Reader i' or just 'Reader'?--- -- >>> :{--- interpret @Reader $ \case+-- interpret @(Reader Bool) $ \case --   Ask -> undefined -- :} -- ...--- ... 'Reader i' is higher-order, but 'interpret' can help only+-- ... 'Reader Bool' is higher-order, but 'interpret' can help only -- ... with first-order effects. -- ... -- ... 'interpretH' instead.@@ -90,16 +89,12 @@ --  in runM foo''' -- :} -- ...--- ... Ambiguous use of effect 'Lift'+-- ... Unhandled effect 'Lift IO' -- ...--- ... add (Member (Lift IO) '[]) ...+-- ... Expected type: Sem '[Lift m] (Bool, ())+-- ... Actual type: Sem '[] (Bool, ()) -- ...------ PROBLEM: We're trying to run more effects than exist in the eff row. This is--- indeed a problem, but the error message isn't helpful.------ SOLUTION: Add a special case to `AmbiguousSend` when `r ~ '[]`.-runningTooManyEffects'WRONG = ()+runningTooManyEffects = ()   --------------------------------------------------------------------------------@@ -111,13 +106,9 @@ -- ... -- ... Ambiguous use of effect 'State' -- ...--- ... (Member (State ()) State Int : r) ...+-- ... (Member (State ()) (State Int : r)) ... -- ...------ PROBLEM: There should be parentheses around `State Int : r`------ SOLUTION: Emit parens only when the effect row is of the form `e1 ': ...`-missingParens'WRONG = ()+ambiguousSendInConcreteR = ()   --------------------------------------------------------------------------------@@ -128,40 +119,36 @@ --  in runM $ runResourceInIO foo -- :} -- ...--- ... Ambiguous use of effect 'Lift'+-- ... Couldn't match expected type ...+-- ... with actual type ...+-- ... Probable cause: ... is applied to too few arguments -- ...--- ... (Member (Lift IO) r0) ...+missingArgumentToRunResourceInIO = ()+++--------------------------------------------------------------------------------+-- |+-- >>> :{+-- existsKV :: Member (State (Maybe Int)) r => Sem r Bool+-- existsKV = isJust get+-- :} -- ...--- ... Could not deduce: (Member Resource r1)+-- ... Ambiguous use of effect 'State' -- ... ----- PROBLEM: This error is totally bogus. We forgot to give an argument to--- 'runResourceInIO'. For comparison, the standard error GHC gives in this case--- is significantly more helpful:------    <interactive>:192:13: error:---        • Couldn't match expected type ‘Sem '[Lift m] a’---                      with actual type ‘Sem (Resource : r0) a0 -> Sem r0 a0’---        • Probable cause: ‘runResourceInIO’ is applied to too few arguments---          In the second argument of ‘($)’, namely ‘runResourceInIO foo’---          In the expression: runM $ runResourceInIO foo---          In the expression:---            let---              foo :: Member Resource r => Sem r ()---              foo = undefined---            in runM $ runResourceInIO foo---        • Relevant bindings include---            it :: m a (bound at <interactive>:190:2)---    <interactive>:192:29: error:---        • Couldn't match expected type ‘Sem r0 x -> IO x’---                      with actual type ‘Sem r1 ()’---        • In the first argument of ‘runResourceInIO’, namely ‘foo’---          In the second argument of ‘($)’, namely ‘runResourceInIO foo’---          In the expression: runM $ runResourceInIO foo--------- SOLUTION: Honestly I'm not sure!-missingArgumentToRunResourceInIO'WRONG = ()-+-- NOTE: This is fixed by enabling the plugin!+missingFmap'PLUGIN = () +--------------------------------------------------------------------------------+-- |+-- >>> :{+-- foo :: Sem '[State Int, Lift IO] ()+-- foo = output ()+-- :}+-- ...+-- ... Unhandled effect 'Output ()'+-- ...+-- ... add an interpretation for 'Output ()'+-- ...+missingEffectInStack'WRONG = ()