mirror of
https://github.com/polysemy-research/polysemy.git
synced 2024-09-11 02:25:43 +03:00
152 lines
4.4 KiB
Haskell
152 lines
4.4 KiB
Haskell
{-# LANGUAGE AllowAmbiguousTypes #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module PluginSpec where
|
|
|
|
import Data.Functor.Identity
|
|
import GHC.Exts
|
|
import Polysemy
|
|
import Polysemy.Error
|
|
import Polysemy.State
|
|
import Polysemy.Output
|
|
import Test.Hspec
|
|
import Unsafe.Coerce
|
|
|
|
|
|
|
|
idState :: Member (State s) r => Sem r ()
|
|
idState = do
|
|
s <- get
|
|
put s
|
|
|
|
intState :: Member (State Int) r => Sem r ()
|
|
intState = put 10
|
|
|
|
numState :: Num a => Member (State a) r => Sem r ()
|
|
numState = put 10
|
|
|
|
strState :: Member (State String) r => Sem r ()
|
|
strState = put "hello"
|
|
|
|
oStrState :: IsString a => Member (State a) r => Sem r ()
|
|
oStrState = put "hello"
|
|
|
|
|
|
err :: Member (Error e) r => Sem r Bool
|
|
err =
|
|
catch
|
|
(throw undefined)
|
|
(\_ -> pure True)
|
|
|
|
|
|
errState :: Num s => Members '[Error e, State s] r => Sem r Bool
|
|
errState = do
|
|
numState
|
|
err
|
|
|
|
|
|
lifted :: Monad m => Member (Embed m) r => Sem r ()
|
|
lifted = embed $ pure ()
|
|
|
|
|
|
newtype MyString = MyString String
|
|
deriving (IsString, Eq, Show)
|
|
|
|
|
|
data Janky = forall s. Janky (forall i. Sem '[State s] ())
|
|
|
|
jankyState :: Janky
|
|
jankyState = Janky $ put True
|
|
|
|
unsafeUnjank :: Janky -> Sem '[State Bool] ()
|
|
unsafeUnjank (Janky sem) = unsafeCoerce sem
|
|
|
|
|
|
spec :: Spec
|
|
spec = do
|
|
describe "State effect" $ do
|
|
describe "get/put" $ do
|
|
it "should work in simple cases" $ do
|
|
flipShouldBe (True, ()) . run $ runState True idState
|
|
|
|
it "should, when polymorphic, eliminate the first matching effect" $ do
|
|
flipShouldBe (False, (True, ())) . run $ runState False $ runState True idState
|
|
|
|
it "should, when polymorphic, not eliminate unmatching effects" $ do
|
|
flipShouldBe (True, Right @Int ()) . run $ runState True $ runError idState
|
|
|
|
describe "numbers" $ do
|
|
it "should interpret against concrete Int" $ do
|
|
flipShouldBe (10, ()) . run $ runState 0 intState
|
|
|
|
describe "polymorphic Num constraint" $ do
|
|
it "should interpret against Int" $ do
|
|
flipShouldBe (10 :: Int, ()) . run $ runState 0 numState
|
|
|
|
it "should interpret against Float" $ do
|
|
flipShouldBe (10 :: Float, ()) . run $ runState 0 numState
|
|
|
|
it "should interpret against Double" $ do
|
|
flipShouldBe (10 :: Double, ()) . run $ runState 0 numState
|
|
|
|
it "should interpret against Integer" $ do
|
|
flipShouldBe (10 :: Integer, ()) . run $ runState 0 numState
|
|
|
|
describe "strings" $ do
|
|
it "concrete interpret against concrete String" $ do
|
|
flipShouldBe ("hello", ()) . run $ runState "nothing" strState
|
|
|
|
describe "polymorphic IsString constraint" $ do
|
|
it "should interpret against String" $ do
|
|
flipShouldBe ("hello" :: String, ()) . run $ runState "nothing" oStrState
|
|
|
|
it "should interpret against MyString" $ do
|
|
flipShouldBe ("hello" :: MyString, ()) . run $ runState "nothing" oStrState
|
|
|
|
describe "existential state" $ do
|
|
it "JankyState should compile" $ do
|
|
flipShouldBe (True, ()) . run $ runState False $ unsafeUnjank jankyState
|
|
|
|
|
|
describe "Error effect" $ do
|
|
it "should interpret against Int" $ do
|
|
flipShouldBe (Right @Int True) . run $ runError err
|
|
it "should interpret against Bool" $ do
|
|
flipShouldBe (Right @Bool True) . run $ runError err
|
|
|
|
|
|
describe "State/Error effect" $ do
|
|
it "should interpret against Int/String" $ do
|
|
flipShouldBe (10 :: Int, Right @String True) . run $ runState 0 $ runError errState
|
|
it "should interpret against Float/Bool" $ do
|
|
flipShouldBe (10 :: Float, Right @Bool True) . run $ runState 0 $ runError errState
|
|
|
|
|
|
describe "Error/State effect" $ do
|
|
it "should interpret against String/Int" $ do
|
|
flipShouldBe (Right @String (10 :: Int, True)) . run $ runError $ runState 0 errState
|
|
it "should interpret against Bool/Float" $ do
|
|
flipShouldBe (Right @Bool (10 :: Float, True)) . run $ runError $ runState 0 errState
|
|
|
|
describe "Output effect" $ do
|
|
it "should unify recursively with tyvars" $ do
|
|
flipShouldBe 11 . sum . fst . run . runOutputMonoid id $ do
|
|
output [1]
|
|
output $ replicate 2 5
|
|
|
|
|
|
describe "Embed effect" $ do
|
|
it "should interpret against IO" $ do
|
|
res <- runM lifted
|
|
res `shouldBe` ()
|
|
|
|
it "should interpret against Identity" $ do
|
|
let res = runM lifted
|
|
res `shouldBe` Identity ()
|
|
|
|
|
|
flipShouldBe :: (Show a, Eq a) => a -> a -> Expectation
|
|
flipShouldBe = flip shouldBe
|
|
|