cleff-plugin-0.1.0.0: test/CleffSpec.hs

-- Tests copied from `polysemy-plugin` (https://github.com/polysemy-research/polysemy/tree/master/polysemy-plugin/test)
-- (c) 2019 Sandy Maguire, licensed under BSD-3-Clause
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# OPTIONS_GHC -Wno-unused-foralls -fplugin=Cleff.Plugin #-}
module CleffSpec where

import           Cleff
import           Cleff.Error
import           Cleff.State
import           Data.String   (IsString)
import           Unsafe.Coerce (unsafeCoerce)

class MPTC a b where
  mptc :: a -> b

instance MPTC Bool Int where
  mptc _ = 1000

uniquelyInt :: '[State Int, State String] :>> r => Eff r ()
uniquelyInt = put 10

uniquelyA :: (Num a, '[State a, State b] :>> r) => Eff r ()
uniquelyA = put 10

uniquelyString :: '[State Int, State String] :>> r => Eff r ()
uniquelyString = put mempty

uniquelyB :: (MPTC Bool b, '[State String, State b] :>> r) => Eff r ()
uniquelyB = put $ mptc False

uniquelyState' :: '[Error (), State ()] :>> r => Eff r ()
uniquelyState' = pure ()

idState :: State s :> r => Eff r ()
idState = do
  s <- get
  put s

intState :: State Int :> r => Eff r ()
intState = put 10

numState :: Num a => State a :> r => Eff r ()
numState = put 10

strState :: State String :> r => Eff r ()
strState = put "Hello"

oStrState :: IsString a => State a :> r => Eff r ()
oStrState = put "hello"

err :: Error e :> r => Eff r Bool
err =
  catchError
    (throwError (error ""))
    (\_ -> pure True)

errState :: Num s => '[Error e, State s] :>> r => Eff r Bool
errState = do
  numState
  err

newtype MyString = MyString String
  deriving newtype (IsString, Eq, Show)

data Janky = forall s. Janky (forall _i. Eff '[State s] ())

jankyState :: Janky
jankyState = Janky $ put True -- The plugin disambiguates effects for concrete rows too

unsafeUnjank :: Janky -> Eff '[State Bool] ()
unsafeUnjank (Janky m) = unsafeCoerce m

data MoreJanky = forall y. MoreJanky (MPTC Bool y => Eff '[State (Bool, y), State (Char, y)] ())

mptcGet :: MPTC x Bool => x
mptcGet = undefined

moreJankyState :: MoreJanky
moreJankyState = MoreJanky $ put (mptcGet, True)

data TaggedState k s m a where
  TaggedGet :: forall k s m. TaggedState k s m s
  TaggedPut :: forall k s m. s -> TaggedState k s m ()

makeEffect ''TaggedState -- The plugin also disambiguates TH functions generated by 'makeEffect'

runTaggedState :: forall k s r a
                . s
               -> Eff (TaggedState k s : r) a
               -> Eff r (a, s)
runTaggedState s =
    (runState s .)
  $ reinterpret
  $ \case
    TaggedGet    -> get
    TaggedPut s' -> put s'

test :: '[
          TaggedState Char Int
        , TaggedState Bool Int
        ] :>> r
     => Eff r ()
test = do
  taggedPut @Bool 10
  taggedPut @Char (-10)

newtype Select a = Select a

data DBAction whichDb m a where
  DoSelect :: Select a -> DBAction whichDb m (Maybe a)

makeEffect ''DBAction

runDBAction :: Eff (DBAction which ': r) a -> Eff r a
runDBAction = interpret $ \case
  DoSelect (Select a) -> pure $ Just a