mirror of
https://github.com/polysemy-research/polysemy.git
synced 2024-12-04 07:46:37 +03:00
82f86add29
This PR adds doctests allowing us to write tests for the custom type errors. Having this stuff reified in the test suite means we can iterate on the implementations and give much better QA.
154 lines
4.0 KiB
Haskell
154 lines
4.0 KiB
Haskell
{-# LANGUAGE TemplateHaskell, GADTs, DataKinds, AllowAmbiguousTypes #-}
|
|
|
|
module ThEffectSpec where
|
|
|
|
import Polysemy
|
|
import Test.Hspec
|
|
import GHC.TypeLits
|
|
import Data.Kind
|
|
import Language.Haskell.TH hiding (Type)
|
|
|
|
spec :: Spec
|
|
spec = parallel $ it "should compile" True
|
|
|
|
-- Infix effects and actions -------------------------------------------------
|
|
|
|
data (:#) m a where
|
|
(:#) :: a -> b -> m :# a
|
|
|
|
infixl 4 :#
|
|
|
|
makeSem ''(:#)
|
|
|
|
reifyFixity '(#) >>= \case
|
|
Just (Fixity 4 InfixL) -> return []
|
|
_ -> fail "Wrong fixity of generated operator"
|
|
|
|
-- ADTs and ADT syntax -------------------------------------------------------
|
|
|
|
data SimpleADT m a = SimpleADTC1 Int | SimpleADTC2 String
|
|
|
|
makeSem ''SimpleADT
|
|
|
|
data GADTSyntax m a where
|
|
GADTSyntaxC1 :: Int -> GADTSyntax m a
|
|
GADTSyntaxC2 :: String -> GADTSyntax m a
|
|
|
|
makeSem ''GADTSyntax
|
|
|
|
data ADTSyntax1 m a = (a ~ Int) => ADTSyntax1C String
|
|
|
|
makeSem ''ADTSyntax1
|
|
|
|
data ADTSyntax2 m a
|
|
= a ~ Int => ADTSyntax2C1 Int
|
|
| a ~ String => ADTSyntax2C2 String
|
|
|
|
makeSem ''ADTSyntax2
|
|
|
|
data ADTSyntax3 m a = Show a => ADTSyntax3C a
|
|
|
|
makeSem ''ADTSyntax3
|
|
|
|
-- We don't care about named fields (except that we accept them as names from
|
|
-- effect in 'makeSem')
|
|
data Fields m a = FieldsC { fieldsCF1 :: Int, fieldsCF2 :: String }
|
|
|
|
makeSem ''Fields
|
|
|
|
-- Newtypes ------------------------------------------------------------------
|
|
|
|
newtype Newtype1 m a = Newtype1C Int
|
|
|
|
makeSem ''Newtype1
|
|
|
|
newtype Newtype2 m a where
|
|
Newtype2C :: String -> Newtype2 m a
|
|
|
|
makeSem ''Newtype2
|
|
|
|
-- Data families -------------------------------------------------------------
|
|
|
|
data Instance = ADTI | GADTI | NTI
|
|
|
|
data family Family (s :: Instance) (m :: Type -> Type) a
|
|
|
|
data instance Family 'ADTI m a = ADTIC1 Int | ADTIC2 String
|
|
|
|
makeSem 'ADTIC1
|
|
|
|
data instance Family 'GADTI m a where
|
|
GADTIC1 :: Int -> Family 'GADTI m Int
|
|
GADTIC2 :: String -> Family 'GADTI m String
|
|
|
|
makeSem 'GADTIC1
|
|
|
|
newtype instance Family 'NTI m a = NTIC Int
|
|
|
|
makeSem 'NTIC
|
|
|
|
-- Phantom types -------------------------------------------------------------
|
|
|
|
data Phantom m a
|
|
|
|
makeSem ''Phantom
|
|
|
|
-- Complex action types ------------------------------------------------------
|
|
|
|
-- Inspired by:
|
|
-- github.com/lexi-lambda/freer-simple/blob/ec84ae4e23ccba1ae05368100da750c196bbbcbb/tests/Tests/TH.hs#L37
|
|
data Complex m a where
|
|
Mono :: Int -> Complex m Bool
|
|
Poly :: a -> Complex m a
|
|
PolyIn :: a -> Complex m Bool
|
|
PolyOut :: Int -> Complex m a
|
|
Lots :: a -> b -> c -> d -> e -> f -> Complex m ()
|
|
Nested :: Maybe b -> Complex m (Maybe a)
|
|
MultiNested :: (Maybe a, [b]) -> Complex m (Maybe a, [b])
|
|
Existential :: (forall e. e -> Maybe e) -> Complex m a
|
|
LotsNested :: Maybe a -> [b] -> (c, c) -> Complex m (a, b, c)
|
|
Dict :: Ord a => a -> Complex m a
|
|
MultiDict :: (Eq a, Ord b, Enum a, Num c)
|
|
=> a -> b -> c -> Complex m ()
|
|
IndexedMono :: f 0 -> Complex m Int
|
|
IndexedPoly :: forall f (n :: Nat) m . f n -> Complex m (f (n + 1))
|
|
IndexedPolyDict :: KnownNat n => f n -> Complex m Int
|
|
|
|
makeSem ''Complex
|
|
|
|
data HOEff m a where
|
|
EffArgMono :: m () -> HOEff m ()
|
|
EffArgPoly :: m a -> HOEff m a
|
|
EffArgComb :: m a -> (m a -> m b) -> HOEff m b
|
|
EffRank2 :: (forall x. m x -> m (Maybe x)) -> HOEff m a
|
|
|
|
makeSem ''HOEff
|
|
|
|
data ComplexEffArgs b c m a where
|
|
EffMono :: Int -> ComplexEffArgs Int String m Bool
|
|
EffPoly1 :: a -> ComplexEffArgs a b m a
|
|
EffPoly2 :: a -> ComplexEffArgs a (Maybe a) m Bool
|
|
EffPolyFree :: String -> ComplexEffArgs a b m Int
|
|
EffSame1 :: ComplexEffArgs a a m a
|
|
EffSame2 :: ComplexEffArgs b b m a
|
|
EffHO :: m b -> ComplexEffArgs b Int m String
|
|
|
|
makeSem ''ComplexEffArgs
|
|
|
|
data HKEffArgs f g m a where
|
|
HKRank2 :: (forall x . f x -> g x) -> HKEffArgs f g m a
|
|
|
|
makeSem ''HKEffArgs
|
|
|
|
-- 'makeSem' input names -----------------------------------------------------
|
|
|
|
data ByCon m a where
|
|
ByConC :: Int -> ByCon m String
|
|
|
|
makeSem 'ByConC
|
|
|
|
data ByField m a where
|
|
ByFieldC :: { byFieldCF :: Int } -> ByField m Int
|
|
|
|
makeSem 'byFieldCF
|