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

-- | Template Haskell utilities used to implement HMock.
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)
import Data.Generics
import Data.List ((\\))
import Data.Maybe (catMaybes, fromMaybe)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (NameFlavour (..))
import Test.HMock.Internal.Util (choices)
import Data.Foldable (foldl')

#if MIN_VERSION_template_haskell(2,17,0)

-- | Fetches the 'Name' of a 'TyVarBndr'.
tvName :: TyVarBndr flag -> Name
tvName (PlainTV name _) = name
tvName (KindedTV name _ _) = name

-- | Creates a 'TyVarBndr' for a plain variable without a kind annotation.
bindVar :: Name -> TyVarBndr Specificity
bindVar n = PlainTV n SpecifiedSpec

#else

-- | Fetches the 'Name' of a 'TyVarBndr'.
tvName :: TyVarBndr -> Name
tvName :: TyVarBndr -> Name
tvName (PlainTV Name
name) = Name
name
tvName (KindedTV Name
name Kind
_) = Name
name

-- | Creates a 'TyVarBndr' for a plain variable without a kind annotation.
bindVar :: Name -> TyVarBndr
bindVar :: Name -> TyVarBndr
bindVar = Name -> TyVarBndr
PlainTV

#endif

-- | Gets the unapplied top-level name from a type application.
unappliedName :: Type -> Maybe Name
unappliedName :: Kind -> Maybe Name
unappliedName (AppT Kind
a Kind
_) = Kind -> Maybe Name
unappliedName Kind
a
unappliedName (ConT Name
a) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
a
unappliedName Kind
_ = Maybe Name
forall a. Maybe a
Nothing

-- | Substitutes a 'Type' for all occurrences of the given 'Name'.
substTypeVar :: Name -> Type -> Type -> Type
substTypeVar :: Name -> Kind -> Kind -> Kind
substTypeVar Name
n Kind
t = [(Name, Kind)] -> Kind -> Kind
substTypeVars [(Name
n, Kind
t)]

-- | Makes variable substitutions from the given table.
substTypeVars :: [(Name, Type)] -> Type -> Type
substTypeVars :: [(Name, Kind)] -> Kind -> Kind
substTypeVars [(Name, Kind)]
classVars = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Kind -> Kind) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Kind -> Kind
subst)
  where
    subst :: Kind -> Kind
subst (VarT Name
x) | Just Kind
t <- Name -> [(Name, Kind)] -> Maybe Kind
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
x [(Name, Kind)]
classVars = Kind
t
    subst Kind
t = Kind
t

-- | Splits a type application into a top-level constructor and a list of its
-- type arguments.
splitTypeApp :: Type -> Maybe (Name, [Type])
splitTypeApp :: Kind -> Maybe (Name, [Kind])
splitTypeApp (ConT Name
name) = (Name, [Kind]) -> Maybe (Name, [Kind])
forall a. a -> Maybe a
Just (Name
name, [])
splitTypeApp (AppT Kind
a Kind
b) = ([Kind] -> [Kind]) -> (Name, [Kind]) -> (Name, [Kind])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Kind] -> [Kind] -> [Kind]
forall a. [a] -> [a] -> [a]
++ [Kind
b]) ((Name, [Kind]) -> (Name, [Kind]))
-> Maybe (Name, [Kind]) -> Maybe (Name, [Kind])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Kind -> Maybe (Name, [Kind])
splitTypeApp Kind
a
splitTypeApp Kind
_ = Maybe (Name, [Kind])
forall a. Maybe a
Nothing

-- | Splits a function type into a list of bound type vars, context, parameter
-- types, and return value type.
splitType :: Type -> ([Name], Cxt, [Type], Type)
splitType :: Kind -> ([Name], [Kind], [Kind], Kind)
splitType (ForallT [TyVarBndr]
tv [Kind]
cx Kind
b) =
  let ([Name]
tvs, [Kind]
cxs, [Kind]
params, Kind
retval) = Kind -> ([Name], [Kind], [Kind], Kind)
splitType Kind
b
   in ((TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tvName [TyVarBndr]
tv [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
tvs, [Kind]
cx [Kind] -> [Kind] -> [Kind]
forall a. [a] -> [a] -> [a]
++ [Kind]
cxs, [Kind]
params, Kind
retval)
splitType (AppT (AppT Kind
ArrowT Kind
a) Kind
b) =
  let ([Name]
tvs, [Kind]
cx, [Kind]
params, Kind
retval) = Kind -> ([Name], [Kind], [Kind], Kind)
splitType Kind
b in ([Name]
tvs, [Kind]
cx, Kind
a Kind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
: [Kind]
params, Kind
retval)
splitType Kind
r = ([], [], [], Kind
r)

-- | Gets all free type variable 'Name's in the given 'Type'.
freeTypeVars :: Type -> [Name]
freeTypeVars :: Kind -> [Name]
freeTypeVars = [Name]
-> ([Name] -> [Name] -> [Name])
-> GenericQ ([Name] -> ([Name], [Name]))
-> GenericQ [Name]
forall s r.
s -> (r -> r -> r) -> GenericQ (s -> (r, s)) -> GenericQ r
everythingWithContext [] [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
(++) (([Name] -> ([Name], [Name]))
-> (Kind -> [Name] -> ([Name], [Name]))
-> a
-> [Name]
-> ([Name], [Name])
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ ([],) Kind -> [Name] -> ([Name], [Name])
go)
  where
    go :: Kind -> [Name] -> ([Name], [Name])
go (VarT Name
v) [Name]
bound
      | Name
v Name -> [Name] -> Bool
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]
vs [Kind]
_ Kind
_) [Name]
bound = ([], (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tvName [TyVarBndr]
vs [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
bound)
    go Kind
_ [Name]
bound = ([], [Name]
bound)

-- | Produces a 'CxtQ' that gives all given variable 'Name's all of the given
-- class 'Type's.
constrainVars :: [TypeQ] -> [Name] -> CxtQ
constrainVars :: [TypeQ] -> [Name] -> CxtQ
constrainVars [TypeQ]
cs [Name]
vs = [TypeQ] -> CxtQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [TypeQ -> TypeQ -> TypeQ
appT TypeQ
c (Name -> TypeQ
varT Name
v) | TypeQ
c <- [TypeQ]
cs, Name
v <- [Name]
vs]

-- | Culls the given binders and constraints to choose only those that apply to
-- free variables in the given type.
relevantContext :: Type -> ([Name], Cxt) -> ([Name], Cxt)
relevantContext :: Kind -> ([Name], [Kind]) -> ([Name], [Kind])
relevantContext Kind
ty ([Name]
tvs, [Kind]
cx) = ((Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter Name -> Bool
needsTv [Name]
tvs, [Kind]
filteredCx)
  where
    filteredCx :: [Kind]
filteredCx = (Kind -> Bool) -> [Kind] -> [Kind]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Kind -> [Name]
freeTypeVars Kind
ty) ([Name] -> Bool) -> (Kind -> [Name]) -> Kind -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> [Name]
freeTypeVars) [Kind]
cx
    needsTv :: Name -> Bool
needsTv Name
v = (Kind -> Bool) -> [Kind] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Name
v Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) ([Name] -> Bool) -> (Kind -> [Name]) -> Kind -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> [Name]
freeTypeVars) (Kind
ty Kind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
: [Kind]
filteredCx)

-- | Attempts to unify the given types by constructing a table of substitutions
-- for the variables of the left type that obtain the right one.
unifyTypes :: Type -> Type -> Q (Maybe [(Name, Type)])
unifyTypes :: Kind -> Kind -> Q (Maybe [(Name, Kind)])
unifyTypes = [(Name, Kind)] -> Kind -> Kind -> Q (Maybe [(Name, Kind)])
unifyTypesWith []

-- | Unify types, but starting with a table of substitutions.
unifyTypesWith :: [(Name, Type)] -> Type -> Type -> Q (Maybe [(Name, Type)])
unifyTypesWith :: [(Name, Kind)] -> Kind -> Kind -> Q (Maybe [(Name, Kind)])
unifyTypesWith [(Name, Kind)]
tbl (VarT Name
v) Kind
t2
  | Just Kind
t1 <- Name -> [(Name, Kind)] -> Maybe Kind
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
v [(Name, Kind)]
tbl = [(Name, Kind)] -> Kind -> Kind -> Q (Maybe [(Name, Kind)])
unifyTypesWith [(Name, Kind)]
tbl Kind
t1 Kind
t2
  | Bool
otherwise = Maybe [(Name, Kind)] -> Q (Maybe [(Name, Kind)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, Kind)] -> Maybe [(Name, Kind)]
forall a. a -> Maybe a
Just ((Name
v, Kind
t2) (Name, Kind) -> [(Name, Kind)] -> [(Name, Kind)]
forall a. a -> [a] -> [a]
: [(Name, Kind)]
tbl))
unifyTypesWith [(Name, Kind)]
tbl (ConT Name
a) (ConT Name
b) | Name
a Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
b = Maybe [(Name, Kind)] -> Q (Maybe [(Name, Kind)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, Kind)] -> Maybe [(Name, Kind)]
forall a. a -> Maybe a
Just [(Name, Kind)]
tbl)
unifyTypesWith [(Name, Kind)]
tbl Kind
a Kind
b = do
  Maybe Kind
mbA <- Kind -> Q (Maybe Kind)
replaceSyn Kind
a
  Maybe Kind
mbB <- Kind -> Q (Maybe Kind)
replaceSyn Kind
b
  case (Maybe Kind
mbA, Maybe Kind
mbB) of
    (Maybe Kind
Nothing, Maybe Kind
Nothing) -> [(Name, Kind)] -> Kind -> Kind -> Q (Maybe [(Name, Kind)])
forall a b.
(Data a, Data b) =>
[(Name, Kind)] -> a -> b -> Q (Maybe [(Name, Kind)])
unifyWithin [(Name, Kind)]
tbl Kind
a Kind
b
    (Maybe Kind, Maybe Kind)
_ -> [(Name, Kind)] -> Kind -> Kind -> Q (Maybe [(Name, Kind)])
unifyTypesWith [(Name, Kind)]
tbl (Kind -> Maybe Kind -> Kind
forall a. a -> Maybe a -> a
fromMaybe Kind
a Maybe Kind
mbA) (Kind -> Maybe Kind -> Kind
forall a. a -> Maybe a -> a
fromMaybe Kind
b Maybe Kind
mbB)
  where
    replaceSyn :: Type -> Q (Maybe Type)
    replaceSyn :: Kind -> Q (Maybe Kind)
replaceSyn (ConT Name
n) = do
      Info
info <- Name -> Q Info
reify Name
n
      case Info
info of
        TyConI (TySynD Name
_ [] Kind
t) -> Maybe Kind -> Q (Maybe Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
t)
        Info
_ -> Maybe Kind -> Q (Maybe Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Kind
forall a. Maybe a
Nothing
    replaceSyn Kind
_ = Maybe Kind -> Q (Maybe Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Kind
forall a. Maybe a
Nothing

-- Unifies the types that occur within the arguments, starting with a table of
-- substitutions.
unifyWithin ::
  (Data a, Data b) => [(Name, Type)] -> a -> b -> Q (Maybe [(Name, Type)])
unifyWithin :: [(Name, Kind)] -> a -> b -> Q (Maybe [(Name, Kind)])
unifyWithin [(Name, Kind)]
tbl a
a b
b
  | a -> Constr
forall a. Data a => a -> Constr
toConstr a
a Constr -> Constr -> Bool
forall a. Eq a => a -> a -> Bool
== b -> Constr
forall a. Data a => a -> Constr
toConstr b
b =
    [[(Name, Kind)] -> Q (Maybe [(Name, Kind)])]
-> [(Name, Kind)] -> Q (Maybe [(Name, Kind)])
forall (m :: * -> *) t.
Monad m =>
[t -> m (Maybe t)] -> t -> m (Maybe t)
compose (GenericQ (GenericQ ([(Name, Kind)] -> Q (Maybe [(Name, Kind)])))
-> a -> b -> [[(Name, Kind)] -> Q (Maybe [(Name, Kind)])]
forall r. GenericQ (GenericQ r) -> GenericQ (GenericQ [r])
gzipWithQ (\a
a' a
b' [(Name, Kind)]
tbl' -> [(Name, Kind)] -> a -> a -> Q (Maybe [(Name, Kind)])
forall a b.
(Data a, Data b) =>
[(Name, Kind)] -> a -> b -> Q (Maybe [(Name, Kind)])
unify [(Name, Kind)]
tbl' a
a' a
b') a
a b
b) [(Name, Kind)]
tbl
  | Bool
otherwise = Maybe [(Name, Kind)] -> Q (Maybe [(Name, Kind)])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [(Name, Kind)]
forall a. Maybe a
Nothing
  where
    unify ::
      (Data a, Data b) => [(Name, Type)] -> a -> b -> Q (Maybe [(Name, Type)])
    unify :: [(Name, Kind)] -> a -> b -> Q (Maybe [(Name, Kind)])
unify [(Name, Kind)]
tbl' a
a' b
b' = do
      case (a -> Maybe Kind
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
a', b -> Maybe Kind
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b
b') of
        (Just Kind
a'', Just Kind
b'') -> [(Name, Kind)] -> Kind -> Kind -> Q (Maybe [(Name, Kind)])
unifyTypesWith [(Name, Kind)]
tbl' Kind
a'' Kind
b''
        (Maybe Kind, Maybe Kind)
_ -> [(Name, Kind)] -> a -> b -> Q (Maybe [(Name, Kind)])
forall a b.
(Data a, Data b) =>
[(Name, Kind)] -> a -> b -> Q (Maybe [(Name, Kind)])
unifyWithin [(Name, Kind)]
tbl' a
a' b
b'

    compose :: Monad m => [t -> m (Maybe t)] -> t -> m (Maybe t)
    compose :: [t -> m (Maybe t)] -> t -> m (Maybe t)
compose [] t
x = Maybe t -> m (Maybe t)
forall (m :: * -> *) a. Monad m => a -> m a
return (t -> Maybe t
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' -> [t -> m (Maybe t)] -> t -> m (Maybe t)
forall (m :: * -> *) t.
Monad m =>
[t -> m (Maybe t)] -> t -> m (Maybe t)
compose [t -> m (Maybe t)]
fs t
y'
        Maybe t
_ -> Maybe t -> m (Maybe t)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe t
forall a. Maybe a
Nothing

-- | Removes all module names from 'Name's in the given value, so that it will
-- pretty-print more cleanly.
removeModNames :: Data a => a -> a
removeModNames :: a -> a
removeModNames = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((NameFlavour -> NameFlavour) -> a -> a
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

-- | Determines if there is a polytype nested anywhere in the given type.
-- Top-level quantification doesn't count.
hasNestedPolyType :: Type -> Bool
hasNestedPolyType :: Kind -> Bool
hasNestedPolyType (ForallT [TyVarBndr]
_ [Kind]
_ Kind
t) = Kind -> Bool
hasPolyType Kind
t
hasNestedPolyType Kind
t = Kind -> Bool
hasPolyType Kind
t

-- | Determines if this is a polytype, including top-level quantification.
hasPolyType :: Type -> Bool
hasPolyType :: Kind -> Bool
hasPolyType = (Bool -> Bool -> Bool) -> GenericQ Bool -> GenericQ Bool
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything Bool -> Bool -> Bool
(||) (Bool -> (Kind -> Bool) -> a -> Bool
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ Bool
False Kind -> Bool
isPolyType)
  where
    isPolyType :: Kind -> Bool
isPolyType (ForallT [TyVarBndr]
tvs [Kind]
_ Kind
_) = Bool -> Bool
not ([TyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr]
tvs)
    isPolyType Kind
_ = Bool
False

-- | Attempts to produce sufficient constraints for the given 'Type' to be an
-- instance of the given class 'Name'.
resolveInstance :: Name -> [Type] -> Q (Maybe Cxt)
resolveInstance :: Name -> [Kind] -> Q (Maybe [Kind])
resolveInstance Name
cls [Kind]
args
  | (Kind -> Bool) -> [Kind] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Kind -> Bool
isTypeVar [Kind]
args = Maybe [Kind] -> Q (Maybe [Kind])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Kind] -> Maybe [Kind]
forall a. a -> Maybe a
Just [(Kind -> Kind -> Kind) -> Kind -> [Kind] -> Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
cls) [Kind]
args])
  where
    isTypeVar :: Type -> Bool
    isTypeVar :: Kind -> Bool
isTypeVar (VarT Name
_) = Bool
True
    isTypeVar Kind
_ = Bool
False
resolveInstance Name
cls [Kind]
args = do
  [Dec]
decs <- Name -> [Kind] -> Q [Dec]
reifyInstances Name
cls [Kind]
args
  [Maybe [Kind]]
result <- (Dec -> Q (Maybe [Kind])) -> [Dec] -> Q [Maybe [Kind]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([Kind] -> Dec -> Q (Maybe [Kind])
tryInstance [Kind]
args) [Dec]
decs
  case [Maybe [Kind]] -> [[Kind]]
forall a. [Maybe a] -> [a]
catMaybes [Maybe [Kind]]
result of
    [[Kind]
cx] -> Maybe [Kind] -> Q (Maybe [Kind])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Kind] -> Maybe [Kind]
forall a. a -> Maybe a
Just ((Kind -> Bool) -> [Kind] -> [Kind]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Kind -> Bool) -> Kind -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Name] -> Bool) -> (Kind -> [Name]) -> Kind -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> [Name]
freeTypeVars) [Kind]
cx))
    [[Kind]]
_ -> Maybe [Kind] -> Q (Maybe [Kind])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Kind]
forall a. Maybe a
Nothing
  where
    tryInstance :: [Type] -> InstanceDec -> Q (Maybe Cxt)
    tryInstance :: [Kind] -> Dec -> Q (Maybe [Kind])
tryInstance [Kind]
actualArgs (InstanceD Maybe Overlap
_ [Kind]
cx Kind
instType [Dec]
_) =
      case Kind -> Maybe (Name, [Kind])
splitTypeApp Kind
instType of
        Just (Name
cls', [Kind]
instArgs) | Name
cls' Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
cls ->
          [(Name, Kind)] -> [Kind] -> [Kind] -> Q (Maybe [(Name, Kind)])
forall a b.
(Data a, Data b) =>
[(Name, Kind)] -> a -> b -> Q (Maybe [(Name, Kind)])
unifyWithin [] [Kind]
instArgs [Kind]
actualArgs Q (Maybe [(Name, Kind)])
-> (Maybe [(Name, Kind)] -> Q (Maybe [Kind])) -> Q (Maybe [Kind])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just [(Name, Kind)]
tbl ->
              let cx' :: [Kind]
cx' = [(Name, Kind)] -> Kind -> Kind
substTypeVars [(Name, Kind)]
tbl (Kind -> Kind) -> [Kind] -> [Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Kind]
cx
              in ([[Kind]] -> [Kind]) -> Maybe [[Kind]] -> Maybe [Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Kind]] -> [Kind]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Maybe [[Kind]] -> Maybe [Kind])
-> ([Maybe [Kind]] -> Maybe [[Kind]])
-> [Maybe [Kind]]
-> Maybe [Kind]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe [Kind]] -> Maybe [[Kind]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Maybe [Kind]] -> Maybe [Kind])
-> Q [Maybe [Kind]] -> Q (Maybe [Kind])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Kind -> Q (Maybe [Kind])) -> [Kind] -> Q [Maybe [Kind]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Kind -> Q (Maybe [Kind])
resolveInstanceType [Kind]
cx'
            Maybe [(Name, Kind)]
Nothing -> Maybe [Kind] -> Q (Maybe [Kind])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Kind]
forall a. Maybe a
Nothing
        Maybe (Name, [Kind])
_ -> Maybe [Kind] -> Q (Maybe [Kind])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Kind]
forall a. Maybe a
Nothing
    tryInstance [Kind]
_ Dec
_ = Maybe [Kind] -> Q (Maybe [Kind])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Kind]
forall a. Maybe a
Nothing

-- | Attempts to produce sufficient constraints for the given 'Type' to be a
-- satisfied constraint.  The type should be a class applied to its type
-- parameters.
resolveInstanceType :: Type -> Q (Maybe Cxt)
resolveInstanceType :: Kind -> Q (Maybe [Kind])
resolveInstanceType Kind
t = case Kind -> Maybe (Name, [Kind])
splitTypeApp Kind
t of
  Just (Name
cls, [Kind]
args) -> Name -> [Kind] -> Q (Maybe [Kind])
resolveInstance Name
cls [Kind]
args
  Maybe (Name, [Kind])
Nothing -> Maybe [Kind] -> Q (Maybe [Kind])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Kind]
forall a. Maybe a
Nothing

-- | Simplifies a context with complex types (requiring FlexibleContexts) to try
-- to obtain one with all constraints applied to variables.
simplifyContext :: Cxt -> Q (Maybe Cxt)
simplifyContext :: [Kind] -> Q (Maybe [Kind])
simplifyContext (Kind
p : [Kind]
preds) =
  case Kind -> Maybe (Name, [Kind])
splitTypeApp Kind
p of
    Just (Name
cls, [Kind]
args) ->
      Name -> [Kind] -> Q (Maybe [Kind])
resolveInstance Name
cls [Kind]
args Q (Maybe [Kind])
-> (Maybe [Kind] -> Q (Maybe [Kind])) -> Q (Maybe [Kind])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just [Kind]
cxt' -> ([Kind] -> [Kind]) -> Maybe [Kind] -> Maybe [Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Kind]
cxt' [Kind] -> [Kind] -> [Kind]
forall a. [a] -> [a] -> [a]
++) (Maybe [Kind] -> Maybe [Kind])
-> Q (Maybe [Kind]) -> Q (Maybe [Kind])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Kind] -> Q (Maybe [Kind])
simplifyContext [Kind]
preds
        Maybe [Kind]
Nothing -> Maybe [Kind] -> Q (Maybe [Kind])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Kind]
forall a. Maybe a
Nothing
    Maybe (Name, [Kind])
_ -> ([Kind] -> [Kind]) -> Maybe [Kind] -> Maybe [Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Kind
p Kind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
:) (Maybe [Kind] -> Maybe [Kind])
-> Q (Maybe [Kind]) -> Q (Maybe [Kind])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Kind] -> Q (Maybe [Kind])
simplifyContext [Kind]
preds
simplifyContext [] = Maybe [Kind] -> Q (Maybe [Kind])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Kind] -> Maybe [Kind]
forall a. a -> Maybe a
Just [])

-- | Remove instance context from a method.
--
-- Some GHC versions report class members including the instance context (for
-- example, @show :: Show a => a -> String@, instead of @show :: a -> String@).
-- This looks for the instance context, and substitutes if needed to eliminate
-- it.
localizeMember :: Type -> Name -> Type -> Q Type
localizeMember :: Kind -> Name -> Kind -> TypeQ
localizeMember Kind
instTy Name
m t :: Kind
t@(ForallT [TyVarBndr]
tvs [Kind]
cx Kind
ty) = do
  let fullConstraint :: Kind
fullConstraint = Kind -> Kind -> Kind
AppT Kind
instTy (Name -> Kind
VarT Name
m)
  let unifyLeft :: (Kind, t) -> Q (Maybe ([(Name, Kind)], t))
unifyLeft (Kind
c, t
cs) = ([(Name, Kind)] -> ([(Name, Kind)], t))
-> Maybe [(Name, Kind)] -> Maybe ([(Name, Kind)], t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,t
cs) (Maybe [(Name, Kind)] -> Maybe ([(Name, Kind)], t))
-> Q (Maybe [(Name, Kind)]) -> Q (Maybe ([(Name, Kind)], t))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Kind -> Kind -> Q (Maybe [(Name, Kind)])
unifyTypes Kind
c Kind
fullConstraint
  [([(Name, Kind)], [Kind])]
results <- ((Kind, [Kind]) -> Q (Maybe ([(Name, Kind)], [Kind])))
-> [(Kind, [Kind])] -> Q [([(Name, Kind)], [Kind])]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (Kind, [Kind]) -> Q (Maybe ([(Name, Kind)], [Kind]))
forall t. (Kind, t) -> Q (Maybe ([(Name, Kind)], t))
unifyLeft ([Kind] -> [(Kind, [Kind])]
forall a. [a] -> [(a, [a])]
choices [Kind]
cx)
  case [([(Name, Kind)], [Kind])]
results of
    (([(Name, Kind)]
tbl, [Kind]
remainingCx) : [([(Name, Kind)], [Kind])]
_) -> do
      let cx' :: [Kind]
cx' = [(Name, Kind)] -> Kind -> Kind
substTypeVars [(Name, Kind)]
tbl (Kind -> Kind) -> [Kind] -> [Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Kind]
remainingCx
          ty' :: Kind
ty' = [(Name, Kind)] -> Kind -> Kind
substTypeVars [(Name, Kind)]
tbl Kind
ty
          ([Name]
tvs', [Kind]
cx'') =
            Kind -> ([Name], [Kind]) -> ([Name], [Kind])
relevantContext
              Kind
ty'
              ((TyVarBndr -> Name
tvName (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr]
tvs) [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
\\ ((Name, Kind) -> Name
forall a b. (a, b) -> a
fst ((Name, Kind) -> Name) -> [(Name, Kind)] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Kind)]
tbl), [Kind]
cx')
          t' :: Kind
t'
            | [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
tvs' Bool -> Bool -> Bool
&& [Kind] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Kind]
cx'' = Kind
ty'
            | Bool
otherwise = [TyVarBndr] -> [Kind] -> Kind -> Kind
ForallT (Name -> TyVarBndr
bindVar (Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
tvs') [Kind]
cx'' Kind
ty'
      Kind -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
t'
    [([(Name, Kind)], [Kind])]
_ -> Kind -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
t
localizeMember Kind
_ Name
_ Kind
t = Kind -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
t