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