{-# LANGUAGE CPP #-}
module Language.Haskell.TH.ReifyMany.Internal where

#if !(MIN_VERSION_template_haskell(2,7,0))
import Data.List (foldl')
#endif
import Data.Maybe (catMaybes)
import Language.Haskell.TH
import Language.Haskell.TH.ExpandSyns (expandSyns)
import Safe (headMay, tailMay)

-- | Returns 'True' if the 'Dec' is a 'DataD' or 'NewtypeD'
isDataDec :: Dec -> Bool
isDataDec :: Dec -> Bool
isDataDec DataD {} = Bool
True
isDataDec NewtypeD {} = Bool
True
isDataDec Dec
_ = Bool
False

-- | Returns 'True' if the 'Dec' is a 'DataD', 'NewtypeD', or
-- 'TySynD'.
isNormalTyCon :: Dec -> Bool
isNormalTyCon :: Dec -> Bool
isNormalTyCon DataD {} = Bool
True
isNormalTyCon NewtypeD {} = Bool
True
isNormalTyCon TySynD {} = Bool
True
isNormalTyCon Dec
_ = Bool
False

-- | For data, newtype, and type declarations, yields a list of the
-- types of the fields.  In the case of a type synonyms, it just
-- returns the body of the type synonym as a singleton list.
decToFieldTypes :: Dec -> [[Type]]
#if MIN_VERSION_template_haskell(2,11,0)
decToFieldTypes :: Dec -> [[Type]]
decToFieldTypes (DataD [Type]
_ Name
_ [TyVarBndr]
_ Maybe Type
_ [Con]
cons [DerivClause]
_) = (Con -> [Type]) -> [Con] -> [[Type]]
forall a b. (a -> b) -> [a] -> [b]
map Con -> [Type]
conToFieldTypes [Con]
cons
decToFieldTypes (NewtypeD [Type]
_ Name
_ [TyVarBndr]
_ Maybe Type
_ Con
con [DerivClause]
_) = [Con -> [Type]
conToFieldTypes Con
con]
#else
decToFieldTypes (DataD _ _ _ cons _) = map conToFieldTypes cons
decToFieldTypes (NewtypeD _ _ _ con _) = [conToFieldTypes con]
#endif
decToFieldTypes (TySynD Name
_ [TyVarBndr]
_ Type
ty) = [[Type
ty]]
decToFieldTypes Dec
_ = []

-- | Returns the types of the fields of the constructor.
conToFieldTypes :: Con -> [Type]
conToFieldTypes :: Con -> [Type]
conToFieldTypes (NormalC Name
_ [BangType]
xs) = (BangType -> Type) -> [BangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType]
xs
conToFieldTypes (RecC Name
_ [VarBangType]
xs) = (VarBangType -> Type) -> [VarBangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
_, Bang
_, Type
ty) -> Type
ty) [VarBangType]
xs
conToFieldTypes (InfixC (Bang
_, Type
ty1) Name
_ (Bang
_, Type
ty2)) = [Type
ty1, Type
ty2]
conToFieldTypes (ForallC [TyVarBndr]
_ [Type]
_ Con
con) = Con -> [Type]
conToFieldTypes Con
con
#if MIN_VERSION_template_haskell(2,11,0)
conToFieldTypes (GadtC [Name]
_ [BangType]
xs Type
_) = (BangType -> Type) -> [BangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType]
xs
conToFieldTypes (RecGadtC [Name]
_ [VarBangType]
xs Type
_) = (VarBangType -> Type) -> [VarBangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
_, Bang
_, Type
ty) -> Type
ty) [VarBangType]
xs
#endif

-- | Returns the names of all type constructors which aren't involved
-- in constraints.
typeConcreteNames :: Type -> [Name]
typeConcreteNames :: Type -> [Name]
typeConcreteNames (ForallT [TyVarBndr]
_ [Type]
_ Type
ty) = Type -> [Name]
typeConcreteNames Type
ty
typeConcreteNames (AppT Type
l Type
r) = Type -> [Name]
typeConcreteNames Type
l [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Type -> [Name]
typeConcreteNames Type
r
typeConcreteNames (SigT Type
ty Type
_) = Type -> [Name]
typeConcreteNames Type
ty
typeConcreteNames (ConT Name
n) = [Name
n]
typeConcreteNames Type
_ = []

-- | Returns the names of all type constructors used when defining
-- type constructors.
decConcreteNames :: Dec -> [Name]
decConcreteNames :: Dec -> [Name]
decConcreteNames = ([Type] -> [Name]) -> [[Type]] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Type -> [Name]) -> [Type] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type -> [Name]
typeConcreteNames) ([[Type]] -> [Name]) -> (Dec -> [[Type]]) -> Dec -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dec -> [[Type]]
decToFieldTypes

-- | Datatype to capture the fields of 'InstanceD'.
data TypeclassInstance = TypeclassInstance Cxt Type [Dec]
    deriving Int -> TypeclassInstance -> ShowS
[TypeclassInstance] -> ShowS
TypeclassInstance -> String
(Int -> TypeclassInstance -> ShowS)
-> (TypeclassInstance -> String)
-> ([TypeclassInstance] -> ShowS)
-> Show TypeclassInstance
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeclassInstance] -> ShowS
$cshowList :: [TypeclassInstance] -> ShowS
show :: TypeclassInstance -> String
$cshow :: TypeclassInstance -> String
showsPrec :: Int -> TypeclassInstance -> ShowS
$cshowsPrec :: Int -> TypeclassInstance -> ShowS
Show

-- | Given the 'Name' of a class, yield all of the
-- 'TypeclassInstance's, with synonyms expanded in the 'Type' field.
getInstances :: Name -> Q [TypeclassInstance]
getInstances :: Name -> Q [TypeclassInstance]
getInstances Name
clz = do
    Info
res <- Name -> Q Info
reify Name
clz
    case Info
res of
        ClassI Dec
_ [Dec]
xs -> ([Maybe TypeclassInstance] -> [TypeclassInstance])
-> Q [Maybe TypeclassInstance] -> Q [TypeclassInstance]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe TypeclassInstance] -> [TypeclassInstance]
forall a. [Maybe a] -> [a]
catMaybes (Q [Maybe TypeclassInstance] -> Q [TypeclassInstance])
-> Q [Maybe TypeclassInstance] -> Q [TypeclassInstance]
forall a b. (a -> b) -> a -> b
$ (Dec -> Q (Maybe TypeclassInstance))
-> [Dec] -> Q [Maybe TypeclassInstance]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Dec -> Q (Maybe TypeclassInstance)
convertDec [Dec]
xs
        Info
_ -> String -> Q [TypeclassInstance]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [TypeclassInstance])
-> String -> Q [TypeclassInstance]
forall a b. (a -> b) -> a -> b
$ String
"Error in getInstances: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
clz String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" isn't a class"
  where
#if MIN_VERSION_template_haskell(2,7,0)
#if MIN_VERSION_template_haskell(2,11,0)
    convertDec :: Dec -> Q (Maybe TypeclassInstance)
convertDec (InstanceD Maybe Overlap
_ [Type]
ctxt Type
typ [Dec]
decs) = do
#else
    convertDec (InstanceD ctxt typ decs) = do
#endif
        Type
typ' <- Type -> Q Type
expandSyns Type
typ
        Maybe TypeclassInstance -> Q (Maybe TypeclassInstance)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TypeclassInstance -> Q (Maybe TypeclassInstance))
-> Maybe TypeclassInstance -> Q (Maybe TypeclassInstance)
forall a b. (a -> b) -> a -> b
$ TypeclassInstance -> Maybe TypeclassInstance
forall a. a -> Maybe a
Just ([Type] -> Type -> [Dec] -> TypeclassInstance
TypeclassInstance [Type]
ctxt Type
typ' [Dec]
decs)
    convertDec Dec
_ = Maybe TypeclassInstance -> Q (Maybe TypeclassInstance)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TypeclassInstance
forall a. Maybe a
Nothing
#else
    convertDec (ClassInstance _ _ ctxt _ typs) = do
        let typ = foldl' AppT (ConT clz) typs
        typ' <- expandSyns typ
        return $ Just (TypeclassInstance ctxt typ' [])
#endif

-- | Returns the first 'TypeclassInstance' where 'instanceMatches'
-- returns true.
lookupInstance :: [TypeclassInstance] -> Name -> Maybe TypeclassInstance
lookupInstance :: [TypeclassInstance] -> Name -> Maybe TypeclassInstance
lookupInstance [TypeclassInstance]
xs Name
n = [TypeclassInstance] -> Maybe TypeclassInstance
forall a. [a] -> Maybe a
headMay ([TypeclassInstance] -> Maybe TypeclassInstance)
-> [TypeclassInstance] -> Maybe TypeclassInstance
forall a b. (a -> b) -> a -> b
$ (TypeclassInstance -> Bool)
-> [TypeclassInstance] -> [TypeclassInstance]
forall a. (a -> Bool) -> [a] -> [a]
filter (TypeclassInstance -> Name -> Bool
`instanceMatches` Name
n) [TypeclassInstance]
xs

-- | Checks if the given name is the head of one of the paramaters of
-- the given 'TypeclassInstance'.
instanceMatches :: TypeclassInstance -> Name -> Bool
instanceMatches :: TypeclassInstance -> Name -> Bool
instanceMatches (TypeclassInstance [Type]
_ Type
typ [Dec]
_) Name
n' =
    -- We call unSigT to prevent outermost kind signatures from affecting the
    -- results. We also call unSigT a second time on the head of the
    -- application, as older versions of th-expand-syns incorrectly pushed
    -- kind signatures inwards when expanding type synonyms. (See #9.)
    case [Maybe Type] -> Maybe [Maybe Type]
forall a. [a] -> Maybe [a]
tailMay ([Maybe Type] -> Maybe [Maybe Type])
-> [Maybe Type] -> Maybe [Maybe Type]
forall a b. (a -> b) -> a -> b
$ (Type -> Maybe Type) -> [Type] -> [Maybe Type]
forall a b. (a -> b) -> [a] -> [b]
map ((Type -> Type) -> Maybe Type -> Maybe Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
unSigT (Maybe Type -> Maybe Type)
-> (Type -> Maybe Type) -> Type -> Maybe Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type] -> Maybe Type
forall a. [a] -> Maybe a
headMay ([Type] -> Maybe Type) -> (Type -> [Type]) -> Type -> Maybe Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [Type]
unAppsT (Type -> [Type]) -> (Type -> Type) -> Type -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
unSigT) ([Type] -> [Maybe Type]) -> [Type] -> [Maybe Type]
forall a b. (a -> b) -> a -> b
$ Type -> [Type]
unAppsT Type
typ of
        Maybe [Maybe Type]
Nothing -> Bool
False
        Just [Maybe Type]
xs -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [() | Just (ConT Name
n) <- [Maybe Type]
xs, Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n']

-- | Breaks a type application like @A b c@ into [A, b, c].
unAppsT :: Type -> [Type]
unAppsT :: Type -> [Type]
unAppsT = [Type] -> Type -> [Type]
go []
  where
    go :: [Type] -> Type -> [Type]
go [Type]
xs (AppT Type
l Type
x) = [Type] -> Type -> [Type]
go (Type
x Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
xs) Type
l
    go [Type]
xs Type
ty = Type
ty Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
xs

-- | Remove any explicit kind signatures (i.e., 'SigT's) from a 'Type'.
unSigT :: Type -> Type
unSigT :: Type -> Type
unSigT (SigT Type
t Type
_) = Type -> Type
unSigT Type
t
unSigT Type
t          = Type
t