polysemy (empty) → 0.1.0.0

raw patch · 32 files changed

+3011/−0 lines, 32 filesdep +basedep +criteriondep +dump-coresetup-changed

Dependencies added: base, criterion, dump-core, free, freer-simple, hspec, inspection-testing, mtl, polysemy, random, syb, template-haskell, transformers

Files

• ChangeLog.md +3/−0
• LICENSE +30/−0
• README.md +158/−0
• Setup.hs +2/−0
• bench/Poly.hs +45/−0
• bench/countDown.hs +133/−0
• polysemy.cabal +123/−0
• src/Polysemy.hs +123/−0
• src/Polysemy/Error.hs +123/−0
• src/Polysemy/Fixpoint.hs +41/−0
• src/Polysemy/Input.hs +61/−0
• src/Polysemy/Internal.hs +290/−0
• src/Polysemy/Internal/Combinators.hs +321/−0
• src/Polysemy/Internal/CustomErrors.hs +149/−0
• src/Polysemy/Internal/Effect.hs +116/−0
• src/Polysemy/Internal/Fixpoint.hs +7/−0
• src/Polysemy/Internal/Lift.hs +29/−0
• src/Polysemy/Internal/NonDet.hs +12/−0
• src/Polysemy/Internal/TH/Effect.hs +203/−0
• src/Polysemy/Internal/TH/Performance.hs +84/−0
• src/Polysemy/Internal/Tactics.hs +174/−0
• src/Polysemy/Internal/Union.hs +233/−0
• src/Polysemy/NonDet.hs +67/−0
• src/Polysemy/Output.hs +48/−0
• src/Polysemy/Random.hs +59/−0
• src/Polysemy/Reader.hs +56/−0
• src/Polysemy/Resource.hs +57/−0
• src/Polysemy/State.hs +76/−0
• src/Polysemy/Trace.hs +50/−0
• src/Polysemy/Writer.hs +61/−0
• test/FusionSpec.hs +76/−0
• test/Main.hs +1/−0

@@ -0,0 +1,3 @@+# Changelog for too-fast-too-free++## Unreleased changes

@@ -0,0 +1,30 @@+Copyright Sandy Maguire (c) 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Sandy Maguire nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,158 @@+# polysemy++[![Build Status](https://api.travis-ci.org/isovector/polysemy.svg?branch=master)](https://travis-ci.org/isovector/polysemy)+[![Hackage](https://img.shields.io/hackage/v/polysemy.svg?logo=haskell)](https://hackage.haskell.org/package/polysemy)++## Dedication++> The word 'good' has many meanings. For example, if a man were to shoot his+> grandmother at a range of five hundred yards, I should call him a good shot,+> but not necessarily a good man.+>+> Gilbert K. Chesterton+++## Overview++`polysemy` is a library for writing high-power, low-boilerplate, zero-cost,+domain specific languages. It allows you to separate your business logic from+your implementation details. And in doing so, `polysemy` lets you turn your+implementation code into reusable library code.++It's like `mtl` but composes better, requires less boilerplate, and avoids the+O(n^2) instances problem.++It's like `freer-simple` but more powerful and 700x faster.++It's like `fused-effects` but with an order of magnitude less boilerplate.+++## Features++* *Effects are higher-order,* meaning it's trivial to write `bracket` and `local`+    as first-class effects.+* *Effects are low-boilerplate,* meaning you can create new effects in a+    single-digit number of lines. New interpreters are nothing but functions and+    pattern matching.+* *Effects are zero-cost,* meaning that GHC<sup>[1](#fn1)</sup> can optimize+    away the entire abstraction at compile time.+++<sup><a name="fn1">1</a></sup>: Unfortunately this is not true in GHC 8.6.3, but+will be true as soon as [my patch](https://gitlab.haskell.org/ghc/ghc/merge_requests/668/) lands.+++## Examples++Console effect:++```haskell+{-# LANGAUGE TemplateHaskell #-}++import Polysemy++data Console m a where+  GetLine :: Console m String+  PutLine :: String -> Console m ()++makeSemantic ''Console++runConsoleIO :: Member (Lift IO) r => Semantic (Console ': r) a -> Semantic r a+runConsoleIO = interpret $ \case+  GetLine     -> sendM getLine+  PutLine msg -> sendM $ putStrLn msg+```+++Resource effect:++```haskell+{-# LANGUAGE TemplateHaskell #-}++import qualified Control.Exception as X+import           Polysemy++data Resource m a where+  Bracket :: m a -> (a -> m ()) -> (a -> m b) -> Resource m b++makeSemantic ''Resource++runResource+    :: forall r a+     . Member (Lift IO) r+    => (∀ x. Semantic r x -> IO x)+    -> Semantic (Resource ': r) a+    -> Semantic r a+runResource finish = interpretH $ \case+  Bracket alloc dealloc use -> do+    a <- runT  alloc+    d <- bindT dealloc+    u <- bindT use++    let runIt :: Semantic (Resource ': r) x -> IO x+        runIt = finish .@ runResource++    sendM $ X.bracket (runIt a) (runIt . d) (runIt . u)+```++Easy.+++## Friendly Error Messages++Free monad libraries aren't well known for their ease-of-use. But following in+the shoes of `freer-simple`, `polysemy` takes a serious stance on providing+helpful error messages.++For example, the library exposes both the `interpret` and `interpretH`+combinators. If you use the wrong one, the library's got your back:++```haskell+runResource+    :: forall r a+     . Member (Lift IO) r+    => (∀ x. Semantic r x -> IO x)+    -> Semantic (Resource ': r) a+    -> Semantic r a+runResource finish = interpret $ \case+  ...+```++makes the helpful suggestion:++```+    • 'Resource' is higher-order, but 'interpret' can help only+      with first-order effects.+      Fix:+        use 'interpretH' instead.+    • In the expression:+        interpret+          $ \case+```++Likewise it will give you tips on what to do if you forget a `TypeApplication`+or forget to handle an effect.++Don't like helpful errors? That's OK too --- just flip the `error-messages` flag+and enjoy the raw, unadulterated fury of the typesystem.+++## Necessary Language Extensions++You're going to want to stick all of this into your `package.yaml` file.++```yaml+  ghc-options: -O2 -flate-specialise -fspecialise-aggressively+  default-extensions:+    - DataKinds+    - FlexibleContexts+    - GADTs+    - LambdaCase+    - PolyKinds+    - RankNTypes+    - ScopedTypeVariables+    - TypeApplications+    - TypeOperators+    - TypeFamilies+```+

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,45 @@+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs            #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -fwarn-all-missed-specializations #-}++module Poly where++import Polysemy+import Polysemy.Error+import Polysemy.Resource+import Polysemy.State+++slowBeforeSpecialization :: Member (State Int) r => Semantic r Int+slowBeforeSpecialization = do+  n <- get+  if n <= 0+     then pure n+     else do+       put $ n - 1+       slowBeforeSpecialization++{-# SPECIALIZE slowBeforeSpecialization :: Semantic '[State Int] Int #-}+++countDown :: Int -> Int+countDown s =+  fst . run . runState s $ slowBeforeSpecialization++prog+    :: Semantic '[ State Bool+                 , Error Bool+                 , Resource+                 , Lift IO+                 ] Bool+prog = catch @Bool (throw True) (pure . not)++zoinks :: IO (Either Bool Bool)+zoinks = fmap (fmap snd)+       . (runM .@ runResource .@@ runErrorInIO)+       . runState False+       $ prog+

@@ -0,0 +1,133 @@+{-# LANGUAGE DataKinds, DeriveFunctor, FlexibleContexts, GADTs, TypeOperators #-}+module Main (main) where++import Control.Monad (replicateM_)++import qualified Control.Monad.Except as MTL+import qualified Control.Monad.State as MTL+import qualified Control.Monad.Free as Free++import Criterion (bench, bgroup, whnf)+import Criterion.Main (defaultMain)++import Control.Monad.Freer (Member, Eff, run, send)+import Control.Monad.Freer.Internal (Eff(..), decomp, qApp, tsingleton)+import Control.Monad.Freer.Error (runError, throwError)+import Control.Monad.Freer.State (get, put, runState)++import qualified Poly as P++--------------------------------------------------------------------------------+                        -- State Benchmarks --+--------------------------------------------------------------------------------++oneGet :: Int -> (Int, Int)+oneGet n = run (runState n get)++oneGetMTL :: Int -> (Int, Int)+oneGetMTL = MTL.runState MTL.get++countDown :: Int -> (Int, Int)+countDown start = run (runState start go)+  where go = get >>= (\n -> if n <= 0 then pure n else put (n-1) >> go)++countDownMTL :: Int -> (Int, Int)+countDownMTL = MTL.runState go+  where go = MTL.get >>= (\n -> if n <= 0 then pure n else MTL.put (n-1) >> go)++--------------------------------------------------------------------------------+                       -- Exception + State --+--------------------------------------------------------------------------------+countDownExc :: Int -> Either String (Int,Int)+countDownExc start = run $ runError (runState start go)+  where go = get >>= (\n -> if n <= (0 :: Int) then throwError "wat" else put (n-1) >> go)++countDownExcMTL :: Int -> Either String (Int,Int)+countDownExcMTL = MTL.runStateT go+  where go = MTL.get >>= (\n -> if n <= (0 :: Int) then MTL.throwError "wat" else MTL.put (n-1) >> go)++--------------------------------------------------------------------------------+                          -- Freer: Interpreter --+--------------------------------------------------------------------------------+data Http out where+  Open :: String -> Http ()+  Close :: Http ()+  Post  :: String -> Http String+  Get   :: Http String++open' :: Member Http r => String -> Eff r ()+open'  = send . Open++close' :: Member Http r => Eff r ()+close' = send Close++post' :: Member Http r => String -> Eff r String+post' = send . Post++get' :: Member Http r => Eff r String+get' = send Get++runHttp :: Eff (Http ': r) w -> Eff r w+runHttp (Val x) = pure x+runHttp (E u q) = case decomp u of+  Right (Open _) -> runHttp (qApp q ())+  Right Close    -> runHttp (qApp q ())+  Right (Post d) -> runHttp (qApp q d)+  Right Get      -> runHttp (qApp q "")+  Left u'        -> E u' (tsingleton (runHttp . qApp q ))++--------------------------------------------------------------------------------+                          -- Free: Interpreter --+--------------------------------------------------------------------------------+data FHttpT x+  = FOpen String x+  | FClose x+  | FPost String (String -> x)+  | FGet (String -> x)+    deriving Functor++type FHttp = Free.Free FHttpT++fopen' :: String -> FHttp ()+fopen' s = Free.liftF $ FOpen s ()++fclose' :: FHttp ()+fclose' = Free.liftF $ FClose ()++fpost' :: String -> FHttp String+fpost' s = Free.liftF $ FPost s id++fget' :: FHttp String+fget' = Free.liftF $ FGet id++runFHttp :: FHttp a -> Maybe a+runFHttp (Free.Pure x) = pure x+runFHttp (Free.Free (FOpen _ n)) = runFHttp n+runFHttp (Free.Free (FClose n))  = runFHttp n+runFHttp (Free.Free (FPost s n)) = pure s  >>= runFHttp . n+runFHttp (Free.Free (FGet n))    = pure "" >>= runFHttp . n++--------------------------------------------------------------------------------+                        -- Benchmark Suite --+--------------------------------------------------------------------------------+prog :: Member Http r => Eff r ()+prog = open' "cats" >> get' >> post' "cats" >> close'++prog' :: FHttp ()+prog' = fopen' "cats" >> fget' >> fpost' "cats" >> fclose'++p :: Member Http r => Int -> Eff r ()+p count   =  open' "cats" >> replicateM_ count (get' >> post' "cats") >>  close'++p' :: Int -> FHttp ()+p' count  = fopen' "cats" >> replicateM_ count (fget' >> fpost' "cats") >> fclose'++main :: IO ()+main =+  defaultMain [+    bgroup "Countdown Bench" [+        bench "discount"          $ whnf P.countDown 10000+      , bench "freer-simple"      $ whnf countDown 10000+      , bench "mtl"               $ whnf countDownMTL 10000+    ]+  ]

@@ -0,0 +1,123 @@+cabal-version: 1.12+name: polysemy+version: 0.1.0.0+license: BSD3+license-file: LICENSE+copyright: 2019 Sandy Maguire+maintainer: sandy@sandymaguire.me+author: Sandy Maguire+homepage: https://github.com/isovector/polysemy#readme+bug-reports: https://github.com/isovector/polysemy/issues+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+build-type: Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+    type: git+    location: https://github.com/isovector/polysemy++flag dump-core+    description:+        Dump HTML for the core generated by GHC during compilation+    default: False+    manual: True++flag error-messages+    description:+        Provide custom error messages+    manual: True++library+    exposed-modules:+        Polysemy+        Polysemy.Error+        Polysemy.Fixpoint+        Polysemy.Input+        Polysemy.Internal+        Polysemy.Internal.Combinators+        Polysemy.Internal.CustomErrors+        Polysemy.Internal.Effect+        Polysemy.Internal.Fixpoint+        Polysemy.Internal.Lift+        Polysemy.Internal.NonDet+        Polysemy.Internal.Tactics+        Polysemy.Internal.TH.Effect+        Polysemy.Internal.TH.Performance+        Polysemy.Internal.Union+        Polysemy.NonDet+        Polysemy.Output+        Polysemy.Random+        Polysemy.Reader+        Polysemy.Resource+        Polysemy.State+        Polysemy.Trace+        Polysemy.Writer+    hs-source-dirs: src+    other-modules:+        Paths_polysemy+    default-language: Haskell2010+    default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs+                        LambdaCase PolyKinds RankNTypes ScopedTypeVariables+                        StandaloneDeriving TypeApplications TypeOperators TypeFamilies+                        UnicodeSyntax+    ghc-options: -O2 -Wall+    build-depends:+        base >=4.7 && <5,+        mtl >=2.2.2 && <2.3,+        random ==1.1.*,+        syb ==0.7.*,+        template-haskell >=2.14.0.0 && <2.15,+        transformers >=0.5.5.0 && <0.6+    +    if flag(dump-core)+        ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html+        build-depends:+            dump-core >=0.1.3.2 && <0.2+    +    if flag(error-messages)+        cpp-options: -DERROR_MESSAGES++test-suite polysemy-test+    type: exitcode-stdio-1.0+    main-is: Main.hs+    hs-source-dirs: test+    other-modules:+        FusionSpec+        Paths_polysemy+    default-language: Haskell2010+    ghc-options: -threaded -rtsopts -with-rtsopts=-N+    build-depends:+        base >=4.7 && <5,+        hspec >=2.6.0 && <2.7,+        inspection-testing >=0.4.1.1 && <0.5,+        mtl >=2.2.2 && <2.3,+        polysemy -any,+        random ==1.1.*,+        syb ==0.7.*,+        template-haskell >=2.14.0.0 && <2.15,+        transformers >=0.5.5.0 && <0.6++benchmark polysemy-bench+    type: exitcode-stdio-1.0+    main-is: countDown.hs+    hs-source-dirs: bench+    other-modules:+        Poly+        Paths_polysemy+    default-language: Haskell2010+    build-depends:+        base >=4.7 && <5,+        criterion >=1.5.3.0 && <1.6,+        free ==5.1.*,+        freer-simple >=1.2.1.0 && <1.3,+        mtl >=2.2.2 && <2.3,+        polysemy -any,+        random ==1.1.*,+        syb ==0.7.*,+        template-haskell >=2.14.0.0 && <2.15,+        transformers >=0.5.5.0 && <0.6

@@ -0,0 +1,123 @@+module Polysemy+  ( -- * Core Types+    Semantic ()+  , Member++  -- * Running Semantic+  , run+  , runM++  -- * Interoperating With Other Monads+  , Lift ()+  , sendM++    -- * Lifting+  , raise++    -- * Creating New Effects+    -- | Effects should be defined as a GADT (enable @-XGADTs@), with kind @(* -> *) -> *@.+    -- Every primitive action in the effect should be its own constructor of+    -- the type. For example, we can model an effect which interacts with a tty+    -- console as follows:+    --+    -- @+    -- data Console m a where+    --   WriteLine :: String -> Console m ()+    --   ReadLine  :: Console m String+    -- @+    --+    -- Notice that the 'a' parameter gets instataniated at the /desired return+    -- type/ of the actions. Writing a line returns a '()', but reading one+    -- returns 'String'.+    --+    -- By enabling @-XTemplateHaskell@, we can use the 'makeSemantic' function+    -- to generate smart constructors for the actions. These smart constructors+    -- can be invoked directly inside of the 'Semantic' monad.+    --+    -- >>> makeSemantic ''Console+    --+    -- results in the following definitions:+    --+    -- @+    -- writeLine :: 'Member' Console r => String -> 'Semantic' r ()+    -- readLine  :: 'Member' Console r => 'Semantic' r String+    -- @+    --+    -- Effects which don't make use of the @m@ parameter are known as+    -- "first-order effects."++    -- ** Higher-Order Effects+    -- | Every effect has access to the @m@ parameter, which corresponds to the+    -- 'Semantic' monad it's used in. Using this parameter, we're capable of+    -- writing effects which themselves contain subcomputations.+    --+    -- For example, the definition of 'Polysemy.Error.Error' is+    --+    -- @+    -- data 'Polysemy.Error.Error' e m a where+    --   'Polysemy.Error.Throw' :: e -> 'Polysemy.Error.Error' e m a+    --   'Polysemy.Error.Catch' :: m a -> (e -> m a) -> 'Polysemy.Error.Error' e m a+    -- @+    --+    -- where 'Polysemy.Error.Catch' is an action that can run an exception+    -- handler if its first argument calls 'Polysemy.Error.throw'.+    --+    -- >>> makeSemantic ''Error+    --+    -- @+    -- 'Polysemy.Error.throw' :: 'Member' ('Polysemy.Error.Error' e) r => e -> 'Semantic' r a+    -- 'Polysemy.Error.catch'  :: 'Member' ('Polysemy.Error.Error' e) r => 'Semantic' r a -> (e -> 'Semantic' r a) -> 'Semantic' r a+    -- @+    --+    -- As you see, in the smart constructors, the @m@ parameter has become @'Semantic' r@.+  , makeSemantic+  , makeSemantic_++    -- * Combinators for Interpreting First-Order Effects+  , interpret+  , intercept+  , reinterpret+  , reinterpret2+  , reinterpret3++    -- * Combinators for Interpreting Higher-Order Effects+  , interpretH+  , interceptH+  , reinterpretH+  , reinterpret2H+  , reinterpret3H++    -- * Improving Performance for Interpreters+  , inlineRecursiveCalls++    -- * Composing IO-based Interpreters+  , (.@)+  , (.@@)++    -- * Tactics+    -- | Higher-order effects need to explicitly thread /other effects'/ state+    -- through themselves. Tactics are a domain-specific language for describing+    -- exactly how this threading should take place.+    --+    -- The first computation to be run should use 'runT', and subsequent+    -- computations /in the same environment/ should use 'bindT'. Any+    -- first-order constructors which appear in a higher-order context may use+    -- 'pureT' to satisfy the typechecker.+  , Tactical+  , WithTactics+  , getInitialStateT+  , pureT+  , runT+  , bindT++  -- * Reexports+  , Typeable+  ) where++import Data.Typeable+import Polysemy.Internal+import Polysemy.Internal.Combinators+import Polysemy.Internal.TH.Effect+import Polysemy.Internal.TH.Performance+import Polysemy.Internal.Tactics+

@@ -0,0 +1,123 @@+{-# LANGUAGE TemplateHaskell #-}++module Polysemy.Error+  ( -- * Effect+    Error (..)++    -- * Actions+  , throw+  , catch++    -- * Interpretations+  , runError+  , runErrorInIO+  ) where++import qualified Control.Exception as X+import qualified Control.Monad.Trans.Except as E+import           Data.Bifunctor (first)+import           Data.Typeable+import           Polysemy+import           Polysemy.Internal+import           Polysemy.Internal.Effect+import           Polysemy.Internal.Union+++data Error e m a where+  Throw :: e -> Error e m a+  Catch :: ∀ e m a. m a -> (e -> m a) -> Error e m a++makeSemantic ''Error+++------------------------------------------------------------------------------+-- | Run an 'Error' effect in the style of+-- 'Control.Monad.Trans.Except.ExceptT'.+runError+    :: Typeable e+    => Semantic (Error e ': r) a+    -> Semantic r (Either e a)+runError (Semantic m) = Semantic $ \k -> E.runExceptT $ m $ \u ->+  case decomp u of+    Left x -> E.ExceptT $ k $+      weave (Right ()) (either (pure . Left) runError_b) x+    Right (Yo (Throw e) _ _ _) -> E.throwE e+    Right (Yo (Catch try handle) s d y) ->+      E.ExceptT $ usingSemantic k $ do+        ma <- runError_b $ d $ try <$ s+        case ma of+          Right a -> pure . Right $ y a+          Left e -> do+            ma' <- runError_b $ d $ (<$ s) $ handle e+            case ma' of+              Left e' -> pure $ Left e'+              Right a -> pure . Right $ y a+{-# INLINE runError #-}++runError_b+    :: Typeable e+    => Semantic (Error e ': r) a+    -> Semantic r (Either e a)+runError_b = runError+{-# NOINLINE runError_b #-}+++newtype WrappedExc e = WrappedExc { unwrapExc :: e }+  deriving (Typeable)++instance Typeable e => Show (WrappedExc e) where+  show = mappend "WrappedExc: " . show . typeRep++instance (Typeable e) => X.Exception (WrappedExc e)+++------------------------------------------------------------------------------+-- | Run an 'Error' effect as an 'IO' 'X.Exception'. This interpretation is+-- significantly faster than 'runError', at the cost of being less flexible.+runErrorInIO+    :: ( Typeable e+       , Member (Lift IO) r+       )+    => (∀ x. Semantic r x -> IO x)+       -- ^ Strategy for lowering a 'Semantic' action down to 'IO'. This is+       -- likely some combination of 'runM' and other interpters composed via+       -- '.@'.+    -> Semantic (Error e ': r) a+    -> Semantic r (Either e a)+runErrorInIO lower+    = sendM+    . fmap (first unwrapExc)+    . X.try+    . (lower .@ runErrorAsExc)+{-# INLINE runErrorInIO #-}+++runErrorAsExc+    :: forall e r a. ( Typeable e+       , Member (Lift IO) r+       )+    => (∀ x. Semantic r x -> IO x)+    -> Semantic (Error e ': r) a+    -> Semantic r a+runErrorAsExc lower = interpretH $ \case+  Throw e -> sendM $ X.throwIO $ WrappedExc e+  Catch try handle -> do+    is <- getInitialStateT+    t  <- runT try+    h  <- bindT handle+    let runIt = lower . runErrorAsExc_b 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. Semantic r x -> IO x)+    -> Semantic (Error e ': r) a+    -> Semantic r a+runErrorAsExc_b = runErrorAsExc+{-# NOINLINE runErrorAsExc_b #-}+

@@ -0,0 +1,41 @@+{-# LANGUAGE TemplateHaskell #-}++module Polysemy.Fixpoint+  ( -- * Effect+    Fixpoint (..)++    -- * Interpretations+  , module Polysemy.Fixpoint+  ) where++import Control.Monad.Fix+import Polysemy+import Polysemy.Internal.Fixpoint+++------------------------------------------------------------------------------+-- | Run a 'Fixpoint' effect purely.+runFixpoint+    :: (∀ x. Semantic r x -> x)+    -> Semantic (Fixpoint ': r) a+    -> Semantic r a+runFixpoint lower = interpretH $ \case+  Fixpoint mf -> do+    c <- bindT mf+    pure $ fix $ lower . runFixpoint lower . c+++------------------------------------------------------------------------------+-- | Run a 'Fixpoint' effect in terms of an underlying 'MonadFix' instance.+runFixpointM+    :: ( MonadFix m+       , Member (Lift m) r+       )+    => (∀ x. Semantic r x -> m x)+    -> Semantic (Fixpoint ': r) a+    -> Semantic r a+runFixpointM lower = interpretH $ \case+  Fixpoint mf -> do+    c <- bindT mf+    sendM $ mfix $ lower . runFixpointM lower . c+

@@ -0,0 +1,61 @@+{-# LANGUAGE BlockArguments  #-}+{-# LANGUAGE TemplateHaskell #-}++module Polysemy.Input+  ( -- * Effect+    Input (..)++    -- * Actions+  , input++    -- * Interpretations+  , runConstInput+  , runListInput+  , runMonadicInput+  ) where++import Data.Foldable (for_)+import Data.List (uncons)+import Polysemy+import Polysemy.State++------------------------------------------------------------------------------+-- | An effect which can provide input to an application. Useful for dealing+-- with streaming input.+data Input i m a where+  Input :: Input i m i++makeSemantic ''Input+++------------------------------------------------------------------------------+-- | Run an 'Input' effect by always giving back the same value.+runConstInput :: i -> Semantic (Input i ': r) a -> Semantic r a+runConstInput c = interpret \case+  Input -> pure c+{-# INLINE runConstInput #-}+++------------------------------------------------------------------------------+-- | Run an 'Input' effect by providing a different element of a list each+-- time. Returns 'Nothing' after the list is exhausted.+runListInput+    :: Typeable i+    => [i]+    -> Semantic (Input (Maybe i) ': r) a+    -> Semantic r a+runListInput is = fmap snd . runState is . reinterpret \case+  Input -> do+    s <- gets uncons+    for_ s $ put . snd+    pure $ fmap fst s+{-# INLINE runListInput #-}+++------------------------------------------------------------------------------+-- | Runs an 'Input' effect by evaluating a monadic action for each request.+runMonadicInput :: Semantic r i -> Semantic (Input i ': r) a -> Semantic r a+runMonadicInput m = interpret \case+  Input -> m+{-# INLINE runMonadicInput #-}+

@@ -0,0 +1,290 @@+{-# LANGUAGE AllowAmbiguousTypes  #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE MonoLocalBinds       #-}+{-# LANGUAGE UndecidableInstances #-}++module Polysemy.Internal+  ( Semantic (..)+  , Member+  , send+  , sendM+  , run+  , runM+  , raise+  , Lift ()+  , usingSemantic+  , liftSemantic+  , hoistSemantic+  , (.@)+  , (.@@)+  ) where++import Control.Applicative+import Control.Monad.Fix+import Control.Monad.IO.Class+import Data.Functor.Identity+import Polysemy.Internal.Effect+import Polysemy.Internal.Fixpoint+import Polysemy.Internal.Lift+import Polysemy.Internal.NonDet+import Polysemy.Internal.Union+++------------------------------------------------------------------------------+-- | The 'Semantic' monad handles computations of arbitrary extensible effects.+-- A value of type @Semantic r@ describes a program with the capabilities of+-- @r@. For best results, @r@ should always be kept polymorphic, but you can+-- add capabilities via the 'Member' constraint.+--+-- The value of the 'Semantic' monad is that it allows you to write programs+-- against a set of effects without a predefined meaning, and provide that+-- meaning later. For example, unlike with mtl, you can decide to interpret an+-- 'Polysemy.Error.Error' effect tradtionally as an 'Either', or instead+-- significantly faster as an 'IO' 'Control.Exception.Exception'. These+-- 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'.+--+-- 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 'Semantic' via 'sendM'.+--+-- A 'Semantic' can be interpreted as a pure value (via 'run') or as any+-- traditional 'Monad' (via 'runM'). Each effect @E@ comes equipped with some+-- interpreters of the form:+--+-- @+-- runE :: 'Semantic' (E ': r) a -> 'Semantic' r a+-- @+--+-- which is responsible for removing the effect @E@ from the effect stack. It+-- is the order in which you call the interpreters that determines the+-- monomorphic representation of the @r@ parameter.+--+-- After all of your effects are handled, you'll be left with either+-- a @'Semantic' '[] a@ or a @'Semantic' ('Lift' m) a@ value, which can be+-- consumed respectively by 'run' and 'runM'.+--+-- ==== Examples+--+-- As an example of keeping @r@ polymorphic, we can consider the type+--+-- @+-- 'Member' ('Polysemy.State' String) r => 'Semantic' r ()+-- @+--+-- to be a program with access to+--+-- @+-- 'Polysemy.State.get' :: 'Semantic' r String+-- 'Polysemy.State.put' :: String -> 'Semantic' r ()+-- @+--+-- methods.+--+-- By also adding a+--+-- @+-- 'Member' ('Polysemy.Error' Bool) r+-- @+--+-- constraint on @r@, we gain access to the+--+-- @+-- 'Polysemy.Error.throw' :: Bool -> 'Semantic' r a+-- 'Polysemy.Error.catch' :: 'Semantic' r a -> (Bool -> 'Semantic' r a) -> 'Semantic' r a+-- @+--+-- functions as well.+--+-- In this sense, a @'Member' ('Polysemy.State.State' s) r@ constraint is+-- analogous to mtl's @'Control.Monad.State.Class.MonadState' s m@ and should+-- be thought of as such. However, /unlike/ mtl, a 'Semantic' monad may have+-- an arbitrary number of the same effect.+--+-- For example, we can write a 'Semantic' program which can output either+-- 'Int's or 'Bool's:+--+-- @+-- foo :: ( 'Member' ('Polysemy.Output.Output' Int) r+--        , 'Member' ('Polysemy.Output.Output' Bool) r+--        )+--     => 'Semantic' r ()+-- foo = do+--   'Polysemy.Output.output' @Int  5+--   'Polysemy.Output.output' True+-- @+--+-- Notice that we must use @-XTypeApplications@ to specify that we'd like to+-- use the ('Polysemy.Output.Output' 'Int') effect.+newtype Semantic r a = Semantic+  { runSemantic+        :: ∀ m+         . Monad m+        => (∀ x. Union r (Semantic r) x -> m x)+        -> m a+  }++------------------------------------------------------------------------------+-- | Like 'runSemantic' but flipped for better ergonomics sometimes.+usingSemantic+    :: Monad m+    => (∀ x. Union r (Semantic r) x -> m x)+    -> Semantic r a+    -> m a+usingSemantic k m = runSemantic m k+{-# INLINE usingSemantic #-}+++instance Functor (Semantic f) where+  fmap f (Semantic m) = Semantic $ \k -> fmap f $ m k+  {-# INLINE fmap #-}+++instance Applicative (Semantic f) where+  pure a = Semantic $ const $ pure a+  {-# INLINE pure #-}++  Semantic f <*> Semantic a = Semantic $ \k -> f k <*> a k+  {-# INLINE (<*>) #-}+++instance Monad (Semantic f) where+  return = pure+  {-# INLINE return #-}++  Semantic ma >>= f = Semantic $ \k -> do+    z <- ma k+    runSemantic (f z) k+  {-# INLINE (>>=) #-}+++instance (Member NonDet r) => Alternative (Semantic r) where+  empty = send Empty+  a <|> b = do+    send (Choose id) >>= \case+      False -> a+      True  -> b+++instance (Member (Lift IO) r) => MonadIO (Semantic r) where+  liftIO = sendM+  {-# INLINE liftIO #-}++instance Member Fixpoint r => MonadFix (Semantic r) where+  mfix f = send $ Fixpoint f+++liftSemantic :: Union r (Semantic r) a -> Semantic r a+liftSemantic u = Semantic $ \k -> k u+{-# INLINE liftSemantic #-}+++hoistSemantic+    :: (∀ x. Union r (Semantic r) x -> Union r' (Semantic r') x)+    -> Semantic r a+    -> Semantic r' a+hoistSemantic nat (Semantic m) = Semantic $ \k -> m $ \u -> k $ nat u+{-# INLINE hoistSemantic #-}+++------------------------------------------------------------------------------+-- | Introduce an effect into 'Semantic'. Analogous to+-- 'Control.Monad.Class.Trans.lift' in the mtl ecosystem+raise :: ∀ e r a. Semantic r a -> Semantic (e ': r) a+raise = hoistSemantic $ hoist raise_b . weaken+{-# INLINE raise #-}+++raise_b :: Semantic r a -> Semantic (e ': r) a+raise_b = raise+{-# NOINLINE raise_b #-}+++------------------------------------------------------------------------------+-- | Lift an effect into a 'Semantic'. This is used primarily via+-- 'Polysemy.makeSemantic' to implement smart constructors.+send :: Member e r => e (Semantic r) a -> Semantic r a+send = liftSemantic . inj+{-# INLINE[3] send #-}+++------------------------------------------------------------------------------+-- | Lift a monadic action @m@ into 'Semantic'.+sendM :: Member (Lift m) r => m a -> Semantic r a+sendM = send . Lift+{-# INLINE sendM #-}+++------------------------------------------------------------------------------+-- | Run a 'Semantic' containing no effects as a pure value.+run :: Semantic '[] a -> a+run (Semantic m) = runIdentity $ m absurdU+{-# INLINE run #-}+++------------------------------------------------------------------------------+-- | Lower a 'Semantic' containing only a single lifted 'Monad' into that+-- monad.+runM :: Monad m => Semantic '[Lift m] a -> m a+runM (Semantic m) = m $ \z ->+  case extract z of+    Yo e s _ f -> do+      a <- unLift e+      pure $ f $ a <$ s+{-# INLINE runM #-}+++------------------------------------------------------------------------------+-- | 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.runResource'.+--+-- However, these interpreters don't compose particularly nicely; for example,+-- to run 'Polysemy.Resource.runResource', you must write:+--+-- @+-- runM . runErrorInIO runM+-- @+--+-- Notice that 'runM' is duplicated in two places here. The situation gets+-- exponentially worse the more intepreters you have that need to run in this+-- pattern.+--+-- Instead, '.@' performs the composition we'd like. The above can be written as+--+-- @+-- (runM .@ runErrorInIO)+-- @+--+-- The parentheses here are important; without them you'll run into operator+-- precedence errors.+(.@)+    :: Monad m+    => (∀ x. Semantic r x -> m x)+       -- ^ The lowering function, likely 'runM'.+    -> (∀ y. (∀ x. Semantic r x -> m x)+          -> Semantic (e ': r) y+          -> Semantic r y)+    -> Semantic (e ': r) z+    -> m z+f .@ g = f . g f+infixl 9 .@+++------------------------------------------------------------------------------+-- | Like '.@', but for interpreters which change the resulting type --- eg.+-- 'Polysemy.Error.runErrorInIO'.+(.@@)+    :: Monad m+    => (∀ x. Semantic r x -> m x)+       -- ^ The lowering function, likely 'runM'.+    -> (∀ y. (∀ x. Semantic r x -> m x)+          -> Semantic (e ': r) y+          -> Semantic r (f y))+    -> Semantic (e ': r) z+    -> m (f z)+f .@@ g = f . g f+infixl 9 .@@+

@@ -0,0 +1,321 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE QuantifiedConstraints #-}++module Polysemy.Internal.Combinators+  ( -- * First order+    interpret+  , intercept+  , reinterpret+  , reinterpret2+  , reinterpret3+    -- * Higher order+  , interpretH+  , interceptH+  , reinterpretH+  , reinterpret2H+  , reinterpret3H+    -- * Statefulness+  , stateful+  , lazilyStateful+  ) where++import qualified Control.Monad.Trans.State.Lazy as LS+import qualified Control.Monad.Trans.State.Strict as S+import           Data.Typeable+import           Polysemy.Internal+import           Polysemy.Internal.CustomErrors+import           Polysemy.Internal.Effect+import           Polysemy.Internal.Tactics+import           Polysemy.Internal.Union+++------------------------------------------------------------------------------+-- | A lazier version of 'Data.Tuple.swap'.+swap :: (a, b) -> (b, a)+swap ~(a, b) = (b, a)++++------------------------------------------------------------------------------+-- | The simplest way to produce an effect handler. Interprets an effect 'e' by+-- transforming it into other effects inside of 'r'.+interpret+    :: FirstOrder e "interpret"+    => (∀ x m. e m x -> Semantic r x)+       -- ^ A natural transformation from the handled effect to other effects+       -- already in 'Semantic'.+    -> Semantic (e ': r) a+    -> Semantic r a+-- TODO(sandy): could probably give a `coerce` impl for `runTactics` here+interpret f = interpretH $ \(e :: e m x) -> liftT @m $ f e+++------------------------------------------------------------------------------+-- | Like 'interpret', but for higher-order effects (ie. those which make use of+-- the 'm' parameter.)+--+-- See the notes on 'Tactical' for how to use this function.+interpretH+    :: (∀ x m . e m x -> Tactical e m r x)+       -- ^ A natural transformation from the handled effect to other effects+       -- already in 'Semantic'.+    -> Semantic (e ': r) a+    -> Semantic r a+interpretH f (Semantic m) = m $ \u ->+  case decomp u of+    Left  x -> liftSemantic $ hoist (interpretH_b f) x+    Right (Yo e s d y) -> do+      a <- runTactics s (raise . interpretH_b f . d) (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.+interpretInStateT+    :: Typeable s+    => (∀ x m. e m x -> S.StateT s (Semantic r) x)+    -> s+    -> Semantic (e ': r) a+    -> Semantic r (s, a)+interpretInStateT f s (Semantic m) = Semantic $ \k ->+  fmap swap $ flip S.runStateT s $ m $ \u ->+    case decomp u of+        Left x -> S.StateT $ \s' ->+          k . fmap swap+            . weave (s', ()) (uncurry $ interpretInStateT_b f)+            $ x+        Right (Yo e z _ y) ->+          fmap (y . (<$ z)) $ S.mapStateT (usingSemantic 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.+interpretInLazyStateT+    :: Typeable s+    => (∀ x m. e m x -> LS.StateT s (Semantic r) x)+    -> s+    -> Semantic (e ': r) a+    -> Semantic r (s, a)+interpretInLazyStateT f s (Semantic m) = Semantic $ \k ->+  fmap swap $ flip LS.runStateT s $ m $ \u ->+    case decomp u of+        Left x -> LS.StateT $ \s' ->+          k . fmap swap+            . weave (s', ()) (uncurry $ interpretInLazyStateT_b f)+            $ x+        Right (Yo e z _ y) ->+          fmap (y . (<$ z)) $ LS.mapStateT (usingSemantic k) $ f e+{-# INLINE interpretInLazyStateT #-}++------------------------------------------------------------------------------+-- | Like 'interpret', but with access to an intermediate state @s@.+stateful+    :: Typeable s+    => (∀ x m. e m x -> s -> Semantic r (s, x))+    -> s+    -> Semantic (e ': r) a+    -> Semantic r (s, a)+stateful f = interpretInStateT $ \e -> S.StateT $ fmap swap . f e+{-# INLINE[3] stateful #-}+++------------------------------------------------------------------------------+-- | Like 'interpret', but with access to an intermediate state @s@.+lazilyStateful+    :: Typeable s+    => (∀ x m. e m x -> s -> Semantic r (s, x))+    -> s+    -> Semantic (e ': r) a+    -> Semantic r (s, a)+lazilyStateful f = interpretInLazyStateT $ \e -> LS.StateT $ fmap swap . f e+{-# INLINE[3] lazilyStateful #-}+++------------------------------------------------------------------------------+-- | Like 'reinterpret', but for higher-order effects.+--+-- See the notes on 'Tactical' for how to use this function.+reinterpretH+    :: (∀ m x. e1 m x -> Tactical e1 m (e2 ': r) x)+       -- ^ A natural transformation from the handled effect to the new effect.+    -> Semantic (e1 ': r) a+    -> Semantic (e2 ': r) a+reinterpretH f (Semantic m) = Semantic $ \k -> m $ \u ->+  case decompCoerce u of+    Left x  -> k $ hoist (reinterpretH_b f) $ x+    Right (Yo e s d y) -> do+      a <- usingSemantic k $ runTactics s (raise . reinterpretH_b f . d) $ f e+      pure $ y a+{-# INLINE[3] reinterpretH #-}+-- TODO(sandy): Make this fuse in with 'stateful' directly.+++------------------------------------------------------------------------------+-- | Like 'interpret', but instead of removing the effect @e@, reencodes it in+-- some new effect @f@. This function will fuse when followed by+-- 'Polysemy.State.runState', meaning it's free to 'reinterpret' in terms of+-- the 'Polysemy.State.State' effect and immediately run it.+reinterpret+    :: FirstOrder e1 "reinterpret"+    => (∀ m x. e1 m x -> Semantic (e2 ': r) x)+       -- ^ A natural transformation from the handled effect to the new effect.+    -> Semantic (e1 ': r) a+    -> Semantic (e2 ': r) a+reinterpret f = reinterpretH $ \(e :: e m x) -> liftT @m $ f e+{-# INLINE[3] reinterpret #-}+-- TODO(sandy): Make this fuse in with 'stateful' directly.+++------------------------------------------------------------------------------+-- | Like 'reinterpret2', but for higher-order effects.+--+-- See the notes on 'Tactical' for how to use this function.+reinterpret2H+    :: (∀ m x. e1 m x -> Tactical e1 m (e2 ': e3 ': r) x)+       -- ^ A natural transformation from the handled effect to the new effects.+    -> Semantic (e1 ': r) a+    -> Semantic (e2 ': e3 ': r) a+reinterpret2H f (Semantic m) = Semantic $ \k -> m $ \u ->+  case decompCoerce u of+    Left x  -> k $ weaken $ hoist (reinterpret2H_b f) $ x+    Right (Yo e s d y) -> do+      a <- usingSemantic k $ runTactics s (raise . reinterpret2H_b f . d) $ f e+      pure $ y a+{-# INLINE[3] reinterpret2H #-}+++------------------------------------------------------------------------------+-- | Like 'reinterpret', but introduces /two/ intermediary effects.+reinterpret2+    :: FirstOrder e1 "reinterpret2"+    => (∀ m x. e1 m x -> Semantic (e2 ': e3 ': r) x)+       -- ^ A natural transformation from the handled effect to the new effects.+    -> Semantic (e1 ': r) a+    -> Semantic (e2 ': e3 ': r) a+reinterpret2 f = reinterpret2H $ \(e :: e m x) -> liftT @m $ f e+{-# INLINE[3] reinterpret2 #-}+++------------------------------------------------------------------------------+-- | Like 'reinterpret3', but for higher-order effects.+--+-- See the notes on 'Tactical' for how to use this function.+reinterpret3H+    :: (∀ m x. e1 m x -> Tactical e1 m (e2 ': e3 ': e4 ': r) x)+       -- ^ A natural transformation from the handled effect to the new effects.+    -> Semantic (e1 ': r) a+    -> Semantic (e2 ': e3 ': e4 ': r) a+reinterpret3H f (Semantic m) = Semantic $ \k -> m $ \u ->+  case decompCoerce u of+    Left x  -> k . weaken . weaken . hoist (reinterpret3H_b f) $ x+    Right (Yo e s d y) -> do+      a <- usingSemantic k $ runTactics s (raise . reinterpret3H_b f . d) $ f e+      pure $ y a+{-# INLINE[3] reinterpret3H #-}+++------------------------------------------------------------------------------+-- | Like 'reinterpret', but introduces /three/ intermediary effects.+reinterpret3+    :: FirstOrder e1 "reinterpret2"+    => (∀ m x. e1 m x -> Semantic (e2 ': e3 ': e4 ': r) x)+       -- ^ A natural transformation from the handled effect to the new effects.+    -> Semantic (e1 ': r) a+    -> Semantic (e2 ': e3 ': e4 ': r) a+reinterpret3 f = reinterpret3H $ \(e :: e m x) -> liftT @m $ f e+{-# INLINE[3] reinterpret3 #-}+++------------------------------------------------------------------------------+-- | Like 'interpret', but instead of handling the effect, allows responding to+-- the effect while leaving it unhandled. This allows you, for example, to+-- intercept other effects and insert logic around them.+intercept+    :: ( Member e r+       , FirstOrder e "intercept"+       )+    => (∀ x m. e m x -> Semantic r x)+       -- ^ A natural transformation from the handled effect to other effects+       -- already in 'Semantic'.+    -> Semantic r a+       -- ^ Unlike 'interpret', 'intercept' does not consume any effects.+    -> Semantic r a+intercept f = interceptH $ \(e :: e m x) -> liftT @m $ f e+{-# INLINE intercept #-}+++------------------------------------------------------------------------------+-- | Like 'interceptH', but for higher-order effects.+--+-- See the notes on 'Tactical' for how to use this function.+interceptH+    :: Member e r+    => (∀ x m. e m x -> Tactical e m r x)+       -- ^ A natural transformation from the handled effect to other effects+       -- already in 'Semantic'.+    -> Semantic r a+       -- ^ Unlike 'interpretH', 'interceptH' does not consume any effects.+    -> Semantic r a+interceptH f (Semantic m) = Semantic $ \k -> m $ \u ->+  case prj u of+    Just (Yo e s d y) ->+      usingSemantic k $ fmap y $ runTactics s (raise . d) $ f e+    Nothing -> k u+{-# INLINE interceptH #-}+++------------------------------------------------------------------------------+-- Loop breakers+interpretH_b+    :: (∀ x m . e m x -> Tactical e m r x)+    -> Semantic (e ': r) a+    -> Semantic r a+interpretH_b = interpretH+{-# NOINLINE interpretH_b #-}+++interpretInStateT_b+    :: Typeable s+    => (∀ x m. e m x -> S.StateT s (Semantic r) x)+    -> s+    -> Semantic (e ': r) a+    -> Semantic r (s, a)+interpretInStateT_b = interpretInStateT+{-# NOINLINE interpretInStateT_b #-}+++interpretInLazyStateT_b+    :: Typeable s+    => (∀ x m. e m x -> LS.StateT s (Semantic r) x)+    -> s+    -> Semantic (e ': r) a+    -> Semantic r (s, a)+interpretInLazyStateT_b = interpretInLazyStateT+{-# NOINLINE interpretInLazyStateT_b #-}+++reinterpretH_b+    :: (∀ m x. e1 m x -> Tactical e1 m (e2 ': r) x)+    -> Semantic (e1 ': r) a+    -> Semantic (e2 ': r) a+reinterpretH_b = reinterpretH+{-# NOINLINE reinterpretH_b #-}+++reinterpret2H_b+    :: (∀ m x. e1 m x -> Tactical e1 m (e2 ': e3 ': r) x)+    -> Semantic (e1 ': r) a+    -> Semantic (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)+    -> Semantic (e1 ': r) a+    -> Semantic (e2 ': e3 ': e4 ': r) a+reinterpret3H_b = reinterpret3H+{-# NOINLINE reinterpret3H_b #-}+

@@ -0,0 +1,149 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++module Polysemy.Internal.CustomErrors+  ( AmbiguousSend+  , Break+  , FirstOrder+  , UnhandledEffect+  , DefiningModule+  , DefiningModuleForEffect+  ) where++import Data.Coerce+import Data.Kind+import GHC.TypeLits+++type family DefiningModule (t :: k) :: Symbol++type family DefiningModuleForEffect (e :: k) :: Symbol where+  DefiningModuleForEffect (e a) = DefiningModuleForEffect e+  DefiningModuleForEffect e     = DefiningModule e++++data T1 m a++type family Break (c :: Constraint)+                  (rep :: (* -> *) -> * -> *) :: Constraint where+  Break _ T1 = ((), ())+  Break _ c  = ()++++type AmbigousEffectMessage r e t vs =+        ( 'Text "Ambiguous use of effect '"+    ':<>: 'ShowType e+    ':<>: 'Text "'"+    ':$$: 'Text "Possible fix:"+    ':$$: 'Text "  add (Member ("+    ':<>: 'ShowType t+    ':<>: 'Text ") "+    ':<>: 'ShowType 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+    ':<>: 'Text " directly"+        )++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 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])++  AmbiguousSend r (e a b c d) =+    TypeError (AmbigousEffectMessage 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])++  AmbiguousSend r (e a b) =+    TypeError (AmbigousEffectMessage r e (e a b) '[a, b])++  AmbiguousSend r (e a) =+    TypeError (AmbigousEffectMessage r e (e a) '[a])++  AmbiguousSend r e =+    TypeError+        ( 'Text "Could not deduce: (Member "+    ':<>: 'ShowType e+    ':<>: 'Text " "+    ':<>: 'ShowType r+    ':<>: 'Text ") "+    ':$$: 'Text "Fix:"+    ':$$: 'Text "  add (Member "+    ':<>: 'ShowType e+    ':<>: 'Text " "+    ':<>: 'ShowType r+    ':<>: 'Text ") to the context of"+    ':$$: 'Text "    the type signature"+        )++++++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."+              )++------------------------------------------------------------------------------+-- | This constraint gives helpful error messages if you attempt to use a+-- first-order combinator with a higher-order type.+type FirstOrder e fn = ∀ m. Coercible (e m) (e (FirstOrderError e fn))+++------------------------------------------------------------------------------+-- | Unhandled effects+type UnhandledEffectMsg e+      = 'Text "Unhandled effect '"+  ':<>: 'ShowType e+  ':<>: 'Text "'"+  ':$$: 'Text "Probable fix:"+  ':$$: 'Text "  add an interpretation for '"+  ':<>: 'ShowType e+  ':<>: 'Text "'"++type CheckDocumentation e+      = 'Text "  If you are looking for inspiration, try consulting"+  ':$$: 'Text "    the documentation for module '"+  ':<>: '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 z e where+  UnhandledEffect z e =+    BreakSym z e (TypeError (UnhandledEffectMsg e)) (DefiningModuleForEffect e)+

@@ -0,0 +1,116 @@+{-# LANGUAGE DefaultSignatures     #-}+{-# LANGUAGE QuantifiedConstraints #-}++module Polysemy.Internal.Effect where++import Data.Coerce+import Data.Functor.Identity+import Data.Kind (Constraint)+import Data.Typeable+++type Typeable1 f = (∀ y. Typeable y => Typeable (f y) :: Constraint)++------------------------------------------------------------------------------+-- | The class for semantic effects.+--+-- An effect @e@ is a type @e m a@, where the other types are given by:+--+-- * The @m@ type variable corresponds to a monad, which will eventually be+-- instantiated at 'Polysemy.Semantic'---meaning it is capable of encoding+-- arbitrary other effects.+--+-- * The @a@ type is handled automatically and uninteresting.+--+-- The type @e m@ must be a 'Functor', but this instance can always be given+-- for free via the @-XDeriveFunctor@ language extension. Often this instance+-- must be derived as a standalone (@-XStandaloneDeriving@):+--+-- @+-- deriving instance Functor (MyEffect m)+-- @+--+-- If the effect doesn't use @m@ whatsoever it is said to be /first-order/.+-- First-order effects can be given an instance of 'Effect' for free with+-- @-XDeriveAnyClass@.+--+-- @+-- deriving instance Effect MyEffect+-- @+class (∀ m. Functor m => Functor (e m)) => Effect e where+  -- | Higher-order effects require the ability to distribute state from other+  -- effects throughout themselves. This state is given by an initial piece of+  -- state @s ()@, and a distributive law that describes how to move the state+  -- through an effect.+  --+  -- When the effect @e@ has multiple computations in the @m@ monad, 'weave'+  -- defines the semantics for how these computations will view with the state:+  --+  -- * If the resulting state from one computation is fed to another, the second+  -- computation will see the state that results from the first computation.+  --+  -- * If instead it is given the intial state, both computations will see the+  -- same state, but the result of (at least) one will necessarily be ignored.+  weave+      :: (Functor s, Functor m, Functor n, Typeable1 s, Typeable s)+      => s ()+      -> (∀ x. s (m x) -> n (s x))+      -> e m a+      -> e n (s a)++  -- | When @e@ is first order, 'weave' can be given for free.+  default weave+      :: ( Coercible (e m (s a)) (e n (s a))+         , Typeable1 s+         , Typeable s+         , Functor s+         , Functor m+         , Functor n+         )+      => s ()+      -> (∀ x. s (m x) -> n (s x))+      -> e m a+      -> e n (s a)+  weave s _ = coerce . fmap (<$ s)+  {-# INLINE weave #-}++  -- | Lift a natural transformation from @m@ to @n@ over the effect. 'hoist'+  -- should be defined as 'defaultHoist', but can be hand-written if the+  -- default performance isn't sufficient.+  hoist+        :: ( Functor m+           , Functor n+           )+        => (∀ x. m x -> n x)+        -> e m a+        -> e n a++  -- | When @e@ is first order, 'hoist' be given for free.+  default hoist+      :: ( Coercible (e m a) (e n a)+         , Functor m+         )+      => (∀ x. m x -> n x)+      -> e m a+      -> e n a+  hoist _ = coerce+  {-# INLINE hoist #-}+++------------------------------------------------------------------------------+-- | A default implementation of 'hoist'. Particularly performance-sensitive+-- effects should give a hand-written their own implementation of 'hoist'.+defaultHoist+      :: ( Functor m+         , Functor n+         , Effect e+         )+      => (∀ x. m x -> n x)+      -> e m a+      -> e n a+defaultHoist f+  = fmap runIdentity+  . weave (Identity ())+          (fmap Identity . f . runIdentity)+{-# INLINE defaultHoist #-}+

@@ -0,0 +1,7 @@+module Polysemy.Internal.Fixpoint where++------------------------------------------------------------------------------+-- | An effect for providing 'Control.Monad.Fix.mfix'.+data Fixpoint m a where+  Fixpoint :: (a -> m a) -> Fixpoint m a+

@@ -0,0 +1,29 @@+{-# LANGUAGE NoPolyKinds #-}++module Polysemy.Internal.Lift where+++------------------------------------------------------------------------------+-- | An effect which allows a regular 'Monad' @m@ into the 'Polysemy.Semantic'+-- ecosystem. Monadic actions in @m@ can be lifted into 'Polysemy.Semantic' via+-- 'Polysemy.sendM'.+--+-- For example, you can use this effect to lift 'IO' actions directly into+-- 'Polysemy.Semantic':+--+-- @+-- 'Polysemy.sendM' (putStrLn "hello") :: 'Polysemy.Member' ('Polysemy.Lift' IO) r => 'Polysemy.Semantic' r ()+-- @+--+-- That being said, you lose out on a significant amount of the benefits of+-- 'Polysemy.Semantic' by using '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 :: * -> *) a = Lift+  { unLift :: m a+  }+

@@ -0,0 +1,12 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFunctor  #-}+{-# LANGUAGE NoPolyKinds    #-}++module Polysemy.Internal.NonDet where++------------------------------------------------------------------------------+-- | An effect corresponding to the 'Control.Applicative.Alternative' typeclass.+data NonDet (m :: * -> *) a+  = Empty+  | Choose (Bool -> a)+

@@ -0,0 +1,203 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE TupleSections     #-}++-- Originally ported from code written by Sandy Maguire (@isovector), available+-- at https://github.com/IxpertaSolutions/freer-effects/pull/28.++{-|+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+the module documentation for "Polysemy", we can write the following:++@+data FileSystem m a where+  ReadFile :: 'FilePath' -> FileSystem 'String'+  WriteFile :: 'FilePath' -> 'String' -> FileSystem ()+'makeSemantic' ''FileSystem+@++This will automatically generate the following functions:++@+readFile :: 'Member' FileSystem r => 'FilePath' -> 'Semantic' r 'String'+readFile a = 'send' (ReadFile a)++writeFile :: 'Member' FileSystem r => 'FilePath' -> 'String' -> 'Semantic' r ()+writeFile a b = 'send' (WriteFile a b)+@+-}+module Polysemy.Internal.TH.Effect+  ( makeSemantic+  , makeSemantic_+  )+where++import Control.Monad (join, forM, unless)+import Data.Char (toLower)+import Data.List+import Generics.SYB+import Language.Haskell.TH+import Polysemy.Internal (send, Member, Semantic)+import Polysemy.Internal.CustomErrors (DefiningModule)+++-- | If @T@ is a GADT representing an effect algebra, as described in the module+-- documentation for "Polysemy", @$('makeSemantic' ''T)@ automatically+-- generates a smart constructor for every data constructor of @T@.+makeSemantic :: Name -> Q [Dec]+makeSemantic = genFreer True++-- | Like 'makeSemantic', but does not provide type signatures. This can be used+-- to attach Haddock comments to individual arguments for each generated+-- function.+--+-- @+-- data Lang m a where+--   Output :: String -> Lang ()+--+-- makeSemantic_ ''Lang+--+-- -- | Output a string.+-- output :: Member Lang r+--        => String         -- ^ String to output.+--        -> Semantic r ()  -- ^ No result.+-- @+--+-- Note that 'makeEffect_' must be used /before/ the explicit type signatures.+makeSemantic_ :: Name -> Q [Dec]+makeSemantic_ = genFreer False++-- | Generates declarations and possibly signatures for functions to lift GADT+-- constructors into 'Semantic' actions.+genFreer :: Bool -> Name -> Q [Dec]+genFreer makeSigs tcName = do+  -- The signatures for the generated definitions require FlexibleContexts.+  isExtEnabled FlexibleContexts+    >>= flip unless (fail "makeSemantic requires FlexibleContexts to be enabled")+  hasTyFams <- isExtEnabled TypeFamilies++  reify tcName >>= \case+    TyConI (DataD _ _ _ _ cons _) -> do+      sigs <- filter (const makeSigs) <$> mapM genSig cons+      decs <- join <$> mapM genDecl cons+      loc <- location++      return $+        [ TySynInstD ''DefiningModule+            . TySynEqn [ConT tcName]+            . LitT+            . StrTyLit+            $ loc_module loc+        | hasTyFams+        ] ++ sigs ++ decs++    _ -> fail "makeSemantic expects a type constructor"++-- | Given the name of a GADT constructor, return the name of the corresponding+-- lifted function.+getDeclName :: Name -> Name+getDeclName = mkName . overFirst toLower . nameBase+ where+  overFirst f (a : as) = f a : as+  overFirst _ as       = as++-- | Builds a function definition of the form @x a b c = send $ X a b c@.+genDecl :: Con -> Q [Dec]+genDecl (ForallC _       _     con) = genDecl con+genDecl (GadtC   [cName] tArgs _  ) = do+  let fnName = getDeclName cName+  let arity  = length tArgs - 1+  dTypeVars <- forM [0 .. arity] $ const $ newName "a"+  pure $+    [PragmaD (InlineP fnName Inlinable ConLike AllPhases)+    , FunD fnName . pure $ Clause+        (VarP <$> dTypeVars)+        (NormalB . AppE (VarE 'send) $ foldl+          (\b -> AppE b . VarE)+          (ConE cName)+          dTypeVars+        )+        []+    ]+genDecl _ = fail "genDecl expects a GADT constructor"++tyVarBndrName :: TyVarBndr -> Name+tyVarBndrName (PlainTV n) = n+tyVarBndrName (KindedTV n _) = n++tyVarBndrKind :: TyVarBndr -> Maybe Type+tyVarBndrKind (PlainTV _) = Nothing+tyVarBndrKind (KindedTV _ k) = Just k++-- | Generates a function type from the corresponding GADT type constructor+-- @x :: Member (Effect e) r => a -> b -> c -> Semantic r r@.+genType :: Con -> Q (Type, Maybe Name, Maybe Type)+genType (ForallC tyVarBindings conCtx con) = do+  (t, mn, _) <- genType con+  let k = do n <- mn+             z <- find ((== n) . tyVarBndrName) tyVarBindings+             tyVarBndrKind z+      free = everything mappend freeVars t+  pure ( ForallT (filter (flip elem free . tyVarBndrName) tyVarBindings) conCtx t+       , mn+       , k+       )+genType (GadtC   _ tArgs' (eff `AppT` m `AppT` tRet)) = do+  r <- newName "r"+  let+    tArgs            = fmap snd tArgs'+    memberConstraint = ConT ''Member `AppT` eff `AppT` VarT r+    resultType       = ConT ''Semantic `AppT` VarT r `AppT` tRet++    replaceMType t | t == m = ConT ''Semantic `AppT` VarT r+                   | otherwise = t+    ts = everywhere (mkT replaceMType) tArgs+    tn = case tRet of+           VarT n -> Just n+           _ -> Nothing++  pure+    . (, tn, Nothing)+    .  ForallT [PlainTV r] [memberConstraint]+    .  foldArrows+    $  ts+    ++ [resultType]+-- TODO: Although this should never happen, we obviously need a better error message below.+genType _       = fail "genSig expects a GADT constructor"++-- | Turn all (KindedTV tv StarT) into (PlainTV tv) in the given type+-- This can prevent the need for KindSignatures+simplifyBndrs :: Maybe Type -> Type -> Type+simplifyBndrs star = everywhere (mkT $ simplifyBndr star)++-- | Turn TvVarBndrs of the form (KindedTV tv StarT) into (PlainTV tv)+-- This can prevent the need for KindSignatures+simplifyBndr :: Maybe Type -> TyVarBndr -> TyVarBndr+simplifyBndr (Just star) (KindedTV tv k) | star == k = PlainTV tv+simplifyBndr _ (KindedTV tv StarT) = PlainTV tv+simplifyBndr _ bndr = bndr++-- | Generates a type signature of the form+-- @x :: Member (Effect e) r => a -> b -> c -> Semantic r r@.+genSig :: Con -> Q Dec+genSig con = do+  let+    getConName (ForallC _ _ c) = getConName c+    getConName (GadtC [n] _ _) = pure n+    getConName c = fail $ "failed to get GADT name from " ++ show c+  conName <- getConName con+  (t, _, k) <- genType con+  pure $ SigD (getDeclName conName) $ simplifyBndrs k t++-- | Folds a list of 'Type's into a right-associative arrow 'Type'.+foldArrows :: [Type] -> Type+foldArrows = foldr1 (AppT . AppT ArrowT)+++freeVars :: Data a => a -> [Name]+freeVars = mkQ [] $ \case+  VarT n -> [n]+  _ -> []+

@@ -0,0 +1,84 @@+{-# LANGUAGE BlockArguments  #-}+{-# LANGUAGE TemplateHaskell #-}++module Polysemy.Internal.TH.Performance+  ( inlineRecursiveCalls+  ) where++import Control.Monad+import Data.Bool+import Data.Maybe (maybeToList, mapMaybe)+import Data.Monoid (Any (..))+import Generics.SYB+import Language.Haskell.TH++------------------------------------------------------------------------------+-- | GHC has a really hard time inlining recursive calls---such as those used in+-- interpreters for higher-order effects. This can have disastrous repercussions+-- for your performance.+--+-- Fortunately there's a solution, but it's ugly boilerplate. You can enable+-- @-XTemplateHaskell@ and use 'inlineRecursiveCalls' to convince GHC to make+-- these functions fast again.+--+-- @+-- 'inlineRecursiveCalls' [d|+--   'Polysemy.Reader.runReader' :: i -> 'Polysemy.Semantic' ('Polysemy.Reader.Reader' i ': r) a -> 'Polysemy.Semantic' r a+--   'Polysemy.Reader.runReader' i = 'Polysemy.interpretH' $ \\case+--     'Polysemy.Reader.Ask' -> 'Polysemy.pureT' i+--     'Polysemy.Reader.Local' f m -> do+--       mm <- 'Polysemy.runT' m+--       'Polysemy.raise' $ 'Polysemy.Reader.runReader' (f i) mm+--   |]+-- @+inlineRecursiveCalls :: Q [Dec] -> Q [Dec]+inlineRecursiveCalls m = do+  decs <- m+  let types   = mapMaybe getType decs+      inlines = mapMaybe hasInline decs+  fmap join $ traverse (loopbreaker types inlines) decs+++isRecursive :: Name -> [Clause] -> Bool+isRecursive n cs =+  getAny $+    everything+      (<>)+      (mkQ (Any False) $ withRec (const $ Any False) (Any True) n)+      cs+++withRec :: (Exp -> a) -> a -> Name -> Exp -> a+withRec unmatched matched n = \case+  VarE n' | n == n' -> matched+  a                 -> unmatched a+++getType :: Dec -> Maybe (Name, Type)+getType (SigD n t) = Just (n, t)+getType _ = Nothing+++hasInline :: Dec -> Maybe (Name)+hasInline (PragmaD (InlineP n Inline _ _)) = Just n+hasInline _ = Nothing+++loopbreaker :: [(Name, Type)] -> [Name] -> Dec -> Q [Dec]+loopbreaker types inlined (FunD n cs)+  | isRecursive n cs = do+      nLB <- newName $ mconcat+               [ "___"+               , nameBase n+               , "___loop_breaker"+               ]+      pure $+        [ FunD n $ everywhere (mkT $ withRec id (VarE nLB) n) cs+        , FunD nLB [Clause [] (NormalB $ VarE n) []]+        , PragmaD $ InlineP nLB NoInline FunLike AllPhases+        ] ++ maybeToList (fmap (SigD nLB) $ lookup n types)+          ++ bool [PragmaD $ InlineP n Inline FunLike AllPhases]+                  []+                  (elem n inlined)+loopbreaker _ _ z = pure [z]+

@@ -0,0 +1,174 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE QuantifiedConstraints #-}++module Polysemy.Internal.Tactics+  ( Tactics (..)+  , getInitialStateT+  , runT+  , bindT+  , pureT+  , liftT+  , runTactics+  , Tactical+  , WithTactics+  ) where++import Polysemy.Internal+import Polysemy.Internal.Effect+import Polysemy.Internal.Union+++------------------------------------------------------------------------------+-- | 'Tactical' is an environment in which you're capable of explicitly+-- threading higher-order effect states. This is provided by the (internal)+-- effect @Tactics@, which is capable of rewriting monadic actions so they run+-- in the correct stateful environment.+--+-- Inside a 'Tactical', you're capable of running 'pureT', 'runT' and 'bindT'+-- which are the main tools for rewriting monadic stateful environments.+--+-- For example, consider trying to write an interpreter for+-- 'Polysemy.Resource.Resource', whose effect is defined as:+--+-- @+-- data 'Polysemy.Resource.Resource' m a where+--   'Polysemy.Resource.Bracket' :: m a -> (a -> m ()) -> (a -> m b) -> 'Polysemy.Resource.Resource' m b+-- @+--+-- Here we have an @m a@ which clearly needs to be run first, and then+-- subsequently call the @a -> m ()@ and @a -> m b@ arguments. In a 'Tactical'+-- environment, we can write the threading code thusly:+--+-- @+-- 'Polysemy.Resource.Bracket' alloc dealloc use -> do+--   alloc'   <- 'runT'  alloc+--   dealloc' <- 'bindT' dealloc+--   use'     <- 'bindT' use+-- @+--+-- where+--+-- @+-- alloc'   ::         'Polysemy.Semantic' ('Polysemy.Resource.Resource' ': r) (f a1)+-- dealloc' :: f a1 -> 'Polysemy.Semantic' ('Polysemy.Resource.Resource' ': r) (f ())+-- use'     :: f a1 -> 'Polysemy.Semantic' ('Polysemy.Resource.Resource' ': r) (f x)+-- @+--+-- The @f@ type here is existential and corresponds to "whatever+-- state the other effects want to keep track of." @f@ is always+-- a 'Functor'.+--+-- @alloc'@, @dealloc'@ and @use'@ are now in a form that can be+-- easily consumed by your interpreter. At this point, simply bind+-- them in the desired order and continue on your merry way.+--+-- We can see from the types of @dealloc'@ and @use'@ that since they both+-- consume a @f a1@, they must run in the same stateful environment. This+-- means, for illustration, any 'Polysemy.State.put's run inside the @use@+-- block will not be visible inside of the @dealloc@ block.+--+-- Power users may explicitly use 'getInitialStateT' and 'bindT' to construct+-- whatever data flow they'd like; although this is usually necessary.+type Tactical e m r x = ∀ f. (Functor f, Typeable1 f)+                          => Semantic (WithTactics e f m r) (f x)++type WithTactics e f m r = Tactics f m (e ': r) ': r++data Tactics f n r m a where+  GetInitialState     :: Tactics f n r m (f ())+  HoistInterpretation :: (a -> n b) -> Tactics f n r m (f a -> Semantic r (f b))+++------------------------------------------------------------------------------+-- | Get the stateful environment of the world at the moment the effect @e@ is+-- to be run. Prefer 'pureT', 'runT' or 'bindT' instead of using this function+-- directly.+getInitialStateT :: forall f m r e. Semantic (WithTactics e f m r) (f ())+getInitialStateT = send @(Tactics _ m (e ': r)) GetInitialState+++------------------------------------------------------------------------------+-- | Lift a value into 'Tactical'.+pureT :: a -> Tactical e m r a+pureT a = do+  istate <- getInitialStateT+  pure $ a <$ istate+++------------------------------------------------------------------------------+-- | Run a monadic action in a 'Tactical' environment. The stateful environment+-- used will be the same one that the effect is initally run in. Use 'bindT' if+-- you'd prefer to explicitly manage your stateful environment.+runT+    :: m a+      -- ^ The monadic action to lift. This is usually a parameter in your+      -- effect.+    -> Semantic (WithTactics e f m r)+                (Semantic (e ': r) (f a))+runT na = do+  istate <- getInitialStateT+  na'    <- bindT (const na)+  pure $ na' istate+{-# INLINE runT #-}+++------------------------------------------------------------------------------+-- | Lift a kleisli action into the stateful environment. You can use+-- 'bindT' to get an effect parameter of the form @a -> m b@ into something+-- that can be used after calling 'runT' on an effect parameter @m a@.+bindT+    :: (a -> m b)+       -- ^ The monadic continuation to lift. This is usually a parameter in+       -- your effect.+       --+       -- Continuations lifted via 'bindT' will run in the same environment+       -- which produced the 'a'.+    -> Semantic (WithTactics e f m r)+                (f a -> Semantic (e ': r) (f b))+bindT f = send $ HoistInterpretation f+{-# INLINE bindT #-}+++------------------------------------------------------------------------------+-- | Internal function to create first-order interpreter combinators out of+-- higher-order ones.+liftT+    :: forall m f r e a+     . ( Functor f+       , Typeable1 f+       )+    => Semantic r a+    -> Semantic (WithTactics e f m r) (f a)+liftT m = do+  a <- raise m+  pureT a+{-# INLINE liftT #-}+++------------------------------------------------------------------------------+-- | Run the 'Tactics' effect.+runTactics+   :: Functor f+   => f ()+   -> (∀ x. f (m x) -> Semantic r2 (f x))+   -> Semantic (Tactics f m r2 ': r) a+   -> Semantic r a+runTactics s d (Semantic m) = m $ \u ->+  case decomp u of+    Left x -> liftSemantic $ hoist (runTactics_b s d) x+    Right (Yo GetInitialState s' _ y) ->+      pure $ y $ s <$ s'+    Right (Yo (HoistInterpretation na) s' _ y) -> do+      pure $ y $ (d . fmap na) <$ s'+{-# INLINE runTactics #-}+++runTactics_b+   :: Functor f+   => f ()+   -> (∀ x. f (m x) -> Semantic r2 (f x))+   -> Semantic (Tactics f m r2 ': r) a+   -> Semantic r a+runTactics_b = runTactics+{-# NOINLINE runTactics_b #-}+

@@ -0,0 +1,233 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE StrictData            #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++module Polysemy.Internal.Union+  ( Union (..)+  , Yo (..)+  , liftYo+  , Member+  -- * Building Unions+  , inj+  , weaken+  -- * Using Unions+  , decomp+  , prj+  , extract+  , absurdU+  , decompCoerce+  -- * Witnesses+  , SNat (..)+  , Nat (..)+  ) where++import Data.Functor.Compose+import Data.Functor.Identity+import Data.Typeable+import Polysemy.Internal.Effect++#ifdef ERROR_MESSAGES+import Polysemy.Internal.CustomErrors+#endif+++------------------------------------------------------------------------------+-- | An extensible, type-safe union. The @r@ type parameter is a type-level+-- list of effects, any one of which may be held within the 'Union'.+data Union (r :: [(* -> *) -> * -> *]) (m :: * -> *) a where+  Union+      :: SNat n+         -- ^ A proof that the effect is actually in @r@.+      -> Yo (IndexOf r n) m a+         -- ^ The effect to wrap. The functions 'prj' and 'decomp' can help+         -- retrieve this value later.+      -> Union r m a++++data Yo e m a where+  Yo :: (Functor f, Typeable1 f, Typeable f)+     => e m a+     -> f ()+     -> (forall x. f (m x) -> n (f x))+     -> (f a -> b)+     -> Yo e n b++instance Functor (Yo e m) where+  fmap f (Yo e s d f') = Yo e s d (f . f')+  {-# INLINE fmap #-}++instance Effect (Yo e) where+  weave s' d (Yo e s nt f) =+    Yo e (Compose $ s <$ s')+         (fmap Compose . d . fmap nt . getCompose)+         (fmap f . getCompose)+  {-# INLINE weave #-}++  hoist = defaultHoist+  {-# INLINE hoist #-}++liftYo :: Functor m => e m a -> Yo e m a+liftYo e = Yo e (Identity ()) (fmap Identity . runIdentity) runIdentity+{-# INLINE liftYo #-}+++instance (Functor m) => Functor (Union r m) where+  fmap f (Union w t) = Union w $ fmap' f t+    where+      -- This is necessary to delay the interaction between the type family+      -- 'IndexOf' and the quantified superclass constraint on 'Effect'.+      fmap' :: (Functor m, Effect f) => (a -> b) -> f m a -> f m b+      fmap' = fmap+      {-# INLINE fmap' #-}+  {-# INLINE fmap #-}+++instance Effect (Union r) where+  weave s f (Union w e) = Union w $ weave s f e+  {-# INLINE weave #-}++  hoist f (Union w e) = Union w $ hoist f e+  {-# INLINE hoist #-}+++------------------------------------------------------------------------------+-- | 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 =+  ( Find r e+  , e ~ IndexOf r (Found r e)+#ifdef ERROR_MESSAGES+  , Break (AmbiguousSend r e) (IndexOf r (Found r e))+#endif+  )+++data Dict c where Dict :: c => Dict c+++induceTypeable :: SNat n -> Dict (Typeable n)+induceTypeable SZ = Dict+induceTypeable (SS _) = Dict+{-# INLINE induceTypeable #-}+++------------------------------------------------------------------------------+-- | The kind of type-level natural numbers.+data Nat = Z | S Nat+  deriving Typeable+++------------------------------------------------------------------------------+-- | A singleton for 'Nat'.+data SNat :: Nat -> * where+  SZ :: SNat 'Z+  SS :: Typeable n => SNat n -> SNat ('S n)+  deriving Typeable+++type family IndexOf (ts :: [k]) (n :: Nat) :: k where+  IndexOf (k ': ks) 'Z = k+  IndexOf (k ': ks) ('S n) = IndexOf ks n+++type family Found (ts :: [k]) (t :: k) :: Nat where+#ifdef ERROR_MESSAGES+  Found '[]       t = UnhandledEffect 'S t+#endif+  Found (t ': ts) t = 'Z+  Found (u ': ts) t = 'S (Found ts t)+++class Typeable (Found r t) => Find (r :: [k]) (t :: k) where+  finder :: SNat (Found r t)++instance {-# OVERLAPPING #-} Find (t ': z) t where+  finder = SZ+  {-# INLINE finder #-}++instance ( Find z t+         , Found (_1 ': z) t ~ 'S (Found z t)+         ) => Find (_1 ': z) t where+  finder = SS $ finder @_ @z @t+  {-# INLINE finder #-}+++------------------------------------------------------------------------------+-- | Decompose a 'Union'. Either this union contains an effect @e@---the head+-- of the @r@ list---or it doesn't.+decomp :: Union (e ': r) m a -> Either (Union r m a) (Yo e m a)+decomp (Union p a) =+  case p of+    SZ   -> Right a+    SS n -> Left $ Union n a+{-# INLINE decomp #-}+++------------------------------------------------------------------------------+-- | Retrieve the last effect in a 'Union'.+extract :: Union '[e] m a -> Yo e m a+extract (Union SZ a) = a+extract _ = error "impossible"+{-# INLINE extract #-}+++------------------------------------------------------------------------------+-- | An empty union contains nothing, so this function is uncallable.+absurdU :: Union '[] m a -> b+absurdU = absurdU+++------------------------------------------------------------------------------+-- | Weaken a 'Union' so it is capable of storing a new sort of effect.+weaken :: Union r m a -> Union (e ': r) m a+weaken (Union n a) =+  case induceTypeable n of+    Dict -> Union (SS n) a+{-# INLINE weaken #-}+++------------------------------------------------------------------------------+-- | Lift an effect @e@ into a 'Union' capable of holding it.+inj :: forall r e a m. (Functor m , Member e r) => e m a -> Union r m a+inj e = Union (finder @_ @r @e) $ liftYo e+{-# INLINE inj #-}+++------------------------------------------------------------------------------+-- | Attempt to take an @e@ effect out of a 'Union'.+prj :: forall e r a m+     . ( Member e r+       )+    => Union r m a+    -> Maybe (Yo e m a)+prj (Union (s :: SNat n) a) =+  case induceTypeable s of+    Dict ->+      case eqT @n @(Found r e) of+        Just Refl -> Just a+        Nothing -> Nothing+{-# INLINE prj #-}+++------------------------------------------------------------------------------+-- | Like 'decomp', but allows for a more efficient+-- 'Polysemy.Interpretation.reinterpret' function.+decompCoerce+    :: Union (e ': r) m a+    -> Either (Union (f ': r) m a) (Yo e m a)+decompCoerce (Union p a) =+  case p of+    SZ -> Right a+    SS n -> Left (Union (SS n) a)+{-# INLINE decompCoerce #-}++

@@ -0,0 +1,67 @@+{-# LANGUAGE DeriveAnyClass  #-}+{-# LANGUAGE TemplateHaskell #-}++module Polysemy.NonDet+  ( -- * Effect+    NonDet (..)++    -- * Interpretations+  , runNonDet+  ) where++import Control.Applicative+import Polysemy.Internal+import Polysemy.Internal.NonDet+import Polysemy.Internal.Union+import Polysemy.Internal.Effect+++--------------------------------------------------------------------------------+-- This stuff is lifted from 'fused-effects'. Thanks guys!+runNonDetC :: (Alternative f, Applicative m) => NonDetC m a -> m (f a)+runNonDetC (NonDetC m) = m (fmap . (<|>) . pure) (pure empty)+{-# INLINE runNonDetC #-}+++newtype NonDetC m a = NonDetC+  { -- | A higher-order function receiving two parameters: a function to combine+    -- each solution with the rest of the solutions, and an action to run when no+    -- results are produced.+    unNonDetC :: forall b . (a -> m b -> m b) -> m b -> m b+  }+  deriving (Functor)++instance Applicative (NonDetC m) where+  pure a = NonDetC (\ cons -> cons a)+  {-# INLINE pure #-}++  NonDetC f <*> NonDetC a = NonDetC $ \ cons ->+    f (\ f' -> a (cons . f'))+  {-# INLINE (<*>) #-}++instance Alternative (NonDetC m) where+  empty = NonDetC (\ _ nil -> nil)+  {-# INLINE empty #-}++  NonDetC l <|> NonDetC r = NonDetC $ \ cons -> l cons . r cons+  {-# INLINE (<|>) #-}++instance Monad (NonDetC m) where+  NonDetC a >>= f = NonDetC $ \ cons ->+    a (\ a' -> unNonDetC (f a') cons)+  {-# INLINE (>>=) #-}+++------------------------------------------------------------------------------+-- | Run a 'NonDet' effect in terms of some underlying 'Alternative' @f@.+runNonDet :: Alternative f => Semantic (NonDet ': r) a -> Semantic r (f a)+runNonDet (Semantic m) = Semantic $ \k -> runNonDetC $ m $ \u ->+  case decomp u of+    Left x  -> NonDetC $ \cons nil -> do+      z <- k $ weave [()] (fmap concat . traverse runNonDet) x+      foldr cons nil z+    Right (Yo Empty _ _ _) -> empty+    Right (Yo (Choose ek) s _ y) -> do+      z <- pure (ek True) <|> pure (ek False)+      pure $ y $ z <$ s+

@@ -0,0 +1,48 @@+{-# LANGUAGE BlockArguments  #-}+{-# LANGUAGE TemplateHaskell #-}++module Polysemy.Output+  ( -- * Effect+    Output (..)++    -- * Actions+  , output++    -- * Interpretations+  , runFoldMapOutput+  , runIgnoringOutput+  ) where++import Polysemy+import Polysemy.State+++------------------------------------------------------------------------------+-- | An effect capable of sending messages. Useful for streaming output and for+-- logging.+data Output o m a where+  Output :: o -> Output o m ()++makeSemantic ''Output+++------------------------------------------------------------------------------+-- | Run an 'Output' effect by transforming it into a monoid.+runFoldMapOutput+    :: forall o m r a+     . (Typeable m, Monoid m)+    => (o -> m)+    -> Semantic (Output o ': r) a+    -> Semantic r (m, a)+runFoldMapOutput f = runState mempty . reinterpret \case+  Output o -> modify (<> f o)+{-# INLINE runFoldMapOutput #-}+++------------------------------------------------------------------------------+-- | Run an 'Ouput' effect by ignoring it.+runIgnoringOutput :: Semantic (Output o ': r) a -> Semantic r a+runIgnoringOutput = interpret \case+  Output _ -> pure ()+{-# INLINE runIgnoringOutput #-}+

@@ -0,0 +1,59 @@+{-# LANGUAGE BlockArguments  #-}+{-# LANGUAGE TemplateHaskell #-}++module Polysemy.Random+  ( -- * Effect+    Random (..)++    -- * Actions+  , random+  , randomR++    -- * Interpretations+  , runRandom+  , runRandomIO+  ) where++import           Polysemy+import           Polysemy.State+import qualified System.Random as R++------------------------------------------------------------------------------+-- | An effect capable of providing 'R.Random' values.+data Random m a where+  Random :: R.Random x => Random m x+  RandomR :: R.Random x => (x, x) -> Random m x++makeSemantic ''Random+++------------------------------------------------------------------------------+-- | Run a 'Random' effect with an explicit 'R.RandomGen'.+runRandom+    :: forall q r a+     . ( Typeable q+       , R.RandomGen q+       )+    => q+    -> Semantic (Random ': r) a+    -> Semantic r (q, a)+runRandom q = runState q . reinterpret \case+  Random -> do+    ~(a, q') <- gets @q R.random+    put q'+    pure a+  RandomR r -> do+    ~(a, q') <- gets @q $ R.randomR r+    put q'+    pure a+{-# INLINE runRandom #-}+++------------------------------------------------------------------------------+-- | Run a 'Random' effect by using the 'IO' random generator.+runRandomIO :: Member (Lift IO) r => Semantic (Random ': r) a -> Semantic r a+runRandomIO m = do+  q <- sendM R.newStdGen+  snd <$> runRandom q m+{-# INLINE runRandomIO #-}+

@@ -0,0 +1,56 @@+{-# LANGUAGE TemplateHaskell #-}++module Polysemy.Reader+  ( -- * Effect+    Reader (..)++    -- * Actions+  , ask+  , asks+  , local++    -- * Interpretations+  , runReader+  , runInputAsReader+  ) where++import Polysemy+import Polysemy.Input+++------------------------------------------------------------------------------+-- | An effect corresponding to 'Control.Monad.Trans.Reader.ReaderT'.+data Reader i m a where+  Ask   :: Reader i m i+  Local :: (i -> i) -> m a -> Reader i m a++makeSemantic ''Reader+++asks :: Member (Reader i) r => (i -> j) -> Semantic r j+asks f = f <$> ask+{-# INLINABLE asks #-}+++------------------------------------------------------------------------------+-- | Run a 'Reader' effect with a constant value.+runReader :: i -> Semantic (Reader i ': r) a -> Semantic r a+runReader i = interpretH $ \case+  Ask -> pureT i+  Local f m -> do+    mm <- runT m+    raise $ runReader_b (f i) mm+{-# INLINE runReader #-}++runReader_b :: i -> Semantic (Reader i ': r) a -> Semantic r a+runReader_b = runReader+{-# NOINLINE runReader_b #-}+++------------------------------------------------------------------------------+-- | Transform an 'Input' effect into a 'Reader' effect.+runInputAsReader :: Semantic (Input i ': r) a -> Semantic (Reader i ': r) a+runInputAsReader = reinterpret $ \case+  Input -> ask+{-# INLINE runInputAsReader #-}+

@@ -0,0 +1,57 @@+{-# LANGUAGE TemplateHaskell #-}++module Polysemy.Resource+  ( -- * Effect+    Resource (..)++    -- * Actions+  , bracket++    -- * Interpretations+  , runResource+  ) where++import qualified Control.Exception as X+import           Polysemy+++------------------------------------------------------------------------------+-- | An effect capable of providing 'X.bracket' semantic. Interpreters for this+-- will successfully run the deallocation action even in the presence of other+-- short-circuiting effects.+data Resource m a where+  Bracket+    :: m a+       -- ^ Action to allocate a resource.+    -> (a -> m ())+       -- ^ Action to cleanup the resource. This is guaranteed to be+       -- called.+    -> (a -> m b)+       -- ^ Action which uses the resource.+    -> Resource m b++makeSemantic ''Resource+++------------------------------------------------------------------------------+-- | Run a 'Resource' effect via in terms of 'X.bracket'.+runResource+    :: forall r a+     . Member (Lift IO) r+    => (∀ x. Semantic r x -> IO x)+       -- ^ Strategy for lowering a 'Semantic' action down to 'IO'. This is+       -- likely some combination of 'runM' and other interpters composed via+       -- '.@'.+    -> Semantic (Resource ': r) a+    -> Semantic r a+runResource finish = interpretH $ \case+  Bracket alloc dealloc use -> do+    a <- runT  alloc+    d <- bindT dealloc+    u <- bindT use++    let runIt :: Semantic (Resource ': r) x -> IO x+        runIt = finish .@ runResource++    sendM $ X.bracket (runIt a) (runIt . d) (runIt . u)+

@@ -0,0 +1,76 @@+{-# LANGUAGE TemplateHaskell #-}++module Polysemy.State+  ( -- * Effect+    State (..)++    -- * Actions+  , get+  , gets+  , put+  , modify++    -- * Interpretations+  , runState+  , runLazyState+  ) where++import Polysemy+import Polysemy.Internal.Combinators+++------------------------------------------------------------------------------+-- | An effect for providing statefulness. Note that unlike mtl's+-- 'Control.Monad.Trans.State.StateT', there is no restriction that the 'State'+-- effect corresponds necessarily to /local/ state. It could could just as well+-- be interrpeted in terms of HTTP requests or database access.+--+-- Interpreters which require statefulness can 'Polysemy.reinterpret'+-- themselves in terms of 'State', and subsequently call 'runState'.+data State s m a where+  Get :: State s m s+  Put :: s -> State s m ()++makeSemantic ''State+++gets :: Member (State s) r => (s -> a) -> Semantic r a+gets f = fmap f get+{-# INLINABLE gets #-}+++modify :: Member (State s) r => (s -> s) -> Semantic r ()+modify f = do+  s <- get+  put $ f s+{-# INLINABLE modify #-}+++------------------------------------------------------------------------------+-- | Run a 'State' effect with local state.+runState :: Typeable s => s -> Semantic (State s ': r) a -> Semantic r (s, a)+runState = stateful $ \case+  Get   -> \s -> pure (s, s)+  Put s -> const $ pure (s, ())+{-# INLINE[3] runState #-}+++------------------------------------------------------------------------------+-- | Run a 'State' effect with local state, lazily.+runLazyState :: Typeable s => s -> Semantic (State s ': r) a -> Semantic r (s, a)+runLazyState = lazilyStateful $ \case+  Get   -> \s -> pure (s, s)+  Put s -> const $ pure (s, ())+{-# INLINE[3] runLazyState #-}+++{-# RULES "runState/reinterpret"+   forall s e (f :: forall m x. e m x -> Semantic (State s ': r) x).+     runState s (reinterpret f e) = stateful (\x s' -> runState s' $ f x) s e+     #-}++{-# RULES "runLazyState/reinterpret"+   forall s e (f :: forall m x. e m x -> Semantic (State s ': r) x).+     runLazyState s (reinterpret f e) = lazilyStateful (\x s' -> runLazyState s' $ f x) s e+     #-}+

@@ -0,0 +1,50 @@+{-# LANGUAGE TemplateHaskell #-}++module Polysemy.Trace+  ( -- * Effect+    Trace (..)++    -- * Actions+  , trace++    -- * Interpretations+  , runTraceIO+  , runIgnoringTrace+  , runTraceAsOutput+  ) where++import Polysemy+import Polysemy.Output+++------------------------------------------------------------------------------+-- | An effect for logging strings.+data Trace m a where+  Trace :: String -> Trace m ()++makeSemantic ''Trace+++------------------------------------------------------------------------------+-- | Run a 'Trace' effect by printing the messages to stdout.+runTraceIO :: Member (Lift IO) r => Semantic (Trace ': r) a -> Semantic r a+runTraceIO = interpret $ \case+  Trace m -> sendM $ putStrLn m+{-# INLINE runTraceIO #-}+++------------------------------------------------------------------------------+-- | Run a 'Trace' effect by ignoring all of its messages.+runIgnoringTrace :: Member (Lift IO) r => Semantic (Trace ': r) a -> Semantic r a+runIgnoringTrace = interpret $ \case+  Trace _ -> pure ()+{-# INLINE runIgnoringTrace #-}+++------------------------------------------------------------------------------+-- | Transform a 'Trace' effect into a 'Output' 'String' effect.+runTraceAsOutput :: Semantic (Trace ': r) a -> Semantic (Output String ': r) a+runTraceAsOutput = reinterpret $ \case+  Trace m -> output m+{-# INLINE runTraceAsOutput #-}+

@@ -0,0 +1,61 @@+{-# LANGUAGE BlockArguments  #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections   #-}++module Polysemy.Writer+  ( -- * Effect+    Writer (..)++    -- * Actions+  , tell+  , listen+  , censor++    -- * Interpretations+  , runOutputAsWriter+  , runWriter+  ) where++import Polysemy+import Polysemy.Output+import Polysemy.State++------------------------------------------------------------------------------+-- | An effect capable of emitting and intercepting messages.+data Writer o m a where+  Tell   :: o -> Writer o m ()+  Listen :: ∀ o m a. m a -> Writer o m (o, a)+  Censor :: (o -> o) -> m a -> Writer o m a++makeSemantic ''Writer+++------------------------------------------------------------------------------+-- | Transform an 'Output' effect into a 'Writer' effect.+runOutputAsWriter :: Semantic (Output o ': r) a -> Semantic (Writer o ': r) a+runOutputAsWriter = reinterpret \case+  Output o -> tell o+{-# INLINE runOutputAsWriter #-}+++------------------------------------------------------------------------------+-- | Run a 'Writer' effect in the style of 'Control.Monad.Trans.Writer.WriterT'+-- (but without the nasty space leak!)+runWriter+    :: (Monoid o, Typeable o)+    => Semantic (Writer o ': r) a+    -> Semantic r (o, a)+runWriter = runState mempty . reinterpretH \case+  Tell o -> do+    modify (<> o) >>= pureT+  Listen m -> do+    mm <- runT m+    -- TODO(sandy): this is fucking stupid+    (o, fa) <- raise $ runWriter mm+    pure $ fmap (o, ) fa+  Censor f m -> do+    mm <- runT m+    ~(o, a) <- raise $ runWriter mm+    modify (<> f o)+    pure a+

@@ -0,0 +1,76 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE TemplateHaskell  #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -O2           #-}++module FusionSpec where++import qualified Control.Monad.Trans.Except as E+import qualified Control.Monad.Trans.State.Strict as S+import           Polysemy.Error+import           Polysemy.Internal+import           Polysemy.Internal.Combinators+import           Polysemy.Internal.Effect+import           Polysemy.Internal.Union+import           Polysemy.State+import           Test.Hspec+import           Test.Inspection+++isSuccess :: Result -> Bool+isSuccess (Success _) = True+isSuccess (Failure e) = error e++shouldSucceed :: Result -> Expectation+shouldSucceed r = r `shouldSatisfy` isSuccess+++spec :: Spec+spec = do+  describe "fusion" $ do+    it "Union proofs should simplify" $ do+      shouldSucceed $(inspectTest $ 'countDown `hasNoType` ''SNat)++    it "internal uses of StateT should simplify" $ do+      shouldSucceed $(inspectTest $ 'countDown `doesNotUse` ''S.StateT)+      shouldSucceed $(inspectTest $ 'jank      `doesNotUse` ''S.StateT)++    it "internal uses of ExceptT should simplify" $ do+      shouldSucceed $(inspectTest $ 'tryIt `doesNotUse` ''E.ExceptT)++    it "`runState . reinterpret` should fuse" $ do+      shouldSucceed $(inspectTest $ 'jank `doesNotUse` 'reinterpret)+      shouldSucceed $(inspectTest $ 'jank `doesNotUse` 'hoist)++    it "who needs Sematic even?" $ do+      shouldSucceed $(inspectTest $ 'countDown `doesNotUse` 'Semantic)+      shouldSucceed $(inspectTest $ 'jank `doesNotUse` 'Semantic)+      shouldSucceed $(inspectTest $ 'tryIt `doesNotUse` 'Semantic)+++go :: Semantic '[State Int] Int+go = do+  n <- get+  if n <= 0+     then pure n+     else do+       put (n-1)+       go+++tryIt :: Either Bool String+tryIt = run . runError @Bool $ do+  catch @Bool+    do+      throw False+    \_ -> pure "hello"+++countDown :: Int -> Int+countDown start = fst $ run $ runState start go+++jank :: Int -> Int+jank start = fst $ run $ runState start $ go+

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}