polysemy-zoo 0.1.0.0 → 0.1.1.0

raw patch · 4 files changed

+182/−2 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• polysemy-zoo.cabal +4/−2
• src/Polysemy/IdempotentLowering.hs +135/−0
• test/IdempotentLoweringSpec.hs +38/−0

@@ -1,3 +1,8 @@ # Changelog for polysemy-zoo +## 0.1.1.0 (2019-05-22)++- Added `Polysemy.IdempotentLowering`++ ## Unreleased changes

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 2d4516a720456988b36823c429a9eb061d049ee62b9cd980163ebff3062f13c3+-- hash: 1c51b9ddcd467cc5950fc9a4c63030c540dc98d4a3f594ef63ac0a3a95d7fc41  name:           polysemy-zoo-version:        0.1.0.0+version:        0.1.1.0 synopsis:       Experimental, user-contributed effects and interpreters for polysemy description:    Please see the README on GitHub at <https://github.com/isovector/polysemy-zoo#readme> category:       Polysemy@@ -29,6 +29,7 @@  library   exposed-modules:+      Polysemy.IdempotentLowering       Polysemy.KVStore       Polysemy.Operators   other-modules:@@ -48,6 +49,7 @@   type: exitcode-stdio-1.0   main-is: Main.hs   other-modules:+      IdempotentLoweringSpec       KVStoreSpec       Paths_polysemy_zoo   hs-source-dirs:

@@ -0,0 +1,135 @@+{-# LANGUAGE ImpredicativeTypes #-}++module Polysemy.IdempotentLowering+  ( (.@!)+  , nat+  , liftNat+  , (.@@!)+  , nat'+  , liftNat'+  ) where++import Polysemy+import Data.Coerce++newtype Nat m n = Nat (∀ x. m x -> n x)++------------------------------------------------------------------------------+-- | This is just 'pure' but with a type specialised for lifting interpreters.+--+-- @since 0.1.1.0+nat :: Applicative base => (∀ x. m x -> n x) -> base (∀ x. m x -> n x)+nat f = pure $ coerce $ Nat f++newtype Nat' m n f = Nat' (∀ x. m x -> n (f x))++------------------------------------------------------------------------------+-- | 'nat'' is to 'nat' as '.@@!' is to '.@!'.+--+-- @since 0.1.1.0+nat' :: Applicative base => (∀ x. m x -> n (f x)) -> base (∀ x. m x -> n (f x))+nat' f = pure $ coerce $ Nat' f++------------------------------------------------------------------------------+-- | Like 'Polysemy..@', but useful for interpreters that wish to perform some+-- initialization before being run. Most of the time, you don't want to+-- duplicate this initialization every time your effect is lowered.+--+-- Consider an interpreter which wants to use an 'Data.IORef.IORef' to store+-- intermediary state. It might begin like this:+--+-- @+-- myIntepreter+--     :: 'Polysemy.Member' ('Polysemy.Lift' 'IO') r+--     => (∀ x. 'Polysemy.Sem' r x -> 'IO' x)+--     -> 'Polysemy.Sem' (MyEff ': r) a+--     -> 'Polysemy.Sem' r a+-- myInterpreter lower sem = do+--     ref <- 'Polysemy.sendM' $ 'Data.IORef.newIORef' 0+--     go ref sem+--   where+--     go ref = 'Polysemy.interpretH' $ \e -> ...+-- @+--+-- This interpreter will do the wrong thing when composed via 'Polysemy..@'. It+-- would have been correct if we didn't attempt to hide the creation of the+-- 'Data.IORef.IORef', but that's an unfortunate side-effect of wanting to hide+-- implementation details.+--+-- Instead, we can write @myInterpreter@ thusly:+--+-- @+-- myIntepreter+--     :: (∀ x. 'Polysemy.Sem' r x -> 'IO' x)+--     -> 'IO' (∀ a. 'Polysemy.Sem' (MyEff ': r) a -> 'Polysemy.Sem' r a)+-- myInterpreter lower = do+--     ref <- 'Data.IORef.newIORef' 0+--     'nat' $ 'Polysemy.interpretH' $ \e -> ...+-- @+--+-- and use '.@!' (rather than 'Polysemy..@') to compose these things together.+--+-- Note: you must enable @-XImpredicativeTypes@ to give the correct type to+-- @myInterpreter@ here. Don't worry, it's (probably) not as scary as it+-- sounds.+--+-- @since 0.1.1.0+(.@!)+    :: (Monad base, Monad m)+    => base (∀ x. Sem r x -> m x)+       -- ^ The lowering function, likely @nat runM@.+    -> ( (∀ x. Sem r x -> m x)+      -> base ( ∀ y+           . Sem (e ': r) y+          -> Sem r y+           )+       )+    -> base (∀ z. Sem (e ': r) z -> m z)+fi .@! gi = do+  f <- fi+  g <- gi f+  nat $ \z -> f $ g z+infixl 8 .@!+++------------------------------------------------------------------------------+-- | Like '.@!', but for interpreters which change the resulting type --- eg.+-- 'Polysemy.Error.runErrorInIO'.+--+-- @since 0.1.1.0+(.@@!)+    :: (Monad base, Monad m)+    => base (∀ x. Sem r x -> m x)+       -- ^ The lowering function, likely @nat runM@.+    -> ( (∀ x. Sem r x -> m x)+      -> base ( ∀ y+           . Sem (e ': r) y+          -> Sem r (f y)+           )+       )+    -> base (∀ z. Sem (e ': r) z -> m (f z))+fi .@@! gi = do+  f <- fi+  g <- gi f+  nat' $ \z -> f $ g z+infixl 8 .@@!+++------------------------------------------------------------------------------+-- | Lift a combinator designed to be used with 'Polysemy..@' into one designed+-- to be used with 'Polysemy..@!'.+liftNat+  :: Applicative base+  => (forall x. (forall y. f y -> g y) -> m x -> n x)+  -> (forall y. f y -> g y) -> base (forall x. m x -> n x)+liftNat z a = nat $ z a++------------------------------------------------------------------------------+-- | Lift a combinator designed to be used with 'Polysemy..@@' into one designed+-- to be used with 'Polysemy..@@!'.+liftNat'+  :: Applicative base+  => (forall x. (forall y. f y -> g y) -> m x -> n (f x))+  -> (forall y. f y -> g y) -> base (forall x. m x -> n (f x))+liftNat' z a = nat' $ z a+

@@ -0,0 +1,38 @@+{-# LANGUAGE ImpredicativeTypes #-}++module IdempotentLoweringSpec where++import Data.IORef+import Polysemy+import Polysemy.State+import Polysemy.IdempotentLowering+import Polysemy.Resource+import Test.Hspec+++runStateInIO :: Member (Lift IO) r => s -> IO (∀ x. Sem (State s ': r) x -> Sem r x)+runStateInIO s = do+  ref <- newIORef s+  nat $ runStateInIORef ref+++test+    :: ( Member Resource r+       , Member (State Int) r+       )+    => Sem r Int+test = do+  bracket+    (modify (+1))+    (const $ modify (+1))+    (const $ modify (+1))+  get+++spec :: Spec+spec = describe "Idempotent Lowering" $ do+  it "should persist an IORef through a bracket" $ do+    runIt <- nat runM .@! const (runStateInIO 0) .@! liftNat runResource+    result <- runIt test+    result `shouldBe` (3 :: Int)+