{-# 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)
isDataDec :: Dec -> Bool
isDataDec :: Dec -> Bool
isDataDec DataD {} = Bool
True
isDataDec NewtypeD {} = Bool
True
isDataDec Dec
_ = Bool
False
isNormalTyCon :: Dec -> Bool
isNormalTyCon :: Dec -> Bool
isNormalTyCon DataD {} = Bool
True
isNormalTyCon NewtypeD {} = Bool
True
isNormalTyCon TySynD {} = Bool
True
isNormalTyCon Dec
_ = Bool
False
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
_ = []
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 Specificity]
_ [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
typeConcreteNames :: Type -> [Name]
typeConcreteNames :: Type -> [Name]
typeConcreteNames (ForallT [TyVarBndr Specificity]
_ [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
_ = []
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
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
$cshowsPrec :: Int -> TypeclassInstance -> ShowS
showsPrec :: Int -> TypeclassInstance -> ShowS
$cshow :: TypeclassInstance -> String
show :: TypeclassInstance -> String
$cshowList :: [TypeclassInstance] -> ShowS
showList :: [TypeclassInstance] -> ShowS
Show
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 a b. (a -> b) -> Q a -> Q b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Dec -> Q (Maybe TypeclassInstance)
convertDec [Dec]
xs
Info
_ -> String -> Q [TypeclassInstance]
forall a. String -> Q a
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 a. a -> Q a
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 a. a -> Q a
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
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
instanceMatches :: TypeclassInstance -> Name -> Bool
instanceMatches :: TypeclassInstance -> Name -> Bool
instanceMatches (TypeclassInstance [Type]
_ Type
typ [Dec]
_) Name
n' =
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 a b. (a -> b) -> Maybe a -> Maybe b
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 a. [a] -> 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']
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
unSigT :: Type -> Type
unSigT :: Type -> Type
unSigT (SigT Type
t Type
_) = Type -> Type
unSigT Type
t
unSigT Type
t = Type
t