polysemy 0.1.2.0 → 0.1.2.1

raw patch · 17 files changed

+323/−192 lines, 17 filesdep ~criteriondep ~dump-coredep ~freePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: criterion, dump-core, free, freer-simple, hspec, mtl

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• README.md +82/−28
• polysemy.cabal +113/−116
• src/Polysemy/Internal.hs +12/−1
• src/Polysemy/Internal/Combinators.hs +7/−6
• src/Polysemy/Internal/CustomErrors.hs +6/−2
• src/Polysemy/Internal/Effect.hs +16/−4
• src/Polysemy/Internal/Fixpoint.hs +2/−0
• src/Polysemy/Internal/Lift.hs +2/−0
• src/Polysemy/Internal/NonDet.hs +2/−0
• src/Polysemy/Internal/PluginLookup.hs +9/−0
• src/Polysemy/Internal/TH/Effect.hs +2/−0
• src/Polysemy/Internal/TH/Performance.hs +2/−0
• src/Polysemy/Internal/Tactics.hs +2/−1
• src/Polysemy/Internal/Union.hs +21/−30
• src/Polysemy/State.hs +37/−3
• test/FusionSpec.hs +1/−1

@@ -1,5 +1,12 @@ # Changelog for polysemy +## 0.1.2.1 (2019-05-18)++- Give explicit package bounds for dependencies+- Haddock improvements+- Remove `Typeable` machinery from `Polysemy.Internal.Union` (thanks to+    @googleson78)+ ## 0.1.2.0 (2019-04-26)  - `runInputAsReader`, `runTraceAsOutput` and `runOutputAsWriter` have more

@@ -26,7 +26,26 @@  It's like `fused-effects` but with an order of magnitude less boilerplate. +Additionally, unlike `mtl`, `polysemy` has no functional dependencies, so you+can use multiple copies of the same effect. This alleviates the need for ~~ugly+hacks~~band-aids like [classy+lenses](http://hackage.haskell.org/package/lens-4.17.1/docs/Control-Lens-TH.html#v:makeClassy),+the [`ReaderT`+pattern](https://www.fpcomplete.com/blog/2017/06/readert-design-pattern) and+nicely solves the [trouble with typed+errors](https://www.parsonsmatt.org/2018/11/03/trouble_with_typed_errors.html). +Concerned about type inference? Check out+[polysemy-plugin](https://github.com/isovector/polysemy/tree/master/polysemy-plugin),+which should perform just as well as `mtl`'s! Add `polysemy-plugin` to your package.yaml+or .cabal file's dependencies section to use. Then turn it on with a pragma in your source-files:++```haskell+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}+```+Or by adding `-fplugin=Polysemy.Plugin` to your package.yaml/.cabal file `ghc-options` section.++ ## Features  * *Effects are higher-order,* meaning it's trivial to write `bracket` and `local`@@ -48,23 +67,59 @@ Extensions](https://github.com/isovector/polysemy#necessary-language-extensions) before trying these yourself! -Console effect:+Teletype effect:  ```haskell {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE LambdaCase, BlockArguments #-}+{-# LANGUAGE GADTs, FlexibleContexts, TypeOperators, DataKinds, PolyKinds #-}  import Polysemy+import Polysemy.Input+import Polysemy.Output -data Console m a where-  ReadTTY  :: Console m String-  WriteTTY :: String -> Console m ()+data Teletype m a where+  ReadTTY  :: Teletype m String+  WriteTTY :: String -> Teletype m () -makeSem ''Console+makeSem ''Teletype -runConsoleIO :: Member (Lift IO) r => Sem (Console ': r) a -> Sem r a-runConsoleIO = interpret $ \case+runTeletypeIO :: Member (Lift IO) r => Sem (Teletype ': r) a -> Sem r a+runTeletypeIO = interpret $ \case   ReadTTY      -> sendM getLine   WriteTTY msg -> sendM $ 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+  . reinterpret2 \case     -- Reinterpret our effect in terms of Input and Output+      ReadTTY -> maybe "" id <$> input+      WriteTTY msg -> output msg+++echo :: Member Teletype r => Sem r ()+echo = do+  i <- readTTY+  case i of+    "" -> pure ()+    _  -> writeTTY i >> echo+++-- Let's pretend+echoPure :: [String] -> Sem '[] ([String], ())+echoPure = flip runTeletypePure echo++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 ```  @@ -72,31 +127,31 @@  ```haskell {-# LANGUAGE TemplateHaskell #-}--import qualified Control.Exception as X-import           Polysemy+{-# LANGUAGE LambdaCase, BlockArguments #-}+{-# LANGUAGE GADTs, FlexibleContexts, TypeOperators, DataKinds, PolyKinds, TypeApplications #-} -data Resource m a where-  Bracket :: m a -> (a -> m ()) -> (a -> m b) -> Resource m b+import Prelude hiding (throw, catch, bracket)+import Polysemy+import Polysemy.Input+import Polysemy.Output+import Polysemy.Error+import Polysemy.Resource -makeSem ''Resource+-- Using Teletype effect from above -runResource-    :: forall r a-     . Member (Lift IO) r-    => (∀ x. Sem r x -> IO x)-    -> Sem (Resource ': r) a-    -> Sem r a-runResource finish = interpretH $ \case-  Bracket alloc dealloc use -> do-    a <- runT  alloc-    d <- bindT dealloc-    u <- bindT use+data CustomException = ThisException | ThatException deriving Show -    let runIt :: Sem (Resource ': r) x -> IO x-        runIt = finish .@ runResource+program :: Members '[Resource, Teletype, Error CustomException] r => Sem r ()+program = catch @CustomException work $ \e -> writeTTY ("Caught " ++ show e)+  where work = bracket (readTTY) (const $ writeTTY "exiting bracket") $ \input -> do+          writeTTY "entering bracket"+          case input of+            "explode"     -> throw ThisException+            "weird stuff" -> writeTTY input >> throw ThatException+            _             -> writeTTY input >> writeTTY "no exceptions" -    sendM $ X.bracket (runIt a) (runIt . d) (runIt . u)+main :: IO (Either CustomException ())+main = (runM .@ runResource .@@ runErrorInIO @CustomException) . runTeletypeIO $ program ```  Easy.@@ -159,4 +214,3 @@     - TypeOperators     - TypeFamilies ```-

@@ -1,133 +1,130 @@ cabal-version: 1.12-name: polysemy-version: 0.1.2.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++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 07720201673d182e7f285d795076b886bb48fb10b1704776922e431bf41b6c27++name:           polysemy+version:        0.1.2.1+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+homepage:       https://github.com/isovector/polysemy#readme+bug-reports:    https://github.com/isovector/polysemy/issues+author:         Sandy Maguire+maintainer:     sandy@sandymaguire.me+copyright:      2019 Sandy Maguire+license:        BSD3+license-file:   LICENSE+build-type:     Simple extra-source-files:     README.md     ChangeLog.md  source-repository head-    type: git-    location: https://github.com/isovector/polysemy+  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+  description: Dump HTML for the core generated by GHC during compilation+  manual: True+  default: False  flag error-messages-    description:-        Provide custom error messages-    manual: True+  description: Provide custom error messages+  manual: True+  default: 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.IO-        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+  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.IO+      Polysemy.NonDet+      Polysemy.Output+      Polysemy.Random+      Polysemy.Reader+      Polysemy.Resource+      Polysemy.State+      Polysemy.Trace+      Polysemy.Writer+  other-modules:+      Polysemy.Internal.PluginLookup+  hs-source-dirs:+      src+  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 && <3+    , random >=1.1 && <1.2+    , syb >=0.7 && <0.8+    , 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:-        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+        dump-core+  if flag(error-messages)+    cpp-options: -DERROR_MESSAGES+  default-language: Haskell2010  test-suite polysemy-test-    type: exitcode-stdio-1.0-    main-is: Main.hs-    hs-source-dirs: test-    other-modules:-        FusionSpec-        OutputSpec-        Paths_polysemy-    default-language: Haskell2010-    default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs-                        LambdaCase PolyKinds RankNTypes ScopedTypeVariables-                        StandaloneDeriving TypeApplications TypeOperators TypeFamilies-                        UnicodeSyntax-    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+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      FusionSpec+      OutputSpec+      Paths_polysemy+  hs-source-dirs:+      test+  default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators TypeFamilies UnicodeSyntax+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , hspec >=2.6.0 && <3+    , inspection-testing >=0.4.1.1 && <0.5+    , mtl >=2.2.2 && <3+    , polysemy+    , random >=1.1 && <1.2+    , syb >=0.7 && <0.8+    , template-haskell >=2.14.0.0 && <2.15+    , transformers >=0.5.5.0 && <0.6+  default-language: Haskell2010  benchmark polysemy-bench-    type: exitcode-stdio-1.0-    main-is: countDown.hs-    hs-source-dirs: bench-    other-modules:-        Poly-        Paths_polysemy-    default-language: Haskell2010-    default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs-                        LambdaCase PolyKinds RankNTypes ScopedTypeVariables-                        StandaloneDeriving TypeApplications TypeOperators TypeFamilies-                        UnicodeSyntax-    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+  type: exitcode-stdio-1.0+  main-is: countDown.hs+  other-modules:+      Poly+      Paths_polysemy+  hs-source-dirs:+      bench+  default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators TypeFamilies UnicodeSyntax+  build-depends:+      base >=4.7 && <5+    , criterion+    , free+    , freer-simple+    , mtl+    , polysemy+    , random >=1.1 && <1.2+    , syb >=0.7 && <0.8+    , template-haskell >=2.14.0.0 && <2.15+    , transformers >=0.5.5.0 && <0.6+  default-language: Haskell2010

@@ -3,6 +3,9 @@ {-# LANGUAGE MonoLocalBinds       #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK not-home #-}+ module Polysemy.Internal   ( Sem (..)   , Member@@ -29,6 +32,7 @@ import Polysemy.Internal.Fixpoint import Polysemy.Internal.Lift import Polysemy.Internal.NonDet+import Polysemy.Internal.PluginLookup import Polysemy.Internal.Union  @@ -73,7 +77,7 @@ -- As an example of keeping @r@ polymorphic, we can consider the type -- -- @--- 'Member' ('Polysemy.State' String) r => 'Sem' r ()+-- 'Member' ('Polysemy.State.State' String) r => 'Sem' r () -- @ -- -- to be a program with access to@@ -129,6 +133,13 @@         => (∀ x. Union r (Sem r) x -> m x)         -> m a   }+++------------------------------------------------------------------------------+-- | Due to a quirk of the GHC plugin interface, it's only easy to find+-- transitive dependencies if they define an orphan instance. This orphan+-- instance allows us to find "Polysemy.Internal" in the polysemy-plugin.+instance PluginLookup Plugin   ------------------------------------------------------------------------------

@@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes   #-}-{-# LANGUAGE QuantifiedConstraints #-} +{-# OPTIONS_HADDOCK not-home #-}+ module Polysemy.Internal.Combinators   ( -- * First order     interpret@@ -39,7 +40,7 @@ -- | 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"+    :: FirstOrder m0 e "interpret"     => (∀ x m. e m x -> Sem r x)        -- ^ A natural transformation from the handled effect to other effects        -- already in 'Sem'.@@ -153,7 +154,7 @@ -- '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"+    :: FirstOrder m0 e1 "reinterpret"     => (∀ m x. e1 m x -> Sem (e2 ': r) x)        -- ^ A natural transformation from the handled effect to the new effect.     -> Sem (e1 ': r) a@@ -184,7 +185,7 @@ ------------------------------------------------------------------------------ -- | Like 'reinterpret', but introduces /two/ intermediary effects. reinterpret2-    :: FirstOrder e1 "reinterpret2"+    :: FirstOrder m0 e1 "reinterpret2"     => (∀ m x. e1 m x -> Sem (e2 ': e3 ': r) x)        -- ^ A natural transformation from the handled effect to the new effects.     -> Sem (e1 ': r) a@@ -214,7 +215,7 @@ ------------------------------------------------------------------------------ -- | Like 'reinterpret', but introduces /three/ intermediary effects. reinterpret3-    :: FirstOrder e1 "reinterpret3"+    :: FirstOrder m0 e1 "reinterpret3"     => (∀ m x. e1 m x -> Sem (e2 ': e3 ': e4 ': r) x)        -- ^ A natural transformation from the handled effect to the new effects.     -> Sem (e1 ': r) a@@ -229,7 +230,7 @@ -- intercept other effects and insert logic around them. intercept     :: ( Member e r-       , FirstOrder e "intercept"+       , FirstOrder m0 e "intercept"        )     => (∀ x m. e m x -> Sem r x)        -- ^ A natural transformation from the handled effect to other effects

@@ -1,9 +1,10 @@ {-# LANGUAGE AllowAmbiguousTypes   #-} {-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE UndecidableInstances  #-} +{-# OPTIONS_HADDOCK not-home #-}+ module Polysemy.Internal.CustomErrors   ( AmbiguousSend   , Break@@ -118,7 +119,10 @@ ------------------------------------------------------------------------------ -- | 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))+--+-- Note that the parameter 'm' is only required to work around supporting+-- versions of GHC without QuantifiedConstraints+type FirstOrder m e fn = Coercible (e m) (e (FirstOrderError e fn))   ------------------------------------------------------------------------------

@@ -1,6 +1,7 @@ {-# LANGUAGE DefaultSignatures     #-}-{-# LANGUAGE QuantifiedConstraints #-} +{-# OPTIONS_HADDOCK not-home #-}+ module Polysemy.Internal.Effect where  import Data.Coerce@@ -33,7 +34,18 @@ -- @ -- deriving instance Effect MyEffect -- @-class (∀ m. Functor m => Functor (e m)) => Effect e where+class Effect e where+  -- | Provide a specialised version of 'fmap' to work around versions of GHC+  -- that cannot express the quantified constraint '(∀ m. Functor m => Functor (e m))'+  --+  -- This must always be equal to 'fmap', and can be removed once GHC 8.6 is the+  -- minimum version supported by this library+  fmap' :: (a -> b) -> (e m a -> e m b)++  default fmap' :: Functor (e m) => (a -> b) -> (e m a -> e m b)+  fmap' = fmap+  {-# INLINE fmap' #-}+   -- | 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@@ -65,7 +77,7 @@       -> (∀ x. s (m x) -> n (s x))       -> e m a       -> e n (s a)-  weave s _ = coerce . fmap (<$ s)+  weave s _ = coerce . fmap' (<$ s)   {-# INLINE weave #-}    -- | Lift a natural transformation from @m@ to @n@ over the effect. 'hoist'@@ -103,7 +115,7 @@       -> e m a       -> e n a defaultHoist f-  = fmap runIdentity+  = fmap' runIdentity   . weave (Identity ())           (fmap Identity . f . runIdentity) {-# INLINE defaultHoist #-}

@@ -1,3 +1,5 @@+{-# OPTIONS_HADDOCK not-home #-}+ module Polysemy.Internal.Fixpoint where  ------------------------------------------------------------------------------

@@ -1,5 +1,7 @@ {-# LANGUAGE NoPolyKinds #-} +{-# OPTIONS_HADDOCK not-home #-}+ module Polysemy.Internal.Lift where  

@@ -2,6 +2,8 @@ {-# LANGUAGE DeriveFunctor  #-} {-# LANGUAGE NoPolyKinds    #-} +{-# OPTIONS_HADDOCK not-home #-}+ module Polysemy.Internal.NonDet where  ------------------------------------------------------------------------------

@@ -0,0 +1,9 @@+-- | Due to a quirk of the GHC plugin interface, it's only easy to find+-- transitive dependencies if they define an orphan instance. This module+-- exists to provide some things so we can define a (safe) orphan instance in+-- the module we want to find ("Polysemy.Internal").+module Polysemy.Internal.PluginLookup where++class PluginLookup t+data Plugin+

@@ -2,6 +2,8 @@ {-# LANGUAGE TemplateHaskell   #-} {-# LANGUAGE TupleSections     #-} +{-# OPTIONS_HADDOCK not-home #-}+ -- Originally ported from code written by Sandy Maguire (@isovector), available -- at https://github.com/IxpertaSolutions/freer-effects/pull/28. 

@@ -1,6 +1,8 @@ {-# LANGUAGE BlockArguments  #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK not-home #-}+ module Polysemy.Internal.TH.Performance   ( inlineRecursiveCalls   ) where

@@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes   #-}-{-# LANGUAGE QuantifiedConstraints #-}++{-# OPTIONS_HADDOCK not-home #-}  module Polysemy.Internal.Tactics   ( Tactics (..)

@@ -3,11 +3,12 @@ {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE StrictData            #-} {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE UndecidableInstances  #-} +{-# OPTIONS_HADDOCK not-home #-}+ module Polysemy.Internal.Union   ( Union (..)   , Yo (..)@@ -29,7 +30,7 @@  import Data.Functor.Compose import Data.Functor.Identity-import Data.Typeable+import Data.Type.Equality import Polysemy.Internal.Effect  #ifdef ERROR_MESSAGES@@ -78,14 +79,8 @@ {-# INLINE liftYo #-}  -instance (Functor m) => Functor (Union r m) where+instance 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 #-}  @@ -111,29 +106,28 @@   )  -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+  SS :: SNat n -> SNat ('S n) +instance TestEquality SNat where+  testEquality SZ     SZ     = Just Refl+  testEquality (SS _) SZ     = Nothing+  testEquality SZ     (SS _) = Nothing+  testEquality (SS n) (SS m) =+    case testEquality n m of+      Nothing -> Nothing+      Just Refl -> Just Refl+  {-# INLINE testEquality #-} + type family IndexOf (ts :: [k]) (n :: Nat) :: k where   IndexOf (k ': ks) 'Z = k   IndexOf (k ': ks) ('S n) = IndexOf ks n@@ -147,7 +141,7 @@   Found (u ': ts) t = 'S (Found ts t)  -class Typeable (Found r t) => Find (r :: [k]) (t :: k) where+class Find (r :: [k]) (t :: k) where   finder :: SNat (Found r t)  instance {-# OVERLAPPING #-} Find (t ': z) t where@@ -189,9 +183,7 @@ ------------------------------------------------------------------------------ -- | 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+weaken (Union n a) = Union (SS n) a {-# INLINE weaken #-}  @@ -209,12 +201,11 @@        )     => 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+prj (Union sn a) =+  let sm = finder @_ @r @e+   in case testEquality sn sm of         Nothing -> Nothing+        Just Refl -> Just a {-# INLINE prj #-}  

@@ -14,11 +14,19 @@   , runState   , runLazyState   , runStateInIORef++    -- * Interoperation with MTL+  , hoistStateIntoStateT   ) where -import Data.IORef-import Polysemy-import Polysemy.Internal.Combinators+import qualified Control.Monad.Trans.State as S+import           Data.IORef+import           Data.Tuple (swap)+import           Polysemy+import           Polysemy.Internal+import           Polysemy.Internal.Combinators+import           Polysemy.Internal.Effect+import           Polysemy.Internal.Union   ------------------------------------------------------------------------------@@ -80,6 +88,32 @@   Get   -> sendM $ readIORef ref   Put s -> sendM $ writeIORef ref s {-# INLINE runStateInIORef #-}+++------------------------------------------------------------------------------+-- | Hoist a 'State' effect into a 'S.StateT' monad transformer. This can be+-- useful when writing interpreters that need to interop with MTL.+--+-- @since 0.1.3.0+hoistStateIntoStateT+    :: Sem (State s ': r) a+    -> S.StateT s (Sem r) a+hoistStateIntoStateT (Sem m) = m $ \u ->+  case decomp u of+    Left x -> S.StateT $ \s ->+      liftSem . fmap swap+              . weave (s, ())+                      (\(s', m') -> fmap swap+                                  $ S.runStateT m' s')+              $ hoist hoistStateIntoStateT_b x+    Right (Yo Get z _ y)     -> fmap (y . (<$ z)) $ S.get+    Right (Yo (Put s) z _ y) -> fmap (y . (<$ z)) $ S.put s+{-# INLINE hoistStateIntoStateT #-}+++hoistStateIntoStateT_b :: Sem (State s ': r) a -> S.StateT s (Sem r) a+hoistStateIntoStateT_b = hoistStateIntoStateT+{-# NOINLINE hoistStateIntoStateT_b #-}   {-# RULES "runState/reinterpret"

@@ -43,7 +43,7 @@       shouldSucceed $(inspectTest $ 'jank `doesNotUse` 'reinterpret)       shouldSucceed $(inspectTest $ 'jank `doesNotUse` 'hoist) -    it "who needs Sematic even?" $ do+    it "who needs Semantic even?" $ do       shouldSucceed $(inspectTest $ 'countDown `doesNotUse` 'Sem)       shouldSucceed $(inspectTest $ 'jank `doesNotUse` 'Sem)       shouldSucceed $(inspectTest $ 'tryIt `doesNotUse` 'Sem)