{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
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)
data MakeMockableOptions = MakeMockableOptions
{
MakeMockableOptions -> Bool
mockEmptySetup :: Bool,
MakeMockableOptions -> Bool
mockDeriveForMockT :: Bool,
MakeMockableOptions -> String
mockSuffix :: String,
MakeMockableOptions -> Bool
mockVerbose :: Bool
}
instance Default MakeMockableOptions where
def :: MakeMockableOptions
def =
MakeMockableOptions
{ mockEmptySetup :: Bool
mockEmptySetup = Bool
True,
mockDeriveForMockT :: Bool
mockDeriveForMockT = Bool
True,
mockSuffix :: String
mockSuffix = String
"",
mockVerbose :: Bool
mockVerbose = Bool
False
}
makeMockable :: Q Type -> Q [Dec]
makeMockable :: Q Type -> Q [Dec]
makeMockable Q Type
qtype = Q Type -> MakeMockableOptions -> Q [Dec]
makeMockableWithOptions Q Type
qtype forall a. Default a => a
def
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],
:: [Dec]
}
deriving (Int -> Instance -> ShowS
[Instance] -> ShowS
Instance -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Instance] -> ShowS
$cshowList :: [Instance] -> ShowS
show :: Instance -> String
$cshow :: Instance -> String
showsPrec :: Int -> Instance -> ShowS
$cshowsPrec :: Int -> Instance -> ShowS
Show)
data Method = Method
{ Method -> Name
methodName :: Name,
Method -> [Name]
methodTyVars :: [Name],
Method -> Cxt
methodCxt :: Cxt,
Method -> Cxt
methodArgs :: [Type],
Method -> Type
methodResult :: Type
}
deriving (Int -> Method -> ShowS
[Method] -> ShowS
Method -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Method] -> ShowS
$cshowList :: [Method] -> ShowS
show :: Method -> String
$cshow :: Method -> String
showsPrec :: Int -> Method -> ShowS
$cshowsPrec :: Int -> Method -> ShowS
Show)
withClass :: Type -> (Dec -> Q a) -> Q a
withClass :: forall a. Type -> (Dec -> Q a) -> Q a
withClass Type
t Dec -> Q a
f = do
case Type -> Maybe Name
unappliedName Type
t of
Just Name
cls -> do
Info
info <- Name -> Q Info
reify Name
cls
case Info
info of
ClassI dec :: Dec
dec@ClassD {} [Dec]
_ -> Dec -> Q a
f Dec
dec
Info
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Expected " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
cls forall a. [a] -> [a] -> [a]
++ String
" to be a class, but it wasn't."
Maybe Name
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected a class, but got something else."
getInstance :: MakeMockableOptions -> Type -> Q Instance
getInstance :: MakeMockableOptions -> Type -> Q Instance
getInstance MakeMockableOptions
options Type
ty = forall a. Type -> (Dec -> Q a) -> Q a
withClass Type
ty Dec -> Q Instance
go
where
go :: Dec -> Q Instance
go (ClassD Cxt
_ Name
className [] [FunDep]
_ [Dec]
_) =
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Class " forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
className forall a. [a] -> [a] -> [a]
++ String
" has no type parameters."
go (ClassD Cxt
cx Name
_ [TyVarBndr ()]
params [FunDep]
_ [Dec]
members) =
Type -> Cxt -> [Name] -> Q Instance
matchVars Type
ty [] (forall flag. TyVarBndr flag -> Name
tvName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr ()]
params)
where
matchVars :: Type -> [Type] -> [Name] -> Q Instance
matchVars :: Type -> Cxt -> [Name] -> Q Instance
matchVars Type
_ Cxt
_ [] = forall a. HasCallStack => Q a
internalError
matchVars (AppT Type
_ Type
_) Cxt
_ [Name
_] =
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Ppr a => a -> String
pprint Type
ty forall a. [a] -> [a] -> [a]
++ String
" is applied to too many arguments."
matchVars (AppT Type
a Type
b) Cxt
ts (Name
_ : [Name]
ps) =
Extension -> Q ()
checkExt Extension
FlexibleInstances forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Cxt -> [Name] -> Q Instance
matchVars Type
a (Type
b forall a. a -> [a] -> [a]
: Cxt
ts) [Name]
ps
matchVars Type
_ Cxt
ts [Name]
ps = do
let genVars :: [Name]
genVars = forall a. [a] -> [a]
init [Name]
ps
let mVar :: Name
mVar = forall a. [a] -> a
last [Name]
ps
let t :: Type
t = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Type
t' Name
v -> Type -> Type -> Type
AppT Type
t' (Name -> Type
VarT Name
v)) Type
ty [Name]
genVars
let tbl :: [(Name, Type)]
tbl = forall a b. [a] -> [b] -> [(a, b)]
zip (forall flag. TyVarBndr flag -> Name
tvName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr ()]
params) Cxt
ts
let cx' :: Cxt
cx' = [(Name, Type)] -> Type -> Type
substTypeVars [(Name, Type)]
tbl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt
cx
MakeMockableOptions
-> Type
-> Cxt
-> [(Name, Type)]
-> [Name]
-> Name
-> [Dec]
-> Q Instance
makeInstance MakeMockableOptions
options Type
t Cxt
cx' [(Name, Type)]
tbl [Name]
genVars Name
mVar [Dec]
members
go Dec
_ = forall a. HasCallStack => Q a
internalError
makeInstance ::
MakeMockableOptions ->
Type ->
Cxt ->
[(Name, Type)] ->
[Name] ->
Name ->
[Dec] ->
Q Instance
makeInstance :: MakeMockableOptions
-> Type
-> Cxt
-> [(Name, Type)]
-> [Name]
-> Name
-> [Dec]
-> Q Instance
makeInstance MakeMockableOptions
options Type
ty Cxt
cx [(Name, Type)]
tbl [Name]
ps Name
m [Dec]
members = do
[Either [String] Method]
processedMembers <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Name -> [(Name, Type)] -> Dec -> Q (Either [String] Method)
getMethod Type
ty Name
m [(Name, Type)]
tbl) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter Dec -> Bool
isRelevantMember [Dec]
members
([Dec]
extraMembers, [Method]
methods) <-
forall a b. [Either a b] -> ([a], [b])
partitionEithers forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Dec -> Either [String] Method -> Q (Either Dec Method)
memberOrMethod [Dec]
members [Either [String] Method]
processedMembers
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
Instance
{ instType :: Type
instType = Type
ty,
instRequiredContext :: Cxt
instRequiredContext = Cxt
cx,
instGeneralParams :: [Name]
instGeneralParams = [Name]
ps,
instMonadVar :: Name
instMonadVar = Name
m,
instMethods :: [Method]
instMethods = [Method]
methods,
instExtraMembers :: [Dec]
instExtraMembers = [Dec]
extraMembers
}
where
isRelevantMember :: Dec -> Bool
isRelevantMember :: Dec -> Bool
isRelevantMember DefaultSigD {} = Bool
False
isRelevantMember Dec
_ = Bool
True
memberOrMethod :: Dec -> Either [String] Method -> Q (Either Dec Method)
memberOrMethod :: Dec -> Either [String] Method -> Q (Either Dec Method)
memberOrMethod Dec
dec (Left [String]
warnings) = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MakeMockableOptions -> Bool
mockVerbose MakeMockableOptions
options) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Q ()
reportWarning [String]
warnings
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left Dec
dec)
memberOrMethod Dec
_ (Right Method
method) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right Method
method)
getMethod :: Type -> Name -> [(Name, Type)] -> Dec -> Q (Either [String] Method)
getMethod :: Type -> Name -> [(Name, Type)] -> Dec -> Q (Either [String] Method)
getMethod Type
instTy Name
m [(Name, Type)]
tbl (SigD Name
name Type
ty) = do
Type
simpleTy <- Type -> Name -> Type -> Q Type
localizeMember Type
instTy Name
m ([(Name, Type)] -> Type -> Type
substTypeVars [(Name, Type)]
tbl Type
ty)
let ([Name]
tvs, Cxt
cx, Cxt
args, Type
mretval) = Type -> ([Name], Cxt, Cxt, Type)
splitType Type
simpleTy
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
Type
retval <- case Type
mretval of
AppT (VarT Name
m') Type
retval | Name
m' forall a. Eq a => a -> a -> Bool
== Name
m -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
retval
Type
_ ->
forall a b. a -> Either a b
Left
[ Name -> String
nameBase Name
name
forall a. [a] -> [a] -> [a]
++ String
" can't be mocked: return value not in the expected monad."
]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
( forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all
(Cxt -> Name -> Bool
isVarTypeable Cxt
cx)
(forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
tvs) (Type -> [Name]
freeTypeVars Type
retval))
)
forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left
[ Name -> String
nameBase Name
name
forall a. [a] -> [a] -> [a]
++ String
" can't be mocked: return value not Typeable."
]
let argTypes :: Cxt
argTypes = forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type -> Type -> Type
substTypeVar Name
m (Type -> Type -> Type
AppT (Name -> Type
ConT ''MockT) (Name -> Type
VarT Name
m))) Cxt
args
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Type -> Bool
hasNestedPolyType Cxt
argTypes) forall a b. (a -> b) -> a -> b
$
forall a b. a -> Either a b
Left
[ Name -> String
nameBase Name
name
forall a. [a] -> [a] -> [a]
++ String
" can't be mocked: rank-n types nested in arguments."
]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
Method
{ methodName :: Name
methodName = Name
name,
methodTyVars :: [Name]
methodTyVars = [Name]
tvs,
methodCxt :: Cxt
methodCxt = Cxt
cx,
methodArgs :: Cxt
methodArgs = Cxt
argTypes,
methodResult :: Type
methodResult = Type
retval
}
where
isVarTypeable :: Cxt -> Name -> Bool
isVarTypeable :: Cxt -> Name -> Bool
isVarTypeable Cxt
cx Name
v = Type -> Type -> Type
AppT (Name -> Type
ConT ''Typeable) (Name -> Type
VarT Name
v) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Cxt
cx
getMethod Type
_ Name
_ [(Name, Type)]
_ (DataD Cxt
_ Name
name [TyVarBndr ()]
_ Maybe Type
_ [Con]
_ [DerivClause]
_) =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
forall a b. a -> Either a b
Left [Name -> String
nameBase Name
name forall a. [a] -> [a] -> [a]
++ String
" must be defined manually in MockT instance."]
getMethod Type
_ Name
_ [(Name, Type)]
_ (NewtypeD Cxt
_ Name
name [TyVarBndr ()]
_ Maybe Type
_ Con
_ [DerivClause]
_) =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
forall a b. a -> Either a b
Left [Name -> String
nameBase Name
name forall a. [a] -> [a] -> [a]
++ String
" must be defined manually in MockT instance."]
getMethod Type
_ Name
_ [(Name, Type)]
_ (TySynD Name
name [TyVarBndr ()]
_ Type
_) =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
forall a b. a -> Either a b
Left [Name -> String
nameBase Name
name forall a. [a] -> [a] -> [a]
++ String
" must be defined manually in MockT instance."]
getMethod Type
_ Name
_ [(Name, Type)]
_ (DataFamilyD Name
name [TyVarBndr ()]
_ Maybe Type
_) =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
forall a b. a -> Either a b
Left [Name -> String
nameBase Name
name forall a. [a] -> [a] -> [a]
++ String
" must be defined manually in MockT instance."]
getMethod Type
_ Name
_ [(Name, Type)]
_ (OpenTypeFamilyD (TypeFamilyHead Name
name [TyVarBndr ()]
_ FamilyResultSig
_ Maybe InjectivityAnn
_)) =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
forall a b. a -> Either a b
Left [Name -> String
nameBase Name
name forall a. [a] -> [a] -> [a]
++ String
" must be defined manually in MockT instance."]
getMethod Type
_ Name
_ [(Name, Type)]
_ (ClosedTypeFamilyD (TypeFamilyHead Name
name [TyVarBndr ()]
_ FamilyResultSig
_ Maybe InjectivityAnn
_) [TySynEqn]
_) =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
forall a b. a -> Either a b
Left [Name -> String
nameBase Name
name forall a. [a] -> [a] -> [a]
++ String
" must be defined manually in MockT instance."]
getMethod Type
_ Name
_ [(Name, Type)]
_ Dec
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left [])
isKnownType :: Method -> Type -> Bool
isKnownType :: Method -> Type -> Bool
isKnownType Method
method Type
ty = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
tyVars Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
cx
where
([Name]
tyVars, Cxt
cx) =
Type -> ([Name], Cxt) -> ([Name], Cxt)
relevantContext Type
ty (Method -> [Name]
methodTyVars Method
method, Method -> Cxt
methodCxt Method
method)
withMethodParams :: Instance -> Method -> TypeQ -> TypeQ
withMethodParams :: Instance -> Method -> Q Type -> Q Type
withMethodParams Instance
inst Method
method Q Type
t =
[t|
$t
$(pure (instType inst))
$(litT (strTyLit (nameBase (methodName method))))
$(varT (instMonadVar inst))
$(pure (methodResult method))
|]
makeMockableImpl :: MakeMockableOptions -> Q Type -> Q [Dec]
makeMockableImpl :: MakeMockableOptions -> Q Type -> Q [Dec]
makeMockableImpl MakeMockableOptions
options Q Type
qtype = do
Extension -> Q ()
checkExt Extension
DataKinds
Extension -> Q ()
checkExt Extension
FlexibleInstances
Extension -> Q ()
checkExt Extension
GADTs
Extension -> Q ()
checkExt Extension
MultiParamTypeClasses
Extension -> Q ()
checkExt Extension
ScopedTypeVariables
Extension -> Q ()
checkExt Extension
TypeFamilies
Type
ty <- Q Type
qtype
let generalizedTy :: Type
generalizedTy = case Type -> Maybe Name
unappliedName Type
ty of
Just Name
cls -> Name -> Type
ConT Name
cls
Maybe Name
_ -> Type
ty
Instance
inst <- MakeMockableOptions -> Type -> Q Instance
getInstance MakeMockableOptions
options Type
generalizedTy
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Instance -> [Method]
instMethods Instance
inst)) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
String
"Cannot derive Mockable because " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint (Instance -> Type
instType Instance
inst)
forall a. [a] -> [a] -> [a]
++ String
" has no mockable methods."
Cxt
typeableCxt <- [Q Type] -> [Name] -> CxtQ
constrainVars [forall (m :: * -> *). Quote m => Name -> m Type
conT ''Typeable] (Instance -> [Name]
instGeneralParams Instance
inst)
Bool
needsMockableBase <-
forall a. Maybe a -> Bool
isNothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Cxt -> Q (Maybe Cxt)
resolveInstance ''MockableBase [Instance -> Type
instType Instance
inst]
[Dec]
mockableBase <-
if Bool
needsMockableBase
then do
Dec
mockableBase <-
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
(forall (f :: * -> *) a. Applicative f => a -> f a
pure Cxt
typeableCxt)
[t|MockableBase $(pure (instType inst))|]
[ MakeMockableOptions -> Instance -> Q Dec
defineActionType MakeMockableOptions
options Instance
inst,
MakeMockableOptions -> Instance -> Q Dec
defineMatcherType MakeMockableOptions
options Instance
inst,
MakeMockableOptions -> [Method] -> Q Dec
defineShowAction MakeMockableOptions
options (Instance -> [Method]
instMethods Instance
inst),
MakeMockableOptions -> [Method] -> Q Dec
defineShowMatcher MakeMockableOptions
options (Instance -> [Method]
instMethods Instance
inst),
MakeMockableOptions -> [Method] -> Q Dec
defineMatchAction MakeMockableOptions
options (Instance -> [Method]
instMethods Instance
inst)
]
[Dec]
expectables <- MakeMockableOptions -> Instance -> Q [Dec]
defineExpectableActions MakeMockableOptions
options Instance
inst
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec
mockableBase forall a. a -> [a] -> [a]
: [Dec]
expectables)
else forall (m :: * -> *) a. Monad m => a -> m a
return []
Bool
needsMockable <-
if MakeMockableOptions -> Bool
mockEmptySetup MakeMockableOptions
options
then forall a. Maybe a -> Bool
isNothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Cxt -> Q (Maybe Cxt)
resolveInstance ''Mockable [Instance -> Type
instType Instance
inst]
else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
[Dec]
mockable <-
if Bool
needsMockable
then do
Type
t <- [t|Mockable $(pure (instType inst))|]
forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD (forall a. a -> Maybe a
Just Overlap
Overlappable) Cxt
typeableCxt Type
t []]
else forall (m :: * -> *) a. Monad m => a -> m a
return []
[Dec]
mockt <- MakeMockableOptions -> Type -> Q [Dec]
deriveForMockT MakeMockableOptions
options Type
ty
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
mockableBase forall a. [a] -> [a] -> [a]
++ [Dec]
mockable forall a. [a] -> [a] -> [a]
++ [Dec]
mockt
defineActionType :: MakeMockableOptions -> Instance -> DecQ
defineActionType :: MakeMockableOptions -> Instance -> Q Dec
defineActionType MakeMockableOptions
options Instance
inst = do
Type
kind <-
[t|
Symbol ->
(Data.Kind.Type -> Data.Kind.Type) ->
Data.Kind.Type ->
Data.Kind.Type
|]
let cons :: [ConQ]
cons = MakeMockableOptions -> Instance -> Method -> ConQ
actionConstructor MakeMockableOptions
options Instance
inst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Instance -> [Method]
instMethods Instance
inst
forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [m Type]
-> Maybe Type
-> [m Con]
-> [m DerivClause]
-> m Dec
dataInstD
(forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
''Action
[forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instance -> Type
instType Instance
inst)]
(forall a. a -> Maybe a
Just Type
kind)
[ConQ]
cons
[]
actionConstructor :: MakeMockableOptions -> Instance -> Method -> ConQ
actionConstructor :: MakeMockableOptions -> Instance -> Method -> ConQ
actionConstructor MakeMockableOptions
options Instance
inst Method
method = do
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Con -> m Con
forallC [] (forall (m :: * -> *) a. Monad m => a -> m a
return (Method -> Cxt
methodCxt Method
method)) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
Quote m =>
[Name] -> [m StrictType] -> m Type -> m Con
gadtC
[MakeMockableOptions -> Method -> Name
getActionName MakeMockableOptions
options Method
method]
[ forall (m :: * -> *) a. Monad m => a -> m a
return (SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, Type
argTy)
| Type
argTy <- Method -> Cxt
methodArgs Method
method
]
(Instance -> Method -> Q Type -> Q Type
withMethodParams Instance
inst Method
method [t|Action|])
getActionName :: MakeMockableOptions -> Method -> Name
getActionName :: MakeMockableOptions -> Method -> Name
getActionName MakeMockableOptions
options Method
method =
String -> Name
mkName (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (forall a. Int -> [a] -> [a]
take Int
1 String
name) forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
drop Int
1 String
name forall a. [a] -> [a] -> [a]
++ MakeMockableOptions -> String
mockSuffix MakeMockableOptions
options)
where
name :: String
name = Name -> String
nameBase (Method -> Name
methodName Method
method)
defineMatcherType :: MakeMockableOptions -> Instance -> Q Dec
defineMatcherType :: MakeMockableOptions -> Instance -> Q Dec
defineMatcherType MakeMockableOptions
options Instance
inst = do
Type
kind <-
[t|
Symbol ->
(Data.Kind.Type -> Data.Kind.Type) ->
Data.Kind.Type ->
Data.Kind.Type
|]
let cons :: [ConQ]
cons = MakeMockableOptions -> Instance -> Method -> ConQ
matcherConstructor MakeMockableOptions
options Instance
inst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Instance -> [Method]
instMethods Instance
inst
forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [m Type]
-> Maybe Type
-> [m Con]
-> [m DerivClause]
-> m Dec
dataInstD
(forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
''Matcher
[forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instance -> Type
instType Instance
inst)]
(forall a. a -> Maybe a
Just Type
kind)
[ConQ]
cons
[]
matcherConstructor :: MakeMockableOptions -> Instance -> Method -> ConQ
matcherConstructor :: MakeMockableOptions -> Instance -> Method -> ConQ
matcherConstructor MakeMockableOptions
options Instance
inst Method
method = do
forall (m :: * -> *).
Quote m =>
[Name] -> [m StrictType] -> m Type -> m Con
gadtC
[MakeMockableOptions -> Method -> Name
getMatcherName MakeMockableOptions
options Method
method]
[ (SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Type
mkPredicate Type
argTy
| Type
argTy <- Method -> Cxt
methodArgs Method
method
]
(Instance -> Method -> Q Type -> Q Type
withMethodParams Instance
inst Method
method [t|Matcher|])
where
mkPredicate :: Type -> Q Type
mkPredicate Type
argTy
| Type -> Bool
hasPolyType Type
argTy = do
Extension -> Q ()
checkExt Extension
RankNTypes
Name
v <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Type -> m Type
forallT [Name -> TyVarBndr Specificity
bindVar Name
v] (forall (f :: * -> *) a. Applicative f => a -> f a
pure []) [t|Predicate $(varT v)|]
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
tyVars Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
cx = [t|Predicate $(pure argTy)|]
| Bool
otherwise = do
Extension -> Q ()
checkExt Extension
RankNTypes
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Type -> m Type
forallT (Name -> TyVarBndr Specificity
bindVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
tyVars) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Cxt
cx) [t|Predicate $(pure argTy)|]
where
([Name]
tyVars, Cxt
cx) =
Type -> ([Name], Cxt) -> ([Name], Cxt)
relevantContext Type
argTy (Method -> [Name]
methodTyVars Method
method, Method -> Cxt
methodCxt Method
method)
getMatcherName :: MakeMockableOptions -> Method -> Name
getMatcherName :: MakeMockableOptions -> Method -> Name
getMatcherName MakeMockableOptions
options Method
method =
String -> Name
mkName (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (forall a. Int -> [a] -> [a]
take Int
1 String
name) forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
drop Int
1 String
name forall a. [a] -> [a] -> [a]
++ MakeMockableOptions -> String
mockSuffix MakeMockableOptions
options forall a. [a] -> [a] -> [a]
++ String
"_")
where
name :: String
name = Name -> String
nameBase (Method -> Name
methodName Method
method)
defineShowAction :: MakeMockableOptions -> [Method] -> Q Dec
defineShowAction :: MakeMockableOptions -> [Method] -> Q Dec
defineShowAction MakeMockableOptions
options [Method]
methods =
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'showAction (MakeMockableOptions -> Method -> Q Clause
showActionClause MakeMockableOptions
options forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Method]
methods)
showActionClause :: MakeMockableOptions -> Method -> Q Clause
showActionClause :: MakeMockableOptions -> Method -> Q Clause
showActionClause MakeMockableOptions
options Method
method = do
[Name]
argVars <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length (Method -> Cxt
methodArgs Method
method)) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"a")
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
[ forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP
(MakeMockableOptions -> Method -> Name
getActionName MakeMockableOptions
options Method
method)
(forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> Name -> Q Pat
argPattern (Method -> Cxt
methodArgs Method
method) [Name]
argVars)
]
( forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
[|
unwords
( $(lift (nameBase (methodName method))) :
$(listE (zipWith showArg (methodArgs method) argVars))
)
|]
)
[]
where
isLocalPoly :: Type -> Bool
isLocalPoly Type
ty =
Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$
Type -> ([Name], Cxt) -> ([Name], Cxt)
relevantContext Type
ty (Method -> [Name]
methodTyVars Method
method, Method -> Cxt
methodCxt Method
method)
canShow :: Type -> Q Bool
canShow Type
ty
| Type -> Bool
hasPolyType Type
ty = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| Type -> Bool
isLocalPoly Type
ty = (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Method -> Cxt
methodCxt Method
method) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|Show $(pure ty)|]
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Type -> [Name]
freeTypeVars Type
ty) = Name -> Cxt -> Q Bool
isInstance ''Show [Type
ty]
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
canType :: Type -> m Bool
canType Type
ty
| Type -> Bool
hasPolyType Type
ty = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| Type -> Bool
isLocalPoly Type
ty =
(forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Method -> Cxt
methodCxt Method
method)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|Typeable $(pure ty)|]
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Type -> [Name]
freeTypeVars Type
ty))
argPattern :: Type -> Name -> Q Pat
argPattern Type
ty Name
v = Type -> Q Bool
canShow Type
ty forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> a -> Bool -> a
bool forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
v)
showArg :: Type -> Name -> Q Exp
showArg Type
ty Name
var = do
Bool
showable <- Type -> Q Bool
canShow Type
ty
Bool
typeable <- forall {m :: * -> *}. Quote m => Type -> m Bool
canType Type
ty
case (Bool
showable, Bool
typeable) of
(Bool
True, Bool
_) -> [|showsPrec 11 $(varE var) ""|]
(Bool
_, Bool
True) ->
[|
"(_ :: "
++ show (typeRep (undefined :: Proxy $(return ty)))
++ ")"
|]
(Bool, Bool)
_ -> forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift (String
"(_ :: " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint (forall a. Data a => a -> a
removeModNames Type
ty) forall a. [a] -> [a] -> [a]
++ String
")")
defineShowMatcher :: MakeMockableOptions -> [Method] -> Q Dec
defineShowMatcher :: MakeMockableOptions -> [Method] -> Q Dec
defineShowMatcher MakeMockableOptions
options [Method]
methods = do
[Q Clause]
clauses <- forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (MakeMockableOptions -> Method -> Q [Q Clause]
showMatcherClauses MakeMockableOptions
options) [Method]
methods
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'showMatcher [Q Clause]
clauses
showMatcherClauses :: MakeMockableOptions -> Method -> Q [ClauseQ]
showMatcherClauses :: MakeMockableOptions -> Method -> Q [Q Clause]
showMatcherClauses MakeMockableOptions
options Method
method = do
[Name]
argTVars <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length (Method -> Cxt
methodArgs Method
method)) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"t")
[Name]
predVars <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length (Method -> Cxt
methodArgs Method
method)) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"p")
let actionArgs :: [Q Pat]
actionArgs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {m :: * -> *}. Quote m => Name -> Type -> m Pat
actionArg [Name]
argTVars (Method -> Cxt
methodArgs Method
method)
let matcherArgs :: [Q Pat]
matcherArgs = forall (m :: * -> *). Quote m => Name -> m Pat
varP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
predVars
let printedArgs :: [Q Exp]
printedArgs = forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 forall {m :: * -> *}. Quote m => Name -> Name -> Type -> m Exp
printedArg [Name]
predVars [Name]
argTVars (Method -> Cxt
methodArgs Method
method)
let polyMatcherArgs :: [Q Pat]
polyMatcherArgs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {m :: * -> *}. Quote m => Name -> Type -> m Pat
matcherArg [Name]
predVars (Method -> Cxt
methodArgs Method
method)
let printedPolyArgs :: [Q Exp]
printedPolyArgs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {m :: * -> *}. Quote m => Name -> Type -> m Exp
printedPolyArg [Name]
predVars (Method -> Cxt
methodArgs Method
method)
let body :: t -> [m Exp] -> m Body
body t
name [m Exp]
args = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|unwords ($(lift name) : $(listE args))|]
forall (m :: * -> *) a. Monad m => a -> m a
return
[ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
[ forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Just [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (MakeMockableOptions -> Method -> Name
getActionName MakeMockableOptions
options Method
method) [Q Pat]
actionArgs],
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (MakeMockableOptions -> Method -> Name
getMatcherName MakeMockableOptions
options Method
method) [Q Pat]
matcherArgs
]
(forall {m :: * -> *} {t}.
(Quote m, Lift t) =>
t -> [m Exp] -> m Body
body (Name -> String
nameBase (Method -> Name
methodName Method
method)) [Q Exp]
printedArgs)
[],
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
[ forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Nothing [],
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (MakeMockableOptions -> Method -> Name
getMatcherName MakeMockableOptions
options Method
method) [Q Pat]
polyMatcherArgs
]
(forall {m :: * -> *} {t}.
(Quote m, Lift t) =>
t -> [m Exp] -> m Body
body (Name -> String
nameBase (Method -> Name
methodName Method
method)) [Q Exp]
printedPolyArgs)
[]
]
where
actionArg :: Name -> Type -> m Pat
actionArg Name
t Type
ty
| Method -> Type -> Bool
isKnownType Method
method Type
ty = forall (m :: * -> *). Quote m => m Pat
wildP
| Bool
otherwise = forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => Name -> m Type
varT Name
t)
matcherArg :: Name -> Type -> m Pat
matcherArg Name
p Type
ty
| Method -> Type -> Bool
isKnownType Method
method Type
ty = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
p
| Bool
otherwise = forall (m :: * -> *). Quote m => m Pat
wildP
printedArg :: Name -> Name -> Type -> m Exp
printedArg Name
p Name
t Type
ty
| Method -> Type -> Bool
isKnownType Method
method Type
ty = [|"«" ++ show $(varE p) ++ "»"|]
| Bool
otherwise =
[|"«" ++ show ($(varE p) :: Predicate $(varT t)) ++ "»"|]
printedPolyArg :: Name -> Type -> m Exp
printedPolyArg Name
p Type
ty
| Method -> Type -> Bool
isKnownType Method
method Type
ty = [|"«" ++ show $(varE p) ++ "»"|]
| Bool
otherwise = [|"«polymorphic»"|]
defineMatchAction :: MakeMockableOptions -> [Method] -> Q Dec
defineMatchAction :: MakeMockableOptions -> [Method] -> Q Dec
defineMatchAction MakeMockableOptions
options [Method]
methods =
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'matchAction (MakeMockableOptions -> Method -> Q Clause
matchActionClause MakeMockableOptions
options forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Method]
methods)
matchActionClause :: MakeMockableOptions -> Method -> Q Clause
matchActionClause :: MakeMockableOptions -> Method -> Q Clause
matchActionClause MakeMockableOptions
options Method
method = do
[(Name, Name)]
argVars <-
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM
(forall (t :: * -> *) a. Foldable t => t a -> Int
length (Method -> Cxt
methodArgs Method
method))
((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => String -> m Name
newName String
"p" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). Quote m => String -> m Name
newName String
"a")
Name
mmVar <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"mismatches"
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
[ forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP
(MakeMockableOptions -> Method -> Name
getMatcherName MakeMockableOptions
options Method
method)
(forall (m :: * -> *). Quote m => Name -> m Pat
varP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Name)]
argVars),
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (MakeMockableOptions -> Method -> Name
getActionName MakeMockableOptions
options Method
method) (forall (m :: * -> *). Quote m => Name -> m Pat
varP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Name)]
argVars)
]
( forall (m :: * -> *). Quote m => [m (Guard, Exp)] -> m Body
guardedB
[ (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => m Exp -> m Guard
normalG [|null $(varE mmVar)|] forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [|Match|],
(,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => m Exp -> m Guard
normalG [|otherwise|] forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [|NoMatch $(varE mmVar)|]
]
)
[ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD
(forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
mmVar)
( forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
[|
catMaybes $
zipWith
(fmap . (,))
[1 ..]
$(listE (mkAccept <$> argVars))
|]
)
[]
]
where
mkAccept :: (Name, Name) -> m Exp
mkAccept (Name
p, Name
a) =
[|
if accept $(return (VarE p)) $(return (VarE a))
then Nothing
else Just $ explain $(return (VarE p)) $(return (VarE a))
|]
defineExpectableActions :: MakeMockableOptions -> Instance -> Q [Dec]
defineExpectableActions :: MakeMockableOptions -> Instance -> Q [Dec]
defineExpectableActions MakeMockableOptions
options Instance
inst =
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MakeMockableOptions -> Instance -> Method -> Q Dec
defineExpectableAction MakeMockableOptions
options Instance
inst) (Instance -> [Method]
instMethods Instance
inst)
type ComplexExpectableMessage name =
( 'Text "Method " ':<>: 'Text name
':<>: 'Text " is too complex to expect with an Action."
)
':$$: 'Text "Suggested fix: Use a Matcher instead of an Action."
defineExpectableAction :: MakeMockableOptions -> Instance -> Method -> Q Dec
defineExpectableAction :: MakeMockableOptions -> Instance -> Method -> Q Dec
defineExpectableAction MakeMockableOptions
options Instance
inst Method
method = do
Maybe Cxt
maybeCxt <- Cxt -> Q (Maybe Cxt)
wholeCxt (Method -> Cxt
methodArgs Method
method)
[Name]
argVars <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length (Method -> Cxt
methodArgs Method
method)) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"a")
case Maybe Cxt
maybeCxt of
Just Cxt
cx -> do
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
(forall (f :: * -> *) a. Applicative f => a -> f a
pure (Method -> Cxt
methodCxt Method
method forall a. [a] -> [a] -> [a]
++ Cxt
cx))
( forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT
(Instance -> Method -> Q Type -> Q Type
withMethodParams Instance
inst Method
method [t|Expectable|])
(Instance -> Method -> Q Type -> Q Type
withMethodParams Instance
inst Method
method [t|Action|])
)
[ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
'toRule
[ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
[forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (MakeMockableOptions -> Method -> Name
getActionName MakeMockableOptions
options Method
method) (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
argVars)]
( forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$
let matcherCon :: Q Exp
matcherCon = forall (m :: * -> *). Quote m => Name -> m Exp
conE (MakeMockableOptions -> Method -> Name
getMatcherName MakeMockableOptions
options Method
method)
in forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'toRule) (forall {m :: * -> *}. Quote m => [Name] -> m Exp -> m Exp
makeBody [Name]
argVars Q Exp
matcherCon)
)
[]
]
]
Maybe Cxt
_ -> do
Extension -> Q ()
checkExt Extension
UndecidableInstances
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
( (forall a. a -> [a] -> [a]
: [])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|
TypeError
( ComplexExpectableMessage
$(litT $ strTyLit $ nameBase $ methodName method)
)
|]
)
( forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT
(Instance -> Method -> Q Type -> Q Type
withMethodParams Instance
inst Method
method [t|Expectable|])
(Instance -> Method -> Q Type -> Q Type
withMethodParams Instance
inst Method
method [t|Action|])
)
[ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
'toRule
[forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|undefined|]) []]
]
where
makeBody :: [Name] -> m Exp -> m Exp
makeBody [] m Exp
e = m Exp
e
makeBody (Name
v : [Name]
vs) m Exp
e = [Name] -> m Exp -> m Exp
makeBody [Name]
vs [|$e (eq $(varE v))|]
wholeCxt :: [Type] -> Q (Maybe Cxt)
wholeCxt :: Cxt -> Q (Maybe Cxt)
wholeCxt (Type
ty : Cxt
ts) = do
Maybe Cxt
thisCxt <- Type -> Q (Maybe Cxt)
argCxt Type
ty
Maybe Cxt
otherCxt <- Cxt -> Q (Maybe Cxt)
wholeCxt Cxt
ts
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a] -> [a]
(++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Cxt
thisCxt forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Cxt
otherCxt)
wholeCxt [] = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just [])
argCxt :: Type -> Q (Maybe Cxt)
argCxt :: Type -> Q (Maybe Cxt)
argCxt Type
argTy
| Bool -> Bool
not (Method -> Type -> Bool
isKnownType Method
method Type
argTy) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| Bool
otherwise =
Cxt -> Q (Maybe Cxt)
simplifyContext [Type -> Type -> Type
AppT (Name -> Type
ConT ''Eq) Type
argTy, Type -> Type -> Type
AppT (Name -> Type
ConT ''Show) Type
argTy]
deriveForMockT :: MakeMockableOptions -> Type -> Q [Dec]
deriveForMockT :: MakeMockableOptions -> Type -> Q [Dec]
deriveForMockT MakeMockableOptions
options Type
ty = do
Instance
inst <- MakeMockableOptions -> Type -> Q Instance
getInstance MakeMockableOptions
options {mockVerbose :: Bool
mockVerbose = Bool
False} Type
ty
Bool
needsMockT <-
if MakeMockableOptions -> Bool
mockDeriveForMockT MakeMockableOptions
options
then
forall a. Maybe a -> Bool
isNothing
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q (Maybe Cxt)
resolveInstanceType
( Type -> Type -> Type
AppT
(Instance -> Type
instType Instance
inst)
(Type -> Type -> Type
AppT (Name -> Type
ConT ''MockT) (Name -> Type
VarT (Instance -> Name
instMonadVar Instance
inst)))
)
else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
if Bool
needsMockT
then do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Instance -> [Dec]
instExtraMembers Instance
inst)) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
String
"Cannot derive MockT because " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint (Instance -> Type
instType Instance
inst)
forall a. [a] -> [a] -> [a]
++ String
" has unmockable methods."
Name
m <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"m"
let decs :: [Q Dec]
decs = forall a b. (a -> b) -> [a] -> [b]
map (MakeMockableOptions -> Method -> Q Dec
implementMethod MakeMockableOptions
options) (Instance -> [Method]
instMethods Instance
inst)
let cx :: Cxt
cx =
Instance -> Cxt
instRequiredContext Instance
inst
forall a. Eq a => [a] -> [a] -> [a]
\\ [ Type -> Type -> Type
AppT (Name -> Type
ConT ''Typeable) (Name -> Type
VarT (Instance -> Name
instMonadVar Instance
inst)),
Type -> Type -> Type
AppT (Name -> Type
ConT ''Functor) (Name -> Type
VarT (Instance -> Name
instMonadVar Instance
inst)),
Type -> Type -> Type
AppT (Name -> Type
ConT ''Applicative) (Name -> Type
VarT (Instance -> Name
instMonadVar Instance
inst)),
Type -> Type -> Type
AppT (Name -> Type
ConT ''Monad) (Name -> Type
VarT (Instance -> Name
instMonadVar Instance
inst)),
Type -> Type -> Type
AppT (Name -> Type
ConT ''MonadIO) (Name -> Type
VarT (Instance -> Name
instMonadVar Instance
inst))
]
let mockTConstraints :: Cxt
mockTConstraints =
Name -> Type -> Type -> Type
substTypeVar
(Instance -> Name
instMonadVar Instance
inst)
(Type -> Type -> Type
AppT (Name -> Type
ConT ''MockT) (Name -> Type
VarT Name
m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt
cx
Cxt -> Q (Maybe Cxt)
simplifyContext Cxt
mockTConstraints
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Cxt
cxMockT ->
(forall a. a -> [a] -> [a]
: [])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
( forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
cxMockT,
[Q Type] -> [Name] -> CxtQ
constrainVars [[t|Typeable|]] (Instance -> [Name]
instGeneralParams Instance
inst),
[Q Type] -> [Name] -> CxtQ
constrainVars [[t|Typeable|], [t|MonadIO|]] [Name
m]
]
)
[t|$(pure (instType inst)) (MockT $(varT m))|]
[Q Dec]
decs
Maybe Cxt
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Missing MockT instance for a superclass."
else forall (m :: * -> *) a. Monad m => a -> m a
return []
implementMethod :: MakeMockableOptions -> Method -> Q Dec
implementMethod :: MakeMockableOptions -> Method -> Q Dec
implementMethod MakeMockableOptions
options Method
method = do
[Name]
argVars <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length (Method -> Cxt
methodArgs Method
method)) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"a")
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
(Method -> Name
methodName Method
method)
[forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause (forall (m :: * -> *). Quote m => Name -> m Pat
varP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
argVars) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ([Name] -> Q Exp
body [Name]
argVars)) []]
where
actionExp :: [Name] -> m Exp -> m Exp
actionExp [] m Exp
e = m Exp
e
actionExp (Name
v : [Name]
vs) m Exp
e = [Name] -> m Exp -> m Exp
actionExp [Name]
vs [|$e $(varE v)|]
body :: [Name] -> Q Exp
body [Name]
argVars = do
Maybe Cxt
defaultCxt <- Cxt -> Q (Maybe Cxt)
simplifyContext [Type -> Type -> Type
AppT (Name -> Type
ConT ''Default) (Method -> Type
methodResult Method
method)]
let someMockMethod :: Q Exp
someMockMethod = case Maybe Cxt
defaultCxt of
Just [] -> [|mockMethod|]
Maybe Cxt
_ -> [|mockDefaultlessMethod|]
[|
$someMockMethod
$(actionExp argVars (conE (getActionName options method)))
|]
checkExt :: Extension -> Q ()
checkExt :: Extension -> Q ()
checkExt Extension
e = do
Bool
enabled <- Extension -> Q Bool
isExtEnabled Extension
e
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
enabled forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Please enable " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Extension
e forall a. [a] -> [a] -> [a]
++ String
" to generate this mock."
internalError :: HasCallStack => Q a
internalError :: forall a. HasCallStack => Q a
internalError = forall a. HasCallStack => String -> a
error String
"Internal error in HMock. Please report this as a bug."