{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
module Test.HMock.Internal.TH
( unappliedName,
tvName,
bindVar,
substTypeVar,
substTypeVars,
splitType,
freeTypeVars,
relevantContext,
constrainVars,
unifyTypes,
removeModNames,
hasPolyType,
hasNestedPolyType,
resolveInstance,
resolveInstanceType,
simplifyContext,
localizeMember,
)
where
import Control.Monad.Extra (mapMaybeM, concatMapM)
import Data.Generics
import Data.List ((\\), nub)
import Data.Maybe (catMaybes, fromMaybe)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (NameFlavour (..))
import Test.HMock.Internal.Util (choices)
#if MIN_VERSION_template_haskell(2,17,0)
tvName :: TyVarBndr flag -> Name
tvName :: forall flag. TyVarBndr flag -> Name
tvName (PlainTV Name
name flag
_) = Name
name
tvName (KindedTV Name
name flag
_ Type
_) = Name
name
bindVar :: Name -> TyVarBndr Specificity
bindVar :: Name -> TyVarBndr Specificity
bindVar Name
n = forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n Specificity
SpecifiedSpec
#else
tvName :: TyVarBndr -> Name
tvName (PlainTV name) = name
tvName (KindedTV name _) = name
bindVar :: Name -> TyVarBndr
bindVar = PlainTV
#endif
unappliedName :: Type -> Maybe Name
unappliedName :: Type -> Maybe Name
unappliedName (AppT Type
a Type
_) = Type -> Maybe Name
unappliedName Type
a
unappliedName (ConT Name
a) = forall a. a -> Maybe a
Just Name
a
unappliedName Type
_ = forall a. Maybe a
Nothing
substTypeVar :: Name -> Type -> Type -> Type
substTypeVar :: Name -> Type -> Type -> Type
substTypeVar Name
n Type
t = [(Name, Type)] -> Type -> Type
substTypeVars [(Name
n, Type
t)]
substTypeVars :: [(Name, Type)] -> Type -> Type
substTypeVars :: [(Name, Type)] -> Type -> Type
substTypeVars [(Name, Type)]
classVars = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere (forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Type -> Type
subst)
where
subst :: Type -> Type
subst (VarT Name
x) | Just Type
t <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
x [(Name, Type)]
classVars = Type
t
subst Type
t = Type
t
splitTypeApp :: Type -> Maybe (Name, [Type])
splitTypeApp :: Type -> Maybe (Name, [Type])
splitTypeApp (ConT Name
name) = forall a. a -> Maybe a
Just (Name
name, [])
splitTypeApp (AppT Type
a Type
b) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. [a] -> [a] -> [a]
++ [Type
b]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe (Name, [Type])
splitTypeApp Type
a
splitTypeApp Type
_ = forall a. Maybe a
Nothing
splitType :: Type -> ([Name], Cxt, [Type], Type)
splitType :: Type -> ([Name], [Type], [Type], Type)
splitType (ForallT [TyVarBndr Specificity]
tv [Type]
cx Type
b) =
let ([Name]
tvs, [Type]
cxs, [Type]
params, Type
retval) = Type -> ([Name], [Type], [Type], Type)
splitType Type
b
in (forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr flag -> Name
tvName [TyVarBndr Specificity]
tv forall a. [a] -> [a] -> [a]
++ [Name]
tvs, [Type]
cx forall a. [a] -> [a] -> [a]
++ [Type]
cxs, [Type]
params, Type
retval)
splitType (AppT (AppT Type
ArrowT Type
a) Type
b) =
let ([Name]
tvs, [Type]
cx, [Type]
params, Type
retval) = Type -> ([Name], [Type], [Type], Type)
splitType Type
b in ([Name]
tvs, [Type]
cx, Type
a forall a. a -> [a] -> [a]
: [Type]
params, Type
retval)
splitType Type
r = ([], [], [], Type
r)
freeTypeVars :: Type -> [Name]
freeTypeVars :: Type -> [Name]
freeTypeVars = forall s r.
s -> (r -> r -> r) -> GenericQ (s -> (r, s)) -> GenericQ r
everythingWithContext [] forall a. [a] -> [a] -> [a]
(++) (forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ ([],) Type -> [Name] -> ([Name], [Name])
go)
where
go :: Type -> [Name] -> ([Name], [Name])
go (VarT Name
v) [Name]
bound
| Name
v forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
bound = ([], [Name]
bound)
| Bool
otherwise = ([Name
v], [Name]
bound)
go (ForallT [TyVarBndr Specificity]
vs [Type]
_ Type
_) [Name]
bound = ([], forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr flag -> Name
tvName [TyVarBndr Specificity]
vs forall a. [a] -> [a] -> [a]
++ [Name]
bound)
go Type
_ [Name]
bound = ([], [Name]
bound)
constrainVars :: [TypeQ] -> [Name] -> CxtQ
constrainVars :: [TypeQ] -> [Name] -> CxtQ
constrainVars [TypeQ]
cs [Name]
vs = forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT TypeQ
c (forall (m :: * -> *). Quote m => Name -> m Type
varT Name
v) | TypeQ
c <- [TypeQ]
cs, Name
v <- [Name]
vs]
relevantContext :: Type -> ([Name], Cxt) -> ([Name], Cxt)
relevantContext :: Type -> ([Name], [Type]) -> ([Name], [Type])
relevantContext Type
ty ([Name]
tvs, [Type]
cx) = (forall a. (a -> Bool) -> [a] -> [a]
filter Name -> Bool
needsTv [Name]
tvs, [Type]
filteredCx)
where
filteredCx :: [Type]
filteredCx = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Type -> [Name]
freeTypeVars Type
ty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [Name]
freeTypeVars) [Type]
cx
needsTv :: Name -> Bool
needsTv Name
v = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Name
v forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [Name]
freeTypeVars) (Type
ty forall a. a -> [a] -> [a]
: [Type]
filteredCx)
unifyTypes :: Type -> Type -> Q (Maybe [(Name, Type)])
unifyTypes :: Type -> Type -> Q (Maybe [(Name, Type)])
unifyTypes = [(Name, Type)] -> Type -> Type -> Q (Maybe [(Name, Type)])
unifyTypesWith []
unifyTypesWith :: [(Name, Type)] -> Type -> Type -> Q (Maybe [(Name, Type)])
unifyTypesWith :: [(Name, Type)] -> Type -> Type -> Q (Maybe [(Name, Type)])
unifyTypesWith [(Name, Type)]
tbl (VarT Name
v) Type
t2
| Just Type
t1 <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
v [(Name, Type)]
tbl = [(Name, Type)] -> Type -> Type -> Q (Maybe [(Name, Type)])
unifyTypesWith [(Name, Type)]
tbl Type
t1 Type
t2
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just ((Name
v, Type
t2) forall a. a -> [a] -> [a]
: [(Name, Type)]
tbl))
unifyTypesWith [(Name, Type)]
tbl (ConT Name
a) (ConT Name
b) | Name
a forall a. Eq a => a -> a -> Bool
== Name
b = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just [(Name, Type)]
tbl)
unifyTypesWith [(Name, Type)]
tbl Type
a Type
b = do
Maybe Type
mbA <- Type -> Q (Maybe Type)
replaceSyn Type
a
Maybe Type
mbB <- Type -> Q (Maybe Type)
replaceSyn Type
b
case (Maybe Type
mbA, Maybe Type
mbB) of
(Maybe Type
Nothing, Maybe Type
Nothing) -> forall a b.
(Data a, Data b) =>
[(Name, Type)] -> a -> b -> Q (Maybe [(Name, Type)])
unifyWithin [(Name, Type)]
tbl Type
a Type
b
(Maybe Type, Maybe Type)
_ -> [(Name, Type)] -> Type -> Type -> Q (Maybe [(Name, Type)])
unifyTypesWith [(Name, Type)]
tbl (forall a. a -> Maybe a -> a
fromMaybe Type
a Maybe Type
mbA) (forall a. a -> Maybe a -> a
fromMaybe Type
b Maybe Type
mbB)
where
replaceSyn :: Type -> Q (Maybe Type)
replaceSyn :: Type -> Q (Maybe Type)
replaceSyn (ConT Name
n) = do
Info
info <- Name -> Q Info
reify Name
n
case Info
info of
TyConI (TySynD Name
_ [] Type
t) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Type
t)
Info
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
replaceSyn Type
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
unifyWithin ::
(Data a, Data b) => [(Name, Type)] -> a -> b -> Q (Maybe [(Name, Type)])
unifyWithin :: forall a b.
(Data a, Data b) =>
[(Name, Type)] -> a -> b -> Q (Maybe [(Name, Type)])
unifyWithin [(Name, Type)]
tbl a
a b
b
| forall a. Data a => a -> Constr
toConstr a
a forall a. Eq a => a -> a -> Bool
== forall a. Data a => a -> Constr
toConstr b
b =
forall (m :: * -> *) t.
Monad m =>
[t -> m (Maybe t)] -> t -> m (Maybe t)
compose (forall r. GenericQ (GenericQ r) -> GenericQ (GenericQ [r])
gzipWithQ (\a
a' a
b' [(Name, Type)]
tbl' -> forall a b.
(Data a, Data b) =>
[(Name, Type)] -> a -> b -> Q (Maybe [(Name, Type)])
unify [(Name, Type)]
tbl' a
a' a
b') a
a b
b) [(Name, Type)]
tbl
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
where
unify ::
(Data a, Data b) => [(Name, Type)] -> a -> b -> Q (Maybe [(Name, Type)])
unify :: forall a b.
(Data a, Data b) =>
[(Name, Type)] -> a -> b -> Q (Maybe [(Name, Type)])
unify [(Name, Type)]
tbl' a
a' b
b' = do
case (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
a', forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b
b') of
(Just Type
a'', Just Type
b'') -> [(Name, Type)] -> Type -> Type -> Q (Maybe [(Name, Type)])
unifyTypesWith [(Name, Type)]
tbl' Type
a'' Type
b''
(Maybe Type, Maybe Type)
_ -> forall a b.
(Data a, Data b) =>
[(Name, Type)] -> a -> b -> Q (Maybe [(Name, Type)])
unifyWithin [(Name, Type)]
tbl' a
a' b
b'
compose :: Monad m => [t -> m (Maybe t)] -> t -> m (Maybe t)
compose :: forall (m :: * -> *) t.
Monad m =>
[t -> m (Maybe t)] -> t -> m (Maybe t)
compose [] t
x = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just t
x)
compose (t -> m (Maybe t)
f : [t -> m (Maybe t)]
fs) t
x = do
Maybe t
y <- t -> m (Maybe t)
f t
x
case Maybe t
y of
Just t
y' -> forall (m :: * -> *) t.
Monad m =>
[t -> m (Maybe t)] -> t -> m (Maybe t)
compose [t -> m (Maybe t)]
fs t
y'
Maybe t
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
removeModNames :: Data a => a -> a
removeModNames :: forall a. Data a => a -> a
removeModNames = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere (forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT NameFlavour -> NameFlavour
unMod)
where
unMod :: NameFlavour -> NameFlavour
unMod NameG {} = NameFlavour
NameS
unMod NameFlavour
other = NameFlavour
other
hasNestedPolyType :: Type -> Bool
hasNestedPolyType :: Type -> Bool
hasNestedPolyType (ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
t) = Type -> Bool
hasPolyType Type
t
hasNestedPolyType Type
t = Type -> Bool
hasPolyType Type
t
hasPolyType :: Type -> Bool
hasPolyType :: Type -> Bool
hasPolyType = forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything Bool -> Bool -> Bool
(||) (forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ Bool
False Type -> Bool
isPolyType)
where
isPolyType :: Type -> Bool
isPolyType (ForallT [TyVarBndr Specificity]
tvs [Type]
_ Type
_) = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr Specificity]
tvs)
isPolyType Type
_ = Bool
False
resolveInstance :: Name -> [Type] -> Q (Maybe Cxt)
resolveInstance :: Name -> [Type] -> Q (Maybe [Type])
resolveInstance Name
cls [Type]
args = do
[Dec]
decs <- Name -> [Type] -> Q [Dec]
reifyInstances Name
cls [Type]
args
[[Type]]
results <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([Type] -> Dec -> Q (Maybe [Type])
tryInstance [Type]
args) [Dec]
decs
case [[Type]]
results of
[[Type]
cx] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just [Type]
cx)
[[Type]]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
where
tryInstance :: [Type] -> InstanceDec -> Q (Maybe Cxt)
tryInstance :: [Type] -> Dec -> Q (Maybe [Type])
tryInstance [Type]
actualArgs (InstanceD Maybe Overlap
_ [Type]
cx Type
instType [Dec]
_) =
case Type -> Maybe (Name, [Type])
splitTypeApp Type
instType of
Just (Name
cls', [Type]
instArgs)
| Name
cls' forall a. Eq a => a -> a -> Bool
== Name
cls ->
forall a b.
(Data a, Data b) =>
[(Name, Type)] -> a -> b -> Q (Maybe [(Name, Type)])
unifyWithin [] [Type]
instArgs [Type]
actualArgs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just [(Name, Type)]
tbl -> [Type] -> Q (Maybe [Type])
simplifyContext ([(Name, Type)] -> Type -> Type
substTypeVars [(Name, Type)]
tbl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
cx)
Maybe [(Name, Type)]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Maybe (Name, [Type])
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
tryInstance [Type]
_ Dec
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
resolveInstanceType :: Type -> Q (Maybe Cxt)
resolveInstanceType :: Type -> Q (Maybe [Type])
resolveInstanceType Type
t =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> [Type] -> Q (Maybe [Type])
resolveInstance) (Type -> Maybe (Name, [Type])
splitTypeApp Type
t)
simplifyContext :: Cxt -> Q (Maybe Cxt)
simplifyContext :: [Type] -> Q (Maybe [Type])
simplifyContext [Type]
preds
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isVarApp [Type]
preds = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just [Type]
preds)
| Bool
otherwise = do
let simplifyPred :: Type -> CxtQ
simplifyPred Type
t = forall a. a -> Maybe a -> a
fromMaybe [Type
t] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q (Maybe [Type])
resolveInstanceType Type
t
[Type]
components <- forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Type -> CxtQ
simplifyPred [Type]
preds
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [Name]
freeTypeVars) [Type]
components
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall a. Eq a => [a] -> [a]
nub [Type]
components))
where
isVarApp :: Type -> Bool
isVarApp (ConT Name
_) = Bool
True
isVarApp (AppT Type
t (VarT Name
_)) | Type -> Bool
isVarApp Type
t = Bool
True
isVarApp Type
_ = Bool
False
localizeMember :: Type -> Name -> Type -> Q Type
localizeMember :: Type -> Name -> Type -> TypeQ
localizeMember Type
instTy Name
m t :: Type
t@(ForallT [TyVarBndr Specificity]
tvs [Type]
cx Type
ty) = do
let fullConstraint :: Type
fullConstraint = Type -> Type -> Type
AppT Type
instTy (Name -> Type
VarT Name
m)
let unifyLeft :: (Type, t) -> Q (Maybe ([(Name, Type)], t))
unifyLeft (Type
c, t
cs) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,t
cs) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Type -> Q (Maybe [(Name, Type)])
unifyTypes Type
c Type
fullConstraint
[([(Name, Type)], [Type])]
results <- forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM forall {t}. (Type, t) -> Q (Maybe ([(Name, Type)], t))
unifyLeft (forall a. [a] -> [(a, [a])]
choices [Type]
cx)
case [([(Name, Type)], [Type])]
results of
(([(Name, Type)]
tbl, [Type]
remainingCx) : [([(Name, Type)], [Type])]
_) -> do
let cx' :: [Type]
cx' = [(Name, Type)] -> Type -> Type
substTypeVars [(Name, Type)]
tbl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
remainingCx
ty' :: Type
ty' = [(Name, Type)] -> Type -> Type
substTypeVars [(Name, Type)]
tbl Type
ty
([Name]
tvs', [Type]
cx'') =
Type -> ([Name], [Type]) -> ([Name], [Type])
relevantContext
Type
ty'
((forall flag. TyVarBndr flag -> Name
tvName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr Specificity]
tvs) forall a. Eq a => [a] -> [a] -> [a]
\\ (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Type)]
tbl), [Type]
cx')
t' :: Type
t'
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
tvs' Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
cx'' = Type
ty'
| Bool
otherwise = [TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT (Name -> TyVarBndr Specificity
bindVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
tvs') [Type]
cx'' Type
ty'
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t'
[([(Name, Type)], [Type])]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
localizeMember Type
_ Name
_ Type
t = forall (m :: * -> *) a. Monad m => a -> m a
return Type
t