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

-- | Generate mock using template-haskell.
-- Example usage:
--
-- @
-- genMock ''Teletype
-- @
genMock :: Name -> Q [Dec]
genMock :: Name -> Q [Dec]
genMock Name
effName = do
  [ConLiftInfo]
constructors <- Name -> Q [ConLiftInfo]
getEffectMetadata Name
effName
  -- MockImpl
  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 []
  -- MockState
  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] []
  -- initialMockState
  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 []]
  -- mock
  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 []]
  -- mockToState
  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 []]
  -- instance
  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
          ]
  -- makeSem
  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
  -- Bring it together
  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

{- ORMOLU_DISABLE -}
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 []
{- ORMOLU_ENABLE -}

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 ::
  -- | Should look like: @MockImpl Teletype n@
  -- n is assumed to be 'stateEffectName', maybe this is problematic, but it works for now
  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 ::
  -- | Should look like: @MockImpl Teletype n@
  -- n is assumed to be 'stateEffectName', maybe this is problematic, but it works for now
  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"