{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# 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.  If this
    -- is 'False', you are responsible for providing a 'Mockable' instance.
    -- 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 :: Bool -> Bool -> String -> Bool -> MakeMockableOptions
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 MakeMockableOptions
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
(Int -> Instance -> ShowS)
-> (Instance -> String) -> ([Instance] -> ShowS) -> Show Instance
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
(Int -> Method -> ShowS)
-> (Method -> String) -> ([Method] -> ShowS) -> Show Method
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 :: 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
_ -> String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
"Expected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
cls String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" to be a class, but it wasn't."
    Maybe Name
_ -> String -> Q a
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 = Type -> (Dec -> Q Instance) -> Q Instance
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]
_) =
      String -> Q Instance
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Instance) -> String -> Q Instance
forall a b. (a -> b) -> a -> b
$ String
"Class " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
className String -> ShowS
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 [] (TyVarBndr -> Name
tvName (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
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
_ [] = Q Instance
forall a. HasCallStack => Q a
internalError
        matchVars (AppT Type
_ Type
_) Cxt
_ [Name
_] =
          String -> Q Instance
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Instance) -> String -> Q Instance
forall a b. (a -> b) -> a -> b
$ Type -> String
forall a. Ppr a => a -> String
pprint Type
ty String -> ShowS
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 Q () -> Q Instance -> Q Instance
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Cxt -> [Name] -> Q Instance
matchVars Type
a (Type
b Type -> Cxt -> Cxt
forall a. a -> [a] -> [a]
: Cxt
ts) [Name]
ps
        matchVars Type
_ Cxt
ts [Name]
ps = do
          let genVars :: [Name]
genVars = [Name] -> [Name]
forall a. [a] -> [a]
init [Name]
ps
          let mVar :: Name
mVar = [Name] -> Name
forall a. [a] -> a
last [Name]
ps
          let t :: Type
t = (Type -> Name -> Type) -> Type -> [Name] -> Type
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 = [Name] -> Cxt -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip (TyVarBndr -> Name
tvName (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
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 (Type -> Type) -> Cxt -> Cxt
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
_ = Q Instance
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 <- (Dec -> Q (Either [String] Method))
-> [Dec] -> Q [Either [String] Method]
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) [Dec]
members
  ([Dec]
extraMembers, [Method]
methods) <-
    [Either Dec Method] -> ([Dec], [Method])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either Dec Method] -> ([Dec], [Method]))
-> Q [Either Dec Method] -> Q ([Dec], [Method])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Dec -> Either [String] Method -> Q (Either Dec Method))
-> [Dec] -> [Either [String] Method] -> Q [Either Dec Method]
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
  Instance -> Q Instance
forall (m :: * -> *) a. Monad m => a -> m a
return (Instance -> Q Instance) -> Instance -> Q Instance
forall a b. (a -> b) -> a -> b
$
    Instance :: Type -> Cxt -> [Name] -> Name -> [Method] -> [Dec] -> Instance
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
    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
      Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MakeMockableOptions -> Bool
mockVerbose MakeMockableOptions
options) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ (String -> Q ()) -> [String] -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Q ()
reportWarning [String]
warnings
      Either Dec Method -> Q (Either Dec Method)
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Either Dec Method
forall a b. a -> Either a b
Left Dec
dec)
    memberOrMethod Dec
_ (Right Method
method) = Either Dec Method -> Q (Either Dec Method)
forall (m :: * -> *) a. Monad m => a -> m a
return (Method -> Either Dec Method
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
  Either [String] Method -> Q (Either [String] Method)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Method -> Q (Either [String] Method))
-> Either [String] Method -> Q (Either [String] Method)
forall a b. (a -> b) -> a -> b
$ do
    Type
retval <- case Type
mretval of
      AppT (VarT Name
m') Type
retval | Name
m' Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m -> Type -> Either [String] Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
retval
      Type
_ ->
        [String] -> Either [String] Type
forall a b. a -> Either a b
Left
          [ Name -> String
nameBase Name
name
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" can't be mocked: return value not in the expected monad."
          ]
    Bool -> Either [String] () -> Either [String] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
      ( (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all
          (Cxt -> Name -> Bool
isVarTypeable Cxt
cx)
          ((Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
tvs) (Type -> [Name]
freeTypeVars Type
retval))
      )
      (Either [String] () -> Either [String] ())
-> Either [String] () -> Either [String] ()
forall a b. (a -> b) -> a -> b
$ [String] -> Either [String] ()
forall a b. a -> Either a b
Left
        [ Name -> String
nameBase Name
name
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" can't be mocked: return value not Typeable."
        ]
    let argTypes :: Cxt
argTypes = (Type -> Type) -> Cxt -> Cxt
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
    Bool -> Either [String] () -> Either [String] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Type -> Bool
hasNestedPolyType Cxt
argTypes) (Either [String] () -> Either [String] ())
-> Either [String] () -> Either [String] ()
forall a b. (a -> b) -> a -> b
$
      [String] -> Either [String] ()
forall a b. a -> Either a b
Left
        [ Name -> String
nameBase Name
name
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" can't be mocked: rank-n types nested in arguments."
        ]

    Method -> Either [String] Method
forall (m :: * -> *) a. Monad m => a -> m a
return (Method -> Either [String] Method)
-> Method -> Either [String] Method
forall a b. (a -> b) -> a -> b
$
      Method :: Name -> [Name] -> Cxt -> Cxt -> Type -> Method
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) Type -> Cxt -> Bool
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]
_) =
  Either [String] Method -> Q (Either [String] Method)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Method -> Q (Either [String] Method))
-> Either [String] Method -> Q (Either [String] Method)
forall a b. (a -> b) -> a -> b
$
    [String] -> Either [String] Method
forall a b. a -> Either a b
Left [Name -> String
nameBase Name
name String -> ShowS
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]
_) =
  Either [String] Method -> Q (Either [String] Method)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Method -> Q (Either [String] Method))
-> Either [String] Method -> Q (Either [String] Method)
forall a b. (a -> b) -> a -> b
$
    [String] -> Either [String] Method
forall a b. a -> Either a b
Left [Name -> String
nameBase Name
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" must be defined manually in MockT instance."]
getMethod Type
_ Name
_ [(Name, Type)]
_ (TySynD Name
name [TyVarBndr]
_ Type
_) =
  Either [String] Method -> Q (Either [String] Method)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Method -> Q (Either [String] Method))
-> Either [String] Method -> Q (Either [String] Method)
forall a b. (a -> b) -> a -> b
$
    [String] -> Either [String] Method
forall a b. a -> Either a b
Left [Name -> String
nameBase Name
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" must be defined manually in MockT instance."]
getMethod Type
_ Name
_ [(Name, Type)]
_ (DataFamilyD Name
name [TyVarBndr]
_ Maybe Type
_) =
  Either [String] Method -> Q (Either [String] Method)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Method -> Q (Either [String] Method))
-> Either [String] Method -> Q (Either [String] Method)
forall a b. (a -> b) -> a -> b
$
    [String] -> Either [String] Method
forall a b. a -> Either a b
Left [Name -> String
nameBase Name
name String -> ShowS
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
_)) =
  Either [String] Method -> Q (Either [String] Method)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Method -> Q (Either [String] Method))
-> Either [String] Method -> Q (Either [String] Method)
forall a b. (a -> b) -> a -> b
$
    [String] -> Either [String] Method
forall a b. a -> Either a b
Left [Name -> String
nameBase Name
name String -> ShowS
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]
_) =
  Either [String] Method -> Q (Either [String] Method)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Method -> Q (Either [String] Method))
-> Either [String] Method -> Q (Either [String] Method)
forall a b. (a -> b) -> a -> b
$
    [String] -> Either [String] Method
forall a b. a -> Either a b
Left [Name -> String
nameBase Name
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" must be defined manually in MockT instance."]
getMethod Type
_ Name
_ [(Name, Type)]
_ Dec
_ = Either [String] Method -> Q (Either [String] Method)
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> Either [String] Method
forall a b. a -> Either a b
Left [])

isKnownType :: Method -> Type -> Bool
isKnownType :: Method -> Type -> Bool
isKnownType Method
method Type
ty = [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
tyVars Bool -> Bool -> Bool
&& Cxt -> 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

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

  Cxt
typeableCxt <- [Q Type] -> [Name] -> CxtQ
constrainVars [Name -> Q Type
conT ''Typeable] (Instance -> [Name]
instGeneralParams Instance
inst)

  Bool
needsMockableBase <-
    Maybe Cxt -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Cxt -> Bool) -> Q (Maybe Cxt) -> Q Bool
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 <-
          CxtQ -> Q Type -> [DecQ] -> DecQ
instanceD
            (Cxt -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cxt
typeableCxt)
            [t|MockableBase $(pure (instType inst))|]
            [ MakeMockableOptions -> Instance -> DecQ
defineActionType MakeMockableOptions
options Instance
inst,
              MakeMockableOptions -> Instance -> DecQ
defineMatcherType MakeMockableOptions
options Instance
inst,
              MakeMockableOptions -> [Method] -> DecQ
defineShowAction MakeMockableOptions
options (Instance -> [Method]
instMethods Instance
inst),
              MakeMockableOptions -> [Method] -> DecQ
defineShowMatcher MakeMockableOptions
options (Instance -> [Method]
instMethods Instance
inst),
              MakeMockableOptions -> [Method] -> DecQ
defineMatchAction MakeMockableOptions
options (Instance -> [Method]
instMethods Instance
inst)
            ]
        [Dec]
expectables <- MakeMockableOptions -> Instance -> Q [Dec]
defineExpectableActions MakeMockableOptions
options Instance
inst
        [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec
mockableBase Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
expectables)
      else [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []

  Bool
needsMockable <-
    if MakeMockableOptions -> Bool
mockEmptySetup MakeMockableOptions
options
      then Maybe Cxt -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Cxt -> Bool) -> Q (Maybe Cxt) -> Q Bool
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 Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  [Dec]
mockable <-
    if Bool
needsMockable
      then
        (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [])
          (Dec -> [Dec]) -> DecQ -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CxtQ -> Q Type -> [DecQ] -> DecQ
instanceD
            (Cxt -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cxt
typeableCxt)
            [t|Mockable $(pure (instType inst))|]
            []
      else [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []

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

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

defineActionType :: MakeMockableOptions -> Instance -> DecQ
defineActionType :: MakeMockableOptions -> Instance -> DecQ
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 (Method -> ConQ) -> [Method] -> [ConQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Instance -> [Method]
instMethods Instance
inst
  CxtQ
-> Name
-> [Q Type]
-> Maybe Type
-> [ConQ]
-> [DerivClauseQ]
-> DecQ
dataInstD
    (Cxt -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
    ''Action
    [Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instance -> Type
instType Instance
inst)]
    (Type -> Maybe Type
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
  [TyVarBndr] -> CxtQ -> ConQ -> ConQ
forallC [] (Cxt -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Method -> Cxt
methodCxt Method
method)) (ConQ -> ConQ) -> ConQ -> ConQ
forall a b. (a -> b) -> a -> b
$
    [Name] -> [StrictTypeQ] -> Q Type -> ConQ
gadtC
      [MakeMockableOptions -> Method -> Name
getActionName MakeMockableOptions
options Method
method]
      [ (Bang, Type) -> StrictTypeQ
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 ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
1 String
name) String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 String
name String -> ShowS
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 -> DecQ
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 (Method -> ConQ) -> [Method] -> [ConQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Instance -> [Method]
instMethods Instance
inst
  CxtQ
-> Name
-> [Q Type]
-> Maybe Type
-> [ConQ]
-> [DerivClauseQ]
-> DecQ
dataInstD
    (Cxt -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
    ''Matcher
    [Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instance -> Type
instType Instance
inst)]
    (Type -> Maybe Type
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
  [Name] -> [StrictTypeQ] -> Q Type -> ConQ
gadtC
    [MakeMockableOptions -> Method -> Name
getMatcherName MakeMockableOptions
options Method
method]
    [ (SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness,) (Type -> (Bang, Type)) -> Q Type -> StrictTypeQ
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 <- String -> Q Name
newName String
"t"
        [TyVarBndr] -> CxtQ -> Q Type -> Q Type
forallT [Name -> TyVarBndr
bindVar Name
v] (Cxt -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) [t|Predicate $(varT v)|]
      | [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
tyVars Bool -> Bool -> Bool
&& Cxt -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
cx = [t|Predicate $(pure argTy)|]
      | Bool
otherwise = do
        Extension -> Q ()
checkExt Extension
RankNTypes
        [TyVarBndr] -> CxtQ -> Q Type -> Q Type
forallT (Name -> TyVarBndr
bindVar (Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
tyVars) (Cxt -> CxtQ
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 ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
1 String
name) String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ MakeMockableOptions -> String
mockSuffix MakeMockableOptions
options String -> ShowS
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] -> DecQ
defineShowAction MakeMockableOptions
options [Method]
methods =
  Name -> [ClauseQ] -> DecQ
funD 'showAction (MakeMockableOptions -> Method -> ClauseQ
showActionClause MakeMockableOptions
options (Method -> ClauseQ) -> [Method] -> [ClauseQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Method]
methods)

showActionClause :: MakeMockableOptions -> Method -> Q Clause
showActionClause :: MakeMockableOptions -> Method -> ClauseQ
showActionClause MakeMockableOptions
options Method
method = do
  [Name]
argVars <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Method -> Cxt
methodArgs Method
method)) (String -> Q Name
newName String
"a")
  [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
    [ Name -> [PatQ] -> PatQ
conP
        (MakeMockableOptions -> Method -> Name
getActionName MakeMockableOptions
options Method
method)
        ((Type -> Name -> PatQ) -> Cxt -> [Name] -> [PatQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> Name -> PatQ
argPattern (Method -> Cxt
methodArgs Method
method) [Name]
argVars)
    ]
    ( ExpQ -> BodyQ
normalB
        [|
          unwords
            ( $(lift (nameBase (methodName method))) :
              $(listE (zipWith showArg (methodArgs method) argVars))
            )
          |]
    )
    []
  where
    isLocalPoly :: Type -> Bool
isLocalPoly Type
ty =
      Bool -> Bool
not (Bool -> Bool) -> (([Name], Cxt) -> Bool) -> ([Name], Cxt) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Name] -> Bool)
-> (([Name], Cxt) -> [Name]) -> ([Name], Cxt) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Name], Cxt) -> [Name]
forall a b. (a, b) -> a
fst (([Name], Cxt) -> Bool) -> ([Name], Cxt) -> Bool
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 = Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      | Type -> Bool
isLocalPoly Type
ty = (Type -> Cxt -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Method -> Cxt
methodCxt Method
method) (Type -> Bool) -> Q Type -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|Show $(pure ty)|]
      | [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Type -> [Name]
freeTypeVars Type
ty) = Name -> Cxt -> Q Bool
isInstance ''Show [Type
ty]
      | Bool
otherwise = Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

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

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

    showArg :: Type -> Name -> ExpQ
showArg Type
ty Name
var = do
      Bool
showable <- Type -> Q Bool
canShow Type
ty
      Bool
typeable <- Type -> Q 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)
_ -> String -> ExpQ
forall t. Lift t => t -> ExpQ
lift (String
"(_  :: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint (Type -> Type
forall a. Data a => a -> a
removeModNames Type
ty) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")")

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

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

    matcherArg :: Name -> Type -> PatQ
matcherArg Name
p Type
ty
      | Method -> Type -> Bool
isKnownType Method
method Type
ty = Name -> PatQ
varP Name
p
      | Bool
otherwise = PatQ
wildP

    printedArg :: Name -> Name -> Type -> ExpQ
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 -> ExpQ
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] -> DecQ
defineMatchAction MakeMockableOptions
options [Method]
methods =
  Name -> [ClauseQ] -> DecQ
funD 'matchAction (MakeMockableOptions -> Method -> ClauseQ
matchActionClause MakeMockableOptions
options (Method -> ClauseQ) -> [Method] -> [ClauseQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Method]
methods)

matchActionClause :: MakeMockableOptions -> Method -> Q Clause
matchActionClause :: MakeMockableOptions -> Method -> ClauseQ
matchActionClause MakeMockableOptions
options Method
method = do
  [(Name, Name)]
argVars <-
    Int -> Q (Name, Name) -> Q [(Name, Name)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM
      (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Method -> Cxt
methodArgs Method
method))
      ((,) (Name -> Name -> (Name, Name))
-> Q Name -> Q (Name -> (Name, Name))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName String
"p" Q (Name -> (Name, Name)) -> Q Name -> Q (Name, Name)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Q Name
newName String
"a")
  Name
mmVar <- String -> Q Name
newName String
"mismatches"
  [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
    [ Name -> [PatQ] -> PatQ
conP
        (MakeMockableOptions -> Method -> Name
getMatcherName MakeMockableOptions
options Method
method)
        (Name -> PatQ
varP (Name -> PatQ) -> ((Name, Name) -> Name) -> (Name, Name) -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Name) -> Name
forall a b. (a, b) -> a
fst ((Name, Name) -> PatQ) -> [(Name, Name)] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Name)]
argVars),
      Name -> [PatQ] -> PatQ
conP (MakeMockableOptions -> Method -> Name
getActionName MakeMockableOptions
options Method
method) (Name -> PatQ
varP (Name -> PatQ) -> ((Name, Name) -> Name) -> (Name, Name) -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Name) -> Name
forall a b. (a, b) -> b
snd ((Name, Name) -> PatQ) -> [(Name, Name)] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Name)]
argVars)
    ]
    ( [Q (Guard, Exp)] -> BodyQ
guardedB
        [ (,) (Guard -> Exp -> (Guard, Exp))
-> Q Guard -> Q (Exp -> (Guard, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExpQ -> Q Guard
normalG [|null $(varE mmVar)|] Q (Exp -> (Guard, Exp)) -> ExpQ -> Q (Guard, Exp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [|Match|],
          (,) (Guard -> Exp -> (Guard, Exp))
-> Q Guard -> Q (Exp -> (Guard, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExpQ -> Q Guard
normalG [|otherwise|] Q (Exp -> (Guard, Exp)) -> ExpQ -> Q (Guard, Exp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [|NoMatch $(varE mmVar)|]
        ]
    )
    [ PatQ -> BodyQ -> [DecQ] -> DecQ
valD
        (Name -> PatQ
varP Name
mmVar)
        ( ExpQ -> BodyQ
normalB
            [|
              catMaybes $
                zipWith
                  (\i mm -> fmap (\x -> (i, x)) mm)
                  [1 ..]
                  $(listE (mkAccept <$> argVars))
              |]
        )
        []
    ]
  where
    mkAccept :: (Name, Name) -> ExpQ
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 =
  (Method -> DecQ) -> [Method] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MakeMockableOptions -> Instance -> Method -> DecQ
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 -> DecQ
defineExpectableAction MakeMockableOptions
options Instance
inst Method
method = do
  Maybe Cxt
maybeCxt <- Cxt -> Q (Maybe Cxt)
wholeCxt (Method -> Cxt
methodArgs Method
method)
  [Name]
argVars <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Method -> Cxt
methodArgs Method
method)) (String -> Q Name
newName String
"a")
  case Maybe Cxt
maybeCxt of
    Just Cxt
cx -> do
      CxtQ -> Q Type -> [DecQ] -> DecQ
instanceD
        (Cxt -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Method -> Cxt
methodCxt Method
method Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Cxt
cx))
        ( Q Type -> Q Type -> Q 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|])
        )
        [ Name -> [ClauseQ] -> DecQ
funD
            'toRule
            [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
                [Name -> [PatQ] -> PatQ
conP (MakeMockableOptions -> Method -> Name
getActionName MakeMockableOptions
options Method
method) ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
argVars)]
                ( ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$
                    let matcherCon :: ExpQ
matcherCon = Name -> ExpQ
conE (MakeMockableOptions -> Method -> Name
getMatcherName MakeMockableOptions
options Method
method)
                     in ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'toRule) ([Name] -> ExpQ -> ExpQ
makeBody [Name]
argVars ExpQ
matcherCon)
                )
                []
            ]
        ]
    Maybe Cxt
_ -> do
      Extension -> Q ()
checkExt Extension
UndecidableInstances
      CxtQ -> Q Type -> [DecQ] -> DecQ
instanceD
        ( (Type -> Cxt -> Cxt
forall a. a -> [a] -> [a]
: [])
            (Type -> Cxt) -> Q Type -> CxtQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|
              TypeError
                ( ComplexExpectableMessage
                    $(litT $ strTyLit $ nameBase $ methodName method)
                )
              |]
        )
        ( Q Type -> Q Type -> Q 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|])
        )
        [ Name -> [ClauseQ] -> DecQ
funD
            'toRule
            [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|undefined|]) []]
        ]
  where
    makeBody :: [Name] -> ExpQ -> ExpQ
makeBody [] ExpQ
e = ExpQ
e
    makeBody (Name
v : [Name]
vs) ExpQ
e = [Name] -> ExpQ -> ExpQ
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
      Maybe Cxt -> Q (Maybe Cxt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
(++) (Cxt -> Cxt -> Cxt) -> Maybe Cxt -> Maybe (Cxt -> Cxt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Cxt
thisCxt Maybe (Cxt -> Cxt) -> Maybe Cxt -> Maybe Cxt
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Cxt
otherCxt)
    wholeCxt [] = Maybe Cxt -> Q (Maybe Cxt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cxt -> Maybe Cxt
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) = Maybe Cxt -> Q (Maybe Cxt)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Cxt
forall a. Maybe a
Nothing
      | VarT Name
v <- Type
argTy =
        Cxt -> Maybe Cxt
forall a. a -> Maybe a
Just (Cxt -> Maybe Cxt) -> CxtQ -> Q (Maybe Cxt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Type] -> CxtQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [[t|Eq $(varT v)|], [t|Show $(varT v)|]]
      | Bool
otherwise = do
        Maybe Cxt
eqCxt <- Name -> Cxt -> Q (Maybe Cxt)
resolveInstance ''Eq [Type
argTy]
        Maybe Cxt
showCxt <- Name -> Cxt -> Q (Maybe Cxt)
resolveInstance ''Show [Type
argTy]
        Maybe Cxt -> Q (Maybe Cxt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
(++) (Cxt -> Cxt -> Cxt) -> Maybe Cxt -> Maybe (Cxt -> Cxt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Cxt
eqCxt Maybe (Cxt -> Cxt) -> Maybe Cxt -> Maybe Cxt
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Cxt
showCxt)

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
        Maybe Cxt -> Bool
forall a. Maybe a -> Bool
isNothing
          (Maybe Cxt -> Bool) -> Q (Maybe Cxt) -> Q Bool
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 Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

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

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

      let cx :: Cxt
cx =
            Instance -> Cxt
instRequiredContext Instance
inst
              Cxt -> Cxt -> Cxt
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))
                 ]

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

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

    body :: [Name] -> ExpQ
body [Name]
argVars = do
      Maybe Cxt
defaultCxt <- Name -> Cxt -> Q (Maybe Cxt)
resolveInstance ''Default [Method -> Type
methodResult Method
method]
      let someMockMethod :: ExpQ
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
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
enabled (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
    String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Please enable " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Extension -> String
forall a. Show a => a -> String
show Extension
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" to generate this mock."

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