{-# LANGUAGE CPP #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}

-- | This module provides Template Haskell splices that can be used to derive
-- boilerplate instances for HMock.
--
-- There are 20 splices described here, based on combinations of four
-- choices:
--
-- * Whether to generate a 'Test.HMock.MockableBase', an instance for
--   'Test.HMock.MockT', or both.
-- * When generating 'Test.HMock.MockableBase', whether to also generate a
--   'Test.HMock.Mockable' instance with an empty setup.
-- * Whether the argument is a class name, or a type which may be partially
--   applied to concrete arguments.
-- * Whether options are passed to customize the behavior.
module Test.HMock.TH
  ( MockableOptions (..),
    makeMockable,
    makeMockableType,
    makeMockableWithOptions,
    makeMockableTypeWithOptions,
    makeMockableBase,
    makeMockableBaseType,
    makeMockableBaseWithOptions,
    makeMockableBaseTypeWithOptions,
    deriveMockable,
    deriveMockableType,
    deriveMockableWithOptions,
    deriveMockableTypeWithOptions,
    deriveMockableBase,
    deriveMockableBaseType,
    deriveMockableBaseWithOptions,
    deriveMockableBaseTypeWithOptions,
    deriveForMockT,
    deriveTypeForMockT,
    deriveForMockTWithOptions,
    deriveTypeForMockTWithOptions,
  )
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.Typeable (Typeable)
import GHC.Stack (HasCallStack)
import GHC.TypeLits (Symbol)
import Language.Haskell.TH hiding (Match, match)
import Language.Haskell.TH.Syntax (Lift (lift))
import Test.HMock.Internal.TH
import Test.HMock.MockT (MockT)
import Test.HMock.MockMethod (mockMethod, mockDefaultlessMethod)
import Test.HMock.Mockable (MatchResult (..), Mockable, MockableBase (..))
import Test.HMock.Predicates (Predicate (..), eq)
import Test.HMock.Rule (Expectable (..))

-- | Custom options for deriving a 'Mockable' class.
data MockableOptions = MockableOptions
  { -- | Suffix to add to 'Action' and 'Matcher' names.  Defaults to @""@.
    MockableOptions -> 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'@.
    MockableOptions -> Bool
mockVerbose :: Bool
  }

instance Default MockableOptions where
  def :: MockableOptions
def = MockableOptions :: String -> Bool -> MockableOptions
MockableOptions {mockSuffix :: String
mockSuffix = String
"", mockVerbose :: Bool
mockVerbose = Bool
False}

-- | Define all instances necessary to use HMock with the given class.
-- Equivalent to both 'deriveMockable' and 'deriveForMockT'.
--
-- If @MyClass@ is a class and @myMethod@ is one of its methods, then
-- @'makeMockable' MyClass@ generates all of the following:
--
-- If @MyClass@ is a class and @myMethod@ is one of its methods, then
-- @'makeMockable' MyClass@ generates everything generated by
-- 'makeMockableBase', as well as a 'Mockable' instance that does no setup.
makeMockable :: Name -> Q [Dec]
makeMockable :: Name -> Q [Dec]
makeMockable = Q Type -> Q [Dec]
makeMockableType (Q Type -> Q [Dec]) -> (Name -> Q Type) -> Name -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Type
conT

-- | Define all instances necessary to use HMock with the given constraint type,
-- which should be a class applied to zero or more type arguments.  Equivalent
-- to both 'deriveMockableType' and 'deriveTypeForMockT'.
--
-- See 'makeMockable' for a list of what is generated by this splice.
makeMockableType :: Q Type -> Q [Dec]
makeMockableType :: Q Type -> Q [Dec]
makeMockableType = MockableOptions -> Q Type -> Q [Dec]
makeMockableTypeWithOptions MockableOptions
forall a. Default a => a
def

-- | Define all instances necessary to use HMock with the given class.  This is
-- like 'makeMockable', but with the ability to specify custom options.
--
-- See 'makeMockable' for a list of what is generated by this splice.
makeMockableWithOptions :: MockableOptions -> Name -> Q [Dec]
makeMockableWithOptions :: MockableOptions -> Name -> Q [Dec]
makeMockableWithOptions MockableOptions
options = MockableOptions -> Q Type -> Q [Dec]
makeMockableTypeWithOptions MockableOptions
options (Q Type -> Q [Dec]) -> (Name -> Q Type) -> Name -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Type
conT

-- | Define all instances necessary to use HMock with the given constraint type,
-- which should be a class applied to zero or more type arguments.  This is
-- like 'makeMockableType', but with the ability to specify custom options.
--
-- See 'makeMockable' for a list of what is generated by this splice.
makeMockableTypeWithOptions :: MockableOptions -> Q Type -> Q [Dec]
makeMockableTypeWithOptions :: MockableOptions -> Q Type -> Q [Dec]
makeMockableTypeWithOptions MockableOptions
options Q Type
qt =
  [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
(++) ([Dec] -> [Dec] -> [Dec]) -> Q [Dec] -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MockableOptions -> Q Type -> Q [Dec]
deriveMockableTypeWithOptions MockableOptions
options Q Type
qt
    Q ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MockableOptions -> Q Type -> Q [Dec]
deriveTypeForMockTWithOptions MockableOptions
options Q Type
qt

-- | Defines almost all instances necessary to use HMock with the given class.
-- Equivalent to both 'deriveMockableBase' and 'deriveForMockT'.
makeMockableBase :: Name -> Q [Dec]
makeMockableBase :: Name -> Q [Dec]
makeMockableBase = Q Type -> Q [Dec]
makeMockableBaseType (Q Type -> Q [Dec]) -> (Name -> Q Type) -> Name -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Type
conT

-- | Defines almost all instances necessary to use HMock with the given
-- constraint type, which should be a class applied to zero or more type
-- arguments.  Equivalent to both 'deriveMockableBaseType' and
-- 'deriveTypeForMockT'.
makeMockableBaseType :: Q Type -> Q [Dec]
makeMockableBaseType :: Q Type -> Q [Dec]
makeMockableBaseType = MockableOptions -> Q Type -> Q [Dec]
makeMockableBaseTypeWithOptions MockableOptions
forall a. Default a => a
def

-- | Defines almost all instances necessary to use HMock with the given class.
-- This is like 'makeMockable', but with the ability to specify custom options.
makeMockableBaseWithOptions :: MockableOptions -> Name -> Q [Dec]
makeMockableBaseWithOptions :: MockableOptions -> Name -> Q [Dec]
makeMockableBaseWithOptions MockableOptions
options =
  MockableOptions -> Q Type -> Q [Dec]
makeMockableBaseTypeWithOptions MockableOptions
options (Q Type -> Q [Dec]) -> (Name -> Q Type) -> Name -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Type
conT

-- | Defines almost all instances necessary to use HMock with the given
-- constraint type, which should be a class applied to zero or more type
-- arguments.  This is like 'makeMockableType', but with the ability to specify
-- custom options.
makeMockableBaseTypeWithOptions :: MockableOptions -> Q Type -> Q [Dec]
makeMockableBaseTypeWithOptions :: MockableOptions -> Q Type -> Q [Dec]
makeMockableBaseTypeWithOptions MockableOptions
options Q Type
qt =
  [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
(++) ([Dec] -> [Dec] -> [Dec]) -> Q [Dec] -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MockableOptions -> Q Type -> Q [Dec]
deriveMockableBaseTypeWithOptions MockableOptions
options Q Type
qt
    Q ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MockableOptions -> Q Type -> Q [Dec]
deriveTypeForMockTWithOptions MockableOptions
options Q Type
qt

-- | Defines the 'Mockable' instance for the given class.
--
-- If @MyClass@ is a class and @myMethod@ is one of its methods, then
-- @'deriveMockable' MyClass@ generates everything generated by
-- 'makeMockableBase', as well as a 'Mockable' instance that does no setup.
deriveMockable :: Name -> Q [Dec]
deriveMockable :: Name -> Q [Dec]
deriveMockable = Q Type -> Q [Dec]
deriveMockableType (Q Type -> Q [Dec]) -> (Name -> Q Type) -> Name -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Type
conT

-- | Defines the 'Mockable' instance for the given constraint type, which should
-- be a class applied to zero or more type arguments.
--
-- See 'deriveMockable' for a list of what is generated by this splice.
deriveMockableType :: Q Type -> Q [Dec]
deriveMockableType :: Q Type -> Q [Dec]
deriveMockableType = MockableOptions -> Q Type -> Q [Dec]
deriveMockableTypeWithOptions MockableOptions
forall a. Default a => a
def

-- | Defines the 'Mockable' instance for the given class.  This is like
-- 'deriveMockable', but with the ability to specify custom options.
--
-- See 'deriveMockable' for a list of what is generated by this splice.
deriveMockableWithOptions :: MockableOptions -> Name -> Q [Dec]
deriveMockableWithOptions :: MockableOptions -> Name -> Q [Dec]
deriveMockableWithOptions MockableOptions
options = MockableOptions -> Q Type -> Q [Dec]
deriveMockableTypeWithOptions MockableOptions
options (Q Type -> Q [Dec]) -> (Name -> Q Type) -> Name -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Type
conT

-- | Defines the 'Mockable' instance for the given constraint type, which should
-- be a class applied to zero or more type arguments.  This is like
-- 'deriveMockableType', but with the ability to specify custom options.
--
-- See 'deriveMockable' for a list of what is generated by this splice.
deriveMockableTypeWithOptions :: MockableOptions -> Q Type -> Q [Dec]
deriveMockableTypeWithOptions :: MockableOptions -> Q Type -> Q [Dec]
deriveMockableTypeWithOptions = Bool -> MockableOptions -> Q Type -> Q [Dec]
deriveMockableImpl Bool
False

-- | Defines the 'MockableBase' instance for the given class.
--
-- If @MyClass@ is a class and @myMethod@ is one of its methods, then
-- @'deriveMockableBase' MyClass@ generates all of the following:
--
-- * A @'MockableBase' MyClass@ instance.
-- * An associated type @'Action' MyClass@, with a constructor @MyMethod@.
-- * An associated type @'Matcher' MyClass@, with a constructor @MyMethod_@.
-- * An 'Expectable' instance for @'Action' MyClass@ which matches an exact set
--   of arguments, if and only if all of @myMethod@'s arguments have 'Eq' and
--   'Show' instances.
deriveMockableBase :: Name -> Q [Dec]
deriveMockableBase :: Name -> Q [Dec]
deriveMockableBase = Q Type -> Q [Dec]
deriveMockableBaseType (Q Type -> Q [Dec]) -> (Name -> Q Type) -> Name -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Type
conT

-- | Defines the 'MockableBase' instance for the given constraint type, which
-- should be a class applied to zero or more type arguments.
--
-- See 'deriveMockableBase' for a list of what is generated by this splice.
deriveMockableBaseType :: Q Type -> Q [Dec]
deriveMockableBaseType :: Q Type -> Q [Dec]
deriveMockableBaseType = MockableOptions -> Q Type -> Q [Dec]
deriveMockableBaseTypeWithOptions MockableOptions
forall a. Default a => a
def

-- | Defines the 'MockableBase' instance for the given class.  This is like
-- 'deriveMockableBase', but with the ability to specify custom options.
--
-- See 'deriveMockableBase' for a list of what is generated by this splice.
deriveMockableBaseWithOptions :: MockableOptions -> Name -> Q [Dec]
deriveMockableBaseWithOptions :: MockableOptions -> Name -> Q [Dec]
deriveMockableBaseWithOptions MockableOptions
options =
  MockableOptions -> Q Type -> Q [Dec]
deriveMockableBaseTypeWithOptions MockableOptions
options (Q Type -> Q [Dec]) -> (Name -> Q Type) -> Name -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Type
conT

-- | Defines the 'MockableBase' instance for the given constraint type, which
-- should be a class applied to zero or more type arguments.  This is like
-- 'deriveMockableBaseType', but with the ability to specify custom options.
--
-- See 'deriveMockableBase' for a list of what is generated by this splice.
deriveMockableBaseTypeWithOptions :: MockableOptions -> Q Type -> Q [Dec]
deriveMockableBaseTypeWithOptions :: MockableOptions -> Q Type -> Q [Dec]
deriveMockableBaseTypeWithOptions = Bool -> MockableOptions -> Q Type -> Q [Dec]
deriveMockableImpl Bool
True

-- | Defines an instance of the given class for @'MockT' m@, delegating all of
-- its methods to 'mockMethod' to be handled by HMock.
--
-- This may only be used if all members of the class are mockable methods.  If
-- the class contains some unmockable methods, associated types, or other
-- members, you will need to define this instance yourself, delegating the
-- mockable methods as follows:
--
-- @
-- instance MyClass ('MockT' m) where
--   myMethod x y = 'mockMethod' (MyMethod x y)
--   ...
-- @
deriveForMockT :: Name -> Q [Dec]
deriveForMockT :: Name -> Q [Dec]
deriveForMockT = Q Type -> Q [Dec]
deriveTypeForMockT (Q Type -> Q [Dec]) -> (Name -> Q Type) -> Name -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Type
conT

-- | Defines an instance of the given constraint type for @'MockT' m@,
-- delegating all of its methods to 'mockMethod' to be handled by HMock.
-- The type should be a class applied to zero or more type arguments.
--
-- See 'deriveForMockT' for restrictions on the use of this splice.
deriveTypeForMockT :: Q Type -> Q [Dec]
deriveTypeForMockT :: Q Type -> Q [Dec]
deriveTypeForMockT = MockableOptions -> Q Type -> Q [Dec]
deriveTypeForMockTWithOptions MockableOptions
forall a. Default a => a
def

-- | Defines an instance of the given class for @'MockT' m@, delegating all of
-- its methods to 'mockMethod' to be handled by HMock.  This is like
-- 'deriveForMockT', but with the ability to specify custom options.
--
-- See 'deriveForMockT' for restrictions on the use of this splice.
deriveForMockTWithOptions :: MockableOptions -> Name -> Q [Dec]
deriveForMockTWithOptions :: MockableOptions -> Name -> Q [Dec]
deriveForMockTWithOptions MockableOptions
options = MockableOptions -> Q Type -> Q [Dec]
deriveTypeForMockTWithOptions MockableOptions
options (Q Type -> Q [Dec]) -> (Name -> Q Type) -> Name -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Type
conT

-- | Defines an instance of the given constraint type for @'MockT' m@,
-- delegating all of its methods to 'mockMethod' to be handled by HMock.
-- The type should be a class applied to zero or more type arguments.  This is
-- like 'deriveTypeForMockT', but with the ability to specify custom options.
--
-- See 'deriveForMockT' for restrictions on the use of this splice.
deriveTypeForMockTWithOptions :: MockableOptions -> Q Type -> Q [Dec]
deriveTypeForMockTWithOptions :: MockableOptions -> Q Type -> Q [Dec]
deriveTypeForMockTWithOptions = MockableOptions -> Q Type -> Q [Dec]
deriveForMockTImpl

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 :: MockableOptions -> Type -> Q Instance
getInstance :: MockableOptions -> Type -> Q Instance
getInstance MockableOptions
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 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] -> [Name]
forall a. [a] -> [a]
init [Name]
ps)
          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
          MockableOptions
-> Type
-> Cxt
-> [(Name, Type)]
-> [Name]
-> Name
-> [Dec]
-> Q Instance
makeInstance MockableOptions
options Type
t Cxt
cx' [(Name, Type)]
tbl ([Name] -> [Name]
forall a. [a] -> [a]
init [Name]
ps) ([Name] -> Name
forall a. [a] -> a
last [Name]
ps) [Dec]
members
    go Dec
_ = Q Instance
forall a. HasCallStack => Q a
internalError

makeInstance ::
  MockableOptions ->
  Type ->
  Cxt ->
  [(Name, Type)] ->
  [Name] ->
  Name ->
  [Dec] ->
  Q Instance
makeInstance :: MockableOptions
-> Type
-> Cxt
-> [(Name, Type)]
-> [Name]
-> Name
-> [Dec]
-> Q Instance
makeInstance MockableOptions
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
warning) = do
      Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MockableOptions -> Bool
mockVerbose MockableOptions
options) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
reportWarning String
warning
      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)
  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
    let ([Name]
tvs, Cxt
cx, Cxt
argsAndReturn) = Type -> ([Name], Cxt, Cxt)
splitType Type
simpleTy
    (Name
m', Type
result) <- case Cxt -> Type
forall a. [a] -> a
last Cxt
argsAndReturn of
      AppT (VarT Name
m') Type
result -> (Name, Type) -> Either String (Name, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
m', Type
result)
      Type
_ ->
        String -> Either String (Name, Type)
forall a b. a -> Either a b
Left (String -> Either String (Name, Type))
-> String -> Either String (Name, Type)
forall a b. (a -> b) -> a -> b
$
          Name -> String
nameBase Name
name
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" can't be mocked: non-monadic result."
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
m' Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
m) (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 (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
        Name -> String
nameBase Name
name
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" can't be mocked: return value in wrong monad."
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Type -> ([Name], Cxt) -> ([Name], Cxt)
relevantContext Type
result ([Name]
tvs, Cxt
cx) ([Name], Cxt) -> ([Name], Cxt) -> Bool
forall a. Eq a => a -> a -> Bool
/= ([], [])) (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 (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
        Name -> String
nameBase Name
name
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" can't be mocked: polymorphic return value."
    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 -> Cxt
forall a. [a] -> [a]
init Cxt
argsAndReturn)
    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 (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
        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
result
        }
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 String
"A non-value member cannot be mocked.")

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))
    |]

deriveMockableImpl :: Bool -> MockableOptions -> Q Type -> Q [Dec]
deriveMockableImpl :: Bool -> MockableOptions -> Q Type -> Q [Dec]
deriveMockableImpl Bool
baseOnly MockableOptions
options Q Type
qt = 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
TypeFamilies

  Instance
inst <- MockableOptions -> Type -> Q Instance
getInstance MockableOptions
options (Type -> Q Instance) -> Q Type -> Q Instance
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q Type
qt

  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
typeableCxts <- [Q Type] -> [Name] -> CxtQ
constrainVars [Name -> Q Type
conT ''Typeable] (Instance -> [Name]
instGeneralParams Instance
inst)

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

  [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]
expectables

defineActionType :: MockableOptions -> Instance -> DecQ
defineActionType :: MockableOptions -> Instance -> DecQ
defineActionType MockableOptions
options Instance
inst = do
  Type
kind <-
    [t|
      Symbol ->
      (Data.Kind.Type -> Data.Kind.Type) ->
      Data.Kind.Type ->
      Data.Kind.Type
      |]
  let cons :: [ConQ]
cons = MockableOptions -> Instance -> Method -> ConQ
actionConstructor MockableOptions
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 :: MockableOptions -> Instance -> Method -> ConQ
actionConstructor :: MockableOptions -> Instance -> Method -> ConQ
actionConstructor MockableOptions
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
      [MockableOptions -> Method -> Name
getActionName MockableOptions
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 :: MockableOptions -> Method -> Name
getActionName :: MockableOptions -> Method -> Name
getActionName MockableOptions
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]
++ MockableOptions -> String
mockSuffix MockableOptions
options)
  where
    name :: String
name = Name -> String
nameBase (Method -> Name
methodName Method
method)

defineMatcherType :: MockableOptions -> Instance -> Q Dec
defineMatcherType :: MockableOptions -> Instance -> DecQ
defineMatcherType MockableOptions
options Instance
inst = do
  Type
kind <-
    [t|
      Symbol ->
      (Data.Kind.Type -> Data.Kind.Type) ->
      Data.Kind.Type ->
      Data.Kind.Type
      |]
  let cons :: [ConQ]
cons = MockableOptions -> Instance -> Method -> ConQ
matcherConstructor MockableOptions
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 :: MockableOptions -> Instance -> Method -> ConQ
matcherConstructor :: MockableOptions -> Instance -> Method -> ConQ
matcherConstructor MockableOptions
options Instance
inst Method
method = do
  [Name] -> [StrictTypeQ] -> Q Type -> ConQ
gadtC
    [MockableOptions -> Method -> Name
getMatcherName MockableOptions
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 :: MockableOptions -> Method -> Name
getMatcherName :: MockableOptions -> Method -> Name
getMatcherName MockableOptions
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]
++ MockableOptions -> String
mockSuffix MockableOptions
options String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_")
  where
    name :: String
name = Name -> String
nameBase (Method -> Name
methodName Method
method)

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

showActionClause :: MockableOptions -> Method -> Q Clause
showActionClause :: MockableOptions -> Method -> ClauseQ
showActionClause MockableOptions
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
        (MockableOptions -> Method -> Name
getActionName MockableOptions
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
    canShow :: Type -> Q Bool
canShow Type
ty
      | Bool -> Bool
not ([Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Type -> [Name]
freeTypeVars Type
ty)) = Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      | Bool
otherwise = Name -> Cxt -> Q Bool
isInstance ''Show [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 -> 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 =
      Type -> Q Bool
canShow Type
ty
        Q Bool -> (Bool -> ExpQ) -> ExpQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExpQ -> ExpQ -> Bool -> ExpQ
forall a. a -> a -> Bool -> a
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
")"))
          [|showsPrec 11 $(varE var) ""|]

defineShowMatcher :: MockableOptions -> [Method] -> Q Dec
defineShowMatcher :: MockableOptions -> [Method] -> DecQ
defineShowMatcher MockableOptions
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 (MockableOptions -> Method -> Q [ClauseQ]
showMatcherClauses MockableOptions
options) [Method]
methods
  Name -> [ClauseQ] -> DecQ
funD 'showMatcher [ClauseQ]
clauses

showMatcherClauses :: MockableOptions -> Method -> Q [ClauseQ]
showMatcherClauses :: MockableOptions -> Method -> Q [ClauseQ]
showMatcherClauses MockableOptions
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 (MockableOptions -> Method -> Name
getActionName MockableOptions
options Method
method) [PatQ]
actionArgs],
          Name -> [PatQ] -> PatQ
conP (MockableOptions -> Method -> Name
getMatcherName MockableOptions
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 (MockableOptions -> Method -> Name
getMatcherName MockableOptions
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 = Extension -> Q ()
checkExt Extension
ScopedTypeVariables Q () -> PatQ -> PatQ
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 :: MockableOptions -> [Method] -> Q Dec
defineMatchAction :: MockableOptions -> [Method] -> DecQ
defineMatchAction MockableOptions
options [Method]
methods =
  Name -> [ClauseQ] -> DecQ
funD 'matchAction (MockableOptions -> Method -> ClauseQ
matchActionClause MockableOptions
options (Method -> ClauseQ) -> [Method] -> [ClauseQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Method]
methods)

matchActionClause :: MockableOptions -> Method -> Q Clause
matchActionClause :: MockableOptions -> Method -> ClauseQ
matchActionClause MockableOptions
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
        (MockableOptions -> Method -> Name
getMatcherName MockableOptions
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 (MockableOptions -> Method -> Name
getActionName MockableOptions
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 [|$(varE mmVar) == 0|] 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 [|length (filter not $(listE (mkAccept <$> argVars)))|])
        []
    ]
  where
    mkAccept :: (Name, Name) -> ExpQ
mkAccept (Name
p, Name
a) = [|accept $(return (VarE p)) $(return (VarE a))|]

defineExpectableActions :: MockableOptions -> Instance -> Q [Dec]
defineExpectableActions :: MockableOptions -> Instance -> Q [Dec]
defineExpectableActions MockableOptions
options Instance
inst =
  (Method -> Q [Dec]) -> [Method] -> Q [Dec]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (MockableOptions -> Instance -> Method -> Q [Dec]
defineExpectableAction MockableOptions
options Instance
inst) (Instance -> [Method]
instMethods Instance
inst)

defineExpectableAction :: MockableOptions -> Instance -> Method -> Q [Dec]
defineExpectableAction :: MockableOptions -> Instance -> Method -> Q [Dec]
defineExpectableAction MockableOptions
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
      (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 (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 (MockableOptions -> Method -> Name
getActionName MockableOptions
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 (MockableOptions -> Method -> Name
getMatcherName MockableOptions
options Method
method)
                       in ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'toRule) ([Name] -> ExpQ -> ExpQ
makeBody [Name]
argVars ExpQ
matcherCon)
                  )
                  []
              ]
          ]
    Maybe Cxt
_ -> [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  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 -> Type -> Q (Maybe Cxt)
resolveInstance ''Eq Type
argTy
        Maybe Cxt
showCxt <- Name -> Type -> 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)

deriveForMockTImpl :: MockableOptions -> Q Type -> Q [Dec]
deriveForMockTImpl :: MockableOptions -> Q Type -> Q [Dec]
deriveForMockTImpl MockableOptions
options Q Type
qt = do
  Instance
inst <- MockableOptions -> Type -> Q Instance
getInstance MockableOptions
options (Type -> Q Instance) -> Q Type -> Q Instance
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q Type
qt

  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 (MockableOptions -> Method -> DecQ
implementMethod MockableOptions
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."

implementMethod :: MockableOptions -> Method -> Q Dec
implementMethod :: MockableOptions -> Method -> DecQ
implementMethod MockableOptions
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 -> Type -> 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."