polysemy-0.5.0.0: test/ThEffectSpec.hs

{-# 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