polysemy 0.7.0.0 → 1.0.0.0

raw patch · 35 files changed

+780/−517 lines, 35 filesdep +type-errors-prettyPVP ok

version bump matches the API change (PVP)

Dependencies added: type-errors-pretty

API changes (from Hackage documentation)

Files

• ChangeLog.md +44/−3
• README.md +25/−12
• bench/Poly.hs +4/−4
• polysemy.cabal +7/−3
• src/Polysemy.hs +2/−2
• src/Polysemy/Async.hs +17/−18
• src/Polysemy/Embed.hs +29/−0
• src/Polysemy/Embed/Type.hs +36/−0
• src/Polysemy/Error.hs +19/−17
• src/Polysemy/Fixpoint.hs +2/−2
• src/Polysemy/IO.hs +20/−20
• src/Polysemy/Input.hs +12/−12
• src/Polysemy/Internal.hs +77/−26
• src/Polysemy/Internal/CustomErrors.hs +25/−56
• src/Polysemy/Internal/Forklift.hs +11/−11
• src/Polysemy/Internal/Lift.hs +0/−32
• src/Polysemy/Internal/NonDet.hs +2/−4
• src/Polysemy/Internal/TH/Common.hs +195/−154
• src/Polysemy/Internal/TH/Effect.hs +22/−21
• src/Polysemy/NonDet.hs +52/−5
• src/Polysemy/Output.hs +28/−21
• src/Polysemy/Reader.hs +6/−4
• src/Polysemy/Resource.hs +23/−24
• src/Polysemy/State.hs +27/−8
• src/Polysemy/Trace.hs +29/−23
• src/Polysemy/Writer.hs +7/−4
• test/AlternativeSpec.hs +20/−1
• test/AsyncSpec.hs +5/−5
• test/BracketSpec.hs +4/−4
• test/DoctestSpec.hs +3/−0
• test/InspectorSpec.hs +3/−3
• test/InterceptSpec.hs +1/−1
• test/OutputSpec.hs +7/−7
• test/ThEffectSpec.hs +9/−3
• test/TypeErrors.hs +7/−7

@@ -1,12 +1,53 @@ # Changelog for polysemy +## 1.0.0.0 (2019-07-24)++### Breaking Changes++- Renamed `Lift`  to `Embed` (thanks to @googleson78)+- Renamed `runAsyncInIO` to `lowerAsync`+- Renamed `runAsync` to `asyncToIO`+- Renamed `runBatchOutput` to `runOutputBatched`+- Renamed `runConstInput` to `runInputConst`+- Renamed `runEmbed` to `runEmbedded` (thanks to @googleson78)+- Renamed `runEmbedded` to `lowerEmbedded`+- Renamed `runErrorAsAnother` to `mapError`+- Renamed `runErrorInIO` to `lowerError`+- Renamed `runFoldMapOutput` to `runOutputMonoid`+- Renamed `runIO` to `embedToMonadIO`+- Renamed `runIgnoringOutput` to `ignoreOutput`+- Renamed `runIgnoringTrace` to `ignoreTrace`+- Renamed `runInputAsReader` to `inputToReader`+- Renamed `runListInput` to `runInputList`+- Renamed `runMonadicInput` to `runInputSem`+- Renamed `runOutputAsList` to `runOutputList`+- Renamed `runOutputAsTrace` to `outputToTrace`+- Renamed `runOutputAsWriter` to `outputToWriter`+- Renamed `runResourceBase` to `resourceToIO`+- Renamed `runResourceInIO` to `lowerResource`+- Renamed `runStateInIORef` to `runStateIORef`+- Renamed `runTraceAsList` to `runTraceList`+- Renamed `runTraceAsOutput` to `traceToOutput`+- Renamed `runTraceIO` to `traceToIO`+- Renamed `sendM` to `embed` (thanks to @googleson78)+- The `NonDet` effect will no longer perform effects in untaken branches (thanks to @KingoftheHomeless)++### Other Changes++- Added `evalState` and `evalLazyState`+- Added `runNonDetMaybe` (thanks to @KingoftheHomeless)+- Added `nonDetToMaybe` (thanks to @KingoftheHomeless)+- Haddock documentation for smart constructors generated via `makeSem` will no+    longer have weird variable names (thanks to @TheMatten)++ ## 0.7.0.0 (2019-07-08)  ### Breaking Changes -- Added a `Pass` constructor to `Writer`-- Fixed a bug in `runWriter` where the MTL semantics wouldn't be respected-- Removed the `Censor` constructor of `Writer`+- Added a `Pass` constructor to `Writer` (thanks to @KingoftheHomeless)+- Fixed a bug in `runWriter` where the MTL semantics wouldn't be respected (thanks to @KingoftheHomeless)+- Removed the `Censor` constructor of `Writer` (thanks to @KingoftheHomeless) - Renamed `Yo` to `Weaving` - Changed the visible type applications for `asks`, `gets`, and `runErrorAsAnother` 

@@ -91,15 +91,15 @@  makeSem ''Teletype -runTeletypeIO :: Member (Lift IO) r => Sem (Teletype ': r) a -> Sem r a-runTeletypeIO = interpret $ \case-  ReadTTY      -> sendM getLine-  WriteTTY msg -> sendM $ putStrLn msg+teletypeToIO :: Member (Lift IO) r => Sem (Teletype ': r) a -> Sem r a+teletypeToIO = interpret $ \case+  ReadTTY      -> embed getLine+  WriteTTY msg -> embed $ putStrLn msg  runTeletypePure :: [String] -> Sem (Teletype ': r) a -> Sem r ([String], a) runTeletypePure i-  = runFoldMapOutput pure  -- For each WriteTTY in our program, consume an output by appending it to the list in a ([String], a)-  . runListInput i         -- Treat each element of our list of strings as a line of input+  = runOutputMonoid pure  -- For each WriteTTY in our program, consume an output by appending it to the list in a ([String], a)+  . runInputList i         -- Treat each element of our list of strings as a line of input   . reinterpret2 \case     -- Reinterpret our effect in terms of Input and Output       ReadTTY -> maybe "" id <$> input       WriteTTY msg -> output msg@@ -120,13 +120,9 @@ pureOutput :: [String] -> [String] pureOutput = fst . run . echoPure --- Now let's do things-echoIO :: Sem '[Lift IO] ()-echoIO = runTeletypeIO echo- -- echo forever main :: IO ()-main = runM echoIO+main = runM . teletypeToIO $ echo ```  @@ -157,7 +153,7 @@             _             -> writeTTY input >> writeTTY "no exceptions"  main :: IO (Either CustomException ())-main = (runM .@ runResourceInIO .@@ runErrorInIO @CustomException) . runTeletypeIO $ program+main = (runM .@ lowerResource .@@ lowerError @CustomException) . teletypeToIO $ program ```  Easy.@@ -218,3 +214,20 @@     - TypeOperators     - TypeFamilies ```++## Stellar Engineering - Aligning the stars to optimize `polysemy` away++Several things need to be in place to fully realize our performance goals: ++- GHC Version+  - GHC 8.9++- Your code+  - The module you want to be optimized needs to import `Polysemy.Internal` somewhere in its dependency tree (sufficient to `import Polysemy`)+- GHC Flags+  - `-O` or `-O2`+  - `-flate-specialise` (this should be automatically turned on by the plugin, but it's worth mentioning)+- Plugin+  - `-fplugin=Polysemy.Plugin`+- Additional concerns:+  - additional core passes (turned on by the plugin)+

@@ -36,13 +36,13 @@     :: Sem '[ State Bool             , Error Bool             , Resource-            , Lift IO+            , Embed IO             ] Bool prog = catch @Bool (throw True) (pure . not)  zoinks :: IO (Either Bool Bool) zoinks = fmap (fmap snd)-       . (runM .@ runResourceInIO .@@ runErrorInIO)+       . (runM .@ lowerResource .@@ lowerError)        . runState False        $ prog @@ -54,8 +54,8 @@  runConsoleBoring :: [String] -> Sem (Console ': r) a -> Sem r ([String], a) runConsoleBoring inputs-  = runFoldMapOutput (:[])-  . runListInput inputs+  = runOutputMonoid (:[])+  . runInputList inputs   . reinterpret2   (\case       ReadLine -> maybe "" id <$> input

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: e22afd49cd8b82cdc69be962d872539c65eedc43a2978aa7a0652b40dd7db105+-- hash: f543f8ca2c4f661f0b6702fb6ec6d7db075660d19bf550e50a04e64c56826913  name:           polysemy-version:        0.7.0.0+version:        1.0.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@@ -41,6 +41,8 @@   exposed-modules:       Polysemy       Polysemy.Async+      Polysemy.Embed+      Polysemy.Embed.Type       Polysemy.Error       Polysemy.Fixpoint       Polysemy.Input@@ -51,7 +53,6 @@       Polysemy.Internal.Fixpoint       Polysemy.Internal.Forklift       Polysemy.Internal.Kind-      Polysemy.Internal.Lift       Polysemy.Internal.NonDet       Polysemy.Internal.Tactics       Polysemy.Internal.TH.Common@@ -82,6 +83,7 @@     , th-abstraction >=0.3.1.0 && <0.4     , transformers >=0.5.2.0 && <0.6     , type-errors >=0.2.0.0+    , type-errors-pretty >=0.0.0.0 && <0.1     , unagi-chan >=0.4.0.0 && <0.5   if impl(ghc < 8.6)     default-extensions: MonadFailDesugaring TypeInType@@ -141,6 +143,7 @@     , th-abstraction >=0.3.1.0 && <0.4     , transformers >=0.5.2.0 && <0.6     , type-errors >=0.2.0.0+    , type-errors-pretty >=0.0.0.0 && <0.1     , unagi-chan >=0.4.0.0 && <0.5   if impl(ghc < 8.6)     default-extensions: MonadFailDesugaring TypeInType@@ -173,6 +176,7 @@     , th-abstraction >=0.3.1.0 && <0.4     , transformers >=0.5.2.0 && <0.6     , type-errors >=0.2.0.0+    , type-errors-pretty >=0.0.0.0 && <0.1     , unagi-chan >=0.4.0.0 && <0.5   if impl(ghc < 8.6)     default-extensions: MonadFailDesugaring TypeInType

@@ -10,8 +10,8 @@   , runM    -- * Interoperating With Other Monads-  , Lift (..)-  , sendM+  , Embed (..)+  , embed      -- * Lifting   , raise

@@ -9,8 +9,8 @@   , await      -- * Interpretations-  , runAsync-  , runAsyncInIO+  , asyncToIO+  , lowerAsync   ) where  import qualified Control.Concurrent.Async as A@@ -32,53 +32,52 @@ makeSem ''Async  --------------------------------------------------------------------------------- | A more flexible --- though less performant ---  version of 'runAsyncInIO'.+-- | A more flexible --- though less performant ---  version of 'lowerAsync'. -- -- This function is capable of running 'Async' effects anywhere within an -- effect stack, without relying on an explicit function to lower it into 'IO'. -- Notably, this means that 'Polysemy.State.State' effects will be consistent -- in the presence of 'Async'. ----- @since 0.5.0.0-runAsync-    :: LastMember (Lift IO) r+-- @since 1.0.0.0+asyncToIO+    :: LastMember (Embed IO) r     => Sem (Async ': r) a     -> Sem r a-runAsync m = withLowerToIO $ \lower _ -> lower $+asyncToIO m = withLowerToIO $ \lower _ -> lower $   interpretH     ( \case         Async a -> do           ma  <- runT a           ins <- getInspectorT-          fa  <- sendM $ A.async $ lower $ runAsync ma+          fa  <- embed $ A.async $ lower $ asyncToIO ma           pureT $ fmap (inspect ins) fa -        Await a -> pureT =<< sendM (A.wait a)+        Await a -> pureT =<< embed (A.wait a)     )  m-{-# INLINE runAsync #-}+{-# INLINE asyncToIO #-}   ------------------------------------------------------------------------------ -- | Run an 'Async' effect via in terms of 'A.async'. -------- @since 0.5.0.0-runAsyncInIO-    :: Member (Lift IO) r+-- @since 1.0.0.0+lowerAsync+    :: Member (Embed IO) r     => (forall x. Sem r x -> IO x)        -- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is likely        -- some combination of 'runM' and other interpreters composed via '.@'.     -> Sem (Async ': r) a     -> Sem r a-runAsyncInIO lower m = interpretH+lowerAsync lower m = interpretH     ( \case         Async a -> do           ma  <- runT a           ins <- getInspectorT-          fa  <- sendM $ A.async $ lower $ runAsyncInIO lower ma+          fa  <- embed $ A.async $ lower $ lowerAsync lower ma           pureT $ fmap (inspect ins) fa -        Await a -> pureT =<< sendM (A.wait a)+        Await a -> pureT =<< embed (A.wait a)     )  m-{-# INLINE runAsyncInIO #-}+{-# INLINE lowerAsync #-} 

@@ -0,0 +1,29 @@+{-# LANGUAGE TemplateHaskell #-}++module Polysemy.Embed+  ( -- * Effect+    Embed (..)++    -- * Actions+  , embed++    -- * Interpretations+  , runEmbedded+  ) where++import Polysemy+import Polysemy.Embed.Type (Embed (..))++------------------------------------------------------------------------------+-- | Given a natural transform from @m1@ to @m2@+-- run a @Embed m1@ effect by transforming it into a @Embed m2@ effect.+--+-- @since 1.0.0.0+runEmbedded+    :: forall m1 m2 r a+     . Member (Embed m2) r+    => (forall x. m1 x -> m2 x)+    -> Sem (Embed m1 ': r) a+    -> Sem r a+runEmbedded f = interpret $ embed . f . unEmbed+{-# INLINE runEmbedded #-}

@@ -0,0 +1,36 @@+{-# LANGUAGE NoPolyKinds #-}++{-# OPTIONS_HADDOCK not-home #-}++module Polysemy.Embed.Type+  ( -- * Effect+    Embed (..)+  ) where++import Data.Kind+++------------------------------------------------------------------------------+-- | An effect which allows a regular 'Monad' @m@ into the 'Polysemy.Sem'+-- ecosystem. Monadic actions in @m@ can be lifted into 'Polysemy.Sem' via+-- 'Polysemy.embed'.+--+-- For example, you can use this effect to lift 'IO' actions directly into+-- 'Polysemy.Sem':+--+-- @+-- 'Polysemy.embed' (putStrLn "hello") :: 'Polysemy.Member' ('Polysemy.Embed' IO) r => 'Polysemy.Sem' r ()+-- @+--+-- That being said, you lose out on a significant amount of the benefits of+-- 'Polysemy.Sem' by using 'Polysemy.embed' directly in application code; doing+-- so will tie your application code directly to the underlying monad, and+-- prevent you from interpreting it differently. For best results, only use+-- 'Embed' in your effect interpreters.+--+-- Consider using 'Polysemy.Trace.trace' and 'Polysemy.Trace.traceToIO' as+-- a substitute for using 'putStrLn' directly.+--+-- @since 1.0.0.0+newtype Embed m (z :: Type -> Type) a where+  Embed :: { unEmbed :: m a } -> Embed m z a

@@ -12,8 +12,8 @@      -- * Interpretations   , runError-  , runErrorAsAnother-  , runErrorInIO+  , mapError+  , lowerError   ) where  import qualified Control.Exception as X@@ -51,18 +51,18 @@   --------------------------------------------------------------------------------- | A combinator doing 'sendM' and 'fromEither' at the same time. Useful for+-- | A combinator doing 'embed' and 'fromEither' at the same time. Useful for -- interoperating with 'IO'. -- -- @since 0.5.1.0 fromEitherM     :: forall e m r a      . ( Member (Error e) r-       , Member (Lift m) r+       , Member (Embed m) r        )     => m (Either e a)     -> Sem r a-fromEitherM = fromEither <=< sendM+fromEitherM = fromEither <=< embed   ------------------------------------------------------------------------------@@ -96,14 +96,14 @@ -- | Transform one 'Error' into another. This function can be used to aggregate -- multiple errors into a single type. ----- @since 0.2.2.0-runErrorAsAnother+-- @since 1.0.0.0+mapError   :: forall e1 e2 r a    . Member (Error e2) r   => (e1 -> e2)   -> Sem (Error e1 ': r) a   -> Sem r a-runErrorAsAnother f = interpretH $ \case+mapError f = interpretH $ \case   Throw e -> throw $ f e   Catch action handler -> do     a  <- runT action@@ -118,7 +118,7 @@         case mx' of           Right x -> pure x           Left e' -> throw $ f e'-{-# INLINE runErrorAsAnother #-}+{-# INLINE mapError #-}   newtype WrappedExc e = WrappedExc { unwrapExc :: e }@@ -133,9 +133,11 @@ ------------------------------------------------------------------------------ -- | Run an 'Error' effect as an 'IO' 'X.Exception'. This interpretation is -- significantly faster than 'runError', at the cost of being less flexible.-runErrorInIO+--+-- @since 1.0.0.0+lowerError     :: ( Typeable e-       , Member (Lift IO) r+       , Member (Embed IO) r        )     => (∀ x. Sem r x -> IO x)        -- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is@@ -143,30 +145,30 @@        -- '.@'.     -> Sem (Error e ': r) a     -> Sem r (Either e a)-runErrorInIO lower-    = sendM+lowerError lower+    = embed     . fmap (first unwrapExc)     . X.try     . (lower .@ runErrorAsExc)-{-# INLINE runErrorInIO #-}+{-# INLINE lowerError #-}   -- TODO(sandy): Can we use the new withLowerToIO machinery for this? runErrorAsExc     :: forall e r a. ( Typeable e-       , Member (Lift IO) r+       , Member (Embed IO) r        )     => (∀ x. Sem r x -> IO x)     -> Sem (Error e ': r) a     -> Sem r a runErrorAsExc lower = interpretH $ \case-  Throw e -> sendM $ X.throwIO $ WrappedExc e+  Throw e -> embed $ X.throwIO $ WrappedExc e   Catch try handle -> do     is <- getInitialStateT     t  <- runT try     h  <- bindT handle     let runIt = lower . runErrorAsExc lower-    sendM $ X.catch (runIt t) $ \(se :: WrappedExc e) ->+    embed $ X.catch (runIt t) $ \(se :: WrappedExc e) ->       runIt $ h $ unwrapExc se <$ is {-# INLINE runErrorAsExc #-} 

@@ -29,7 +29,7 @@ -- | Run a 'Fixpoint' effect in terms of an underlying 'MonadFix' instance. runFixpointM     :: ( MonadFix m-       , Member (Lift m) r+       , Member (Embed m) r        )     => (∀ x. Sem r x -> m x)     -> Sem (Fixpoint ': r) a@@ -37,5 +37,5 @@ runFixpointM lower = interpretH $ \case   Fixpoint mf -> do     c <- bindT mf-    sendM $ mfix $ lower . runFixpointM lower . c+    embed $ mfix $ lower . runFixpointM lower . c 

@@ -2,19 +2,18 @@  module Polysemy.IO   ( -- * Interpretations-    runIO-  , runEmbedded+    embedToMonadIO+  , lowerEmbedded   ) where  import Control.Monad.IO.Class import Polysemy+import Polysemy.Embed import Polysemy.Internal import Polysemy.Internal.Union   --------------------------------------------------------------------------------- | __If you trying to run 'Sem' in 'IO', the function you want is 'runM'.__--- -- The 'MonadIO' class is conceptually an interpretation of 'IO' to some -- other monad. This function reifies that intuition, by transforming an 'IO' -- effect into some other 'MonadIO'.@@ -22,52 +21,53 @@ -- This function is especially useful when using the 'MonadIO' instance for -- 'Sem' instance. ----- Make sure to type-apply the desired 'MonadIO' instance when using 'runIO'.+-- Make sure to type-apply the desired 'MonadIO' instance when using+-- 'embedToMonadIO'. ----- @since 0.1.1.0+-- @since 1.0.0.0 -- -- ==== Example -- -- @ -- foo :: PandocIO ()--- foo = 'runM' . 'runIO' @PandocIO $ do+-- foo = 'runM' . 'embedToMonadIO' @PandocIO $ do --   'liftIO' $ putStrLn "hello from polysemy" -- @ ---runIO+embedToMonadIO     :: forall m r a      . ( MonadIO m-       , Member (Lift m) r+       , Member (Embed m) r        )-    => Sem (Lift IO ': r) a+    => Sem (Embed IO ': r) a     -> Sem r a-runIO = interpret $ sendM . liftIO @m . unLift-{-# INLINE runIO #-}+embedToMonadIO = runEmbedded $ liftIO @m+{-# INLINE embedToMonadIO #-}   --------------------------------------------------------------------------------- | Given some @'MonadIO' m@, interpret all @'Lift' m@ actions in that monad+-- | Given some @'MonadIO' m@, interpret all @'Embed' 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@. ----- @since 0.6.0.0-runEmbedded+-- @since 1.0.0.0+lowerEmbedded     :: ( MonadIO m-       , LastMember (Lift IO) r+       , LastMember (Embed IO) r        )     => (forall x. m x -> IO x)  -- ^ The means of running this monad.-    -> Sem (Lift m ': r) a+    -> Sem (Embed m ': r) a     -> Sem r a-runEmbedded run_m (Sem m) = withLowerToIO $ \lower _ ->+lowerEmbedded run_m (Sem m) = withLowerToIO $ \lower _ ->   run_m $ m $ \u ->     case decomp u of       Left x -> liftIO               . lower               . liftSem-              $ hoist (runEmbedded run_m) x+              $ hoist (lowerEmbedded run_m) x -      Right (Weaving (Lift wd) s _ y _) ->+      Right (Weaving (Embed wd) s _ y _) ->         fmap y $ fmap (<$ s) wd 

@@ -8,9 +8,9 @@   , input      -- * Interpretations-  , runConstInput-  , runListInput-  , runMonadicInput+  , runInputConst+  , runInputList+  , runInputSem   ) where  import Data.Foldable (for_)@@ -29,33 +29,33 @@  ------------------------------------------------------------------------------ -- | Run an 'Input' effect by always giving back the same value.-runConstInput :: i -> Sem (Input i ': r) a -> Sem r a-runConstInput c = interpret $ \case+runInputConst :: i -> Sem (Input i ': r) a -> Sem r a+runInputConst c = interpret $ \case   Input -> pure c-{-# INLINE runConstInput #-}+{-# INLINE runInputConst #-}   ------------------------------------------------------------------------------ -- | Run an 'Input' effect by providing a different element of a list each -- time. Returns 'Nothing' after the list is exhausted.-runListInput+runInputList     :: [i]     -> Sem (Input (Maybe i) ': r) a     -> Sem r a-runListInput is = fmap snd . runState is . reinterpret+runInputList is = fmap snd . runState is . reinterpret   (\case       Input -> do         s <- gets uncons         for_ s $ put . snd         pure $ fmap fst s   )-{-# INLINE runListInput #-}+{-# INLINE runInputList #-}   ------------------------------------------------------------------------------ -- | Runs an 'Input' effect by evaluating a monadic action for each request.-runMonadicInput :: forall i r a. Sem r i -> Sem (Input i ': r) a -> Sem r a-runMonadicInput m = interpret $ \case+runInputSem :: forall i r a. Sem r i -> Sem (Input i ': r) a -> Sem r a+runInputSem m = interpret $ \case   Input -> m-{-# INLINE runMonadicInput #-}+{-# INLINE runInputSem #-} 

@@ -11,14 +11,14 @@   , Member   , Members   , send-  , sendM+  , embed   , run   , runM   , raise   , raiseUnder   , raiseUnder2   , raiseUnder3-  , Lift (..)+  , Embed (..)   , usingSem   , liftSem   , hoistSem@@ -34,12 +34,17 @@ import Data.Functor.Identity import Data.Kind import Polysemy.Internal.Fixpoint-import Polysemy.Internal.Lift+import Polysemy.Embed.Type import Polysemy.Internal.NonDet import Polysemy.Internal.PluginLookup import Polysemy.Internal.Union  +-- $setup+-- >>> import Data.Function+-- >>> import Polysemy.State+-- >>> import Polysemy.Error+ ------------------------------------------------------------------------------ -- | The 'Sem' monad handles computations of arbitrary extensible effects. -- A value of type @Sem r@ describes a program with the capabilities of@@ -54,11 +59,11 @@ -- interpretations (and others that you might add) may be used interchangably -- without needing to write any newtypes or 'Monad' instances. The only -- change needed to swap interpretations is to change a call from--- 'Polysemy.Error.runError' to 'Polysemy.Error.runErrorInIO'.+-- 'Polysemy.Error.runError' to 'Polysemy.Error.lowerError'. -- -- The effect stack @r@ can contain arbitrary other monads inside of it. These--- monads are lifted into effects via the 'Lift' effect. Monadic values can be--- lifted into a 'Sem' via 'sendM'.+-- monads are lifted into effects via the 'Embed' effect. Monadic values can be+-- lifted into a 'Sem' via 'embed'. -- -- A 'Sem' can be interpreted as a pure value (via 'run') or as any -- traditional 'Monad' (via 'runM'). Each effect @E@ comes equipped with some@@ -72,8 +77,55 @@ -- is the order in which you call the interpreters that determines the -- monomorphic representation of the @r@ parameter. --+-- Order of interpreters can be important - it determines behaviour of effects+-- that manipulate state or change control flow. For example, when+-- interpreting this action:+--+-- >>> :{+--   example :: Members '[State String, Error String] r => Sem r String+--   example = do+--     put "start"+--     let throwing, catching :: Members '[State String, Error String] r => Sem r String+--         throwing = do+--           modify (++"-throw")+--           throw "error"+--           get+--         catching = do+--           modify (++"-catch")+--           get+--     catch @String throwing (\ _ -> catching)+-- :}+--+-- when handling 'Polysemy.Error.Error' first, state is preserved after error+-- occurs:+--+-- >>> :{+--   example+--     & runError+--     & fmap (either id id)+--     & evalState ""+--     & runM+--     & (print =<<)+-- :}+-- "start-throw-catch"+--+-- while handling 'Polysemy.State.State' first discards state in such cases:+--+-- >>> :{+--   example+--     & evalState ""+--     & runError+--     & fmap (either id id)+--     & runM+--     & (print =<<)+-- :}+-- "start-catch"+--+-- A good rule of thumb is to handle effects which should have \"global\"+-- behaviour over other effects later in the chain.+-- -- After all of your effects are handled, you'll be left with either--- a @'Sem' '[] a@ or a @'Sem' '[ 'Lift' m ] a@ value, which can be+-- a @'Sem' '[] a@ or a @'Sem' '[ 'Embed' m ] a@ value, which can be -- consumed respectively by 'run' and 'runM'. -- -- ==== Examples@@ -211,10 +263,7 @@ instance (Member NonDet r) => Alternative (Sem r) where   empty = send Empty   {-# INLINE empty #-}-  a <|> b = do-    send (Choose id) >>= \case-      False -> a-      True  -> b+  a <|> b = send (Choose a b)   {-# INLINE (<|>) #-}  -- | @since 0.2.1.0@@ -230,9 +279,9 @@ ------------------------------------------------------------------------------ -- | This instance will only lift 'IO' actions. If you want to lift into some -- other 'MonadIO' type, use this instance, and handle it via the--- 'Polysemy.IO.runIO' interpretation.-instance (Member (Lift IO) r) => MonadIO (Sem r) where-  liftIO = sendM+-- 'Polysemy.IO.embedToMonadIO' interpretation.+instance (Member (Embed IO) r) => MonadIO (Sem r) where+  liftIO = embed   {-# INLINE liftIO #-}  instance Member Fixpoint r => MonadFix (Sem r) where@@ -300,7 +349,7 @@   --------------------------------------------------------------------------------- | Lift an effect into a 'Sem'. This is used primarily via+-- | Embed an effect into a 'Sem'. This is used primarily via -- 'Polysemy.makeSem' to implement smart constructors. send :: Member e r => e (Sem r) a -> Sem r a send = liftSem . inj@@ -308,10 +357,12 @@   --------------------------------------------------------------------------------- | Lift a monadic action @m@ into 'Sem'.-sendM :: Member (Lift m) r => m a -> Sem r a-sendM = send . Lift-{-# INLINE sendM #-}+-- | Embed a monadic action @m@ in 'Sem'.+--+-- @since 1.0.0.0+embed :: Member (Embed m) r => m a -> Sem r a+embed = send . Embed+{-# INLINE embed #-}   ------------------------------------------------------------------------------@@ -324,11 +375,11 @@ ------------------------------------------------------------------------------ -- | Lower a 'Sem' containing only a single lifted 'Monad' into that -- monad.-runM :: Monad m => Sem '[Lift m] a -> m a+runM :: Monad m => Sem '[Embed m] a -> m a runM (Sem m) = m $ \z ->   case extract z of     Weaving e s _ f _ -> do-      a <- unLift e+      a <- unEmbed e       pure $ f $ a <$ s {-# INLINE runM #-} @@ -336,13 +387,13 @@ ------------------------------------------------------------------------------ -- | Some interpreters need to be able to lower down to the base monad (often -- 'IO') in order to function properly --- some good examples of this are--- 'Polysemy.Error.runErrorInIO' and 'Polysemy.Resource.runResourceInIO'.+-- 'Polysemy.Error.lowerError' and 'Polysemy.Resource.lowerResource'. -- -- However, these interpreters don't compose particularly nicely; for example,--- to run 'Polysemy.Resource.runResourceInIO', you must write:+-- to run 'Polysemy.Resource.lowerResource', you must write: -- -- @--- runM . runErrorInIO runM+-- runM . lowerError runM -- @ -- -- Notice that 'runM' is duplicated in two places here. The situation gets@@ -352,7 +403,7 @@ -- Instead, '.@' performs the composition we'd like. The above can be written as -- -- @--- (runM .@ runErrorInIO)+-- (runM .@ lowerError) -- @ -- -- The parentheses here are important; without them you'll run into operator@@ -377,7 +428,7 @@  ------------------------------------------------------------------------------ -- | Like '.@', but for interpreters which change the resulting type --- eg.--- 'Polysemy.Error.runErrorInIO'.+-- 'Polysemy.Error.lowerError'. (.@@)     :: Monad m     => (∀ x. Sem r x -> m x)

@@ -17,10 +17,11 @@  import Data.Kind import Fcf-import GHC.TypeLits+import GHC.TypeLits (Symbol) import Polysemy.Internal.Kind import Polysemy.Internal.CustomErrors.Redefined import Type.Errors hiding (IfStuck, WhenStuck, UnlessStuck)+import Type.Errors.Pretty (type (<>), type (%))   ------------------------------------------------------------------------------@@ -37,9 +38,7 @@   -- TODO(sandy): Put in type-errors-type ShowTypeBracketed t = 'Text "("-                     ':<>: 'ShowType t-                     ':<>: 'Text ")"+type ShowTypeBracketed t = "(" <> t <> ")"   ------------------------------------------------------------------------------@@ -67,24 +66,15 @@                            (r :: EffectRow)                            (e :: k)                            (t :: Effect)-                           (vs :: [Type]) =-        ( 'Text "Ambiguous use of effect '"-    ':<>: 'ShowType e-    ':<>: 'Text "'"-    ':$$: 'Text "Possible fix:"-    ':$$: 'Text "  add (Member ("-    ':<>: 'ShowType t-    ':<>: 'Text ") "-    ':<>: 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 "    "-    ':<>: PrettyPrintList vs-    ':<>: 'Text " directly, or activate polysemy-plugin which"-    ':$$: 'Text "      can usually infer the type correctly."-        )+                           (vs :: [Type])+  = "Ambiguous use of effect '" <> e <> "'"+  % "Possible fix:"+  % "  add (Member (" <> t <> ") " <> ShowRQuoted rstate r <> ") to the context of "+  % "    the type signature"+  % "If you already have the constraint you want, instead"+  % "  add a type application to specify"+  % "    " <> PrettyPrintList vs <> " directly, or activate polysemy-plugin which"+  % "      can usually infer the type correctly."  type AmbiguousSend r e =       (IfStuck r@@ -110,18 +100,10 @@    AmbiguousSendError rstate r e =     TypeError-        ( 'Text "Could not deduce: (Member "-    ':<>: 'ShowType e-    ':<>: 'Text " "-    ':<>: ShowRQuoted rstate r-    ':<>: 'Text ") "-    ':$$: 'Text "Fix:"-    ':$$: 'Text "  add (Member "-    ':<>: 'ShowType e-    ':<>: 'Text " "-    ':<>: 'ShowType r-    ':<>: 'Text ") to the context of"-    ':$$: 'Text "    the type signature"+        ( "Could not deduce: (Member " <>  e <> " " <> ShowRQuoted rstate r <> ") "+        % "Fix:"+        % "  add (Member " <>  e <> " " <> r <> ") to the context of"+        % "    the type signature"         )  @@ -129,16 +111,10 @@ 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."+        ( "'" <> e <> "' is higher-order, but '" <> fn <> "' can help only"+        % "with first-order effects."+        % "Fix:"+        % "  use '" <> fn <> "H' instead."         ) |])  ------------------------------------------------------------------------------@@ -150,19 +126,13 @@ ------------------------------------------------------------------------------ -- | Unhandled effects type UnhandledEffectMsg e-      = 'Text "Unhandled effect '"-  ':<>: 'ShowType e-  ':<>: 'Text "'"-  ':$$: 'Text "Probable fix:"-  ':$$: 'Text "  add an interpretation for '"-  ':<>: 'ShowType e-  ':<>: 'Text "'"+  = "Unhandled effect '" <> e <> "'"+  % "Probable fix:"+  % "  add an interpretation for '" <> e <> "'"  type CheckDocumentation e-      = 'Text "  If you are looking for inspiration, try consulting"-  ':$$: 'Text "    the documentation for module '"-  ':<>: 'Text (DefiningModuleForEffect e)-  ':<>: 'Text "'"+  = "  If you are looking for inspiration, try consulting"+  % "    the documentation for module '" <> DefiningModuleForEffect e <> "'"  type family UnhandledEffect e where   UnhandledEffect e =@@ -173,4 +143,3 @@  data DoError :: ErrorMessage -> Exp k type instance Eval (DoError a) = TypeError a-

@@ -19,7 +19,7 @@ -- -- @since 0.5.0.0 data Forklift r = forall a. Forklift-  { responseMVar :: MVar (Sem '[Lift IO] a)+  { responseMVar :: MVar (Sem '[Embed IO] a)   , request      :: Union r (Sem r) a   } @@ -30,13 +30,13 @@ -- -- @since 0.5.0.0 runViaForklift-    :: LastMember (Lift IO) r+    :: LastMember (Embed IO) r     => InChan (Forklift r)     -> Sem r a-    -> Sem '[Lift IO] a+    -> Sem '[Embed IO] a runViaForklift chan (Sem m) = Sem $ \k -> m $ \u -> do   case decompLast u of-    Left x -> usingSem k $ join $ sendM $ do+    Left x -> usingSem k $ join $ embed $ do       mvar <- newEmptyMVar       writeChan chan $ Forklift mvar x       takeMVar mvar@@ -53,29 +53,29 @@ -- -- @since 0.5.0.0 withLowerToIO-    :: LastMember (Lift IO) r+    :: LastMember (Embed IO) r     => ((forall x. Sem r x -> IO x) -> IO () -> IO a)        -- ^ A lambda that takes the lowering function, and a finalizing 'IO'        -- action to mark a the forked thread as being complete. The finalizing        -- action need not be called.     -> Sem r a withLowerToIO action = do-  (inchan, outchan) <- sendM newChan-  signal <- sendM newEmptyMVar+  (inchan, outchan) <- embed newChan+  signal <- embed newEmptyMVar -  res <- sendM $ A.async $ do+  res <- embed $ A.async $ do     a <- action (runM . runViaForklift inchan)                 (putMVar signal ())     putMVar signal ()     pure a    let me = do-        raced <- sendM $ A.race (takeMVar signal) $ readChan outchan+        raced <- embed $ A.race (takeMVar signal) $ readChan outchan         case raced of-          Left () -> sendM $ A.wait res+          Left () -> embed $ A.wait res           Right (Forklift mvar req) -> do             resp <- liftSem req-            sendM $ putMVar mvar $ pure resp+            embed $ putMVar mvar $ pure resp             me_b       {-# INLINE me #-} 

@@ -1,32 +0,0 @@-{-# LANGUAGE NoPolyKinds #-}--{-# OPTIONS_HADDOCK not-home #-}--module Polysemy.Internal.Lift where--import Data.Kind------------------------------------------------------------------------------------ | An effect which allows a regular 'Monad' @m@ into the 'Polysemy.Sem'--- ecosystem. Monadic actions in @m@ can be lifted into 'Polysemy.Sem' via--- 'Polysemy.sendM'.------ For example, you can use this effect to lift 'IO' actions directly into--- 'Polysemy.Sem':------ @--- 'Polysemy.sendM' (putStrLn "hello") :: 'Polysemy.Member' ('Polysemy.Lift' IO) r => 'Polysemy.Sem' r ()--- @------ That being said, you lose out on a significant amount of the benefits of--- 'Polysemy.Sem' by using 'Polysemy.sendM' directly in application code; doing--- so will tie your application code directly to the underlying monad, and--- prevent you from interpreting it differently. For best results, only use--- 'Lift' in your effect interpreters.------ Consider using 'Polysemy.Trace.trace' and 'Polysemy.Trace.runTraceIO' as--- a substitute for using 'putStrLn' directly.-newtype Lift m (z :: Type -> Type) a where-  Lift :: { unLift :: m a } -> Lift m z a-

@@ -6,12 +6,10 @@  module Polysemy.Internal.NonDet where -import Data.Kind - ------------------------------------------------------------------------------ -- | An effect corresponding to the 'Control.Applicative.Alternative' typeclass.-data NonDet (m :: Type -> Type) a+data NonDet m a   = Empty-  | Choose (Bool -> a)+  | Choose (m a) (m a) 

@@ -1,12 +1,11 @@ {-# LANGUAGE CPP             #-}-{-# LANGUAGE NamedFieldPuns  #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections   #-}+{-# LANGUAGE ViewPatterns    #-}  {-# OPTIONS_HADDOCK not-home #-} - module Polysemy.Internal.TH.Common   ( ConLiftInfo (..)   , getEffectMetadata@@ -17,13 +16,15 @@   , makeEffectType   , makeUnambiguousSend   , checkExtensions-  , foldArrows+  , foldArrowTs+  , splitArrowTs+  , pattern (:->)   ) where +import           Control.Arrow ((>>>)) import           Control.Monad import           Data.Bifunctor import           Data.Char (toLower)-import           Data.Either import           Data.Generics hiding (Fixity) import           Data.List import qualified Data.Map.Strict as M@@ -40,30 +41,119 @@   --------------------------------------------------------------------------------- | Given an effect name, eg @''State@, get information about the type--- constructor, and about each of its data constructors.-getEffectMetadata :: Name -> Q (DatatypeInfo, [ConLiftInfo])+-- Effects TH ----------------------------------------------------------------+------------------------------------------------------------------------------++------------------------------------------------------------------------------+-- | Info about constructor being lifted; use 'makeCLInfo' to create one.+data ConLiftInfo = CLInfo+  { -- | Name of effect's type constructor+    cliEffName   :: Name+  , -- | Effect-specific type arguments+    cliEffArgs   :: [Type]+  , -- | Result type specific to action+    cliEffRes    :: Type+  , -- | Name of action constructor+    cliConName   :: Name+  , -- | Name of final function+    cliFunName   :: Name+  , -- | Fixity of function used as an operator+    cliFunFixity :: Maybe Fixity+  , -- | Final function arguments+    cliFunArgs   :: [(Name, Type)]+  , -- | Constraints of final function+    cliFunCxt    :: Cxt+  , -- | Name of type variable parameterizing 'Sem'+    cliUnionName :: Name+  } deriving Show+++------------------------------------------------------------------------------+-- | Given an name of datatype or some of it's constructors/fields, return+-- datatype's name together with info about it's constructors.+getEffectMetadata :: Name -> Q (Name, [ConLiftInfo]) getEffectMetadata type_name = do   dt_info  <- reifyDatatype type_name-  cl_infos <- traverse (mkCLInfo dt_info) $ datatypeCons dt_info-  pure (dt_info, cl_infos)+  cl_infos <- traverse makeCLInfo $ constructorName <$> datatypeCons dt_info+  pure (datatypeName dt_info, cl_infos)   --------------------------------------------------------------------------------- | Turn a 'ConLiftInfo' for @Foo@ into a @Member Foo r@ constraint.-makeMemberConstraint :: Name -> ConLiftInfo -> Pred-makeMemberConstraint r cli = makeMemberConstraint' r $ makeEffectType cli+-- | Creates name of lifting function from action name.+liftFunNameFromCon :: Name -> Name+liftFunNameFromCon n = mkName $+  case nameBase n of+    ':' : cs -> cs+    c   : cs -> toLower c : cs+    ""       -> error "liftFunNameFromCon: empty constructor name"   ------------------------------------------------------------------------------+-- | Creates info about smart constructor being created from name of the+-- original one.+makeCLInfo :: Name -> Q ConLiftInfo+makeCLInfo cliConName = do+  (con_type, cliEffName) <- reify cliConName >>= \case+    DataConI _ t p -> pure (t, p)+    _              -> notDataCon cliConName++  let (con_args, [con_return_type]) = splitAtEnd 1+                                    $ splitArrowTs con_type++  (ty_con_args, [monad_arg, res_arg]) <-+    case splitAtEnd 2 $ tail $ splitAppTs $ con_return_type of+      r@(_, [_, _]) -> pure r+      _             -> missingEffArgs cliEffName++  monad_name   <- maybe (argNotVar cliEffName monad_arg)+                        pure+                        (tVarName monad_arg)++  cliUnionName <- newName "r"++  let normalize_types :: (TypeSubstitution t, Data t) => t -> t+      normalize_types = replaceMArg monad_name cliUnionName+                      . simplifyKinds++      cliEffArgs      = normalize_types ty_con_args+      cliEffRes       = normalize_types res_arg+      cliFunName      = liftFunNameFromCon cliConName++  cliFunFixity  <- reifyFixity cliConName++  fun_arg_names <- replicateM (length con_args) $ newName "x"++  let cliFunArgs    = zip fun_arg_names $ normalize_types con_args+      -- GADTs seem to forbid constraints further in signature, so top level+      -- ones should be fine.+      cliFunCxt     = topLevelConstraints con_type++  pure CLInfo{..}+++------------------------------------------------------------------------------ -- | Given a 'ConLiftInfo', get the corresponding effect type. makeEffectType :: ConLiftInfo -> Type-makeEffectType cli-  = foldl' AppT (ConT $ cliEffName cli)-  $ cliEffArgs cli+makeEffectType cli = foldl' AppT (ConT $ cliEffName cli) $ cliEffArgs cli   ------------------------------------------------------------------------------+-- | @'makeInterpreterType' con r a@ will produce a @'Polysemy.Sem' (Effect ':+-- r) a -> 'Polysemy.Sem' r a@ type, where @Effect@ is the effect+-- corresponding to the 'ConLiftInfo' for @con@.+makeInterpreterType :: ConLiftInfo -> Name -> Type -> Type+makeInterpreterType cli r result = sem_with_eff :-> makeSemType r result where+  sem_with_eff = ConT ''Sem `AppT` r_with_eff `AppT` result+  r_with_eff   = PromotedConsT `AppT` makeEffectType cli `AppT` VarT r+++------------------------------------------------------------------------------+-- | Turn a 'ConLiftInfo' for @Foo@ into a @Member Foo r@ constraint.+makeMemberConstraint :: Name -> ConLiftInfo -> Pred+makeMemberConstraint r cli = makeMemberConstraint' r $ makeEffectType cli+++------------------------------------------------------------------------------ -- | @'makeMemberConstraint'' r type@ will produce a @Member type r@ -- constraint. makeMemberConstraint' :: Name -> Type -> Pred@@ -77,111 +167,39 @@   --------------------------------------------------------------------------------- | @'makeInterpreterType' con r a@ will produce a @'Polysemy.Sem' (Effect ':--- r) a -> 'Polysemy.Sem' r a@ type, where @Effect@ is the effect corresponding--- to the 'ConLiftInfo' for @con@.-makeInterpreterType :: ConLiftInfo -> Name -> Type -> Type-makeInterpreterType cli r result =-  foldArrows (makeSemType r result)-    $ pure-    $ ConT ''Sem-        `AppT` (PromotedConsT `AppT` makeEffectType cli `AppT` VarT r)-        `AppT` result--------------------------------------------------------------------------------- -- | Given a 'ConLiftInfo', this will produce an action for it. It's arguments -- will come from any variables in scope that correspond to the 'cliArgs' of -- the 'ConLiftInfo'. makeUnambiguousSend :: Bool -> ConLiftInfo -> Exp-makeUnambiguousSend should_mk_sigs cli =-  let fun_args_names = fmap fst $ cliArgs cli+makeUnambiguousSend should_make_sigs cli =+  let fun_args_names = fmap fst $ cliFunArgs cli       action = foldl1' AppE              $ ConE (cliConName cli) : (VarE <$> fun_args_names)       eff    = foldl' AppT (ConT $ cliEffName cli) $ args                -- see NOTE(makeSem_)-      args   = (if should_mk_sigs then id else map capturableTVars)-             $ cliEffArgs cli ++ [sem, cliResType cli]+      args   = (if should_make_sigs then id else map capturableTVars)+             $ cliEffArgs cli ++ [sem, cliEffRes cli]       sem    = ConT ''Sem `AppT` VarT (cliUnionName cli)    in AppE (VarE 'send) $ SigE action eff  ---------------------------------------------------------------------------------- | Info about constructor being lifted; use 'mkCLInfo' to create one.-data ConLiftInfo = CLInfo-  { -- | Name of effect's type constructor-    cliEffName   :: Name-    -- | Effect-specific type arguments-  , cliEffArgs   :: [Type]-    -- | Result type specific to action-  , cliResType   :: Type-    -- | Name of action constructor-  , cliConName   :: Name-    -- | Name of final function-  , cliFunName   :: Name-    -- | Fixity of function used as an operator-  , cliFunFixity :: Maybe Fixity-    -- | Final function arguments-  , cliArgs   :: [(Name, Type)]-    -- | Constraints of final function-  , cliFunCxt    :: Cxt-    -- | Name of type variable parameterizing 'Sem'-  , cliUnionName :: Name-  } deriving Show------------------------------------------------------------------------------------ | Creates info about smart constructor being created from info about action--- and it's parent type.-mkCLInfo :: DatatypeInfo -> ConstructorInfo -> Q ConLiftInfo-mkCLInfo dti ci = do-  let cliEffName            = datatypeName dti--  (raw_cli_eff_args, [m_arg, raw_cli_res_arg]) <--    case splitAtEnd 2 $ datatypeInstTypes dti of-      r@(_, [_, _]) -> pure r-      _             -> missingEffArgs cliEffName--  m_name <--    case tVarName m_arg of-      Just r        -> pure r-      Nothing       -> mArgNotVar cliEffName m_arg--  cliUnionName <- newName "r"-  cliFunFixity <- reifyFixity $ constructorName ci--  let normalizeType         = replaceMArg m_name cliUnionName-                            . simplifyKinds-                            . applySubstitution eq_pairs-      -- We extract equality constraints with variables to unify them-      -- manually - this makes type errors more readable. Plus we replace-      -- kind of result with 'Type' if it is a type variable.-      (eq_pairs, cliFunCxt) = first (M.fromList . maybeResKindToType)-                            $ partitionEithers-                            $ eqPairOrCxt <$> constructorContext ci-      maybeResKindToType    = maybe id (\k ps -> (k, StarT) : ps)-                            $ tVarName $ tvKind $ last-                            $ datatypeVars dti--      cliEffArgs            = normalizeType <$> raw_cli_eff_args-      cliResType            = normalizeType     raw_cli_res_arg-      cliConName            = constructorName ci-      cliFunName            = liftFunNameFromCon cliConName-      arg_types             = normalizeType <$> constructorFields ci--  arg_names <- replicateM (length arg_types) $ newName "x"--  pure CLInfo{cliArgs = zip arg_names arg_types, ..}------------------------------------------------------------------------------------ Error messages and checks+-- Error messages and checks ------------------------------------------------- -mArgNotVar :: Name -> Type -> Q a-mArgNotVar name mArg = fail $ show-  $  text "Monad argument ‘" <> ppr mArg <> text "’ in effect ‘"-  <> ppr name <> text "’ is not a type variable"+argNotVar :: Name -> Type -> Q a+argNotVar eff_name arg = fail $ show+  $ text "Argument ‘" <> ppr arg <> text "’ in effect ‘" <> ppr eff_name+    <> text "’ is not a type variable" +-- | Fail the 'Q' monad whenever the given 'Extension's aren't enabled in the+-- current module.+checkExtensions :: [Extension] -> Q ()+checkExtensions exts = do+  states <- zip exts <$> traverse isExtEnabled exts+  maybe (pure ())+        (\(ext, _) -> fail $ show+          $ char '‘' <> text (show ext) <> char '’'+            <+> text "extension needs to be enabled for Polysemy's Template Haskell to work")+        (find (not . snd) states)  missingEffArgs :: Name -> Q a missingEffArgs name = fail $ show@@ -199,32 +217,58 @@     base = capturableBase name     args = PlainTV . mkName <$> ["m", "a"] +notDataCon :: Name -> Q a+notDataCon name = fail $ show+  $ char '‘' <> ppr name <> text "’ is not a data constructor" + --------------------------------------------------------------------------------- | Fail the 'Q' monad whenever the given 'Extension's aren't enabled in the--- current module.-checkExtensions :: [Extension] -> Q ()-checkExtensions exts = do-  states <- zip exts <$> traverse isExtEnabled exts-  maybe (pure ())-        (\(ext, _) -> fail $ show-          $ char '‘' <> text (show ext) <> char '’'-            <+> text "extension needs to be enabled for Polysemy's Template Haskell to work")-        (find (not . snd) states)+-- TH utilities --------------------------------------------------------------+------------------------------------------------------------------------------  ------------------------------------------------------------------------------+-- | Pattern constructing function type and matching on one that may contain+-- type annotations on arrow itself.+infixr 1 :->+pattern (:->) :: Type -> Type -> Type+pattern a :-> b <- (removeTyAnns -> ArrowT) `AppT` a `AppT` b where+  a :-> b = ArrowT `AppT` a `AppT` b+++------------------------------------------------------------------------------ -- | Constructs capturable name from base of input name. capturableBase :: Name -> Name capturableBase = mkName . nameBase + ------------------------------------------------------------------------------+-- | Converts names of all type variables in type to capturable ones based on+-- original name base. Use with caution, may create name conflicts!+capturableTVars :: Type -> Type+capturableTVars = everywhere $ mkT $ \case+  VarT n          -> VarT $ capturableBase n+  ForallT bs cs t -> ForallT (goBndr <$> bs) (capturableTVars <$> cs) t+    where+      goBndr (PlainTV n   ) = PlainTV $ capturableBase n+      goBndr (KindedTV n k) = KindedTV (capturableBase n) $ capturableTVars k+  t -> t+++------------------------------------------------------------------------------+-- | Folds a list of 'Type's into a right-associative arrow 'Type'.+foldArrowTs :: Type -> [Type] -> Type+foldArrowTs = foldr (:->)+++------------------------------------------------------------------------------ -- | Replaces use of @m@ in type with @Sem r@. replaceMArg :: TypeSubstitution t => Name -> Name -> t -> t replaceMArg m r = applySubstitution $ M.singleton m $ ConT ''Sem `AppT` VarT r + ------------------------------------------------------------------------------ -- Removes 'Type' and variable kind signatures from type.-simplifyKinds :: Type -> Type+simplifyKinds :: Data t => t -> t simplifyKinds = everywhere $ mkT $ \case   SigT t StarT    -> t   SigT t VarT{}   -> t@@ -235,54 +279,51 @@       goBndr b = b   t -> t ---------------------------------------------------------------------------------- | Converts equality constraint with type variable to name and type pair if--- possible or leaves constraint as is.-eqPairOrCxt :: Pred -> Either (Name, Type) Pred-eqPairOrCxt p = case asEqualPred p of-  Just (VarT n, b) -> Left (n, b)-  Just (a, VarT n) -> Left (n, a)-  _                -> Right p  --------------------------------------------------------------------------------- | Creates name of lifting function from action name.-liftFunNameFromCon :: Name -> Name-liftFunNameFromCon n = mkName $-  case nameBase n of-    ':' : cs -> cs-    c   : cs -> toLower c : cs-    ""       -> error "liftFunNameFromCon: empty constructor name"+splitAppTs :: Type -> [Type]+splitAppTs = removeTyAnns >>> \case+  t `AppT` arg -> splitAppTs t ++ [arg]+  t            -> [t] + --------------------------------------------------------------------------------- | Folds a list of 'Type's into a right-associative arrow 'Type'.-foldArrows :: Type -> [Type] -> Type-foldArrows = foldr (AppT . AppT ArrowT)+splitArrowTs :: Type -> [Type]+splitArrowTs = removeTyAnns >>> \case+  t :-> ts -> t : splitArrowTs ts+  t        -> [t] + ------------------------------------------------------------------------------ -- | Extracts name from type variable (possibly nested in signature and/or -- some context), returns 'Nothing' otherwise. tVarName :: Type -> Maybe Name-tVarName = \case-  ForallT _ _ t -> tVarName t-  SigT t _      -> tVarName t-  VarT n        -> Just n-  ParensT t     -> tVarName t-  _             -> Nothing+tVarName = removeTyAnns >>> \case+  VarT n -> Just n+  _      -> Nothing + --------------------------------------------------------------------------------- | 'splitAt' counting from the end.-splitAtEnd :: Int -> [a] -> ([a], [a])-splitAtEnd n = swap . join bimap reverse . splitAt n . reverse+topLevelConstraints :: Type -> Cxt+topLevelConstraints = \case+  ForallT _ cs _ -> cs+  _              -> [] + --------------------------------------------------------------------------------- | Converts names of all type variables in type to capturable ones based on--- original name base. Use with caution, may create name conflicts!-capturableTVars :: Type -> Type-capturableTVars = everywhere $ mkT $ \case-  VarT n          -> VarT $ capturableBase n-  ForallT bs cs t -> ForallT (goBndr <$> bs) (capturableTVars <$> cs) t-    where-      goBndr (PlainTV n   ) = PlainTV $ capturableBase n-      goBndr (KindedTV n k) = KindedTV (capturableBase n) $ capturableTVars k+removeTyAnns :: Type -> Type+removeTyAnns = \case+  ForallT _ _ t -> removeTyAnns t+  SigT t _      -> removeTyAnns t+  ParensT t     -> removeTyAnns t   t -> t ++------------------------------------------------------------------------------+-- Miscellaneous -------------------------------------------------------------+------------------------------------------------------------------------------++------------------------------------------------------------------------------+-- | 'splitAt' counting from the end.+splitAtEnd :: Int -> [a] -> ([a], [a])+splitAtEnd n = swap . join bimap reverse . splitAt n . reverse

@@ -1,10 +1,7 @@-{-# OPTIONS_HADDOCK not-home #-}--{-# LANGUAGE NamedFieldPuns  #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections   #-} +{-# OPTIONS_HADDOCK not-home #-}+ -- | This module provides Template Haskell functions for automatically generating -- effect operation functions (that is, functions that use 'send') from a given -- effect algebra. For example, using the @FileSystem@ effect from the example in@@ -38,6 +35,7 @@ import Polysemy.Internal.CustomErrors (DefiningModule) import Polysemy.Internal.TH.Common + -- TODO: write tests for what should (not) compile  ------------------------------------------------------------------------------@@ -79,7 +77,7 @@ -- * signatures have to specify argument of 'Sem' representing union of -- effects as @r@ (e.g. @'Sem' r ()@) -- * all arguments in effect's type constructor have to follow naming scheme--- from effect's declaration:+-- from data constructor's declaration: -- -- @ -- data Foo e m a where@@ -87,11 +85,11 @@ --   FooC2 :: Foo (Maybe x) m () -- @ ----- should have @e@ in type signature of @fooC1@:+-- should have @x@ in type signature of @fooC1@: ----- @fooC1 :: forall e r. Member (Foo e) r => Sem r ()@+-- @fooC1 :: forall x r. Member (Foo x) r => Sem r ()@ ----- but @x@ in signature of @fooC2@:+-- and @Maybe x@ in signature of @fooC2@: -- -- @fooC2 :: forall x r. Member (Foo (Maybe x)) r => Sem r ()@ --@@ -101,16 +99,19 @@ -- These restrictions may be removed in the future, depending on changes to -- the compiler. --+-- Change in (TODO(Sandy): version): in case of GADTs, signatures now only use+-- names from data constructor's type and not from type constructor+-- declaration.+-- -- @since 0.1.2.0 makeSem_ :: Name -> Q [Dec] makeSem_ = genFreer False -- NOTE(makeSem_):--- This function uses an ugly hack to work --- it enables change of names in--- annotation of applied data constructor to capturable ones, based of names--- in effect's definition. This allows user to provide them to us from their--- signature through 'forall' with 'ScopedTypeVariables' enabled, so that we--- can compile liftings of constructors with ambiguous type arguments (see--- issue #48).+-- This function uses an ugly hack to work --- it changes names in data+-- constructor's type to capturable ones. This allows user to provide them to+-- us from their signature through 'forall' with 'ScopedTypeVariables'+-- enabled, so that we can compile liftings of constructors with ambiguous+-- type arguments (see issue #48). -- -- Please, change this as soon as GHC provides some way of inspecting -- signatures, replacing code or generating haddock documentation in TH.@@ -122,12 +123,12 @@ genFreer :: Bool -> Name -> Q [Dec] genFreer should_mk_sigs type_name = do   checkExtensions [ScopedTypeVariables, FlexibleContexts]-  (dt_info, cl_infos) <- getEffectMetadata type_name+  (dt_name, cl_infos) <- getEffectMetadata type_name   tyfams_on  <- isExtEnabled TypeFamilies   def_mod_fi <- sequence [ tySynInstDCompat                              ''DefiningModule                              Nothing-                             [pure . ConT $ datatypeName dt_info]+                             [pure $ ConT dt_name]                              (LitT . StrTyLit . loc_module <$> location)                          | tyfams_on                          ]@@ -146,13 +147,13 @@   =  maybe [] (pure . flip InfixD (cliFunName cli)) (cliFunFixity cli)   ++ [ SigD (cliFunName cli) $ quantifyType        $ ForallT [] (member_cxt : cliFunCxt cli)-       $ foldArrows sem+       $ foldArrowTs sem        $ fmap snd-       $ cliArgs cli+       $ cliFunArgs cli      ]   where     member_cxt = makeMemberConstraint (cliUnionName cli) cli-    sem        = makeSemType (cliUnionName cli) (cliResType cli)+    sem        = makeSemType (cliUnionName cli) (cliEffRes cli)   ------------------------------------------------------------------------------@@ -160,7 +161,7 @@ -- @x a b c = send (X a b c :: E m a)@. genDec :: Bool -> ConLiftInfo -> Q [Dec] genDec should_mk_sigs cli = do-  let fun_args_names = fmap fst $ cliArgs cli+  let fun_args_names = fmap fst $ cliFunArgs cli    pure     [ PragmaD $ InlineP (cliFunName cli) Inlinable ConLike AllPhases

@@ -7,10 +7,15 @@      -- * Interpretations   , runNonDet+  , runNonDetMaybe+  , nonDetToError   ) where  import Control.Applicative+import Control.Monad.Trans.Maybe import Data.Maybe+import Polysemy+import Polysemy.Error import Polysemy.Internal import Polysemy.Internal.NonDet import Polysemy.Internal.Union@@ -55,17 +60,59 @@ ------------------------------------------------------------------------------ -- | Run a 'NonDet' effect in terms of some underlying 'Alternative' @f@. runNonDet :: Alternative f => Sem (NonDet ': r) a -> Sem r (f a)-runNonDet (Sem m) = Sem $ \k -> runNonDetC $ m $ \u ->+runNonDet = runNonDetC . runNonDetInC+{-# INLINE runNonDet #-}++runNonDetInC :: Sem (NonDet ': r) a -> NonDetC (Sem r) a+runNonDetInC = usingSem $ \u ->   case decomp u of     Left x  -> NonDetC $ \cons nil -> do-      z <- k $ weave [()]+      z <- liftSem $ weave [()]                      (fmap concat . traverse runNonDet)                      -- TODO(sandy): Is this the right semantics?                      listToMaybe                      x       foldr cons nil z     Right (Weaving Empty _ _ _ _) -> empty-    Right (Weaving (Choose ek) s _ y _) -> do-      z <- pure (ek False) <|> pure (ek True)-      pure $ y $ z <$ s+    Right (Weaving (Choose left right) s wv ex _) -> fmap ex $+      runNonDetInC (wv (left <$ s)) <|> runNonDetInC (wv (right <$ s))+{-# INLINE runNonDetInC #-} +------------------------------------------------------------------------------+-- | Run a 'NonDet' effect in terms of an underlying 'Maybe'+--+-- Unlike 'runNonDet', uses of '<|>' will not execute the+-- second branch at all if the first option succeeds.+runNonDetMaybe :: Sem (NonDet ': r) a -> Sem r (Maybe a)+runNonDetMaybe (Sem sem) = Sem $ \k -> runMaybeT $ sem $ \u ->+  case decomp u of+    Right (Weaving e s wv ex _) ->+      case e of+        Empty -> empty+        Choose left right ->+          MaybeT $ usingSem k $ runMaybeT $ fmap ex $ do+              MaybeT (runNonDetMaybe (wv (left <$ s)))+          <|> MaybeT (runNonDetMaybe (wv (right <$ s)))+    Left x -> MaybeT $+      k $ weave (Just ())+          (maybe (pure Nothing) runNonDetMaybe)+          id+          x+{-# INLINE runNonDetMaybe #-}++------------------------------------------------------------------------------+-- | Transform a 'NonDet' effect into an @'Error' e@ effect,+-- through providing an exception that 'empty' may be mapped to.+--+-- This allows '<|>' to handle 'throw's of the @'Error' e@ effect.+nonDetToError :: Member (Error e) r+              => e+              -> Sem (NonDet ': r) a+              -> Sem r a+nonDetToError (e :: e) = interpretH $ \case+  Empty -> throw e+  Choose left right -> do+    left'  <- nonDetToError e <$> runT left+    right' <- nonDetToError e <$> runT right+    raise (left' `catch` \(_ :: e) -> right')+{-# INLINE nonDetToError #-}

@@ -8,10 +8,10 @@   , output      -- * Interpretations-  , runOutputAsList-  , runFoldMapOutput-  , runIgnoringOutput-  , runBatchOutput+  , runOutputList+  , runOutputMonoid+  , ignoreOutput+  , runOutputBatched   ) where  import Data.Bifunctor (first)@@ -31,37 +31,43 @@  ------------------------------------------------------------------------------ -- | Run an 'Output' effect by transforming it into a list of its values.-runOutputAsList+--+-- @since 1.0.0.0+runOutputList     :: forall o r a      . Sem (Output o ': r) a     -> Sem r ([o], a)-runOutputAsList = fmap (first reverse) . runState [] . reinterpret+runOutputList = fmap (first reverse) . runState [] . reinterpret   (\case       Output o -> modify (o :)   )-{-# INLINE runOutputAsList #-}+{-# INLINE runOutputList #-}  ------------------------------------------------------------------------------ -- | Run an 'Output' effect by transforming it into a monoid.-runFoldMapOutput+--+-- @since 1.0.0.0+runOutputMonoid     :: forall o m r a      . Monoid m     => (o -> m)     -> Sem (Output o ': r) a     -> Sem r (m, a)-runFoldMapOutput f = runState mempty . reinterpret+runOutputMonoid f = runState mempty . reinterpret   (\case       Output o -> modify (`mappend` f o)   )-{-# INLINE runFoldMapOutput #-}+{-# INLINE runOutputMonoid #-}   ------------------------------------------------------------------------------ -- | Run an 'Output' effect by ignoring it.-runIgnoringOutput :: Sem (Output o ': r) a -> Sem r a-runIgnoringOutput = interpret $ \case+--+-- @since 1.0.0.0+ignoreOutput :: Sem (Output o ': r) a -> Sem r a+ignoreOutput = interpret $ \case   Output _ -> pure ()-{-# INLINE runIgnoringOutput #-}+{-# INLINE ignoreOutput #-}   ------------------------------------------------------------------------------@@ -71,16 +77,17 @@ -- If @size@ is 0, this interpretation will not emit anything in the resulting -- 'Output' effect. ----- @since 0.1.2.0-runBatchOutput+-- @since 1.0.0.0+runOutputBatched     :: forall o r a-     . Int+     . Member (Output [o]) r+    => Int     -> Sem (Output o ': r) a-    -> Sem (Output [o] ': r) a-runBatchOutput 0 m = raise $ runIgnoringOutput m-runBatchOutput size m = do+    -> Sem r a+runOutputBatched 0 m = ignoreOutput m+runOutputBatched size m = do   ((c, res), a) <--    runState (0 :: Int, [] :: [o]) $ reinterpret2 (\case+    runState (0 :: Int, [] :: [o]) $ reinterpret (\case       Output o -> do         (count, acc) <- get         let newCount = 1 + count@@ -91,6 +98,6 @@             output (reverse newAcc)             put (0 :: Int, [] :: [o])     ) m-  when (c > 0) $ output (reverse res)+  when (c > 0) $ output @[o] (reverse res)   pure a 

@@ -13,7 +13,7 @@   , runReader      -- * Interpretations for Other Effects-  , runInputAsReader+  , inputToReader   ) where  import Polysemy@@ -47,8 +47,10 @@  ------------------------------------------------------------------------------ -- | Transform an 'Input' effect into a 'Reader' effect.-runInputAsReader :: Member (Reader i) r => Sem (Input i ': r) a -> Sem r a-runInputAsReader = interpret $ \case+--+-- @since 1.0.0.0+inputToReader :: Member (Reader i) r => Sem (Input i ': r) a -> Sem r a+inputToReader = interpret $ \case   Input -> ask-{-# INLINE runInputAsReader #-}+{-# INLINE inputToReader #-} 

@@ -12,8 +12,8 @@      -- * Interpretations   , runResource-  , runResourceInIO-  , runResourceBase+  , lowerResource+  , resourceToIO   ) where  import qualified Control.Exception as X@@ -76,27 +76,25 @@ ------------------------------------------------------------------------------ -- | Run a 'Resource' effect via in terms of 'X.bracket'. ----- __Note:__ This function used to be called @runResource@ prior to 0.4.0.0.------ @since 0.4.0.0-runResourceInIO+-- @since 1.0.0.0+lowerResource     :: ∀ r a-     . Member (Lift IO) r+     . Member (Embed IO) r     => (∀ x. Sem r x -> IO x)        -- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is likely        -- some combination of 'runM' and other interpreters composed via '.@'.     -> Sem (Resource ': r) a     -> Sem r a-runResourceInIO finish = interpretH $ \case+lowerResource finish = interpretH $ \case   Bracket alloc dealloc use -> do     a <- runT  alloc     d <- bindT dealloc     u <- bindT use      let run_it :: Sem (Resource ': r) x -> IO x-        run_it = finish .@ runResourceInIO+        run_it = finish .@ lowerResource -    sendM $ X.bracket (run_it a) (run_it . d) (run_it . u)+    embed $ X.bracket (run_it a) (run_it . d) (run_it . u)    BracketOnError alloc dealloc use -> do     a <- runT  alloc@@ -104,16 +102,16 @@     u <- bindT use      let run_it :: Sem (Resource ': r) x -> IO x-        run_it = finish .@ runResourceInIO+        run_it = finish .@ lowerResource -    sendM $ X.bracketOnError (run_it a) (run_it . d) (run_it . u)-{-# INLINE runResourceInIO #-}+    embed $ X.bracketOnError (run_it a) (run_it . d) (run_it . u)+{-# INLINE lowerResource #-}   ------------------------------------------------------------------------------ -- | Run a 'Resource' effect purely. ----- @since 0.4.0.0+-- @since 1.0.0.0 runResource     :: ∀ r a      . Sem (Resource ': r) a@@ -150,28 +148,28 @@   --------------------------------------------------------------------------------- | A more flexible --- though less safe ---  version of 'runResourceInIO'.+-- | A more flexible --- though less safe ---  version of 'lowerResource'. -- -- This function is capable of running 'Resource' effects anywhere within an -- effect stack, without relying on an explicit function to lower it into 'IO'. -- Notably, this means that 'Polysemy.State.State' effects will be consistent -- in the presence of 'Resource'. ----- 'runResourceBase' is safe whenever you're concerned about exceptions thrown+-- ResourceToIO' is safe whenever you're concerned about exceptions thrown -- by effects _already handled_ in your effect stack, or in 'IO' code run -- directly inside of 'bracket'. It is not safe against exceptions thrown -- explicitly at the main thread. If this is not safe enough for your use-case,--- use 'runResourceInIO' instead.+-- use 'lowerResource' instead. -- -- This function creates a thread, and so should be compiled with @-threaded@. ----- @since 0.5.0.0-runResourceBase+-- @since 1.0.0.0+resourceToIO     :: forall r a-     . LastMember (Lift IO) r+     . LastMember (Embed IO) r     => Sem (Resource ': r) a     -> Sem r a-runResourceBase = interpretH $ \case+resourceToIO = interpretH $ \case   Bracket a b c -> do     ma <- runT a     mb <- bindT b@@ -179,7 +177,7 @@      withLowerToIO $ \lower finish -> do       let done :: Sem (Resource ': r) x -> IO x-          done = lower . raise . runResourceBase+          done = lower . raise . resourceToIO       X.bracket           (done ma)           (\x -> done (mb x) >> finish)@@ -192,9 +190,10 @@      withLowerToIO $ \lower finish -> do       let done :: Sem (Resource ': r) x -> IO x-          done = lower . raise . runResourceBase+          done = lower . raise . resourceToIO       X.bracketOnError           (done ma)           (\x -> done (mb x) >> finish)           (done . mc)-{-# INLINE runResourceBase #-}+{-# INLINE resourceToIO #-}+

@@ -12,8 +12,10 @@      -- * Interpretations   , runState+  , evalState   , runLazyState-  , runStateInIORef+  , evalLazyState+  , runStateIORef      -- * Interoperation with MTL   , hoistStateIntoStateT@@ -65,6 +67,15 @@   ------------------------------------------------------------------------------+-- | Run a 'State' effect with local state.+--+-- @since 1.0.0.0+evalState :: s -> Sem (State s ': r) a -> Sem r a+evalState s = fmap snd . runState s+{-# INLINE evalState #-}+++------------------------------------------------------------------------------ -- | Run a 'State' effect with local state, lazily. runLazyState :: s -> Sem (State s ': r) a -> Sem r (s, a) runLazyState = lazilyStateful $ \case@@ -72,21 +83,29 @@   Put s -> const $ pure (s, ()) {-# INLINE[3] runLazyState #-} +------------------------------------------------------------------------------+-- | Run a 'State' effect with local state, lazily.+--+-- @since 1.0.0.0+evalLazyState :: s -> Sem (State s ': r) a -> Sem r a+evalLazyState s = fmap snd . runLazyState s+{-# INLINE evalLazyState #-} + ------------------------------------------------------------------------------ -- | Run a 'State' effect by transforming it into operations over an 'IORef'. ----- @since 0.1.2.0-runStateInIORef+-- @since 1.0.0.0+runStateIORef     :: forall s r a-     . Member (Lift IO) r+     . Member (Embed IO) r     => IORef s     -> Sem (State s ': r) a     -> Sem r a-runStateInIORef ref = interpret $ \case-  Get   -> sendM $ readIORef ref-  Put s -> sendM $ writeIORef ref s-{-# INLINE runStateInIORef #-}+runStateIORef ref = interpret $ \case+  Get   -> embed $ readIORef ref+  Put s -> embed $ writeIORef ref s+{-# INLINE runStateIORef #-}   ------------------------------------------------------------------------------

@@ -8,13 +8,13 @@   , trace      -- * Interpretations-  , runTraceIO-  , runTraceAsList-  , runIgnoringTrace-  , runTraceAsOutput+  , traceToIO+  , runTraceList+  , ignoreTrace+  , traceToOutput      -- * Interpretations for Other Effects-  , runOutputAsTrace+  , outputToTrace   ) where  import Polysemy@@ -31,56 +31,62 @@  ------------------------------------------------------------------------------ -- | Run a 'Trace' effect by printing the messages to stdout.-runTraceIO :: Member (Lift IO) r => Sem (Trace ': r) a -> Sem r a-runTraceIO = interpret $ \case-  Trace m -> sendM $ putStrLn m-{-# INLINE runTraceIO #-}+--+-- @since 1.0.0.0+traceToIO :: Member (Embed IO) r => Sem (Trace ': r) a -> Sem r a+traceToIO = interpret $ \case+  Trace m -> embed $ putStrLn m+{-# INLINE traceToIO #-}   ------------------------------------------------------------------------------ -- | Run a 'Trace' effect by ignoring all of its messages.-runIgnoringTrace :: Member (Lift IO) r => Sem (Trace ': r) a -> Sem r a-runIgnoringTrace = interpret $ \case+--+-- @since 1.0.0.0+ignoreTrace :: Sem (Trace ': r) a -> Sem r a+ignoreTrace = interpret $ \case   Trace _ -> pure ()-{-# INLINE runIgnoringTrace #-}+{-# INLINE ignoreTrace #-}   ------------------------------------------------------------------------------ -- | Transform a 'Trace' effect into a 'Output' 'String' effect.-runTraceAsOutput+--+-- @since 1.0.0.0+traceToOutput     :: Member (Output String) r     => Sem (Trace ': r) a     -> Sem r a-runTraceAsOutput = interpret $ \case+traceToOutput = interpret $ \case   Trace m -> output m-{-# INLINE runTraceAsOutput #-}+{-# INLINE traceToOutput #-}   ------------------------------------------------------------------------------ -- | Get the result of a 'Trace' effect as a list of 'String's. ----- @since 0.5.0.0-runTraceAsList+-- @since 1.0.0.0+runTraceList     :: Sem (Trace ': r) a     -> Sem r ([String], a)-runTraceAsList = runOutputAsList . reinterpret (+runTraceList = runOutputList . reinterpret (   \case     Trace m -> output m   )-{-# INLINE runTraceAsList #-}+{-# INLINE runTraceList #-}   ------------------------------------------------------------------------------ -- | Transform a 'Trace' effect into a 'Output' 'String' effect. ----- @since 0.1.2.0-runOutputAsTrace+-- @since 1.0.0.0+outputToTrace     :: ( Show w        , Member Trace r        )     => Sem (Output w ': r) a     -> Sem r a-runOutputAsTrace = interpret $ \case+outputToTrace = interpret $ \case   Output m -> trace $ show m-{-# INLINE runOutputAsTrace #-}+{-# INLINE outputToTrace #-} 

@@ -15,7 +15,7 @@   , runWriter      -- * Interpretations for Other Effects-  , runOutputAsWriter+  , outputToWriter   ) where  import Polysemy@@ -43,10 +43,12 @@  ------------------------------------------------------------------------------ -- | Transform an 'Output' effect into a 'Writer' effect.-runOutputAsWriter :: Member (Writer o) r => Sem (Output o ': r) a -> Sem r a-runOutputAsWriter = interpret $ \case+--+-- @since 1.0.0.0+outputToWriter :: Member (Writer o) r => Sem (Output o ': r) a -> Sem r a+outputToWriter = interpret $ \case   Output o -> tell o-{-# INLINE runOutputAsWriter #-}+{-# INLINE outputToWriter #-}   ------------------------------------------------------------------------------@@ -75,3 +77,4 @@         pure (fmap snd t)   ) {-# INLINE runWriter #-}+

@@ -4,17 +4,24 @@ import Polysemy.NonDet import Test.Hspec import Control.Applicative+import Polysemy.Trace  semFail :: Member NonDet r => Maybe Bool -> Sem r Bool semFail mb = do   Just b <- pure mb   pure b - runAlt :: Alternative f => Sem '[NonDet] a -> f a runAlt = run . runNonDet +failtrace :: (Member NonDet r, Member Trace r)+          => Sem r ()+failtrace = pure () <|> trace "trace" +failtrace' :: (Member NonDet r, Member Trace r)+           => Sem r ()+failtrace' = trace "sim" *> empty <|> trace "salabim"+ spec :: Spec spec = parallel $ do   describe "Alternative instance" $ do@@ -32,3 +39,15 @@       runAlt (semFail $ Just True) `shouldBe` Just True       runAlt (semFail $ Just False) `shouldBe` [False] +  describe "runNonDetMaybe" $ do+    it "should skip second branch if the first branch succeeds" $ do+      (run . runNonDetMaybe . runTraceList) failtrace+        `shouldBe` Just ([], ())+      (run . runTraceList . runNonDetMaybe) failtrace+        `shouldBe` ([], Just ())++    it "should respect local/global state semantics" $ do+      (run . runNonDetMaybe . runTraceList) failtrace'+        `shouldBe` Just (["salabim"], ())+      (run . runTraceList . runNonDetMaybe) failtrace'+        `shouldBe` (["sim", "salabim"], Just ())

@@ -15,9 +15,9 @@ spec = describe "async" $ do   it "should thread state and not lock" $ do     (ts, (s, r)) <- runM-                  . runTraceAsList+                  . runTraceList                   . runState "hello"-                  . runAsync $ do+                  . asyncToIO $ do       let message :: Member Trace r => Int -> String -> Sem r ()           message n msg = trace $ mconcat             [ show n, "> ", msg ]@@ -27,14 +27,14 @@           message 1 v           put $ reverse v -          sendM $ threadDelay 1e5+          embed $ threadDelay 1e5           get >>= message 1 -          sendM $ threadDelay 1e5+          embed $ threadDelay 1e5           get @String        void $ async $ do-          sendM $ threadDelay 5e4+          embed $ threadDelay 5e4           get >>= message 2           put "pong" 

@@ -13,18 +13,18 @@   :: Sem '[Error (), Resource, State [Char], Trace] a   -> ([String], ([Char], Either () a)) runTest = run-        . runTraceAsList+        . runTraceList         . runState ""         . runResource         . runError @()  runTest2-  :: Sem '[Error (), Resource, State [Char], Trace, Lift IO] a+  :: Sem '[Error (), Resource, State [Char], Trace, Embed IO] a   -> IO ([String], ([Char], Either () a)) runTest2 = runM-         . runTraceAsList+         . runTraceList          . runState ""-         . runResourceBase+         . resourceToIO          . runError @()  

@@ -23,6 +23,8 @@   , "-XTypeOperators"   , "-XUnicodeSyntax" +  , "-package type-errors"+ #if __GLASGOW_HASKELL__ < 806   , "-XMonadFailDesugaring"   , "-XTypeInType"@@ -32,6 +34,7 @@    -- Modules that are explicitly imported for this test must be listed here   , "src/Polysemy.hs"+  , "src/Polysemy/Error.hs"   , "src/Polysemy/Output.hs"   , "src/Polysemy/Reader.hs"   , "src/Polysemy/Resource.hs"

@@ -25,7 +25,7 @@       void . (runM .@ runCallback ref)            . runState False            $ do-        sendM $ pretendPrint ref "hello world"+        embed $ pretendPrint ref "hello world"         callback $ show <$> get @Bool         modify not         callback $ show <$> get @Bool@@ -47,7 +47,7 @@   runCallback-    :: Member (Lift IO) r+    :: Member (Embed IO) r     => IORef [String]     -> (forall x. Sem r x -> IO x)     -> Sem (Callback ': r) a@@ -56,7 +56,7 @@   Callback cb -> do     cb' <- runT cb     ins <- getInspectorT-    sendM $ doCB ref $ do+    embed $ doCB ref $ do       v <- lower .@ runCallback ref $ cb'       pure $ maybe ":(" id $ inspect ins v     getInitialStateT

@@ -16,7 +16,7 @@ spec = describe "intercept" $ do   it "should weave through embedded computations" $ do     let (msgs, ()) = run-                   . runTraceAsList+                   . runTraceList                    . runResource                    . withTraceLogging $ do           trace "outside"

@@ -8,7 +8,7 @@  spec :: Spec spec = parallel $ do-  describe "runBatchOutput" $ do+  describe "runOutputBatched" $ do     it "should return nothing at batch size 0" $ do       let (ms, _) = runOutput 0 $ traverse (output @Int) [0..99]       length ms `shouldBe` 0@@ -23,14 +23,14 @@         it "returns all original elements in the correct order" $           concat ms `shouldBe` [0..99] -  describe "runOutputAsList" $+  describe "runOutputList" $     it "should return elements in the order they were output" $-      let (xs, ()) = runOutputAsList' $ traverse_ (output @Int) [0..100]+      let (xs, ()) = runOutputList' $ traverse_ (output @Int) [0..100]        in xs `shouldBe` [0..100]  -runOutput :: Int -> Sem '[Output Int] a -> ([[Int]], a)-runOutput size = run . runFoldMapOutput (:[]) . runBatchOutput size+runOutput :: Int -> Sem '[Output Int, Output [Int]] a -> ([[Int]], a)+runOutput size = run . runOutputMonoid (:[]) . runOutputBatched size -runOutputAsList' :: Sem '[Output Int] a -> ([Int], a)-runOutputAsList' = run . runOutputAsList+runOutputList' :: Sem '[Output Int] a -> ([Int], a)+runOutputList' = run . runOutputList

@@ -36,12 +36,12 @@  makeSem ''GADTSyntax -data ADTSyntax1 m a = (a ~ Int) => ADTSyntax1C String+data ADTSyntax1 m a = a ~ Int => ADTSyntax1C String  makeSem ''ADTSyntax1  data ADTSyntax2 m a-  = a ~ Int => ADTSyntax2C1 Int+  = a ~ Int    => ADTSyntax2C1 Int   | a ~ String => ADTSyntax2C2 String  makeSem ''ADTSyntax2@@ -69,7 +69,7 @@  -- Data families ------------------------------------------------------------- -data Instance = ADTI | GADTI | NTI+data Instance = ADTI | GADTI | NTI | MMI  data family Family (s :: Instance) (m :: Type -> Type) a @@ -86,6 +86,12 @@ newtype instance Family 'NTI m a = NTIC Int  makeSem 'NTIC++data instance Family 'MMI m (f m) where+  MMIC1 :: f m -> Family 'MMI m (f m)+  MMIC2 :: (forall x. m x -> m (f m)) -> Family 'MMI m (f m)++makeSem 'MMIC1  -- Phantom types ------------------------------------------------------------- 

@@ -61,13 +61,13 @@ -------------------------------------------------------------------------------- -- | -- >>> :{--- runFoldMapOutput+-- runOutputMonoid --     :: forall o m r a --      . Monoid m --     => (o -> m) --     -> Sem (Output o ': r) a --     -> Sem r (m, a)--- runFoldMapOutput f = runState mempty . reinterpret $ \case+-- runOutputMonoid f = runState mempty . reinterpret $ \case --   Output o -> modify (`mappend` f o) -- :} -- ...@@ -85,13 +85,13 @@ --     foo = pure () --     foo' = reinterpretScrub foo --     foo'' = runState True foo'---     foo''' = runTraceIO foo''+--     foo''' = traceToIO foo'' --  in runM foo''' -- :} -- ...--- ... Unhandled effect 'Lift IO'+-- ... Unhandled effect 'Embed IO' -- ...--- ... Expected type: Sem '[Lift m] (Bool, ())+-- ... Expected type: Sem '[Embed m] (Bool, ()) -- ... Actual type: Sem '[] (Bool, ()) -- ... runningTooManyEffects = ()@@ -116,7 +116,7 @@ -- >>> :{ -- let foo :: Member Resource r => Sem r () --     foo = undefined---  in runM $ runResourceInIO foo+--  in runM $ lowerResource foo -- :} -- ... -- ... Couldn't match expected type ...@@ -142,7 +142,7 @@ -------------------------------------------------------------------------------- -- | -- >>> :{--- foo :: Sem '[State Int, Lift IO] ()+-- foo :: Sem '[State Int, Embed IO] () -- foo = output () -- :} -- ...