{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}

module Test.MockCat.TH.FunctionBuilder
  ( createMockBuilderVerifyParams
  , createMockBuilderFnType
  , MockFnContext(..)
  , MockFnBuilder(..)
  , buildMockFnContext
  , buildMockFnDeclarations
  , determineMockFnBuilder
  , createNoInlinePragma
  , doCreateMockFnDecs
  , doCreateConstantMockFnDecs
  , doCreateEmptyVerifyParamMockFnDecs
  , createMockBody
  , createTypeablePreds
  , partialAdditionalPredicates
  , createFnName
  , findParam
  , typeToNames
  , safeIndex
  , generateInstanceMockFnBody
  , generateInstanceRealFnBody
  , generateStubFn
  )
where

import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift)
import Language.Haskell.TH
  ( Dec (..),
    Exp (..),
    Name,
    Pred,
    Q,
    Quote,
    Type (..),
    TyVarBndr(..),
    Inline (NoInline),
    RuleMatch (FunLike),
    Phases (AllPhases),
    mkName,
    newName
  )
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax (nameBase, Specificity (SpecifiedSpec))
import Test.MockCat.Mock ( MockBuilder )
import qualified Test.MockCat.Internal.MockRegistry as Registry
import Test.MockCat.Internal.Builder (buildMock)
import Test.MockCat.Internal.Types (BuiltMock(..))
import Test.MockCat.Cons (Head(..), (:>)(..))
import Test.MockCat.MockT
  ( MockT (..),
    Definition (..),
    getDefinitions,
    addDefinition
  )
import Test.MockCat.TH.TypeUtils
  ( isNotConstantFunctionType,
    needsTypeable,
    collectTypeVars,
    collectTypeableTargets
  )
import Test.MockCat.TH.ContextBuilder
  ( MockType (..)
  )
import Test.MockCat.TH.ClassAnalysis
  ( VarAppliedType (..),
    updateType
  )
import Test.MockCat.Verify (ResolvableParamsOf)
import Data.Dynamic (Dynamic, toDyn)
import Data.Proxy (Proxy(..))
import Data.List (find, nubBy)
import Data.Typeable (Typeable)
import Language.Haskell.TH.Ppr (pprint)
import Unsafe.Coerce (unsafeCoerce)
import GHC.TypeLits (KnownSymbol, symbolVal)
 

import Test.MockCat.Param (Param, param)
import Test.MockCat.TH.Types (MockOptions(..))

createMockBuilderVerifyParams :: Type -> Type
createMockBuilderVerifyParams :: Type -> Type
createMockBuilderVerifyParams (AppT (AppT Type
ArrowT Type
ty) (AppT (VarT Name
_) Type
_)) =
  Type -> Type -> Type
AppT (Name -> Type
ConT ''Param) Type
ty
createMockBuilderVerifyParams (AppT (AppT Type
ArrowT Type
ty) Type
ty2) =
  Type -> Type -> Type
AppT
    (Type -> Type -> Type
AppT (Name -> Type
ConT ''(:>)) (Type -> Type -> Type
AppT (Name -> Type
ConT ''Param) Type
ty))
    (Type -> Type
createMockBuilderVerifyParams Type
ty2)
createMockBuilderVerifyParams (AppT (VarT Name
_) Type
_) = Int -> Type
TupleT Int
0
createMockBuilderVerifyParams (AppT (ConT Name
_) Type
_) = Int -> Type
TupleT Int
0
createMockBuilderVerifyParams (ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
ty) = Type -> Type
createMockBuilderVerifyParams Type
ty
createMockBuilderVerifyParams (VarT Name
_) = Int -> Type
TupleT Int
0
createMockBuilderVerifyParams (ConT Name
_) = Int -> Type
TupleT Int
0
createMockBuilderVerifyParams Type
_ = Int -> Type
TupleT Int
0

createMockBuilderFnType :: Name -> Type -> Type
createMockBuilderFnType :: Name -> Type -> Type
createMockBuilderFnType Name
monadVarName a :: Type
a@(AppT (VarT Name
var) Type
ty)
  | Name
monadVarName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
var = Type
ty
  | Bool
otherwise = Type
a
createMockBuilderFnType Name
monadVarName (AppT Type
ty Type
ty2) =
  Type -> Type -> Type
AppT Type
ty (Name -> Type -> Type
createMockBuilderFnType Name
monadVarName Type
ty2)
createMockBuilderFnType Name
monadVarName (ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
ty) =
  Name -> Type -> Type
createMockBuilderFnType Name
monadVarName Type
ty
createMockBuilderFnType Name
_ Type
ty = Type
ty

partialAdditionalPredicates :: Type -> Type -> [Pred]
partialAdditionalPredicates :: Type -> Type -> Cxt
partialAdditionalPredicates Type
funType Type
verifyParams =
  [ Type -> Type -> Type
AppT
      (Type -> Type -> Type
AppT Type
EqualityT (Type -> Type -> Type
AppT (Name -> Type
ConT ''ResolvableParamsOf) Type
funType))
      Type
verifyParams
  | Bool -> Bool
not ([Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Type -> [Name]
collectTypeVars Type
funType))
  ]

-- Helper to create Typeable predicates using the smart collection logic
createTypeablePreds :: [Type] -> [Pred]
createTypeablePreds :: Cxt -> Cxt
createTypeablePreds Cxt
targets =
  [ Type -> Type -> Type
AppT (Name -> Type
ConT ''Typeable) Type
t
  | Type
t <- (Type -> Type -> Bool) -> Cxt -> Cxt
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\Type
a Type
b -> Type -> String
forall a. Ppr a => a -> String
pprint Type
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Type -> String
forall a. Ppr a => a -> String
pprint Type
b) ((Type -> Cxt) -> Cxt -> Cxt
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type -> Cxt
collectTypeableTargets Cxt
targets)
  , Type -> Bool
needsTypeable Type
t
  ]


data MockFnContext = MockFnContext
  { MockFnContext -> MockType
mockType :: MockType,
    MockFnContext -> Name
monadVarName :: Name,
    MockFnContext -> MockOptions
mockOptions :: MockOptions,
    MockFnContext -> Type
originalType :: Type,
    MockFnContext -> String
fnNameStr :: String,
    MockFnContext -> Name
mockFnName :: Name,
    MockFnContext -> Name
paramsName :: Name,
    MockFnContext -> Type
updatedType :: Type,
    MockFnContext -> Type
fnType :: Type
  }

data MockFnBuilder = VariadicBuilder | ConstantImplicitBuilder | ConstantExplicitBuilder

buildMockFnContext ::
  MockType ->
  Name ->
  [VarAppliedType] ->
  MockOptions ->
  Name ->
  Type ->
  MockFnContext
buildMockFnContext :: MockType
-> Name
-> [VarAppliedType]
-> MockOptions
-> Name
-> Type
-> MockFnContext
buildMockFnContext MockType
mockType Name
monadVarName [VarAppliedType]
varAppliedTypes MockOptions
mockOptions Name
sigFnName Type
ty =
  let fnNameStr :: String
fnNameStr = Name -> MockOptions -> String
createFnName Name
sigFnName MockOptions
mockOptions
      mockFnName :: Name
mockFnName = String -> Name
mkName String
fnNameStr
      params :: Name
params = String -> Name
mkName String
"p"
      updatedType :: Type
updatedType = Type -> [VarAppliedType] -> Type
updateType Type
ty [VarAppliedType]
varAppliedTypes
      fnType :: Type
fnType =
        if MockOptions
mockOptions.implicitMonadicReturn
          then Name -> Type -> Type
createMockBuilderFnType Name
monadVarName Type
updatedType
          else Type
updatedType
   in MockFnContext
        { MockType
mockType :: MockType
mockType :: MockType
mockType,
          Name
monadVarName :: Name
monadVarName :: Name
monadVarName,
          MockOptions
mockOptions :: MockOptions
mockOptions :: MockOptions
mockOptions,
          originalType :: Type
originalType = Type
ty,
          String
fnNameStr :: String
fnNameStr :: String
fnNameStr,
          Name
mockFnName :: Name
mockFnName :: Name
mockFnName,
          paramsName :: Name
paramsName = Name
params,
          Type
updatedType :: Type
updatedType :: Type
updatedType,
          Type
fnType :: Type
fnType :: Type
fnType
        }

buildMockFnDeclarations :: MockFnContext -> Q [Dec]
buildMockFnDeclarations :: MockFnContext -> Q [Dec]
buildMockFnDeclarations ctx :: MockFnContext
ctx@MockFnContext{MockType
mockType :: MockFnContext -> MockType
mockType :: MockType
mockType, String
fnNameStr :: MockFnContext -> String
fnNameStr :: String
fnNameStr, Name
mockFnName :: MockFnContext -> Name
mockFnName :: Name
mockFnName, Name
paramsName :: MockFnContext -> Name
paramsName :: Name
paramsName, Type
fnType :: MockFnContext -> Type
fnType :: Type
fnType, Name
monadVarName :: MockFnContext -> Name
monadVarName :: Name
monadVarName, Type
updatedType :: MockFnContext -> Type
updatedType :: Type
updatedType} =
  case MockFnContext -> MockFnBuilder
determineMockFnBuilder MockFnContext
ctx of
    MockFnBuilder
VariadicBuilder ->
      MockType
-> String -> Name -> Name -> Type -> Name -> Type -> Q [Dec]
forall (m :: * -> *).
Quote m =>
MockType
-> String -> Name -> Name -> Type -> Name -> Type -> m [Dec]
doCreateMockFnDecs MockType
mockType String
fnNameStr Name
mockFnName Name
paramsName Type
fnType Name
monadVarName Type
updatedType
    MockFnBuilder
ConstantImplicitBuilder ->
      MockType -> String -> Name -> Type -> Name -> Q [Dec]
forall (m :: * -> *).
Quote m =>
MockType -> String -> Name -> Type -> Name -> m [Dec]
doCreateConstantMockFnDecs MockType
mockType String
fnNameStr Name
mockFnName Type
fnType Name
monadVarName
    MockFnBuilder
ConstantExplicitBuilder ->
      String -> Name -> Name -> Type -> Name -> Type -> Q [Dec]
forall (m :: * -> *).
Quote m =>
String -> Name -> Name -> Type -> Name -> Type -> m [Dec]
doCreateEmptyVerifyParamMockFnDecs String
fnNameStr Name
mockFnName Name
paramsName Type
fnType Name
monadVarName Type
updatedType

determineMockFnBuilder :: MockFnContext -> MockFnBuilder
determineMockFnBuilder :: MockFnContext -> MockFnBuilder
determineMockFnBuilder MockFnContext
ctx
  | Type -> Bool
isNotConstantFunctionType (MockFnContext -> Type
originalType MockFnContext
ctx) = MockFnBuilder
VariadicBuilder
  | (MockFnContext -> MockOptions
mockOptions MockFnContext
ctx).implicitMonadicReturn = MockFnBuilder
ConstantImplicitBuilder
  | Bool
otherwise = MockFnBuilder
ConstantExplicitBuilder

createNoInlinePragma :: Name -> Q Dec
createNoInlinePragma :: Name -> Q Dec
createNoInlinePragma Name
name = Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
name Inline
NoInline RuleMatch
FunLike Phases
AllPhases

doCreateMockFnDecs :: (Quote m) => MockType -> String -> Name -> Name -> Type -> Name -> Type -> m [Dec]
doCreateMockFnDecs :: forall (m :: * -> *).
Quote m =>
MockType
-> String -> Name -> Name -> Type -> Name -> Type -> m [Dec]
doCreateMockFnDecs MockType
mockType String
funNameStr Name
mockFunName Name
params Type
funType Name
monadVarName Type
updatedType = do
  Dec
newFunSig <- do
    let verifyParams :: Type
verifyParams = Type -> Type
createMockBuilderVerifyParams Type
updatedType
        mockBuilderPred :: Type
mockBuilderPred =
          Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''MockBuilder) (Name -> Type
VarT Name
params)) Type
funType) Type
verifyParams
        eqConstraint :: Cxt
eqConstraint =
          [ Type -> Type -> Type
AppT
              (Type -> Type -> Type
AppT Type
EqualityT (Type -> Type -> Type
AppT (Name -> Type
ConT ''ResolvableParamsOf) Type
funType))
              Type
verifyParams
          | Bool -> Bool
not ([Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Type -> [Name]
collectTypeVars Type
funType))
          ]
        baseCtx :: Cxt
baseCtx =
          ([Type
mockBuilderPred | Type
verifyParams Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Int -> Type
TupleT Int
0])
            Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ [Type -> Type -> Type
AppT (Name -> Type
ConT ''MonadIO) (Name -> Type
VarT Name
monadVarName)]
        typeablePreds :: Cxt
typeablePreds = Cxt -> Cxt
createTypeablePreds [Type
funType, Type
verifyParams]
        ctx :: Cxt
ctx = case MockType
mockType of
          MockType
Partial ->
            Cxt
baseCtx Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Type -> Type -> Cxt
partialAdditionalPredicates Type
funType Type
verifyParams Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Cxt
typeablePreds
          MockType
Total ->
            Cxt
baseCtx Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Cxt
eqConstraint Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Cxt
typeablePreds
        resultType :: Type
resultType =
          Type -> Type -> Type
AppT
            (Type -> Type -> Type
AppT Type
ArrowT (Name -> Type
VarT Name
params))
            (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''MockT) (Name -> Type
VarT Name
monadVarName)) Type
funType)
    Name -> m Type -> m Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
mockFunName (Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT [] Cxt
ctx Type
resultType))

  Exp
mockBody <- String -> m Exp -> Type -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp -> Type -> m Exp
createMockBody String
funNameStr [|p|] Type
funType
  Dec
newFun <- Name -> [m Clause] -> m Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
mockFunName [[m Pat] -> m Body -> [m Dec] -> m Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name -> m Pat) -> Name -> m Pat
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"p"] (m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
mockBody)) []]

  [Dec] -> m [Dec]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> m [Dec]) -> [Dec] -> m [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
newFunSig Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec
newFun]

doCreateConstantMockFnDecs :: (Quote m) => MockType -> String -> Name -> Type -> Name -> m [Dec]
doCreateConstantMockFnDecs :: forall (m :: * -> *).
Quote m =>
MockType -> String -> Name -> Type -> Name -> m [Dec]
doCreateConstantMockFnDecs MockType
Partial String
funNameStr Name
mockFunName Type
_ Name
monadVarName = do
  Name
stubVar <- String -> m Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"r"
  let ctx :: Cxt
ctx =
        [ Type -> Type -> Type
AppT
            (Type -> Type -> Type
AppT Type
EqualityT (Type -> Type -> Type
AppT (Name -> Type
ConT ''ResolvableParamsOf) (Name -> Type
VarT Name
stubVar)))
            (Int -> Type
TupleT Int
0)
        , Type -> Type -> Type
AppT (Name -> Type
ConT ''MonadIO) (Name -> Type
VarT Name
monadVarName)
        , Type -> Type -> Type
AppT (Name -> Type
ConT ''Typeable) (Name -> Type
VarT Name
stubVar)
        , Type -> Type -> Type
AppT (Name -> Type
ConT ''Show) (Name -> Type
VarT Name
stubVar)
        , Type -> Type -> Type
AppT (Name -> Type
ConT ''Eq) (Name -> Type
VarT Name
stubVar)
        ]
      resultType :: Type
resultType =
        Type -> Type -> Type
AppT
          (Type -> Type -> Type
AppT Type
ArrowT (Name -> Type
VarT Name
stubVar))
          (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''MockT) (Name -> Type
VarT Name
monadVarName)) (Name -> Type
VarT Name
stubVar))
  Dec
newFunSig <-
    Name -> m Type -> m Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD
      Name
mockFunName
      ( Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ([TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT
              [ Name -> Specificity -> TyVarBndr Specificity
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
stubVar Specificity
SpecifiedSpec
              , Name -> Specificity -> TyVarBndr Specificity
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
monadVarName Specificity
SpecifiedSpec
              ]
              Cxt
ctx
              Type
resultType
          )
      )
  Exp
headParam <- [|Head :> param p|]
  Exp
mockBody <- String -> m Exp -> Type -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp -> Type -> m Exp
createMockBody String
funNameStr (Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
headParam) (Name -> Type
VarT Name
stubVar)
  Dec
newFun <- Name -> [m Clause] -> m Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
mockFunName [[m Pat] -> m Body -> [m Dec] -> m Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name -> m Pat) -> Name -> m Pat
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"p"] (m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
mockBody)) []]
  [Dec] -> m [Dec]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> m [Dec]) -> [Dec] -> m [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
newFunSig Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec
newFun]
doCreateConstantMockFnDecs MockType
Total String
funNameStr Name
mockFunName Type
ty Name
monadVarName = do
  (Dec
newFunSig, Type
funTypeForBody) <- case Type
ty of
    AppT (ConT Name
_) (VarT Name
mv) | Name
mv Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
monadVarName -> do
      Name
a <- String -> m Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
      let ctx :: Cxt
ctx =
            [ Type -> Type -> Type
AppT (Name -> Type
ConT ''MonadIO) (Name -> Type
VarT Name
monadVarName)
            , Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
EqualityT (Type -> Type -> Type
AppT (Name -> Type
ConT ''ResolvableParamsOf) (Name -> Type
VarT Name
a))) (Int -> Type
TupleT Int
0)
            , Type -> Type -> Type
AppT (Name -> Type
ConT ''Typeable) (Name -> Type
VarT Name
a)
            , Type -> Type -> Type
AppT (Name -> Type
ConT ''Show) (Name -> Type
VarT Name
a)
            , Type -> Type -> Type
AppT (Name -> Type
ConT ''Eq) (Name -> Type
VarT Name
a)
            ]
          resultType :: Type
resultType =
            Type -> Type -> Type
AppT
              (Type -> Type -> Type
AppT Type
ArrowT (Name -> Type
VarT Name
a))
              (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''MockT) (Name -> Type
VarT Name
monadVarName)) (Name -> Type
VarT Name
a))
      Dec
sig <- Name -> m Type -> m Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD
        Name
mockFunName
        ( Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            ([TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT
                [Name -> Specificity -> TyVarBndr Specificity
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
a Specificity
SpecifiedSpec, Name -> Specificity -> TyVarBndr Specificity
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
monadVarName Specificity
SpecifiedSpec]
                Cxt
ctx
                Type
resultType
            )
        )
      (Dec, Type) -> m (Dec, Type)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
sig, Name -> Type
VarT Name
a)
    Type
_ -> do
      let headParamType :: Type
headParamType = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''(:>)) (Name -> Type
ConT ''Head)) (Type -> Type -> Type
AppT (Name -> Type
ConT ''Param) Type
ty)
          verifyParams' :: Type
verifyParams' = Type -> Type
createMockBuilderVerifyParams Type
ty
          mockBuilderPred' :: Type
mockBuilderPred' = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''MockBuilder) Type
headParamType) Type
ty) (Int -> Type
TupleT Int
0)
          ctx :: Cxt
ctx =
            [ Type -> Type -> Type
AppT (Name -> Type
ConT ''MonadIO) (Name -> Type
VarT Name
monadVarName)
            ]
            Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ ([Type
mockBuilderPred' | Type
verifyParams' Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Int -> Type
TupleT Int
0])
            Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Cxt -> Cxt
createTypeablePreds [Type
ty]
          resultType :: Type
resultType =
            Type -> Type -> Type
AppT
              (Type -> Type -> Type
AppT Type
ArrowT Type
ty)
              (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''MockT) (Name -> Type
VarT Name
monadVarName)) Type
ty)
      Dec
sig <- Name -> m Type -> m Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
mockFunName (Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT [Name -> Specificity -> TyVarBndr Specificity
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
monadVarName Specificity
SpecifiedSpec] Cxt
ctx Type
resultType))
      (Dec, Type) -> m (Dec, Type)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
sig, Type
ty)
  Exp
headParam <- [|Head :> param p|]
  Exp
mockBody <- String -> m Exp -> Type -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp -> Type -> m Exp
createMockBody String
funNameStr (Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
headParam) Type
funTypeForBody
  Dec
newFun <- Name -> [m Clause] -> m Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
mockFunName [[m Pat] -> m Body -> [m Dec] -> m Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name -> m Pat) -> Name -> m Pat
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"p"] (m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
mockBody)) []]
  [Dec] -> m [Dec]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> m [Dec]) -> [Dec] -> m [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
newFunSig Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec
newFun]

doCreateEmptyVerifyParamMockFnDecs :: (Quote m) => String -> Name -> Name -> Type -> Name -> Type -> m [Dec]
doCreateEmptyVerifyParamMockFnDecs :: forall (m :: * -> *).
Quote m =>
String -> Name -> Name -> Type -> Name -> Type -> m [Dec]
doCreateEmptyVerifyParamMockFnDecs String
funNameStr Name
mockFunName Name
params Type
funType Name
monadVarName Type
updatedType = do
  Dec
newFunSig <- do
    let verifyParams :: Type
verifyParams = Type -> Type
createMockBuilderVerifyParams Type
updatedType
        mockBuilderPred :: Type
mockBuilderPred = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''MockBuilder) (Name -> Type
VarT Name
params)) Type
funType) Type
verifyParams
        eqConstraint :: Cxt
eqConstraint =
          [ Type -> Type -> Type
AppT
              (Type -> Type -> Type
AppT Type
EqualityT (Type -> Type -> Type
AppT (Name -> Type
ConT ''ResolvableParamsOf) Type
funType))
              Type
verifyParams
          | Bool -> Bool
not ([Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Type -> [Name]
collectTypeVars Type
funType))
          ]
        ctx :: Cxt
ctx =
          [Type
mockBuilderPred]
            Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ [Type -> Type -> Type
AppT (Name -> Type
ConT ''MonadIO) (Name -> Type
VarT Name
monadVarName)]
            Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Cxt
eqConstraint
            Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Cxt -> Cxt
createTypeablePreds [Type
funType, Type
verifyParams]
        resultType :: Type
resultType =
          Type -> Type -> Type
AppT
            (Type -> Type -> Type
AppT Type
ArrowT (Name -> Type
VarT Name
params))
            (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''MockT) (Name -> Type
VarT Name
monadVarName)) Type
funType)
    Name -> m Type -> m Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
mockFunName (Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT [] Cxt
ctx Type
resultType))

  Exp
mockBody <- String -> m Exp -> Type -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp -> Type -> m Exp
createMockBody String
funNameStr [|p|] Type
funType
  Dec
newFun <- Name -> [m Clause] -> m Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
mockFunName [[m Pat] -> m Body -> [m Dec] -> m Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name -> m Pat) -> Name -> m Pat
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"p"] (m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
mockBody)) []]

  [Dec] -> m [Dec]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> m [Dec]) -> [Dec] -> m [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
newFunSig Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec
newFun]

createMockBody :: (Quote m) => String -> m Exp -> Type -> m Exp
createMockBody :: forall (m :: * -> *). Quote m => String -> m Exp -> Type -> m Exp
createMockBody String
funNameStr m Exp
paramsExp Type
_funType = do
  Exp
params <- m Exp
paramsExp
  [|
    MockT $ do
      -- Build the mock instance and its verifier directly so we have access
      -- to the verifier value (avoids runtime type-mismatch when resolving).
      BuiltMock { builtMockFn = mockInstance, builtMockRecorder = verifier } <- liftIO $ buildMock (Just $(Lit -> m Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL String
funNameStr))) $(Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
params)
      -- Register and get the canonical wrapper (preserved for async safety)
      canonicalInstance <- liftIO $ Registry.register (Just $(Lit -> m Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL String
funNameStr))) verifier mockInstance
      addDefinition
        ( Definition
            (Proxy :: Proxy $(m TyLit -> m Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (String -> m TyLit
forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit String
funNameStr)))
            canonicalInstance
            NoVerification
        )
      pure canonicalInstance
    |]

createFnName :: Name -> MockOptions -> String
createFnName :: Name -> MockOptions -> String
createFnName Name
funName MockOptions
opts = do
  MockOptions
opts.prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase Name
funName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> MockOptions
opts.suffix

findParam :: KnownSymbol sym => Proxy sym -> [Definition] -> Maybe Dynamic
findParam :: forall (sym :: Symbol).
KnownSymbol sym =>
Proxy sym -> [Definition] -> Maybe Dynamic
findParam Proxy sym
pa [Definition]
definitions = do
  let definition :: Maybe Definition
definition = (Definition -> Bool) -> [Definition] -> Maybe Definition
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Definition Proxy sym
s f
_ Verification f
_) -> Proxy sym -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy sym
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy sym -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy sym
pa) [Definition]
definitions
  (Definition -> Dynamic) -> Maybe Definition -> Maybe Dynamic
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Definition Proxy sym
_ f
mockFunction Verification f
_) -> f -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn f
mockFunction) Maybe Definition
definition

typeToNames :: Type -> [Q Name]
typeToNames :: Type -> [Q Name]
typeToNames (AppT (AppT Type
ArrowT Type
_) Type
t2) = String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"a" Q Name -> [Q Name] -> [Q Name]
forall a. a -> [a] -> [a]
: Type -> [Q Name]
typeToNames Type
t2
typeToNames (ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
ty) = Type -> [Q Name]
typeToNames Type
ty
typeToNames Type
_ = []

safeIndex :: [a] -> Int -> Maybe a
safeIndex :: forall a. [a] -> Int -> Maybe a
safeIndex [] Int
_ = Maybe a
forall a. Maybe a
Nothing
safeIndex (a
x : [a]
_) Int
0 = a -> Maybe a
forall a. a -> Maybe a
Just a
x
safeIndex (a
_ : [a]
xs) Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Maybe a
forall a. Maybe a
Nothing
  | Bool
otherwise = [a] -> Int -> Maybe a
forall a. [a] -> Int -> Maybe a
safeIndex [a]
xs (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)


generateInstanceMockFnBody :: String -> [Q Exp] -> Name -> MockOptions -> Q Exp
generateInstanceMockFnBody :: String -> [Q Exp] -> Name -> MockOptions -> Q Exp
generateInstanceMockFnBody String
fnNameStr [Q Exp]
args Name
r MockOptions
opts = do
  Exp
returnExp <- if MockOptions
opts.implicitMonadicReturn
    then [| pure $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
r) |]
    else [| lift $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
r) |]

  [|
    MockT $ do
      defs <- getDefinitions
      let findDef = find (\(Definition s _ _) -> symbolVal s == $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL String
fnNameStr))) defs
      case findDef of
        Just (Definition _ mf _) -> do
          let mock = unsafeCoerce mf
          let $(Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Pat
bangP (Q Pat -> Q Pat) -> Q Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
r) = $([Q Exp] -> Q Exp -> Q Exp
generateStubFn [Q Exp]
args [|mock|])
          $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
returnExp)
        Nothing -> error $ "no answer found stub function `" ++ fnNameStr ++ "`."
    |]

generateInstanceRealFnBody :: Name -> String -> [Q Exp] -> Name -> MockOptions -> Q Exp
generateInstanceRealFnBody :: Name -> String -> [Q Exp] -> Name -> MockOptions -> Q Exp
generateInstanceRealFnBody Name
fnName String
fnNameStr [Q Exp]
args Name
r MockOptions
opts = do
  Exp
returnExp <- if MockOptions
opts.implicitMonadicReturn
    then [| pure $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
r) |]
    else [| lift $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
r) |]
  [|
    MockT $ do
      defs <- getDefinitions
      let findDef = find (\(Definition s _ _) -> symbolVal s == $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL String
fnNameStr))) defs
      case findDef of
        Just (Definition _ mf _) -> do
          let mock = unsafeCoerce mf
          let $(Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Pat
bangP (Q Pat -> Q Pat) -> Q Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
r) = $([Q Exp] -> Q Exp -> Q Exp
generateStubFn [Q Exp]
args [|mock|])
          $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
returnExp)
        Nothing -> lift $ $((Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fnName) [Q Exp]
args)
    |]

generateStubFn :: [Q Exp] -> Q Exp -> Q Exp
generateStubFn :: [Q Exp] -> Q Exp -> Q Exp
generateStubFn [] Q Exp
mock = Q Exp
mock
generateStubFn [Q Exp]
args Q Exp
mock = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE Q Exp
mock [Q Exp]
args