diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for polysemy-zoo +## 0.1.2.1 (2019-06-12) + +- Update the tests to run against `polysemy-0.4.0.0` + + ## 0.1.2.0 (2019-06-01) - Added `Polysemy.MTL` for inter-op with MTL (thanks to @adamConnerSax) diff --git a/polysemy-zoo.cabal b/polysemy-zoo.cabal --- a/polysemy-zoo.cabal +++ b/polysemy-zoo.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 07f2fe507c2afe8ef70bcc42b26d3eaa3541eee97656ce45a5afa9ea207334cc +-- hash: b8422eaa237bad8199d235d37dd432322f191094275f7e61d94fb38fb030d101 name: polysemy-zoo -version: 0.1.2.0 +version: 0.1.2.1 synopsis: Experimental, user-contributed effects and interpreters for polysemy description: Please see the README on GitHub at category: Polysemy @@ -35,6 +35,7 @@ Polysemy.Operators Polysemy.Random Polysemy.RandomFu + Polysemy.Several other-modules: Paths_polysemy_zoo hs-source-dirs: @@ -62,6 +63,7 @@ KVStoreSpec MTLSpec RandomFuSpec + SeveralSpec Paths_polysemy_zoo hs-source-dirs: test @@ -73,7 +75,7 @@ , containers , hspec , mtl >=2.0.1.0 && <3.0.0.0 - , polysemy >=0.3 + , polysemy >=0.4 , polysemy-plugin , polysemy-zoo , random >=1.1 && <1.2 diff --git a/src/Polysemy/Operators.hs b/src/Polysemy/Operators.hs --- a/src/Polysemy/Operators.hs +++ b/src/Polysemy/Operators.hs @@ -1,62 +1,75 @@ -{-| - -Operators meant as replacements for traditional 'Sem' type and 'Member' / -'Members' constraints, that allow you to specify types of your actions and -interpreters in more concise way, e.g. without mentioning unnecessary -details: - -@ -foo :: 'Member' ('Lift' 'IO') r => 'String' -> 'Int' -> 'Sem' r () -@ - -can be written simply as: - -@ -foo :: 'String' -> 'Int' -> 'IO' '~@>' () -@ - -Working example with operators: - -@ -import Data.Function -import Polysemy -import Polysemy.Operators -import Polysemy.Random - -data ConsoleIO m a where - WriteStrLn :: 'String' -> ConsoleIO m () - ReadStrLn :: ConsoleIO m 'String' - ShowStrLn :: 'Show' a => a -> ConsoleIO m () - -'makeSem' ''ConsoleIO - --- runConsoleIO :: Member (Lift IO) r => Sem (ConsoleIO:r) a -> Sem r a -runConsoleIO :: ConsoleIO:r '@>' a -> 'IO' '~@' r '@>' a -runConsoleIO = 'interpret' \\case - WriteStrLn s -> 'sendM' '$' 'putStrLn' s - ReadStrLn -> 'sendM' 'getLine' - ShowStrLn v -> 'sendM' '$' 'print' v - -main :: 'IO' () -main = program - 'Data.Function.&' runConsoleIO - 'Data.Function.&' 'Polysemy.Random.runRandomIO' - 'Data.Function.&' 'runM' - --- program :: Members \'[Random, ConsoleIO] r => Sem r () -program :: \'['Polysemy.Random', ConsoleIO] '>@>' () -program = do - writeStrLn "It works! Write something:" - val <- readStrLn - writeStrLn '$' "Here it is!: " '++' val - num <- 'Polysemy.Random.random' \@'Int' - writeStrLn '$' "Some random number:" - showStrLn num -@ - -See documentation of specific operators for more details. - --} +-- | Operators meant as replacements for traditional 'Sem' type and 'Member' / +-- 'Members' constraints, that allow you to specify types of your actions and +-- interpreters in more concise way, without mentioning unnecessary details: +-- +-- @ +-- foo :: 'Member' ('Lift' 'IO') r => 'String' -> 'Int' -> 'Sem' r () +-- @ +-- +-- can be written simply as: +-- +-- @ +-- foo :: 'String' -> 'Int' -> 'IO' '~@>' () +-- @ +-- +-- Working example with operators: +-- +-- @ +-- import Data.Function +-- import Polysemy +-- import Polysemy.Operators +-- import Polysemy.Random +-- +-- data ConsoleIO m a where +-- WriteStrLn :: 'String' -> ConsoleIO m () +-- ReadStrLn :: ConsoleIO m 'String' +-- ShowStrLn :: 'Show' a => a -> ConsoleIO m () +-- +-- 'makeSem' ''ConsoleIO +-- +-- -- runConsoleIO :: Member (Lift IO) r => Sem (ConsoleIO : r) a -> Sem r a +-- runConsoleIO :: ConsoleIO : r '@>' a -> 'IO' '~@' r '@>' a +-- runConsoleIO = 'interpret' \\case +-- WriteStrLn s -> 'sendM' '$' 'putStrLn' s +-- ReadStrLn -> 'sendM' 'getLine' +-- ShowStrLn v -> 'sendM' '$' 'print' v +-- +-- main :: 'IO' () +-- main = program +-- 'Data.Function.&' runConsoleIO +-- 'Data.Function.&' 'Polysemy.Random.runRandomIO' +-- 'Data.Function.&' 'runM' +-- +-- -- program :: Members \'[Random, ConsoleIO] r => Sem r () +-- program :: \'['Polysemy.Random', ConsoleIO] '>@>' () +-- program = do +-- writeStrLn "It works! Write something:" +-- val <- readStrLn +-- writeStrLn '$' "Here it is!: " '++' val +-- num <- 'Polysemy.Random.random' \@'Int' +-- writeStrLn '$' "Some random number:" +-- showStrLn num +-- @ +-- +-- Please keep in mind that constraints created through these operators are +-- limited to the action they are being used on, for example: +-- +-- @ +-- foo :: (forall x. r '@>' x -> 'IO' x) +-- -> 'IO' (forall a. Foo : r '@>' a -> 'IO' '~@' r '@>' a) +-- @ +-- +-- The first argument in the signature above won't have access to the +-- @('IO' ~\@)@ constraint in the result - in such cases, use a normal +-- constraint instead: +-- +-- @ +-- foo :: 'Member' ('Lift' 'IO') r +-- => (forall x. r '@>' x -> 'IO' x) +-- -> 'IO' (forall a. Foo : r '@>' a -> r '@>' a) +-- @ +-- +-- See the documentation of specific operators for more details. module Polysemy.Operators ( -- * 'Sem' operators @@ -80,16 +93,13 @@ import Polysemy ------------------------------------------------------------------------------- -- Miscellaneous ------------------------------------------------------------- ------------------------------------------------------------------------------- -- | Gets list of effects from 'Sem'. type family SemList s where SemList (Sem r _) = r ------------------------------------------------------------------------------- -- Operators ----------------------------------------------------------------- ------------------------------------------------------------------------------- + -- $SemOperators -- Infix equivalents of 'Sem' with versions for specifiying list of effects -- ('@>'), single effect ('@-') and single monad ('@~') as effects of union. diff --git a/src/Polysemy/Several.hs b/src/Polysemy/Several.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Several.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TemplateHaskell #-} + +module Polysemy.Several + ( -- * Data + HList(..) + , TypeMap + , TypeConcat + , runSeveral + ) +where + +import Polysemy +import Data.Kind + +------------------------------------------------------------------------------ +-- | A list capable of storing values of different types. Like the Sem type, +-- it uses a type level list to keep track of what's stored inside. Creating an +-- HList looks like: +-- +-- > 1 ::: "test" ::: True ::: HNil +infixr 5 ::: +data HList a where + HNil :: HList '[] + (:::) :: a -> HList (b :: [Type]) -> HList (a ': b) + +type Eff = (Type -> Type) -> Type -> Type +------------------------------------------------------------------------------ +-- | A map function over type level lists. For example, the following two +-- lines are equivalent: +-- +-- > TypeMap Reader [Int, String, False] +-- > [Reader Int, Reader String, Reader Bool] +type family TypeMap (f :: a -> b) (xs :: [a]) where + TypeMap _ '[] = '[] + TypeMap f (x ': xs) = f x ': TypeMap f xs + +------------------------------------------------------------------------------ +-- | Like ++ but at the type level. The following two lines are equivalent: +-- +-- > TypeConcat [Int, String] [Bool] +-- > [Int, String, Bool] +type family TypeConcat (a :: [t]) (b :: [t]) where + TypeConcat '[] b = b + TypeConcat (a ': as) b = a ': TypeConcat as b + +------------------------------------------------------------------------------ +-- | A helper function for building new runners which accept HLists intsead of +-- individual elements. If you would normally write +-- +-- > f 5 . f "Text" . f True +-- +-- then this function can turn that into +-- +-- > runSeveral f (True ::: "Text" ::: 5 ::: HNil) +-- +-- For example, a runReaders function could be implemented as: +-- +-- > runReaders :: HList t -> Sem (TypeConcat (TypeMap Reader t) r) a -> Sem r a +-- > runReaders = runSeveral runReader +-- +-- Likewise, runStates could be the following if you didn't want the returned +-- state: +-- +-- > runStates :: HList t -> Sem (TypeConcat (TypeMap State t) r) a -> Sem r a +-- > runStates = runSeveral (fmap (fmap snd) . runState) +runSeveral + :: (forall r k x. k -> Sem (e k ': r) x -> Sem r x) + -> HList t + -> Sem (TypeConcat (TypeMap e t) r) a + -> Sem r a +runSeveral f (a ::: as) = runSeveral f as . f a +runSeveral _ HNil = id diff --git a/test/IdempotentLoweringSpec.hs b/test/IdempotentLoweringSpec.hs --- a/test/IdempotentLoweringSpec.hs +++ b/test/IdempotentLoweringSpec.hs @@ -32,7 +32,7 @@ spec :: Spec spec = describe "Idempotent Lowering" $ do it "should persist an IORef through a bracket" $ do - runIt <- nat runM .@! const (runStateInIO 0) .@! liftNat runResource + runIt <- nat runM .@! const (runStateInIO 0) .@! liftNat runResourceInIO result <- runIt test result `shouldBe` (3 :: Int) diff --git a/test/MTLSpec.hs b/test/MTLSpec.hs --- a/test/MTLSpec.hs +++ b/test/MTLSpec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} + module MTLSpec where import Polysemy @@ -70,7 +71,7 @@ ++ " In this case, 16, the sum of \"init [1,5,5,5,5]\"" ) $ do - flip shouldBe 16 . sum . fst . run . runWriter $ do + flip shouldBe 16 . sum @[] . fst . run . runWriter $ do tell [1] absorbWriter $ replicateTell 2 5 censor init $ absorbWriter $ replicateTell 2 5 diff --git a/test/SeveralSpec.hs b/test/SeveralSpec.hs new file mode 100644 --- /dev/null +++ b/test/SeveralSpec.hs @@ -0,0 +1,78 @@ +module SeveralSpec where + +import Polysemy +import Polysemy.State +import Polysemy.Reader +import Polysemy.Input +import Polysemy.Several +import Test.Hspec + + +readerProgram :: ( Member (Reader String) r + , Member (Reader Int) r + , Member (Reader Bool) r + , Members [Reader String, Reader Int, Reader Bool] r + ~ Members (TypeMap Reader [String, Int, Bool]) r + ) => Sem r (Int, String, Bool) +readerProgram = do + a <- ask @Int + b <- ask @String + c <- ask @Bool + pure $ (a, b, c) + +stateProgram :: ( Member (State String) r + , Member (State Int) r + , Member (State Bool) r + , Members [State String, State Int, State Bool] r + ~ Members (TypeMap State [String, Int, Bool]) r + ) => Sem r (Int, String, Bool) +stateProgram = do + put @Int 5 + put "Changed" + a <- get @Int + b <- get @String + c <- get @Bool + pure $ (a, b, c) + +inputProgram :: ( Member (Input String) r + , Member (Input Int) r + , Member (Input Bool) r + , Members [Input String, Input Int, Input Bool] r + ~ Members (TypeMap Input [String, Int, Bool]) r + ) => Sem r (Int, String, Bool) +inputProgram = do + a <- input @Int + b <- input @String + c <- input @Bool + pure $ (a, b, c) + + +runReaders = runSeveral runReader + +runStates = runSeveral (fmap (fmap snd) . runState) + +runConstInputs = runSeveral runConstInput + +spec = do + describe "runReaders" $ do + let original = runReader 5 . runReader "test" . runReader True $ readerProgram + new = runReaders (True ::: "test" ::: 5 ::: HNil) readerProgram + + it "should be equivalent to composed runReader" $ do + run original `shouldBe` run new + + describe "runStates" $ do + let getResult = fmap $ snd . snd . snd + original = getResult $ runState 5 . runState "test" . runState True $ stateProgram + new = runStates (True ::: "test" ::: 5 ::: HNil) stateProgram + + it "should be equivalent to composed runState" $ do + run original `shouldBe` run new + + describe "runConstInput" $ do + let original = runConstInput 5 . runConstInput "test" + . runConstInput True $ inputProgram + new = runConstInputs (True ::: "test" ::: 5 ::: HNil) inputProgram + + it "should be equivalent to composed runConstInput" $ do + run original `shouldBe` run new