{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}

-- | This module provides Template Haskell splices that can be used to derive
-- boilerplate instances for HMock.  'makeMockable' implements the common case
-- where you just want to generate everything you need to mock with a class.
-- The variant 'makeMockableWithOptions' is similar, but takes an options
-- parameter that can be used to customize the generation.
module Test.HMock.TH
  ( MakeMockableOptions (..),
    makeMockable,
    makeMockableWithOptions,
  )
where

import Control.Monad (replicateM, unless, when, zipWithM)
import Control.Monad.Extra (concatMapM)
import Control.Monad.Trans (MonadIO)
import Data.Bool (bool)
import Data.Char (toUpper)
import Data.Default (Default (..))
import Data.Either (partitionEithers)
import qualified Data.Kind
import Data.List (foldl', (\\))
import Data.Maybe (catMaybes, isNothing)
import Data.Proxy (Proxy)
import Data.Typeable (Typeable, typeRep)
import GHC.Stack (HasCallStack)
import GHC.TypeLits (ErrorMessage (Text, (:$$:), (:<>:)), Symbol, TypeError)
import Language.Haskell.TH hiding (Match, match)
import Language.Haskell.TH.Syntax (Lift (lift))
import Test.HMock.Internal.State (MockT)
import Test.HMock.Internal.TH
import Test.HMock.MockMethod (mockDefaultlessMethod, mockMethod)
import Test.HMock.Mockable (MatchResult (..), Mockable, MockableBase (..))
import Test.HMock.Rule (Expectable (..))
import Test.Predicates (Predicate (..), eq)

-- | Custom options for deriving 'MockableBase' and related instances.
data MakeMockableOptions = MakeMockableOptions
  { -- | Whether to generate a 'Mockable' instance with an empty setup.
    -- Defaults to 'True'.
    --
    -- If this is 'False', you are responsible for providing a 'Mockable'
    -- instance as follows:
    --
    -- @
    -- instance 'Mockable' MyClass where
    --   'Test.HMock.Mockable.setupMockable' _ = ...
    -- @
    MakeMockableOptions -> Bool
mockEmptySetup :: Bool,
    -- | Whether to derive instances of the class for 'MockT' or not.  Defaults
    -- to 'True'.
    --
    -- This option will cause a build error if some members of the class are
    -- unmockable or are not methods.  In this case, you'll need to define this
    -- instance yourself, delegating the mockable methods as follows:
    --
    -- @
    -- instance MyClass ('MockT' m) where
    --   myMethod x y = 'mockMethod' (MyMethod x y)
    --   ...
    -- @
    MakeMockableOptions -> Bool
mockDeriveForMockT :: Bool,
    -- | Suffix to add to 'Action' and 'Matcher' names.  Defaults to @""@.
    MakeMockableOptions -> String
mockSuffix :: String,
    -- | Whether to warn about limitations of the generated mocks.  This is
    -- mostly useful temporarily for finding out why generated code doesn't
    -- match your expectations.  Defaults to @'False'@.
    MakeMockableOptions -> Bool
mockVerbose :: Bool
  }

instance Default MakeMockableOptions where
  def :: MakeMockableOptions
def =
    MakeMockableOptions
      { mockEmptySetup :: Bool
mockEmptySetup = Bool
True,
        mockDeriveForMockT :: Bool
mockDeriveForMockT = Bool
True,
        mockSuffix :: String
mockSuffix = String
"",
        mockVerbose :: Bool
mockVerbose = Bool
False
      }

-- | Defines all instances necessary to use HMock with the given type, using
-- default options.  The type should be a type class extending 'Monad', applied
-- to zero or more type arguments.
--
-- This defines all of the following instances, if necessary:
--
-- * 'MockableBase' and the associated 'Action' and 'Matcher' types.
-- * 'Expectable' instances for the 'Action' type.
-- * 'Mockable' with an empty setup.
-- * Instances of the provided application type class to allow unit tests to be
--   run with the 'MockT' monad transformer.
makeMockable :: Q Type -> Q [Dec]
makeMockable :: Q Type -> Q [Dec]
makeMockable Q Type
qtype = Q Type -> MakeMockableOptions -> Q [Dec]
makeMockableWithOptions Q Type
qtype forall a. Default a => a
def

-- | Defines all instances necessary to use HMock with the given type, using
-- the provided options.  The type should be a type class extending 'Monad',
-- applied to zero or more type arguments.
--
-- This defines the following instances, if necessary:
--
-- * 'MockableBase' and the associated 'Action' and 'Matcher' types.
-- * 'Expectable' instances for the 'Action' type.
-- * If 'mockEmptySetup' is 'True': 'Mockable' with an empty setup.
-- * If 'mockDeriveForMockT' is 'True': Instances of the provided application
--   type class to allow unit tests to be run with the 'MockT' monad
--   transformer.
makeMockableWithOptions :: Q Type -> MakeMockableOptions -> Q [Dec]
makeMockableWithOptions :: Q Type -> MakeMockableOptions -> Q [Dec]
makeMockableWithOptions Q Type
qtype MakeMockableOptions
options = MakeMockableOptions -> Q Type -> Q [Dec]
makeMockableImpl MakeMockableOptions
options Q Type
qtype

data Instance = Instance
  { Instance -> Type
instType :: Type,
    Instance -> Cxt
instRequiredContext :: Cxt,
    Instance -> [Name]
instGeneralParams :: [Name],
    Instance -> Name
instMonadVar :: Name,
    Instance -> [Method]
instMethods :: [Method],
    Instance -> [Dec]
instExtraMembers :: [Dec]
  }
  deriving (Int -> Instance -> ShowS
[Instance] -> ShowS
Instance -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Instance] -> ShowS
$cshowList :: [Instance] -> ShowS
show :: Instance -> String
$cshow :: Instance -> String
showsPrec :: Int -> Instance -> ShowS
$cshowsPrec :: Int -> Instance -> ShowS
Show)

data Method = Method
  { Method -> Name
methodName :: Name,
    Method -> [Name]
methodTyVars :: [Name],
    Method -> Cxt
methodCxt :: Cxt,
    Method -> Cxt
methodArgs :: [Type],
    Method -> Type
methodResult :: Type
  }
  deriving (Int -> Method -> ShowS
[Method] -> ShowS
Method -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Method] -> ShowS
$cshowList :: [Method] -> ShowS
show :: Method -> String
$cshow :: Method -> String
showsPrec :: Int -> Method -> ShowS
$cshowsPrec :: Int -> Method -> ShowS
Show)

withClass :: Type -> (Dec -> Q a) -> Q a
withClass :: forall a. Type -> (Dec -> Q a) -> Q a
withClass Type
t Dec -> Q a
f = do
  case Type -> Maybe Name
unappliedName Type
t of
    Just Name
cls -> do
      Info
info <- Name -> Q Info
reify Name
cls
      case Info
info of
        ClassI dec :: Dec
dec@ClassD {} [Dec]
_ -> Dec -> Q a
f Dec
dec
        Info
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Expected " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
cls forall a. [a] -> [a] -> [a]
++ String
" to be a class, but it wasn't."
    Maybe Name
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected a class, but got something else."

getInstance :: MakeMockableOptions -> Type -> Q Instance
getInstance :: MakeMockableOptions -> Type -> Q Instance
getInstance MakeMockableOptions
options Type
ty = forall a. Type -> (Dec -> Q a) -> Q a
withClass Type
ty Dec -> Q Instance
go
  where
    go :: Dec -> Q Instance
go (ClassD Cxt
_ Name
className [] [FunDep]
_ [Dec]
_) =
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Class " forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
className forall a. [a] -> [a] -> [a]
++ String
" has no type parameters."
    go (ClassD Cxt
cx Name
_ [TyVarBndr ()]
params [FunDep]
_ [Dec]
members) =
      Type -> Cxt -> [Name] -> Q Instance
matchVars Type
ty [] (forall flag. TyVarBndr flag -> Name
tvName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr ()]
params)
      where
        matchVars :: Type -> [Type] -> [Name] -> Q Instance
        matchVars :: Type -> Cxt -> [Name] -> Q Instance
matchVars Type
_ Cxt
_ [] = forall a. HasCallStack => Q a
internalError
        matchVars (AppT Type
_ Type
_) Cxt
_ [Name
_] =
          forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Ppr a => a -> String
pprint Type
ty forall a. [a] -> [a] -> [a]
++ String
" is applied to too many arguments."
        matchVars (AppT Type
a Type
b) Cxt
ts (Name
_ : [Name]
ps) =
          Extension -> Q ()
checkExt Extension
FlexibleInstances forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Cxt -> [Name] -> Q Instance
matchVars Type
a (Type
b forall a. a -> [a] -> [a]
: Cxt
ts) [Name]
ps
        matchVars Type
_ Cxt
ts [Name]
ps = do
          let genVars :: [Name]
genVars = forall a. [a] -> [a]
init [Name]
ps
          let mVar :: Name
mVar = forall a. [a] -> a
last [Name]
ps
          let t :: Type
t = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Type
t' Name
v -> Type -> Type -> Type
AppT Type
t' (Name -> Type
VarT Name
v)) Type
ty [Name]
genVars
          let tbl :: [(Name, Type)]
tbl = forall a b. [a] -> [b] -> [(a, b)]
zip (forall flag. TyVarBndr flag -> Name
tvName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr ()]
params) Cxt
ts
          let cx' :: Cxt
cx' = [(Name, Type)] -> Type -> Type
substTypeVars [(Name, Type)]
tbl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt
cx
          MakeMockableOptions
-> Type
-> Cxt
-> [(Name, Type)]
-> [Name]
-> Name
-> [Dec]
-> Q Instance
makeInstance MakeMockableOptions
options Type
t Cxt
cx' [(Name, Type)]
tbl [Name]
genVars Name
mVar [Dec]
members
    go Dec
_ = forall a. HasCallStack => Q a
internalError

makeInstance ::
  MakeMockableOptions ->
  Type ->
  Cxt ->
  [(Name, Type)] ->
  [Name] ->
  Name ->
  [Dec] ->
  Q Instance
makeInstance :: MakeMockableOptions
-> Type
-> Cxt
-> [(Name, Type)]
-> [Name]
-> Name
-> [Dec]
-> Q Instance
makeInstance MakeMockableOptions
options Type
ty Cxt
cx [(Name, Type)]
tbl [Name]
ps Name
m [Dec]
members = do
  [Either [String] Method]
processedMembers <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Name -> [(Name, Type)] -> Dec -> Q (Either [String] Method)
getMethod Type
ty Name
m [(Name, Type)]
tbl) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter Dec -> Bool
isRelevantMember [Dec]
members
  ([Dec]
extraMembers, [Method]
methods) <-
    forall a b. [Either a b] -> ([a], [b])
partitionEithers forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Dec -> Either [String] Method -> Q (Either Dec Method)
memberOrMethod [Dec]
members [Either [String] Method]
processedMembers
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    Instance
      { instType :: Type
instType = Type
ty,
        instRequiredContext :: Cxt
instRequiredContext = Cxt
cx,
        instGeneralParams :: [Name]
instGeneralParams = [Name]
ps,
        instMonadVar :: Name
instMonadVar = Name
m,
        instMethods :: [Method]
instMethods = [Method]
methods,
        instExtraMembers :: [Dec]
instExtraMembers = [Dec]
extraMembers
      }
  where
    isRelevantMember :: Dec -> Bool
    isRelevantMember :: Dec -> Bool
isRelevantMember DefaultSigD {} = Bool
False
    isRelevantMember Dec
_ = Bool
True

    memberOrMethod :: Dec -> Either [String] Method -> Q (Either Dec Method)
    memberOrMethod :: Dec -> Either [String] Method -> Q (Either Dec Method)
memberOrMethod Dec
dec (Left [String]
warnings) = do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MakeMockableOptions -> Bool
mockVerbose MakeMockableOptions
options) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Q ()
reportWarning [String]
warnings
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left Dec
dec)
    memberOrMethod Dec
_ (Right Method
method) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right Method
method)

getMethod :: Type -> Name -> [(Name, Type)] -> Dec -> Q (Either [String] Method)
getMethod :: Type -> Name -> [(Name, Type)] -> Dec -> Q (Either [String] Method)
getMethod Type
instTy Name
m [(Name, Type)]
tbl (SigD Name
name Type
ty) = do
  Type
simpleTy <- Type -> Name -> Type -> Q Type
localizeMember Type
instTy Name
m ([(Name, Type)] -> Type -> Type
substTypeVars [(Name, Type)]
tbl Type
ty)
  let ([Name]
tvs, Cxt
cx, Cxt
args, Type
mretval) = Type -> ([Name], Cxt, Cxt, Type)
splitType Type
simpleTy
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
    Type
retval <- case Type
mretval of
      AppT (VarT Name
m') Type
retval | Name
m' forall a. Eq a => a -> a -> Bool
== Name
m -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
retval
      Type
_ ->
        forall a b. a -> Either a b
Left
          [ Name -> String
nameBase Name
name
              forall a. [a] -> [a] -> [a]
++ String
" can't be mocked: return value not in the expected monad."
          ]
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
      ( forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all
          (Cxt -> Name -> Bool
isVarTypeable Cxt
cx)
          (forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
tvs) (Type -> [Name]
freeTypeVars Type
retval))
      )
      forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left
        [ Name -> String
nameBase Name
name
            forall a. [a] -> [a] -> [a]
++ String
" can't be mocked: return value not Typeable."
        ]
    let argTypes :: Cxt
argTypes = forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type -> Type -> Type
substTypeVar Name
m (Type -> Type -> Type
AppT (Name -> Type
ConT ''MockT) (Name -> Type
VarT Name
m))) Cxt
args
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Type -> Bool
hasNestedPolyType Cxt
argTypes) forall a b. (a -> b) -> a -> b
$
      forall a b. a -> Either a b
Left
        [ Name -> String
nameBase Name
name
            forall a. [a] -> [a] -> [a]
++ String
" can't be mocked: rank-n types nested in arguments."
        ]

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
      Method
        { methodName :: Name
methodName = Name
name,
          methodTyVars :: [Name]
methodTyVars = [Name]
tvs,
          methodCxt :: Cxt
methodCxt = Cxt
cx,
          methodArgs :: Cxt
methodArgs = Cxt
argTypes,
          methodResult :: Type
methodResult = Type
retval
        }
  where
    isVarTypeable :: Cxt -> Name -> Bool
    isVarTypeable :: Cxt -> Name -> Bool
isVarTypeable Cxt
cx Name
v = Type -> Type -> Type
AppT (Name -> Type
ConT ''Typeable) (Name -> Type
VarT Name
v) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Cxt
cx
getMethod Type
_ Name
_ [(Name, Type)]
_ (DataD Cxt
_ Name
name [TyVarBndr ()]
_ Maybe Type
_ [Con]
_ [DerivClause]
_) =
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    forall a b. a -> Either a b
Left [Name -> String
nameBase Name
name forall a. [a] -> [a] -> [a]
++ String
" must be defined manually in MockT instance."]
getMethod Type
_ Name
_ [(Name, Type)]
_ (NewtypeD Cxt
_ Name
name [TyVarBndr ()]
_ Maybe Type
_ Con
_ [DerivClause]
_) =
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    forall a b. a -> Either a b
Left [Name -> String
nameBase Name
name forall a. [a] -> [a] -> [a]
++ String
" must be defined manually in MockT instance."]
getMethod Type
_ Name
_ [(Name, Type)]
_ (TySynD Name
name [TyVarBndr ()]
_ Type
_) =
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    forall a b. a -> Either a b
Left [Name -> String
nameBase Name
name forall a. [a] -> [a] -> [a]
++ String
" must be defined manually in MockT instance."]
getMethod Type
_ Name
_ [(Name, Type)]
_ (DataFamilyD Name
name [TyVarBndr ()]
_ Maybe Type
_) =
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    forall a b. a -> Either a b
Left [Name -> String
nameBase Name
name forall a. [a] -> [a] -> [a]
++ String
" must be defined manually in MockT instance."]
getMethod Type
_ Name
_ [(Name, Type)]
_ (OpenTypeFamilyD (TypeFamilyHead Name
name [TyVarBndr ()]
_ FamilyResultSig
_ Maybe InjectivityAnn
_)) =
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    forall a b. a -> Either a b
Left [Name -> String
nameBase Name
name forall a. [a] -> [a] -> [a]
++ String
" must be defined manually in MockT instance."]
getMethod Type
_ Name
_ [(Name, Type)]
_ (ClosedTypeFamilyD (TypeFamilyHead Name
name [TyVarBndr ()]
_ FamilyResultSig
_ Maybe InjectivityAnn
_) [TySynEqn]
_) =
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    forall a b. a -> Either a b
Left [Name -> String
nameBase Name
name forall a. [a] -> [a] -> [a]
++ String
" must be defined manually in MockT instance."]
getMethod Type
_ Name
_ [(Name, Type)]
_ Dec
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left [])

isKnownType :: Method -> Type -> Bool
isKnownType :: Method -> Type -> Bool
isKnownType Method
method Type
ty = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
tyVars Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
cx
  where
    ([Name]
tyVars, Cxt
cx) =
      Type -> ([Name], Cxt) -> ([Name], Cxt)
relevantContext Type
ty (Method -> [Name]
methodTyVars Method
method, Method -> Cxt
methodCxt Method
method)

withMethodParams :: Instance -> Method -> TypeQ -> TypeQ
withMethodParams :: Instance -> Method -> Q Type -> Q Type
withMethodParams Instance
inst Method
method Q Type
t =
  [t|
    $t
      $(pure (instType inst))
      $(litT (strTyLit (nameBase (methodName method))))
      $(varT (instMonadVar inst))
      $(pure (methodResult method))
    |]

makeMockableImpl :: MakeMockableOptions -> Q Type -> Q [Dec]
makeMockableImpl :: MakeMockableOptions -> Q Type -> Q [Dec]
makeMockableImpl MakeMockableOptions
options Q Type
qtype = do
  Extension -> Q ()
checkExt Extension
DataKinds
  Extension -> Q ()
checkExt Extension
FlexibleInstances
  Extension -> Q ()
checkExt Extension
GADTs
  Extension -> Q ()
checkExt Extension
MultiParamTypeClasses
  Extension -> Q ()
checkExt Extension
ScopedTypeVariables
  Extension -> Q ()
checkExt Extension
TypeFamilies

  Type
ty <- Q Type
qtype
  let generalizedTy :: Type
generalizedTy = case Type -> Maybe Name
unappliedName Type
ty of
        Just Name
cls -> Name -> Type
ConT Name
cls
        Maybe Name
_ -> Type
ty
  Instance
inst <- MakeMockableOptions -> Type -> Q Instance
getInstance MakeMockableOptions
options Type
generalizedTy

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Instance -> [Method]
instMethods Instance
inst)) forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
      String
"Cannot derive Mockable because " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint (Instance -> Type
instType Instance
inst)
        forall a. [a] -> [a] -> [a]
++ String
" has no mockable methods."

  Cxt
typeableCxt <- [Q Type] -> [Name] -> CxtQ
constrainVars [forall (m :: * -> *). Quote m => Name -> m Type
conT ''Typeable] (Instance -> [Name]
instGeneralParams Instance
inst)

  Bool
needsMockableBase <-
    forall a. Maybe a -> Bool
isNothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Cxt -> Q (Maybe Cxt)
resolveInstance ''MockableBase [Instance -> Type
instType Instance
inst]
  [Dec]
mockableBase <-
    if Bool
needsMockableBase
      then do
        Dec
mockableBase <-
          forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
            (forall (f :: * -> *) a. Applicative f => a -> f a
pure Cxt
typeableCxt)
            [t|MockableBase $(pure (instType inst))|]
            [ MakeMockableOptions -> Instance -> Q Dec
defineActionType MakeMockableOptions
options Instance
inst,
              MakeMockableOptions -> Instance -> Q Dec
defineMatcherType MakeMockableOptions
options Instance
inst,
              MakeMockableOptions -> [Method] -> Q Dec
defineShowAction MakeMockableOptions
options (Instance -> [Method]
instMethods Instance
inst),
              MakeMockableOptions -> [Method] -> Q Dec
defineShowMatcher MakeMockableOptions
options (Instance -> [Method]
instMethods Instance
inst),
              MakeMockableOptions -> [Method] -> Q Dec
defineMatchAction MakeMockableOptions
options (Instance -> [Method]
instMethods Instance
inst)
            ]
        [Dec]
expectables <- MakeMockableOptions -> Instance -> Q [Dec]
defineExpectableActions MakeMockableOptions
options Instance
inst
        forall (m :: * -> *) a. Monad m => a -> m a
return (Dec
mockableBase forall a. a -> [a] -> [a]
: [Dec]
expectables)
      else forall (m :: * -> *) a. Monad m => a -> m a
return []

  Bool
needsMockable <-
    if MakeMockableOptions -> Bool
mockEmptySetup MakeMockableOptions
options
      then forall a. Maybe a -> Bool
isNothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Cxt -> Q (Maybe Cxt)
resolveInstance ''Mockable [Instance -> Type
instType Instance
inst]
      else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  [Dec]
mockable <-
    if Bool
needsMockable
      then do
        Type
t <- [t|Mockable $(pure (instType inst))|]
        forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD (forall a. a -> Maybe a
Just Overlap
Overlappable) Cxt
typeableCxt Type
t []]
      else forall (m :: * -> *) a. Monad m => a -> m a
return []

  [Dec]
mockt <- MakeMockableOptions -> Type -> Q [Dec]
deriveForMockT MakeMockableOptions
options Type
ty

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
mockableBase forall a. [a] -> [a] -> [a]
++ [Dec]
mockable forall a. [a] -> [a] -> [a]
++ [Dec]
mockt

defineActionType :: MakeMockableOptions -> Instance -> DecQ
defineActionType :: MakeMockableOptions -> Instance -> Q Dec
defineActionType MakeMockableOptions
options Instance
inst = do
  Type
kind <-
    [t|
      Symbol ->
      (Data.Kind.Type -> Data.Kind.Type) ->
      Data.Kind.Type ->
      Data.Kind.Type
      |]
  let cons :: [ConQ]
cons = MakeMockableOptions -> Instance -> Method -> ConQ
actionConstructor MakeMockableOptions
options Instance
inst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Instance -> [Method]
instMethods Instance
inst
  forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [m Type]
-> Maybe Type
-> [m Con]
-> [m DerivClause]
-> m Dec
dataInstD
    (forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
    ''Action
    [forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instance -> Type
instType Instance
inst)]
    (forall a. a -> Maybe a
Just Type
kind)
    [ConQ]
cons
    []

actionConstructor :: MakeMockableOptions -> Instance -> Method -> ConQ
actionConstructor :: MakeMockableOptions -> Instance -> Method -> ConQ
actionConstructor MakeMockableOptions
options Instance
inst Method
method = do
  forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Con -> m Con
forallC [] (forall (m :: * -> *) a. Monad m => a -> m a
return (Method -> Cxt
methodCxt Method
method)) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *).
Quote m =>
[Name] -> [m StrictType] -> m Type -> m Con
gadtC
      [MakeMockableOptions -> Method -> Name
getActionName MakeMockableOptions
options Method
method]
      [ forall (m :: * -> *) a. Monad m => a -> m a
return (SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, Type
argTy)
        | Type
argTy <- Method -> Cxt
methodArgs Method
method
      ]
      (Instance -> Method -> Q Type -> Q Type
withMethodParams Instance
inst Method
method [t|Action|])

getActionName :: MakeMockableOptions -> Method -> Name
getActionName :: MakeMockableOptions -> Method -> Name
getActionName MakeMockableOptions
options Method
method =
  String -> Name
mkName (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (forall a. Int -> [a] -> [a]
take Int
1 String
name) forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
drop Int
1 String
name forall a. [a] -> [a] -> [a]
++ MakeMockableOptions -> String
mockSuffix MakeMockableOptions
options)
  where
    name :: String
name = Name -> String
nameBase (Method -> Name
methodName Method
method)

defineMatcherType :: MakeMockableOptions -> Instance -> Q Dec
defineMatcherType :: MakeMockableOptions -> Instance -> Q Dec
defineMatcherType MakeMockableOptions
options Instance
inst = do
  Type
kind <-
    [t|
      Symbol ->
      (Data.Kind.Type -> Data.Kind.Type) ->
      Data.Kind.Type ->
      Data.Kind.Type
      |]
  let cons :: [ConQ]
cons = MakeMockableOptions -> Instance -> Method -> ConQ
matcherConstructor MakeMockableOptions
options Instance
inst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Instance -> [Method]
instMethods Instance
inst
  forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [m Type]
-> Maybe Type
-> [m Con]
-> [m DerivClause]
-> m Dec
dataInstD
    (forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
    ''Matcher
    [forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instance -> Type
instType Instance
inst)]
    (forall a. a -> Maybe a
Just Type
kind)
    [ConQ]
cons
    []

matcherConstructor :: MakeMockableOptions -> Instance -> Method -> ConQ
matcherConstructor :: MakeMockableOptions -> Instance -> Method -> ConQ
matcherConstructor MakeMockableOptions
options Instance
inst Method
method = do
  forall (m :: * -> *).
Quote m =>
[Name] -> [m StrictType] -> m Type -> m Con
gadtC
    [MakeMockableOptions -> Method -> Name
getMatcherName MakeMockableOptions
options Method
method]
    [ (SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Type
mkPredicate Type
argTy
      | Type
argTy <- Method -> Cxt
methodArgs Method
method
    ]
    (Instance -> Method -> Q Type -> Q Type
withMethodParams Instance
inst Method
method [t|Matcher|])
  where
    mkPredicate :: Type -> Q Type
mkPredicate Type
argTy
      | Type -> Bool
hasPolyType Type
argTy = do
        Extension -> Q ()
checkExt Extension
RankNTypes
        Name
v <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
        forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Type -> m Type
forallT [Name -> TyVarBndr Specificity
bindVar Name
v] (forall (f :: * -> *) a. Applicative f => a -> f a
pure []) [t|Predicate $(varT v)|]
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
tyVars Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
cx = [t|Predicate $(pure argTy)|]
      | Bool
otherwise = do
        Extension -> Q ()
checkExt Extension
RankNTypes
        forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Type -> m Type
forallT (Name -> TyVarBndr Specificity
bindVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
tyVars) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Cxt
cx) [t|Predicate $(pure argTy)|]
      where
        ([Name]
tyVars, Cxt
cx) =
          Type -> ([Name], Cxt) -> ([Name], Cxt)
relevantContext Type
argTy (Method -> [Name]
methodTyVars Method
method, Method -> Cxt
methodCxt Method
method)

getMatcherName :: MakeMockableOptions -> Method -> Name
getMatcherName :: MakeMockableOptions -> Method -> Name
getMatcherName MakeMockableOptions
options Method
method =
  String -> Name
mkName (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (forall a. Int -> [a] -> [a]
take Int
1 String
name) forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
drop Int
1 String
name forall a. [a] -> [a] -> [a]
++ MakeMockableOptions -> String
mockSuffix MakeMockableOptions
options forall a. [a] -> [a] -> [a]
++ String
"_")
  where
    name :: String
name = Name -> String
nameBase (Method -> Name
methodName Method
method)

defineShowAction :: MakeMockableOptions -> [Method] -> Q Dec
defineShowAction :: MakeMockableOptions -> [Method] -> Q Dec
defineShowAction MakeMockableOptions
options [Method]
methods =
  forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'showAction (MakeMockableOptions -> Method -> Q Clause
showActionClause MakeMockableOptions
options forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Method]
methods)

showActionClause :: MakeMockableOptions -> Method -> Q Clause
showActionClause :: MakeMockableOptions -> Method -> Q Clause
showActionClause MakeMockableOptions
options Method
method = do
  [Name]
argVars <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length (Method -> Cxt
methodArgs Method
method)) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"a")
  forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
    [ forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP
        (MakeMockableOptions -> Method -> Name
getActionName MakeMockableOptions
options Method
method)
        (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> Name -> Q Pat
argPattern (Method -> Cxt
methodArgs Method
method) [Name]
argVars)
    ]
    ( forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
        [|
          unwords
            ( $(lift (nameBase (methodName method))) :
              $(listE (zipWith showArg (methodArgs method) argVars))
            )
          |]
    )
    []
  where
    isLocalPoly :: Type -> Bool
isLocalPoly Type
ty =
      Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$
        Type -> ([Name], Cxt) -> ([Name], Cxt)
relevantContext Type
ty (Method -> [Name]
methodTyVars Method
method, Method -> Cxt
methodCxt Method
method)

    canShow :: Type -> Q Bool
canShow Type
ty
      | Type -> Bool
hasPolyType Type
ty = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      | Type -> Bool
isLocalPoly Type
ty = (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Method -> Cxt
methodCxt Method
method) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|Show $(pure ty)|]
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Type -> [Name]
freeTypeVars Type
ty) = Name -> Cxt -> Q Bool
isInstance ''Show [Type
ty]
      | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    canType :: Type -> m Bool
canType Type
ty
      | Type -> Bool
hasPolyType Type
ty = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      | Type -> Bool
isLocalPoly Type
ty =
        (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Method -> Cxt
methodCxt Method
method)
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|Typeable $(pure ty)|]
      | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Type -> [Name]
freeTypeVars Type
ty))

    argPattern :: Type -> Name -> Q Pat
argPattern Type
ty Name
v = Type -> Q Bool
canShow Type
ty forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> a -> Bool -> a
bool forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
v)

    showArg :: Type -> Name -> Q Exp
showArg Type
ty Name
var = do
      Bool
showable <- Type -> Q Bool
canShow Type
ty
      Bool
typeable <- forall {m :: * -> *}. Quote m => Type -> m Bool
canType Type
ty
      case (Bool
showable, Bool
typeable) of
        (Bool
True, Bool
_) -> [|showsPrec 11 $(varE var) ""|]
        (Bool
_, Bool
True) ->
          [|
            "(_ :: "
              ++ show (typeRep (undefined :: Proxy $(return ty)))
              ++ ")"
            |]
        (Bool, Bool)
_ -> forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift (String
"(_  :: " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint (forall a. Data a => a -> a
removeModNames Type
ty) forall a. [a] -> [a] -> [a]
++ String
")")

defineShowMatcher :: MakeMockableOptions -> [Method] -> Q Dec
defineShowMatcher :: MakeMockableOptions -> [Method] -> Q Dec
defineShowMatcher MakeMockableOptions
options [Method]
methods = do
  [Q Clause]
clauses <- forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (MakeMockableOptions -> Method -> Q [Q Clause]
showMatcherClauses MakeMockableOptions
options) [Method]
methods
  forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'showMatcher [Q Clause]
clauses

showMatcherClauses :: MakeMockableOptions -> Method -> Q [ClauseQ]
showMatcherClauses :: MakeMockableOptions -> Method -> Q [Q Clause]
showMatcherClauses MakeMockableOptions
options Method
method = do
  [Name]
argTVars <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length (Method -> Cxt
methodArgs Method
method)) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"t")
  [Name]
predVars <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length (Method -> Cxt
methodArgs Method
method)) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"p")
  let actionArgs :: [Q Pat]
actionArgs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {m :: * -> *}. Quote m => Name -> Type -> m Pat
actionArg [Name]
argTVars (Method -> Cxt
methodArgs Method
method)
  let matcherArgs :: [Q Pat]
matcherArgs = forall (m :: * -> *). Quote m => Name -> m Pat
varP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
predVars
  let printedArgs :: [Q Exp]
printedArgs = forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 forall {m :: * -> *}. Quote m => Name -> Name -> Type -> m Exp
printedArg [Name]
predVars [Name]
argTVars (Method -> Cxt
methodArgs Method
method)
  let polyMatcherArgs :: [Q Pat]
polyMatcherArgs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {m :: * -> *}. Quote m => Name -> Type -> m Pat
matcherArg [Name]
predVars (Method -> Cxt
methodArgs Method
method)
  let printedPolyArgs :: [Q Exp]
printedPolyArgs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {m :: * -> *}. Quote m => Name -> Type -> m Exp
printedPolyArg [Name]
predVars (Method -> Cxt
methodArgs Method
method)
  let body :: t -> [m Exp] -> m Body
body t
name [m Exp]
args = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|unwords ($(lift name) : $(listE args))|]
  forall (m :: * -> *) a. Monad m => a -> m a
return
    [ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
        [ forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Just [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (MakeMockableOptions -> Method -> Name
getActionName MakeMockableOptions
options Method
method) [Q Pat]
actionArgs],
          forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (MakeMockableOptions -> Method -> Name
getMatcherName MakeMockableOptions
options Method
method) [Q Pat]
matcherArgs
        ]
        (forall {m :: * -> *} {t}.
(Quote m, Lift t) =>
t -> [m Exp] -> m Body
body (Name -> String
nameBase (Method -> Name
methodName Method
method)) [Q Exp]
printedArgs)
        [],
      forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
        [ forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Nothing [],
          forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (MakeMockableOptions -> Method -> Name
getMatcherName MakeMockableOptions
options Method
method) [Q Pat]
polyMatcherArgs
        ]
        (forall {m :: * -> *} {t}.
(Quote m, Lift t) =>
t -> [m Exp] -> m Body
body (Name -> String
nameBase (Method -> Name
methodName Method
method)) [Q Exp]
printedPolyArgs)
        []
    ]
  where
    actionArg :: Name -> Type -> m Pat
actionArg Name
t Type
ty
      | Method -> Type -> Bool
isKnownType Method
method Type
ty = forall (m :: * -> *). Quote m => m Pat
wildP
      | Bool
otherwise = forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => Name -> m Type
varT Name
t)

    matcherArg :: Name -> Type -> m Pat
matcherArg Name
p Type
ty
      | Method -> Type -> Bool
isKnownType Method
method Type
ty = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
p
      | Bool
otherwise = forall (m :: * -> *). Quote m => m Pat
wildP

    printedArg :: Name -> Name -> Type -> m Exp
printedArg Name
p Name
t Type
ty
      | Method -> Type -> Bool
isKnownType Method
method Type
ty = [|"«" ++ show $(varE p) ++ "»"|]
      | Bool
otherwise =
        [|"«" ++ show ($(varE p) :: Predicate $(varT t)) ++ "»"|]

    printedPolyArg :: Name -> Type -> m Exp
printedPolyArg Name
p Type
ty
      | Method -> Type -> Bool
isKnownType Method
method Type
ty = [|"«" ++ show $(varE p) ++ "»"|]
      | Bool
otherwise = [|"«polymorphic»"|]

defineMatchAction :: MakeMockableOptions -> [Method] -> Q Dec
defineMatchAction :: MakeMockableOptions -> [Method] -> Q Dec
defineMatchAction MakeMockableOptions
options [Method]
methods =
  forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'matchAction (MakeMockableOptions -> Method -> Q Clause
matchActionClause MakeMockableOptions
options forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Method]
methods)

matchActionClause :: MakeMockableOptions -> Method -> Q Clause
matchActionClause :: MakeMockableOptions -> Method -> Q Clause
matchActionClause MakeMockableOptions
options Method
method = do
  [(Name, Name)]
argVars <-
    forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM
      (forall (t :: * -> *) a. Foldable t => t a -> Int
length (Method -> Cxt
methodArgs Method
method))
      ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => String -> m Name
newName String
"p" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). Quote m => String -> m Name
newName String
"a")
  Name
mmVar <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"mismatches"
  forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
    [ forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP
        (MakeMockableOptions -> Method -> Name
getMatcherName MakeMockableOptions
options Method
method)
        (forall (m :: * -> *). Quote m => Name -> m Pat
varP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Name)]
argVars),
      forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (MakeMockableOptions -> Method -> Name
getActionName MakeMockableOptions
options Method
method) (forall (m :: * -> *). Quote m => Name -> m Pat
varP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Name)]
argVars)
    ]
    ( forall (m :: * -> *). Quote m => [m (Guard, Exp)] -> m Body
guardedB
        [ (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => m Exp -> m Guard
normalG [|null $(varE mmVar)|] forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [|Match|],
          (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => m Exp -> m Guard
normalG [|otherwise|] forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [|NoMatch $(varE mmVar)|]
        ]
    )
    [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD
        (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
mmVar)
        ( forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
            [|
              catMaybes $
                zipWith
                  (fmap . (,))
                  [1 ..]
                  $(listE (mkAccept <$> argVars))
              |]
        )
        []
    ]
  where
    mkAccept :: (Name, Name) -> m Exp
mkAccept (Name
p, Name
a) =
      [|
        if accept $(return (VarE p)) $(return (VarE a))
          then Nothing
          else Just $ explain $(return (VarE p)) $(return (VarE a))
        |]

defineExpectableActions :: MakeMockableOptions -> Instance -> Q [Dec]
defineExpectableActions :: MakeMockableOptions -> Instance -> Q [Dec]
defineExpectableActions MakeMockableOptions
options Instance
inst =
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MakeMockableOptions -> Instance -> Method -> Q Dec
defineExpectableAction MakeMockableOptions
options Instance
inst) (Instance -> [Method]
instMethods Instance
inst)

type ComplexExpectableMessage name =
  ( 'Text "Method " ':<>: 'Text name
      ':<>: 'Text " is too complex to expect with an Action."
  )
    ':$$: 'Text "Suggested fix: Use a Matcher instead of an Action."

defineExpectableAction :: MakeMockableOptions -> Instance -> Method -> Q Dec
defineExpectableAction :: MakeMockableOptions -> Instance -> Method -> Q Dec
defineExpectableAction MakeMockableOptions
options Instance
inst Method
method = do
  Maybe Cxt
maybeCxt <- Cxt -> Q (Maybe Cxt)
wholeCxt (Method -> Cxt
methodArgs Method
method)
  [Name]
argVars <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length (Method -> Cxt
methodArgs Method
method)) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"a")
  case Maybe Cxt
maybeCxt of
    Just Cxt
cx -> do
      forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
        (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Method -> Cxt
methodCxt Method
method forall a. [a] -> [a] -> [a]
++ Cxt
cx))
        ( forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT
            (Instance -> Method -> Q Type -> Q Type
withMethodParams Instance
inst Method
method [t|Expectable|])
            (Instance -> Method -> Q Type -> Q Type
withMethodParams Instance
inst Method
method [t|Action|])
        )
        [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
            'toRule
            [ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (MakeMockableOptions -> Method -> Name
getActionName MakeMockableOptions
options Method
method) (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
argVars)]
                ( forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$
                    let matcherCon :: Q Exp
matcherCon = forall (m :: * -> *). Quote m => Name -> m Exp
conE (MakeMockableOptions -> Method -> Name
getMatcherName MakeMockableOptions
options Method
method)
                     in forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'toRule) (forall {m :: * -> *}. Quote m => [Name] -> m Exp -> m Exp
makeBody [Name]
argVars Q Exp
matcherCon)
                )
                []
            ]
        ]
    Maybe Cxt
_ -> do
      Extension -> Q ()
checkExt Extension
UndecidableInstances
      forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
        ( (forall a. a -> [a] -> [a]
: [])
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|
              TypeError
                ( ComplexExpectableMessage
                    $(litT $ strTyLit $ nameBase $ methodName method)
                )
              |]
        )
        ( forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT
            (Instance -> Method -> Q Type -> Q Type
withMethodParams Instance
inst Method
method [t|Expectable|])
            (Instance -> Method -> Q Type -> Q Type
withMethodParams Instance
inst Method
method [t|Action|])
        )
        [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
            'toRule
            [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|undefined|]) []]
        ]
  where
    makeBody :: [Name] -> m Exp -> m Exp
makeBody [] m Exp
e = m Exp
e
    makeBody (Name
v : [Name]
vs) m Exp
e = [Name] -> m Exp -> m Exp
makeBody [Name]
vs [|$e (eq $(varE v))|]

    wholeCxt :: [Type] -> Q (Maybe Cxt)
    wholeCxt :: Cxt -> Q (Maybe Cxt)
wholeCxt (Type
ty : Cxt
ts) = do
      Maybe Cxt
thisCxt <- Type -> Q (Maybe Cxt)
argCxt Type
ty
      Maybe Cxt
otherCxt <- Cxt -> Q (Maybe Cxt)
wholeCxt Cxt
ts
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a] -> [a]
(++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Cxt
thisCxt forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Cxt
otherCxt)
    wholeCxt [] = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just [])

    argCxt :: Type -> Q (Maybe Cxt)
    argCxt :: Type -> Q (Maybe Cxt)
argCxt Type
argTy
      | Bool -> Bool
not (Method -> Type -> Bool
isKnownType Method
method Type
argTy) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      | Bool
otherwise =
        Cxt -> Q (Maybe Cxt)
simplifyContext [Type -> Type -> Type
AppT (Name -> Type
ConT ''Eq) Type
argTy, Type -> Type -> Type
AppT (Name -> Type
ConT ''Show) Type
argTy]

deriveForMockT :: MakeMockableOptions -> Type -> Q [Dec]
deriveForMockT :: MakeMockableOptions -> Type -> Q [Dec]
deriveForMockT MakeMockableOptions
options Type
ty = do
  Instance
inst <- MakeMockableOptions -> Type -> Q Instance
getInstance MakeMockableOptions
options {mockVerbose :: Bool
mockVerbose = Bool
False} Type
ty
  Bool
needsMockT <-
    if MakeMockableOptions -> Bool
mockDeriveForMockT MakeMockableOptions
options
      then
        forall a. Maybe a -> Bool
isNothing
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q (Maybe Cxt)
resolveInstanceType
            ( Type -> Type -> Type
AppT
                (Instance -> Type
instType Instance
inst)
                (Type -> Type -> Type
AppT (Name -> Type
ConT ''MockT) (Name -> Type
VarT (Instance -> Name
instMonadVar Instance
inst)))
            )
      else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

  if Bool
needsMockT
    then do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Instance -> [Dec]
instExtraMembers Instance
inst)) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
          String
"Cannot derive MockT because " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint (Instance -> Type
instType Instance
inst)
            forall a. [a] -> [a] -> [a]
++ String
" has unmockable methods."

      Name
m <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"m"
      let decs :: [Q Dec]
decs = forall a b. (a -> b) -> [a] -> [b]
map (MakeMockableOptions -> Method -> Q Dec
implementMethod MakeMockableOptions
options) (Instance -> [Method]
instMethods Instance
inst)

      let cx :: Cxt
cx =
            Instance -> Cxt
instRequiredContext Instance
inst
              forall a. Eq a => [a] -> [a] -> [a]
\\ [ Type -> Type -> Type
AppT (Name -> Type
ConT ''Typeable) (Name -> Type
VarT (Instance -> Name
instMonadVar Instance
inst)),
                   Type -> Type -> Type
AppT (Name -> Type
ConT ''Functor) (Name -> Type
VarT (Instance -> Name
instMonadVar Instance
inst)),
                   Type -> Type -> Type
AppT (Name -> Type
ConT ''Applicative) (Name -> Type
VarT (Instance -> Name
instMonadVar Instance
inst)),
                   Type -> Type -> Type
AppT (Name -> Type
ConT ''Monad) (Name -> Type
VarT (Instance -> Name
instMonadVar Instance
inst)),
                   Type -> Type -> Type
AppT (Name -> Type
ConT ''MonadIO) (Name -> Type
VarT (Instance -> Name
instMonadVar Instance
inst))
                 ]

      let mockTConstraints :: Cxt
mockTConstraints =
            Name -> Type -> Type -> Type
substTypeVar
              (Instance -> Name
instMonadVar Instance
inst)
              (Type -> Type -> Type
AppT (Name -> Type
ConT ''MockT) (Name -> Type
VarT Name
m))
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt
cx
      Cxt -> Q (Maybe Cxt)
simplifyContext Cxt
mockTConstraints
        forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just Cxt
cxMockT ->
            (forall a. a -> [a] -> [a]
: [])
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
                ( forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
                      [ forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
cxMockT,
                        [Q Type] -> [Name] -> CxtQ
constrainVars [[t|Typeable|]] (Instance -> [Name]
instGeneralParams Instance
inst),
                        [Q Type] -> [Name] -> CxtQ
constrainVars [[t|Typeable|], [t|MonadIO|]] [Name
m]
                      ]
                )
                [t|$(pure (instType inst)) (MockT $(varT m))|]
                [Q Dec]
decs
          Maybe Cxt
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Missing MockT instance for a superclass."
    else forall (m :: * -> *) a. Monad m => a -> m a
return []

implementMethod :: MakeMockableOptions -> Method -> Q Dec
implementMethod :: MakeMockableOptions -> Method -> Q Dec
implementMethod MakeMockableOptions
options Method
method = do
  [Name]
argVars <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length (Method -> Cxt
methodArgs Method
method)) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"a")
  forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
    (Method -> Name
methodName Method
method)
    [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause (forall (m :: * -> *). Quote m => Name -> m Pat
varP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
argVars) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ([Name] -> Q Exp
body [Name]
argVars)) []]
  where
    actionExp :: [Name] -> m Exp -> m Exp
actionExp [] m Exp
e = m Exp
e
    actionExp (Name
v : [Name]
vs) m Exp
e = [Name] -> m Exp -> m Exp
actionExp [Name]
vs [|$e $(varE v)|]

    body :: [Name] -> Q Exp
body [Name]
argVars = do
      Maybe Cxt
defaultCxt <- Cxt -> Q (Maybe Cxt)
simplifyContext [Type -> Type -> Type
AppT (Name -> Type
ConT ''Default) (Method -> Type
methodResult Method
method)]
      let someMockMethod :: Q Exp
someMockMethod = case Maybe Cxt
defaultCxt of
            Just [] -> [|mockMethod|]
            Maybe Cxt
_ -> [|mockDefaultlessMethod|]
      [|
        $someMockMethod
          $(actionExp argVars (conE (getActionName options method)))
        |]

checkExt :: Extension -> Q ()
checkExt :: Extension -> Q ()
checkExt Extension
e = do
  Bool
enabled <- Extension -> Q Bool
isExtEnabled Extension
e
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
enabled forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Please enable " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Extension
e forall a. [a] -> [a] -> [a]
++ String
" to generate this mock."

internalError :: HasCallStack => Q a
internalError :: forall a. HasCallStack => Q a
internalError = forall a. HasCallStack => String -> a
error String
"Internal error in HMock.  Please report this as a bug."