{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}

module Test.Polysemy.Mock.TH (genMock) where

import Data.Bifunctor (first)
import Data.List (foldl')
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
  (Name
_, [ConLiftInfo]
constructors) <- Name -> Q (Name, [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 =
        (ConLiftInfo -> Con) -> [ConLiftInfo] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> ConLiftInfo -> Con
mkMockConstructor Type
mockImplReturnType) [ConLiftInfo]
constructors
          [Con] -> [Con] -> [Con]
forall a. Semigroup a => a -> a -> a
<> (ConLiftInfo -> Con) -> [ConLiftInfo] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> ConLiftInfo -> Con
mkMockReturns Type
mockImplReturnType) [ConLiftInfo]
constructors
          [Con] -> [Con] -> [Con]
forall a. Semigroup a => a -> a -> a
<> (ConLiftInfo -> Con) -> [ConLiftInfo] -> [Con]
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 [] Maybe [TyVarBndr]
forall a. Maybe a
Nothing Type
mockImplDataType Maybe Type
forall a. Maybe a
Nothing [Con]
mockImplConstructors []
  -- MockState
  Name
mockStateConName <- String -> Q Name
newName (Name -> String
nameBase ''MockState String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase Name
effName)
  let mockStateRec :: [(Name, Bang, Type)]
mockStateRec =
        (ConLiftInfo -> (Name, Bang, Type))
-> [ConLiftInfo] -> [(Name, Bang, Type)]
forall a b. (a -> b) -> [a] -> [b]
map ConLiftInfo -> (Name, Bang, Type)
mkMockStateCallsField [ConLiftInfo]
constructors
          [(Name, Bang, Type)]
-> [(Name, Bang, Type)] -> [(Name, Bang, Type)]
forall a. Semigroup a => a -> a -> a
<> (ConLiftInfo -> (Name, Bang, Type))
-> [ConLiftInfo] -> [(Name, Bang, Type)]
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 [] Maybe [TyVarBndr]
forall a. Maybe a
Nothing Type
mockStateType Maybe Type
forall a. Maybe a
Nothing [Con
mockStateConstructor] []
  -- initialMockState
  let initialStateExps :: [(Name, Exp)]
initialStateExps =
        (ConLiftInfo -> (Name, Exp)) -> [ConLiftInfo] -> [(Name, Exp)]
forall a b. (a -> b) -> [a] -> [b]
map ConLiftInfo -> (Name, Exp)
mkInitialCalls [ConLiftInfo]
constructors
          [(Name, Exp)] -> [(Name, Exp)] -> [(Name, Exp)]
forall a. Semigroup a => a -> a -> a
<> (ConLiftInfo -> (Name, Exp)) -> [ConLiftInfo] -> [(Name, Exp)]
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 = (ConLiftInfo -> Match) -> [ConLiftInfo] -> [Match]
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 =
        (ConLiftInfo -> Match) -> [ConLiftInfo] -> [Match]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> ConLiftInfo -> Match
mkMockToStateMatch Type
mockStateType) [ConLiftInfo]
constructors
          [Match] -> [Match] -> [Match]
forall a. Semigroup a => a -> a -> a
<> (ConLiftInfo -> Match) -> [ConLiftInfo] -> [Match]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> ConLiftInfo -> Match
mkReturnsToStateMatch Type
mockStateType) [ConLiftInfo]
constructors
          [Match] -> [Match] -> [Match]
forall a. Semigroup a => a -> a -> a
<> (ConLiftInfo -> Match) -> [ConLiftInfo] -> [Match]
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
          Maybe Overlap
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 =
        (ConLiftInfo -> [Dec]) -> [ConLiftInfo] -> [Dec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Type -> ConLiftInfo -> [Dec]
mkReturnsSem Type
mockImplEffectType) [ConLiftInfo]
constructors
          [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> (ConLiftInfo -> [Dec]) -> [ConLiftInfo] -> [Dec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Type -> ConLiftInfo -> [Dec]
mkCallsSem Type
mockImplEffectType) [ConLiftInfo]
constructors
  -- Bring it together
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
mockInstanceD Dec -> [Dec] -> [Dec]
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 = (((Name, Type) -> (Bang, Type)) -> [(Name, Type)] -> [(Bang, Type)]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> Bang) -> (Name, Type) -> (Bang, Type)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Bang -> Name -> Bang
forall a b. a -> b -> a
const Bang
defaultBang)) ([(Name, Type)] -> [(Bang, Type)])
-> [(Name, Type)] -> [(Bang, Type)]
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 (Type -> Type) -> Type -> Type
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 (Type -> Type) -> Type -> Type
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 (((Name, Type) -> Pat) -> [(Name, Type)] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Pat -> (Name, Type) -> Pat
forall a b. a -> b -> a
const Pat
WildP) ([(Name, Type)] -> [Pat]) -> [(Name, Type)] -> [Pat]
forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
c) (Exp -> Exp) -> Exp -> Exp
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 (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ String
"Unexpected mock invocation: " String -> String -> String
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 =
  let pat :: Pat
pat = Name -> [Pat] -> Pat
ConP (ConLiftInfo -> Name
cliConName ConLiftInfo
c) (((Name, Type) -> Pat) -> [(Name, Type)] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Pat
VarP (Name -> Pat) -> ((Name, Type) -> Name) -> (Name, Type) -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Type) -> Name
forall a b. (a, b) -> a
fst) (ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
c))
      sendFn :: Exp
sendFn = Name -> Exp
VarE 'send
      args :: [Exp]
args = ((Name, Type) -> Exp) -> [(Name, Type)] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Exp
VarE (Name -> Exp) -> ((Name, Type) -> Name) -> (Name, Type) -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Type) -> Name
forall a b. (a, b) -> a
fst) (ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
c)
      theMock :: Exp
theMock = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
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 []

mkMockToStateMatch :: Type -> ConLiftInfo -> Match
mkMockToStateMatch :: Type -> ConLiftInfo -> Match
mkMockToStateMatch Type
t ConLiftInfo
c =
  let pat :: Pat
pat = Name -> [Pat] -> Pat
ConP (ConLiftInfo -> Name
mockConName ConLiftInfo
c) ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
vars)
      --
      vars :: [Name]
vars = ((Name, Type) -> Name) -> [(Name, Type)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Type) -> Name
forall a b. (a, b) -> a
fst (ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
c)
      newArgs :: Exp
newArgs = if [(Name, Type)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
c) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
                   then [Exp] -> Exp
ListE [ Name -> Exp
VarE (Name -> Exp) -> (ConLiftInfo -> Name) -> ConLiftInfo -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Type) -> Name
forall a b. (a, b) -> a
fst ((Name, Type) -> Name)
-> (ConLiftInfo -> (Name, Type)) -> ConLiftInfo -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Name, Type)] -> (Name, Type)
forall a. [a] -> a
head ([(Name, Type)] -> (Name, Type))
-> (ConLiftInfo -> [(Name, Type)]) -> ConLiftInfo -> (Name, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConLiftInfo -> [(Name, Type)]
cliFunArgs (ConLiftInfo -> Exp) -> ConLiftInfo -> Exp
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 (((Name, Type) -> Maybe Exp) -> [(Name, Type)] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp)
-> ((Name, Type) -> Exp) -> (Name, Type) -> Maybe Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE (Name -> Exp) -> ((Name, Type) -> Name) -> (Name, Type) -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Type) -> Name
forall a b. (a, b) -> a
fst) ([(Name, Type)] -> [Maybe Exp]) -> [(Name, Type)] -> [Maybe Exp]
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 (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
oldArgs) (Name -> Exp
VarE '(++)) (Exp -> Maybe Exp
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 = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
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 Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: (Name -> Exp) -> [Name] -> [Exp]
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 (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Name -> Exp
VarE 'pureT)) (Name -> Exp
VarE '(=<<)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
embedReturnsFn)
      body :: Body
body =
        Exp -> Body
NormalB
          ( [Stmt] -> Exp
DoE
              [ 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"
      pat :: Pat
pat = Name -> [Pat] -> Pat
ConP (ConLiftInfo -> Name
returnsConName ConLiftInfo
c) [Name -> Pat
VarP Name
f]
      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 (Exp -> Stmt) -> Exp -> Stmt
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
          ( [Stmt] -> Exp
DoE
              [ 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 =
  let pat :: Pat
pat = Name -> [Pat] -> Pat
ConP (ConLiftInfo -> Name
callsConName ConLiftInfo
c) []
      returnCalls :: Stmt
returnCalls = Exp -> Stmt
NoBindS (Exp -> Stmt) -> Exp -> Stmt
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
          ( [Stmt] -> Exp
DoE
              [ 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" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase (ConLiftInfo -> Name
cliConName ConLiftInfo
c) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Returns")
      body :: Body
body = Exp -> Body
NormalB (Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'send) (Name -> Exp
VarE '(.)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE (ConLiftInfo -> Name
returnsConName ConLiftInfo
c)))
      appArrowT :: Type -> Type -> Type
appArrowT = Type -> Type -> Type
AppT (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
ArrowT
      r :: Type
r = Name -> Type
VarT (Name -> Type) -> Name -> Type
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] -> 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 [] Body
body []]
      ]

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" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase (ConLiftInfo -> Name
cliConName ConLiftInfo
c) String -> String -> String
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 (Exp -> Body) -> Exp -> Body
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 (Name -> Type) -> Name -> Type
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] -> Cxt -> Type -> Type
ForallT [Name -> TyVarBndr
PlainTV Name
returnsEffectName, Name -> TyVarBndr
PlainTV (Name -> TyVarBndr) -> Name -> TyVarBndr
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"r"] [Type -> Type -> Type
membersEffListType Type
mockImplEffType Type
r] (Type -> Type
semr (Type -> Type) -> Type -> Type
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 (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
PromotedConsT
      effList :: Type
effList = (Type -> Type -> Type) -> Type -> Cxt -> Type
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" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase (ConLiftInfo -> Name
cliConName ConLiftInfo
c) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Calls")

returnsConName :: ConLiftInfo -> Name
returnsConName :: ConLiftInfo -> Name
returnsConName ConLiftInfo
c = String -> Name
mkName (String
"Mock" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase (ConLiftInfo -> Name
cliConName ConLiftInfo
c) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Returns")

mockConName :: ConLiftInfo -> Name
mockConName :: ConLiftInfo -> Name
mockConName ConLiftInfo
c = String -> Name
mkName (String
"Mock" String -> String -> String
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) String -> String -> String
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) String -> String -> String
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 = [(Name, Type)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(Name, Type)] -> Int) -> [(Name, Type)] -> Int
forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
c
   in if Int
arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
        then Type -> Type -> Type
AppT Type
ListT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ (Name, Type) -> Type
forall a b. (a, b) -> b
snd ((Name, Type) -> Type) -> (Name, Type) -> Type
forall a b. (a -> b) -> a -> b
$ [(Name, Type)] -> (Name, Type)
forall a. [a] -> a
head ([(Name, Type)] -> (Name, Type)) -> [(Name, Type)] -> (Name, Type)
forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
c
        else Type -> Type -> Type
AppT Type
ListT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Int -> Type
TupleT Int
arity) (((Name, Type) -> Type) -> [(Name, Type)] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Name, Type) -> Type
forall a b. (a, b) -> b
snd ([(Name, Type)] -> Cxt) -> [(Name, Type)] -> Cxt
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 = (((Name, Type) -> Type) -> [(Name, Type)] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Name, Type) -> Type
forall a b. (a, b) -> b
snd ([(Name, Type)] -> Cxt) -> [(Name, Type)] -> Cxt
forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
c)
      returnType :: Type
returnType = (Type -> Type -> Type
AppT Type
returnsEffect (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> Type
cliEffRes ConLiftInfo
c)
   in (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
AppT (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
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"