{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
module Test.Polysemy.Mock.TH (genMock) where
import Data.Bifunctor (first)
import Data.List (foldl')
import GHC.Stack (HasCallStack)
import Language.Haskell.TH hiding (Strict)
import Polysemy (Embed, Members, Sem, interpret, pureT, reinterpretH)
import Polysemy.Internal (embed, send)
import Polysemy.Internal.TH.Common
import Polysemy.State (get, put)
import Test.Polysemy.Mock
genMock :: Name -> Q [Dec]
genMock :: Name -> Q [Dec]
genMock Name
effName = do
[ConLiftInfo]
constructors <- Name -> Q [ConLiftInfo]
getEffectMetadata Name
effName
let mockImplEffectType :: Type
mockImplEffectType = Name -> Type
ConT ''MockImpl Type -> Type -> Type
`AppT` Name -> Type
ConT Name
effName Type -> Type -> Type
`AppT` Type
returnsEffect
let mockImplReturnType :: Type
mockImplReturnType = Type
mockImplEffectType Type -> Type -> Type
`AppT` Name -> Type
VarT (String -> Name
mkName String
"m")
let mockImplDataType :: Type
mockImplDataType = Type
mockImplReturnType Type -> Type -> Type
`AppT` Name -> Type
VarT (String -> Name
mkName String
"a")
let mockImplConstructors :: [Con]
mockImplConstructors =
forall a b. (a -> b) -> [a] -> [b]
map (Type -> ConLiftInfo -> Con
mkMockConstructor Type
mockImplReturnType) [ConLiftInfo]
constructors
forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map (Type -> ConLiftInfo -> Con
mkMockReturns Type
mockImplReturnType) [ConLiftInfo]
constructors
forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map (Type -> ConLiftInfo -> Con
mkMockCalls Type
mockImplReturnType) [ConLiftInfo]
constructors
let mockImplD :: Dec
mockImplD = Cxt
-> Maybe [TyVarBndr ()]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD [] forall a. Maybe a
Nothing Type
mockImplDataType forall a. Maybe a
Nothing [Con]
mockImplConstructors []
Name
mockStateConName <- forall (m :: * -> *). Quote m => String -> m Name
newName (Name -> String
nameBase ''MockState forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase Name
effName)
let mockStateRec :: [(Name, Bang, Type)]
mockStateRec =
forall a b. (a -> b) -> [a] -> [b]
map ConLiftInfo -> (Name, Bang, Type)
mkMockStateCallsField [ConLiftInfo]
constructors
forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map ConLiftInfo -> (Name, Bang, Type)
mkMockStateReturnsField [ConLiftInfo]
constructors
let mockStateConstructor :: Con
mockStateConstructor = Name -> [(Name, Bang, Type)] -> Con
RecC Name
mockStateConName [(Name, Bang, Type)]
mockStateRec
let mockStateType :: Type
mockStateType = Name -> Type
ConT ''MockState Type -> Type -> Type
`AppT` Name -> Type
ConT Name
effName Type -> Type -> Type
`AppT` Type
returnsEffect
let mockStateD :: Dec
mockStateD = Cxt
-> Maybe [TyVarBndr ()]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD [] forall a. Maybe a
Nothing Type
mockStateType forall a. Maybe a
Nothing [Con
mockStateConstructor] []
let initialStateExps :: [(Name, Exp)]
initialStateExps =
forall a b. (a -> b) -> [a] -> [b]
map ConLiftInfo -> (Name, Exp)
mkInitialCalls [ConLiftInfo]
constructors
forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map ConLiftInfo -> (Name, Exp)
mkInitialReturns [ConLiftInfo]
constructors
let initialStateBody :: Body
initialStateBody = Exp -> Body
NormalB (Name -> [(Name, Exp)] -> Exp
RecConE Name
mockStateConName [(Name, Exp)]
initialStateExps)
let initialStateD :: Dec
initialStateD = Name -> [Clause] -> Dec
FunD 'initialMockState [[Pat] -> Body -> [Dec] -> Clause
Clause [] Body
initialStateBody []]
let mockMatches :: [Match]
mockMatches = forall a b. (a -> b) -> [a] -> [b]
map (Type -> ConLiftInfo -> Match
mkMockMatch Type
mockImplEffectType) [ConLiftInfo]
constructors
let mockBody :: Body
mockBody = Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'interpret) ([Match] -> Exp
LamCaseE [Match]
mockMatches))
let mockD :: Dec
mockD = Name -> [Clause] -> Dec
FunD 'mock [[Pat] -> Body -> [Dec] -> Clause
Clause [] Body
mockBody []]
let mockToStateMatches :: [Match]
mockToStateMatches =
forall a b. (a -> b) -> [a] -> [b]
map (Type -> ConLiftInfo -> Match
mkMockToStateMatch Type
mockStateType) [ConLiftInfo]
constructors
forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map (Type -> ConLiftInfo -> Match
mkReturnsToStateMatch Type
mockStateType) [ConLiftInfo]
constructors
forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map (Type -> ConLiftInfo -> Match
mkCallsToStateMatch Type
mockStateType) [ConLiftInfo]
constructors
let mockToStateBody :: Body
mockToStateBody = Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'reinterpretH) ([Match] -> Exp
LamCaseE [Match]
mockToStateMatches))
let mockToStateD :: Dec
mockToStateD = Name -> [Clause] -> Dec
FunD 'mockToState [[Pat] -> Body -> [Dec] -> Clause
Clause [] Body
mockToStateBody []]
let mockInstanceD :: Dec
mockInstanceD =
Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD
forall a. Maybe a
Nothing
[Name -> Type
ConT ''Applicative Type -> Type -> Type
`AppT` Type
returnsEffect]
(Name -> Type
ConT ''Mock Type -> Type -> Type
`AppT` Name -> Type
ConT Name
effName Type -> Type -> Type
`AppT` Type
returnsEffect)
[ Dec
mockImplD,
Dec
mockStateD,
Dec
initialStateD,
Dec
mockD,
Dec
mockToStateD
]
let semD :: [Dec]
semD =
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Type -> ConLiftInfo -> [Dec]
mkReturnsSem Type
mockImplEffectType) [ConLiftInfo]
constructors
forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Type -> ConLiftInfo -> [Dec]
mkCallsSem Type
mockImplEffectType) [ConLiftInfo]
constructors
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Dec
mockInstanceD forall a. a -> [a] -> [a]
: [Dec]
semD
mkMockConstructor :: Type -> ConLiftInfo -> Con
mkMockConstructor :: Type -> ConLiftInfo -> Con
mkMockConstructor Type
t ConLiftInfo
c =
let args :: [(Bang, Type)]
args = (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a b. a -> b -> a
const Bang
defaultBang)) forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
c)
in [Name] -> [(Bang, Type)] -> Type -> Con
GadtC [ConLiftInfo -> Name
mockConName ConLiftInfo
c] [(Bang, Type)]
args (Type -> Type -> Type
AppT Type
t forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> Type
cliEffRes ConLiftInfo
c)
mkMockReturns :: Type -> ConLiftInfo -> Con
mkMockReturns :: Type -> ConLiftInfo -> Con
mkMockReturns Type
t ConLiftInfo
c =
[Name] -> [(Bang, Type)] -> Type -> Con
GadtC [ConLiftInfo -> Name
returnsConName ConLiftInfo
c] [(Bang
defaultBang, ConLiftInfo -> Type
returnsFunctionType ConLiftInfo
c)] (Type -> Type -> Type
AppT Type
t forall a b. (a -> b) -> a -> b
$ Int -> Type
TupleT Int
0)
mkMockCalls :: Type -> ConLiftInfo -> Con
mkMockCalls :: Type -> ConLiftInfo -> Con
mkMockCalls Type
t ConLiftInfo
c =
[Name] -> [(Bang, Type)] -> Type -> Con
GadtC [ConLiftInfo -> Name
callsConName ConLiftInfo
c] [] (Type -> Type -> Type
AppT Type
t (ConLiftInfo -> Type
functionCallType ConLiftInfo
c))
mkMockStateCallsField :: ConLiftInfo -> (Name, Bang, Type)
mkMockStateCallsField :: ConLiftInfo -> (Name, Bang, Type)
mkMockStateCallsField ConLiftInfo
c =
(ConLiftInfo -> Name
callsFieldName ConLiftInfo
c, Bang
defaultBang, ConLiftInfo -> Type
functionCallType ConLiftInfo
c)
mkMockStateReturnsField :: ConLiftInfo -> (Name, Bang, Type)
mkMockStateReturnsField :: ConLiftInfo -> (Name, Bang, Type)
mkMockStateReturnsField ConLiftInfo
c =
(ConLiftInfo -> Name
returnsFieldName ConLiftInfo
c, Bang
defaultBang, ConLiftInfo -> Type
returnsFunctionType ConLiftInfo
c)
mkInitialCalls :: ConLiftInfo -> (Name, Exp)
mkInitialCalls :: ConLiftInfo -> (Name, Exp)
mkInitialCalls ConLiftInfo
c =
(ConLiftInfo -> Name
callsFieldName ConLiftInfo
c, [Exp] -> Exp
ListE [])
mkInitialReturns :: ConLiftInfo -> (Name, Exp)
mkInitialReturns :: ConLiftInfo -> (Name, Exp)
mkInitialReturns ConLiftInfo
c =
let returnsFn :: Exp
returnsFn =
case ConLiftInfo -> Type
cliEffRes ConLiftInfo
c of
(TupleT Int
0) -> [Pat] -> Exp -> Exp
LamE (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const Pat
WildP) forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
c) forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pure) ([Maybe Exp] -> Exp
TupE [])
Type
_ -> Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'error) (Lit -> Exp
LitE (String -> Lit
StringL forall a b. (a -> b) -> a -> b
$ String
"Unexpected mock invocation: " forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase (ConLiftInfo -> Name
cliFunName ConLiftInfo
c)))
in (ConLiftInfo -> Name
returnsFieldName ConLiftInfo
c, Exp
returnsFn)
mkMockMatch :: Type -> ConLiftInfo -> Match
mkMockMatch :: Type -> ConLiftInfo -> Match
mkMockMatch Type
t ConLiftInfo
c =
#if MIN_VERSION_template_haskell(2,18,0)
let pat :: Pat
pat = Name -> Cxt -> [Pat] -> Pat
ConP (ConLiftInfo -> Name
cliConName ConLiftInfo
c) [] (forall a b. (a -> b) -> [a] -> [b]
map (Name -> Pat
VarP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
c))
#else
let pat = ConP (cliConName c) (map (VarP . fst) (cliFunArgs c))
#endif
sendFn :: Exp
sendFn = Name -> Exp
VarE 'send
args :: [Exp]
args = forall a b. (a -> b) -> [a] -> [b]
map (Name -> Exp
VarE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
c)
theMock :: Exp
theMock = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> Name
mockConName ConLiftInfo
c) [Exp]
args
body :: Body
body = Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE (Exp -> Type -> Exp
AppTypeE Exp
sendFn Type
t) Exp
theMock)
in Pat -> Body -> [Dec] -> Match
Match Pat
pat Body
body []
#if MIN_VERSION_template_haskell(2,17,0)
#define UNQUALIFIED_DO Nothing
#else
#define UNQUALIFIED_DO
#endif
mkMockToStateMatch :: Type -> ConLiftInfo -> Match
mkMockToStateMatch :: Type -> ConLiftInfo -> Match
mkMockToStateMatch Type
t ConLiftInfo
c =
#if MIN_VERSION_template_haskell(2,18,0)
let pat :: Pat
pat = Name -> Cxt -> [Pat] -> Pat
ConP (ConLiftInfo -> Name
mockConName ConLiftInfo
c) [] (forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
vars)
#else
let pat = ConP (mockConName c) (map VarP vars)
#endif
vars :: [Name]
vars = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
c)
newArgs :: Exp
newArgs = if forall (t :: * -> *) a. Foldable t => t a -> Int
length (ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
c) forall a. Eq a => a -> a -> Bool
== Int
1
then [Exp] -> Exp
ListE [ Name -> Exp
VarE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConLiftInfo -> [(Name, Type)]
cliFunArgs forall a b. (a -> b) -> a -> b
$ ConLiftInfo
c]
else
#if MIN_VERSION_template_haskell(2,16,0)
[Exp] -> Exp
ListE [[Maybe Exp] -> Exp
TupE (forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
c)]
#else
ListE [TupE (map (VarE . fst) $ cliFunArgs c)]
#endif
oldArgs :: Exp
oldArgs = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (ConLiftInfo -> Name
callsFieldName ConLiftInfo
c)) (Name -> Exp
VarE Name
stateName)
allArgs :: Exp
allArgs = Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (forall a. a -> Maybe a
Just Exp
oldArgs) (Name -> Exp
VarE '(++)) (forall a. a -> Maybe a
Just Exp
newArgs)
newState :: Exp
newState = Exp -> [(Name, Exp)] -> Exp
RecUpdE (Name -> Exp
VarE Name
stateName) [(ConLiftInfo -> Name
callsFieldName ConLiftInfo
c, Exp
allArgs)]
applyReturnsFn :: Exp
applyReturnsFn = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (ConLiftInfo -> Name
returnsFieldName ConLiftInfo
c)) (Name -> Exp
VarE Name
stateName forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
vars)
embedReturnsFn :: Exp
embedReturnsFn = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'embed) Exp
applyReturnsFn
returnAsPureT :: Stmt
returnAsPureT = Exp -> Stmt
NoBindS forall a b. (a -> b) -> a -> b
$ Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (forall a. a -> Maybe a
Just (Name -> Exp
VarE 'pureT)) (Name -> Exp
VarE '(=<<)) (forall a. a -> Maybe a
Just Exp
embedReturnsFn)
body :: Body
body =
Exp -> Body
NormalB
( Maybe ModName -> [Stmt] -> Exp
DoE
UNQUALIFIED_DO
[ Type -> Stmt
getState Type
t,
Exp -> Stmt
putState Exp
newState,
Stmt
returnAsPureT
]
)
in Pat -> Body -> [Dec] -> Match
Match Pat
pat Body
body []
mkReturnsToStateMatch :: Type -> ConLiftInfo -> Match
mkReturnsToStateMatch :: Type -> ConLiftInfo -> Match
mkReturnsToStateMatch Type
t ConLiftInfo
c =
let f :: Name
f = String -> Name
mkName String
"f"
#if MIN_VERSION_template_haskell(2,18,0)
pat :: Pat
pat = Name -> Cxt -> [Pat] -> Pat
ConP (ConLiftInfo -> Name
returnsConName ConLiftInfo
c) [] [Name -> Pat
VarP Name
f]
#else
pat = ConP (returnsConName c) [VarP f]
#endif
newState :: Exp
newState = Exp -> [(Name, Exp)] -> Exp
RecUpdE (Name -> Exp
VarE Name
stateName) [(ConLiftInfo -> Name
returnsFieldName ConLiftInfo
c, Name -> Exp
VarE Name
f)]
returnNothing :: Stmt
returnNothing = Exp -> Stmt
NoBindS forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pureT) ([Maybe Exp] -> Exp
TupE [])
body :: Body
body =
Exp -> Body
NormalB
( Maybe ModName -> [Stmt] -> Exp
DoE
UNQUALIFIED_DO
[ Type -> Stmt
getState Type
t,
Exp -> Stmt
putState Exp
newState,
Stmt
returnNothing
]
)
in Pat -> Body -> [Dec] -> Match
Match Pat
pat Body
body []
mkCallsToStateMatch :: Type -> ConLiftInfo -> Match
mkCallsToStateMatch :: Type -> ConLiftInfo -> Match
mkCallsToStateMatch Type
t ConLiftInfo
c =
#if MIN_VERSION_template_haskell(2,18,0)
let pat :: Pat
pat = Name -> Cxt -> [Pat] -> Pat
ConP (ConLiftInfo -> Name
callsConName ConLiftInfo
c) [] []
#else
let pat = ConP (callsConName c) []
#endif
returnCalls :: Stmt
returnCalls = Exp -> Stmt
NoBindS forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pureT) (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (ConLiftInfo -> Name
callsFieldName ConLiftInfo
c)) (Name -> Exp
VarE Name
stateName))
body :: Body
body =
Exp -> Body
NormalB
( Maybe ModName -> [Stmt] -> Exp
DoE
UNQUALIFIED_DO
[ Type -> Stmt
getState Type
t,
Stmt
returnCalls
]
)
in Pat -> Body -> [Dec] -> Match
Match Pat
pat Body
body []
mkReturnsSem ::
Type ->
ConLiftInfo ->
[Dec]
mkReturnsSem :: Type -> ConLiftInfo -> [Dec]
mkReturnsSem Type
mockImplEffType ConLiftInfo
c =
let funcName :: Name
funcName = String -> Name
mkName (String
"mock" forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase (ConLiftInfo -> Name
cliConName ConLiftInfo
c) forall a. Semigroup a => a -> a -> a
<> String
"Returns")
f :: Name
f = String -> Name
mkName String
"f"
body :: Body
body = Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'send Exp -> Exp -> Exp
`AppE` (Name -> Exp
ConE (ConLiftInfo -> Name
returnsConName ConLiftInfo
c) Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
f)
appArrowT :: Type -> Type -> Type
appArrowT = Type -> Type -> Type
AppT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
ArrowT
r :: Type
r = Name -> Type
VarT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"r"
semr :: Type -> Type
semr Type
t = Name -> Type
ConT ''Sem Type -> Type -> Type
`AppT` Type
r Type -> Type -> Type
`AppT` Type
t
typ :: Type
typ = [TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT [] [Type -> Type -> Type
membersEffListType Type
mockImplEffType Type
r] (ConLiftInfo -> Type
returnsFunctionType ConLiftInfo
c Type -> Type -> Type
`appArrowT` Type -> Type
semr (Int -> Type
TupleT Int
0))
in [ Name -> Type -> Dec
SigD Name
funcName Type
typ,
Name -> [Clause] -> Dec
FunD Name
funcName [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
f] Body
body []]
]
#if MIN_VERSION_template_haskell(2,17,0)
#define TY_VAR_SPECIFICTY SpecifiedSpec
#else
#define TY_VAR_SPECIFICTY
#endif
mkCallsSem ::
Type ->
ConLiftInfo ->
[Dec]
mkCallsSem :: Type -> ConLiftInfo -> [Dec]
mkCallsSem Type
mockImplEffType ConLiftInfo
c =
let funcName :: Name
funcName = String -> Name
mkName (String
"mock" forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase (ConLiftInfo -> Name
cliConName ConLiftInfo
c) forall a. Semigroup a => a -> a -> a
<> String
"Calls")
typeAppliedSend :: Exp
typeAppliedSend = Name -> Exp
VarE 'send Exp -> Type -> Exp
`AppTypeE` Type
mockImplEffType
body :: Body
body = Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ Exp
typeAppliedSend Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE (ConLiftInfo -> Name
callsConName ConLiftInfo
c)
r :: Type
r = Name -> Type
VarT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"r"
semr :: Type -> Type
semr Type
t = Name -> Type
ConT ''Sem Type -> Type -> Type
`AppT` Type
r Type -> Type -> Type
`AppT` Type
t
typ :: Type
typ =
[TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT
[forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
returnsEffectName TY_VAR_SPECIFICTY, PlainTV (mkName "r") TY_VAR_SPECIFICTY]
[Type -> Type -> Type
membersEffListType Type
mockImplEffType Type
r]
(Type -> Type
semr forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> Type
functionCallType ConLiftInfo
c)
in [ Name -> Type -> Dec
SigD Name
funcName Type
typ,
Name -> [Clause] -> Dec
FunD Name
funcName [[Pat] -> Body -> [Dec] -> Clause
Clause [] Body
body []]
]
membersEffListType :: Type -> Type -> Type
membersEffListType :: Type -> Type -> Type
membersEffListType Type
mockImplEffType Type
r =
let embededStateEffect :: Type
embededStateEffect = Name -> Type
ConT ''Embed Type -> Type -> Type
`AppT` Name -> Type
VarT Name
returnsEffectName
appConsT :: Type -> Type -> Type
appConsT = Type -> Type -> Type
AppT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
PromotedConsT
effList :: Type
effList = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
appConsT Type
PromotedNilT [Type
mockImplEffType, Type
embededStateEffect]
in Name -> Type
ConT ''Members Type -> Type -> Type
`AppT` Type
effList Type -> Type -> Type
`AppT` Type
r
getState :: Type -> Stmt
getState :: Type -> Stmt
getState Type
t = Pat -> Exp -> Stmt
BindS (Name -> Pat
VarP Name
stateName) (Name -> Exp
VarE 'get Exp -> Type -> Exp
`AppTypeE` Type
t)
putState :: Exp -> Stmt
putState :: Exp -> Stmt
putState Exp
newState = Exp -> Stmt
NoBindS (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'put) Exp
newState)
stateName :: Name
stateName :: Name
stateName = String -> Name
mkName String
"state"
callsConName :: ConLiftInfo -> Name
callsConName :: ConLiftInfo -> Name
callsConName ConLiftInfo
c = String -> Name
mkName (String
"Mock" forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase (ConLiftInfo -> Name
cliConName ConLiftInfo
c) forall a. Semigroup a => a -> a -> a
<> String
"Calls")
returnsConName :: ConLiftInfo -> Name
returnsConName :: ConLiftInfo -> Name
returnsConName ConLiftInfo
c = String -> Name
mkName (String
"Mock" forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase (ConLiftInfo -> Name
cliConName ConLiftInfo
c) forall a. Semigroup a => a -> a -> a
<> String
"Returns")
mockConName :: ConLiftInfo -> Name
mockConName :: ConLiftInfo -> Name
mockConName ConLiftInfo
c = String -> Name
mkName (String
"Mock" forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase (ConLiftInfo -> Name
cliConName ConLiftInfo
c))
callsFieldName :: ConLiftInfo -> Name
callsFieldName :: ConLiftInfo -> Name
callsFieldName ConLiftInfo
c = String -> Name
mkName (Name -> String
nameBase (ConLiftInfo -> Name
cliFunName ConLiftInfo
c) forall a. Semigroup a => a -> a -> a
<> String
"Calls")
returnsFieldName :: ConLiftInfo -> Name
returnsFieldName :: ConLiftInfo -> Name
returnsFieldName ConLiftInfo
c = String -> Name
mkName (Name -> String
nameBase (ConLiftInfo -> Name
cliFunName ConLiftInfo
c) forall a. Semigroup a => a -> a -> a
<> String
"Returns")
defaultBang :: Bang
defaultBang :: Bang
defaultBang = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness
functionCallType :: ConLiftInfo -> Type
functionCallType :: ConLiftInfo -> Type
functionCallType ConLiftInfo
c =
let arity :: Int
arity = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
c
in if Int
arity forall a. Eq a => a -> a -> Bool
== Int
1
then Type -> Type -> Type
AppT Type
ListT forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
c
else Type -> Type -> Type
AppT Type
ListT forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Int -> Type
TupleT Int
arity) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
c)
returnsFunctionType :: ConLiftInfo -> Type
returnsFunctionType :: ConLiftInfo -> Type
returnsFunctionType ConLiftInfo
c =
let argTypes :: Cxt
argTypes = (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
c)
returnType :: Type
returnType = (Type -> Type -> Type
AppT Type
returnsEffect forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> Type
cliEffRes ConLiftInfo
c)
in [TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT [] [Name -> Type
ConT ''HasCallStack] forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
AppT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
ArrowT) Type
returnType Cxt
argTypes
returnsEffect :: Type
returnsEffect :: Type
returnsEffect = Name -> Type
VarT Name
returnsEffectName
returnsEffectName :: Name
returnsEffectName :: Name
returnsEffectName = String -> Name
mkName String
"n"