{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Language.Haskell.TH.TestUtils.QMode
( MockedMode(..)
, QMode(..)
, IsMockedMode(..)
) where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Lift)
import System.IO.Unsafe (unsafePerformIO)
data MockedMode = FullyMocked | FullyMockedWithIO | NotMocked
class IsMockedMode (mode :: MockedMode) where
type TestQResult mode a
runResult :: Q a -> TestQResult mode a
fmapResult :: (a -> b) -> TestQResult mode a -> TestQResult mode b
instance IsMockedMode 'FullyMocked where
type TestQResult 'FullyMocked a = a
runResult :: Q a -> TestQResult 'FullyMocked a
runResult = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> (Q a -> IO a) -> Q a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q a -> IO a
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ
fmapResult :: (a -> b)
-> TestQResult 'FullyMocked a -> TestQResult 'FullyMocked b
fmapResult = (a -> b)
-> TestQResult 'FullyMocked a -> TestQResult 'FullyMocked b
forall a b. (a -> b) -> a -> b
($)
instance IsMockedMode 'FullyMockedWithIO where
type TestQResult 'FullyMockedWithIO a = IO a
runResult :: Q a -> TestQResult 'FullyMockedWithIO a
runResult = Q a -> TestQResult 'FullyMockedWithIO a
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ
fmapResult :: (a -> b)
-> TestQResult 'FullyMockedWithIO a
-> TestQResult 'FullyMockedWithIO b
fmapResult = (a -> b)
-> TestQResult 'FullyMockedWithIO a
-> TestQResult 'FullyMockedWithIO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
instance IsMockedMode 'NotMocked where
type TestQResult 'NotMocked a = Q a
runResult :: Q a -> TestQResult 'NotMocked a
runResult = Q a -> TestQResult 'NotMocked a
forall a. a -> a
id
fmapResult :: (a -> b) -> TestQResult 'NotMocked a -> TestQResult 'NotMocked b
fmapResult = (a -> b) -> TestQResult 'NotMocked a -> TestQResult 'NotMocked b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
data QMode (mode :: MockedMode) where
MockQ :: QMode 'FullyMocked
MockQAllowIO :: QMode 'FullyMockedWithIO
AllowQ :: QMode 'NotMocked
deriving instance Show (QMode mode)
deriving instance Lift (QMode mode)