{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
module Data.Derive.TopDown.Lib (
isInstance'
, generateClassContext
, getTyVarCons,getTVBName
, getCompositeTypeNames
, ClassName
, TypeName
, decType
, DecTyType(..)
,getTypeConstructor
) where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax hiding (lift)
import Data.Generics (mkT,everywhere,mkQ,everything)
import GHC.Exts
import Language.Haskell.TH.ExpandSyns (expandSyns)
import Data.List (nub,intersect,foldr1)
import Control.Monad.State
import Control.Monad.Trans
#ifdef __GLASGOW_HASKELL__
import Data.Typeable
import Data.Data
#endif
isInstance' :: Name -> [Type] -> Q Bool
isInstance' :: Name -> [Type] -> Q Bool
isInstance' Name
className [Type]
tys =
if Name
className Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Typeable
then
Name -> [Type] -> Q Bool
isInstance' ''Data [Type]
tys
else
Name -> [Type] -> Q Bool
isInstance Name
className ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type
removeExplicitForAllTrans(Type -> Type) -> (Type -> Type) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
replacePolyTypeTrans) [Type]
tys)
replacePolyType :: Type -> Type
replacePolyType :: Type -> Type
replacePolyType (VarT Name
t) = Name -> Type
ConT ''Any
replacePolyType Type
x = Type
x
replacePolyTypeTrans :: Type -> Type
replacePolyTypeTrans = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Type -> Type) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Type -> Type
replacePolyType)
removeExplicitForAll :: Type -> Type
removeExplicitForAll :: Type -> Type
removeExplicitForAll (ForallT [TyVarBndr]
_ [Type]
_ Type
t) = Type
t
removeExplicitForAll Type
t = Type
t
removeExplicitForAllTrans :: Type -> Type
removeExplicitForAllTrans :: Type -> Type
removeExplicitForAllTrans = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Type -> Type) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Type -> Type
removeExplicitForAll)
getVarName :: Type -> [Name]
getVarName :: Type -> [Name]
getVarName (VarT Name
n) = [Name
n]
getVarName Type
_ = []
getAllVarNames :: Type -> [Name]
getAllVarNames :: Type -> [Name]
getAllVarNames = ([Name] -> [Name] -> [Name]) -> GenericQ [Name] -> GenericQ [Name]
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
(++) ([Name] -> (Type -> [Name]) -> a -> [Name]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ [] Type -> [Name]
getVarName)
constructorTypesVars :: [(Name, Role)] -> Type -> [Type]
#if __GLASGOW_HASKELL__ > 810
constructorTypesVars n2r f@(ForallT tvbs _ t) = let scopedVarNames = map (getTVBName.voidTyVarBndrFlag) tvbs in
filter (\x -> null $ intersect (getAllVarNames x) scopedVarNames)
(constructorTypesVars n2r t)
#else
constructorTypesVars :: [(Name, Role)] -> Type -> [Type]
constructorTypesVars [(Name, Role)]
n2r f :: Type
f@(ForallT [TyVarBndr]
tvbs [Type]
_ Type
t) = let scopedVarNames :: [Name]
scopedVarNames = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
getTVBName [TyVarBndr]
tvbs in
(Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Type
x -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Name] -> Bool) -> [Name] -> Bool
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
intersect (Type -> [Name]
getAllVarNames Type
x) [Name]
scopedVarNames)
([(Name, Role)] -> Type -> [Type]
constructorTypesVars [(Name, Role)]
n2r Type
t)
#endif
constructorTypesVars [(Name, Role)]
n2r a :: Type
a@(AppT (VarT Name
tvn) Type
t2) = [Type
a]
constructorTypesVars [(Name, Role)]
n2r c :: Type
c@(AppT (ConT Name
name) Type
t) = [(Name, Role)] -> Type -> [Type]
constructorTypesVars [(Name, Role)]
n2r Type
t
constructorTypesVars [(Name, Role)]
n2r c :: Type
c@(AppT Type
t1 Type
t2) = [(Name, Role)] -> Type -> [Type]
constructorTypesVars [(Name, Role)]
n2r Type
t1 [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [(Name, Role)] -> Type -> [Type]
constructorTypesVars [(Name, Role)]
n2r Type
t2
constructorTypesVars [(Name, Role)]
n2r v :: Type
v@(VarT Name
name) = case Name -> [(Name, Role)] -> Maybe Role
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
name [(Name, Role)]
n2r of
Just Role
PhantomR -> []
Maybe Role
_ -> [Type
v]
constructorTypesVars [(Name, Role)]
n2r c :: Type
c@(ConT Name
name) = []
constructorTypesVars [(Name, Role)]
n2r (PromotedT Name
name) = []
#if __GLASGOW_HASKELL__ > 710
constructorTypesVars [(Name, Role)]
n2r (InfixT Type
t1 Name
name Type
t2) = [(Name, Role)] -> Type -> [Type]
constructorTypesVars [(Name, Role)]
n2r Type
t1 [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [(Name, Role)] -> Type -> [Type]
constructorTypesVars [(Name, Role)]
n2r Type
t2
constructorTypesVars [(Name, Role)]
n2r (UInfixT Type
t1 Name
name Type
t2) = [(Name, Role)] -> Type -> [Type]
constructorTypesVars [(Name, Role)]
n2r Type
t1 [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [(Name, Role)] -> Type -> [Type]
constructorTypesVars [(Name, Role)]
n2r Type
t2
constructorTypesVars [(Name, Role)]
n2r (ParensT Type
t) = [(Name, Role)] -> Type -> [Type]
constructorTypesVars [(Name, Role)]
n2r Type
t
#endif
constructorTypesVars [(Name, Role)]
n2r (TupleT Int
i) = []
constructorTypesVars [(Name, Role)]
n2r (Type
ListT ) = []
constructorTypesVars [(Name, Role)]
n2r (Type
EqualityT) = []
constructorTypesVars [(Name, Role)]
n2r (PromotedTupleT Int
i) = []
constructorTypesVars [(Name, Role)]
n2r (Type
PromotedNilT) = []
constructorTypesVars [(Name, Role)]
n2r (Type
PromotedConsT) = []
constructorTypesVars [(Name, Role)]
n2r (LitT TyLit
lit) = []
constructorTypesVars [(Name, Role)]
n2r (Type
ConstraintT) = []
constructorTypesVars [(Name, Role)]
n2r (Type
ArrowT) = []
constructorTypesVars [(Name, Role)]
n2r Type
t = [Char] -> [Type]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Type]) -> [Char] -> [Type]
forall a b. (a -> b) -> a -> b
$ Type -> [Char]
forall a. Ppr a => a -> [Char]
pprint Type
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not support"
expandSynsAndGetContextTypes :: [(Name, Role)] -> Type -> Q [Type]
expandSynsAndGetContextTypes :: [(Name, Role)] -> Type -> Q [Type]
expandSynsAndGetContextTypes [(Name, Role)]
n2r Type
t = do
Type
t' <- Type -> Q Type
expandSyns Type
t
[Type] -> Q [Type]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> Q [Type]) -> [Type] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ ([(Name, Role)] -> Type -> [Type]
constructorTypesVars [(Name, Role)]
n2r Type
t')
third :: (a, b, c) -> c
third (a
a,b
b,c
c) = c
c
getContextType :: [(Name, Role)] -> Con -> Q [Type]
getContextType :: [(Name, Role)] -> Con -> Q [Type]
getContextType [(Name, Role)]
name2role (NormalC Name
name [BangType]
bangtypes) = ([[Type]] -> [Type]) -> Q [[Type]] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Type]] -> Q [Type]) -> Q [[Type]] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ (Type -> Q [Type]) -> [Type] -> Q [[Type]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([(Name, Role)] -> Type -> Q [Type]
expandSynsAndGetContextTypes [(Name, Role)]
name2role) ((BangType -> Type) -> [BangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType]
bangtypes)
getContextType [(Name, Role)]
name2role (RecC Name
name [VarBangType]
varbangtypes) = ([[Type]] -> [Type]) -> Q [[Type]] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Type]] -> Q [Type]) -> Q [[Type]] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ (Type -> Q [Type]) -> [Type] -> Q [[Type]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([(Name, Role)] -> Type -> Q [Type]
expandSynsAndGetContextTypes [(Name, Role)]
name2role) ((VarBangType -> Type) -> [VarBangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Type
forall a b c. (a, b, c) -> c
third [VarBangType]
varbangtypes)
getContextType [(Name, Role)]
name2role (InfixC BangType
bangtype1 Name
name BangType
bangtype2) = ([[Type]] -> [Type]) -> Q [[Type]] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Type]] -> Q [Type]) -> Q [[Type]] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ (Type -> Q [Type]) -> [Type] -> Q [[Type]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([(Name, Role)] -> Type -> Q [Type]
expandSynsAndGetContextTypes [(Name, Role)]
name2role) ((BangType -> Type) -> [BangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType
bangtype1, BangType
bangtype2])
#if __GLASGOW_HASKELL__>810
getContextType name2role (ForallC tvbs _ con) = let scopedVarNames = map (getTVBName.voidTyVarBndrFlag) tvbs in
do
types <- (getContextType name2role) con
let ty_vars = filter (\ty -> (null $ intersect (getAllVarNames ty) scopedVarNames)) types
fmap concat $ mapM (expandSynsAndGetContextTypes name2role) ty_vars
#else
getContextType [(Name, Role)]
name2role (ForallC [TyVarBndr]
tvbs [Type]
_ Con
con) = let scopedVarNames :: [Name]
scopedVarNames = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
getTVBName [TyVarBndr]
tvbs in
do
[Type]
types <- ([(Name, Role)] -> Con -> Q [Type]
getContextType [(Name, Role)]
name2role) Con
con
let ty_vars :: [Type]
ty_vars = (Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Type
ty -> ([Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Name] -> Bool) -> [Name] -> Bool
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
intersect (Type -> [Name]
getAllVarNames Type
ty) [Name]
scopedVarNames)) [Type]
types
([[Type]] -> [Type]) -> Q [[Type]] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Type]] -> Q [Type]) -> Q [[Type]] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ (Type -> Q [Type]) -> [Type] -> Q [[Type]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([(Name, Role)] -> Type -> Q [Type]
expandSynsAndGetContextTypes [(Name, Role)]
name2role) [Type]
ty_vars
#endif
#if __GLASGOW_HASKELL__ > 710
getContextType [(Name, Role)]
name2role (GadtC [Name]
name [BangType]
bangtypes Type
result_type) = ([[Type]] -> [Type]) -> Q [[Type]] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Type]] -> Q [Type]) -> Q [[Type]] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ (Type -> Q [Type]) -> [Type] -> Q [[Type]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([(Name, Role)] -> Type -> Q [Type]
expandSynsAndGetContextTypes [(Name, Role)]
name2role) ((BangType -> Type) -> [BangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType]
bangtypes)
getContextType [(Name, Role)]
name2role (RecGadtC [Name]
name [VarBangType]
bangtypes Type
result_type) = ([[Type]] -> [Type]) -> Q [[Type]] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Type]] -> Q [Type]) -> Q [[Type]] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ (Type -> Q [Type]) -> [Type] -> Q [[Type]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([(Name, Role)] -> Type -> Q [Type]
expandSynsAndGetContextTypes [(Name, Role)]
name2role) ((VarBangType -> Type) -> [VarBangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Type
forall a b c. (a, b, c) -> c
third [VarBangType]
bangtypes)
#endif
#if __GLASGOW_HASKELL__ > 810
getTyVarCons :: ClassName -> TypeName -> StateT [Type] Q ([TyVarBndr ()], [Con])
#else
getTyVarCons :: ClassName -> TypeName -> StateT [Type] Q ([TyVarBndr], [Con])
#endif
getTyVarCons :: Name -> Name -> StateT [Type] Q ([TyVarBndr], [Con])
getTyVarCons Name
cn Name
name = do
Info
info <- Q Info -> StateT [Type] Q Info
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Info -> StateT [Type] Q Info) -> Q Info -> StateT [Type] Q Info
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
name
case Info
info of
TyConI Dec
dec -> case Dec
dec of
#if __GLASGOW_HASKELL__ > 810
DataD _ _ tvbs _ cons _ -> return (map voidTyVarBndrFlag tvbs, cons)
NewtypeD _ _ tvbs _ con _-> return (map voidTyVarBndrFlag tvbs, [con])
#endif
#if __GLASGOW_HASKELL__ > 710 && __GLASGOW_HASKELL__ <= 810
DataD [Type]
_ Name
_ [TyVarBndr]
tvbs Maybe Type
_ [Con]
cons [DerivClause]
_ -> ([TyVarBndr], [Con]) -> StateT [Type] Q ([TyVarBndr], [Con])
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr]
tvbs, [Con]
cons)
NewtypeD [Type]
_ Name
_ [TyVarBndr]
tvbs Maybe Type
_ Con
con [DerivClause]
_-> ([TyVarBndr], [Con]) -> StateT [Type] Q ([TyVarBndr], [Con])
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr]
tvbs, [Con
con])
#endif
#if __GLASGOW_HASKELL__ <= 710
DataD _ _ tvbs cons _ -> return (tvbs, cons)
NewtypeD _ _ tvbs con _-> return (tvbs, [con])
#endif
TySynD Name
name [TyVarBndr]
tvbs Type
t -> [Char] -> StateT [Type] Q ([TyVarBndr], [Con])
forall a. HasCallStack => [Char] -> a
error ([Char] -> StateT [Type] Q ([TyVarBndr], [Con]))
-> [Char] -> StateT [Type] Q ([TyVarBndr], [Con])
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is a type synonym and -XTypeSynonymInstances is not supported. If you did not derive it then This is a bug, please report this bug to the author of this package."
Dec
x -> do
[Type]
tys <- StateT [Type] Q [Type]
forall s (m :: * -> *). MonadState s m => m s
get
[Char] -> StateT [Type] Q ([TyVarBndr], [Con])
forall a. HasCallStack => [Char] -> a
error ([Char] -> StateT [Type] Q ([TyVarBndr], [Con]))
-> [Char] -> StateT [Type] Q ([TyVarBndr], [Con])
forall a b. (a -> b) -> a -> b
$ Dec -> [Char]
forall a. Ppr a => a -> [Char]
pprint Dec
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not a data or newtype definition. " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
"Stack: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Type] -> [Char]
forall a. Show a => a -> [Char]
show [Type]
tys
Info
_ -> [Char] -> StateT [Type] Q ([TyVarBndr], [Con])
forall a. HasCallStack => [Char] -> a
error ([Char] -> StateT [Type] Q ([TyVarBndr], [Con]))
-> [Char] -> StateT [Type] Q ([TyVarBndr], [Con])
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot generate "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
cn [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" instances for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
name
type ClassName = Name
type TypeName = Name
#if __GLASGOW_HASKELL__ > 810
voidTyVarBndrFlag :: TyVarBndr flag -> TyVarBndr ()
voidTyVarBndrFlag (PlainTV n f) = PlainTV n ()
voidTyVarBndrFlag (KindedTV n f k) = KindedTV n () k
#endif
generateClassContext :: ClassName -> TypeName -> Q (Maybe Type)
generateClassContext :: Name -> Name -> Q (Maybe Type)
generateClassContext Name
classname Name
typename = do
([TyVarBndr]
tvbs, [Con]
cons) <- (StateT [Type] Q ([TyVarBndr], [Con])
-> [Type] -> Q ([TyVarBndr], [Con])
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (StateT [Type] Q ([TyVarBndr], [Con])
-> [Type] -> Q ([TyVarBndr], [Con]))
-> StateT [Type] Q ([TyVarBndr], [Con])
-> [Type]
-> Q ([TyVarBndr], [Con])
forall a b. (a -> b) -> a -> b
$ Name -> Name -> StateT [Type] Q ([TyVarBndr], [Con])
getTyVarCons Name
classname Name
typename) []
[Role]
roles <- Name -> Q [Role]
reifyRoles Name
typename
let varName2Role :: [(Name, Role)]
varName2Role = [Name] -> [Role] -> [(Name, Role)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
getTVBName [TyVarBndr]
tvbs) [Role]
roles
[Type]
types <- ([Type] -> [Type]) -> Q [Type] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Type] -> [Type]
forall a. Eq a => [a] -> [a]
nub (Q [Type] -> Q [Type]) -> Q [Type] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ ([[Type]] -> [Type]) -> Q [[Type]] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Type]] -> Q [Type]) -> Q [[Type]] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ (Con -> Q [Type]) -> [Con] -> Q [[Type]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([(Name, Role)] -> Con -> Q [Type]
getContextType [(Name, Role)]
varName2Role) [Con]
cons
let len :: Int
len = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
types
if Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then Maybe Type -> Q (Maybe Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Type
forall a. Maybe a
Nothing
else do
let contexts :: [Type]
contexts = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type -> Type
AppT (Name -> Type
ConT Name
classname)) [Type]
types
let contextTuple :: Type
contextTuple = (Type -> Type -> Type) -> [Type] -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Type -> Type -> Type
AppT ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (Int -> Type
TupleT Int
len) Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
contexts
Maybe Type -> Q (Maybe Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Type -> Q (Maybe Type)) -> Maybe Type -> Q (Maybe Type)
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Type
forall a. a -> Maybe a
Just Type
contextTuple
#if __GLASGOW_HASKELL__ > 810
getTVBName :: TyVarBndr () -> Name
getTVBName (PlainTV name _) = name
getTVBName (KindedTV name _ _) = name
#else
getTVBName :: TyVarBndr -> Name
getTVBName :: TyVarBndr -> Name
getTVBName (PlainTV Name
name) = Name
name
getTVBName (KindedTV Name
name Type
_) = Name
name
#endif
getTypeNames :: Type -> [Name]
getTypeNames :: Type -> [Name]
getTypeNames (ForallT [TyVarBndr]
tvbs [Type]
cxt Type
t) = Type -> [Name]
getTypeNames Type
t
getTypeNames (ConT Name
n) = [Name
n]
getTypeNames (AppT Type
t1 Type
t2) = Type -> [Name]
getTypeNames Type
t1 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Type -> [Name]
getTypeNames Type
t2
getTypeNames Type
_ = []
expandSynsAndGetTypeNames :: [Type] -> Q [TypeName]
expandSynsAndGetTypeNames :: [Type] -> Q [Name]
expandSynsAndGetTypeNames [Type]
ts = do
[Type]
ts' <- (Type -> Q Type) -> [Type] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
expandSyns [Type]
ts
[Name] -> Q [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> Q [Name]) -> [Name] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ (Type -> [Name]) -> [Type] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type -> [Name]
getTypeNames [Type]
ts'
getCompositeTypeNames :: Con -> Q [TypeName]
getCompositeTypeNames :: Con -> Q [Name]
getCompositeTypeNames (NormalC Name
n [BangType]
bts) = [Type] -> Q [Name]
expandSynsAndGetTypeNames ((BangType -> Type) -> [BangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType]
bts)
getCompositeTypeNames (RecC Name
n [VarBangType]
vbts) = [Type] -> Q [Name]
expandSynsAndGetTypeNames ((VarBangType -> Type) -> [VarBangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Type
forall a b c. (a, b, c) -> c
third [VarBangType]
vbts)
getCompositeTypeNames (InfixC BangType
st1 Name
n BangType
st2) = [Type] -> Q [Name]
expandSynsAndGetTypeNames ((BangType -> Type) -> [BangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType
st1 , BangType
st2])
getCompositeTypeNames (ForallC [TyVarBndr]
bind [Type]
context Con
con) = Con -> Q [Name]
getCompositeTypeNames Con
con
#if __GLASGOW_HASKELL__> 710
getCompositeTypeNames (GadtC [Name]
name [BangType]
bangtype Type
resulttype) = [Type] -> Q [Name]
expandSynsAndGetTypeNames ((BangType -> Type) -> [BangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType]
bangtype)
getCompositeTypeNames (RecGadtC [Name]
name [VarBangType]
bangtypes Type
result_type) = [Type] -> Q [Name]
expandSynsAndGetTypeNames ((VarBangType -> Type) -> [VarBangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Type
forall a b c. (a, b, c) -> c
third [VarBangType]
bangtypes)
#endif
#if __GLASGOW_HASKELL__ > 810
tvb2kind :: TyVarBndr a -> Kind
tvb2kind (PlainTV n _) = StarT
tvb2kind (KindedTV n _ kind) = kind
#else
tvb2kind :: TyVarBndr -> Kind
tvb2kind :: TyVarBndr -> Type
tvb2kind (PlainTV Name
n) = Type
StarT
tvb2kind (KindedTV Name
n Type
kind) = Type
kind
#endif
data DecTyType = Data | Newtype | TypeSyn | BuiltIn deriving (Int -> DecTyType -> [Char] -> [Char]
[DecTyType] -> [Char] -> [Char]
DecTyType -> [Char]
(Int -> DecTyType -> [Char] -> [Char])
-> (DecTyType -> [Char])
-> ([DecTyType] -> [Char] -> [Char])
-> Show DecTyType
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [DecTyType] -> [Char] -> [Char]
$cshowList :: [DecTyType] -> [Char] -> [Char]
show :: DecTyType -> [Char]
$cshow :: DecTyType -> [Char]
showsPrec :: Int -> DecTyType -> [Char] -> [Char]
$cshowsPrec :: Int -> DecTyType -> [Char] -> [Char]
Show, Int -> DecTyType
DecTyType -> Int
DecTyType -> [DecTyType]
DecTyType -> DecTyType
DecTyType -> DecTyType -> [DecTyType]
DecTyType -> DecTyType -> DecTyType -> [DecTyType]
(DecTyType -> DecTyType)
-> (DecTyType -> DecTyType)
-> (Int -> DecTyType)
-> (DecTyType -> Int)
-> (DecTyType -> [DecTyType])
-> (DecTyType -> DecTyType -> [DecTyType])
-> (DecTyType -> DecTyType -> [DecTyType])
-> (DecTyType -> DecTyType -> DecTyType -> [DecTyType])
-> Enum DecTyType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: DecTyType -> DecTyType -> DecTyType -> [DecTyType]
$cenumFromThenTo :: DecTyType -> DecTyType -> DecTyType -> [DecTyType]
enumFromTo :: DecTyType -> DecTyType -> [DecTyType]
$cenumFromTo :: DecTyType -> DecTyType -> [DecTyType]
enumFromThen :: DecTyType -> DecTyType -> [DecTyType]
$cenumFromThen :: DecTyType -> DecTyType -> [DecTyType]
enumFrom :: DecTyType -> [DecTyType]
$cenumFrom :: DecTyType -> [DecTyType]
fromEnum :: DecTyType -> Int
$cfromEnum :: DecTyType -> Int
toEnum :: Int -> DecTyType
$ctoEnum :: Int -> DecTyType
pred :: DecTyType -> DecTyType
$cpred :: DecTyType -> DecTyType
succ :: DecTyType -> DecTyType
$csucc :: DecTyType -> DecTyType
Enum, DecTyType -> DecTyType -> Bool
(DecTyType -> DecTyType -> Bool)
-> (DecTyType -> DecTyType -> Bool) -> Eq DecTyType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DecTyType -> DecTyType -> Bool
$c/= :: DecTyType -> DecTyType -> Bool
== :: DecTyType -> DecTyType -> Bool
$c== :: DecTyType -> DecTyType -> Bool
Eq)
decType :: Name -> Q DecTyType
decType :: Name -> Q DecTyType
decType Name
name = do
Info
info <- Name -> Q Info
reify Name
name
case Info
info of
TyConI Dec
dec -> case Dec
dec of
#if __GLASGOW_HASKELL__ > 710
DataD [Type]
_ Name
_ [TyVarBndr]
tvbs Maybe Type
_ [Con]
cons [DerivClause]
_ -> DecTyType -> Q DecTyType
forall (m :: * -> *) a. Monad m => a -> m a
return DecTyType
Data
NewtypeD [Type]
_ Name
_ [TyVarBndr]
tvbs Maybe Type
_ Con
con [DerivClause]
_ -> DecTyType -> Q DecTyType
forall (m :: * -> *) a. Monad m => a -> m a
return DecTyType
Newtype
#else
DataD _ _ tvbs cons _ -> return Data
NewtypeD _ _ tvbs con _ -> return Newtype
#endif
TySynD Name
name [TyVarBndr]
tvbs Type
t -> DecTyType -> Q DecTyType
forall (m :: * -> *) a. Monad m => a -> m a
return DecTyType
TypeSyn
PrimTyConI Name
name Int
arity Bool
unlifted -> DecTyType -> Q DecTyType
forall (m :: * -> *) a. Monad m => a -> m a
return DecTyType
BuiltIn
getKind :: Name -> Q Kind
getKind :: Name -> Q Type
getKind Name
name = do
Info
info <- Name -> Q Info
reify Name
name
case Info
info of
TyConI Dec
dec -> case Dec
dec of
#if __GLASGOW_HASKELL__ > 710
DataD [Type]
_ Name
_ [TyVarBndr]
tvbs Maybe Type
_ [Con]
cons [DerivClause]
_ -> case [TyVarBndr]
tvbs of
[] -> Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
StarT
[TyVarBndr]
xs -> Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return ((Type -> Type -> Type) -> [Type] -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
AppT ((TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
tvb2kind [TyVarBndr]
xs))
NewtypeD [Type]
_ Name
_ [TyVarBndr]
tvbs Maybe Type
_ Con
con [DerivClause]
_ -> case [TyVarBndr]
tvbs of
[] -> Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
StarT
[TyVarBndr]
xs -> Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return ((Type -> Type -> Type) -> [Type] -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
AppT ((TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
tvb2kind [TyVarBndr]
xs))
#else
DataD _ _ tvbs cons _ -> case tvbs of
[] -> return StarT
xs -> return (foldr1 AppT (map tvb2kind xs))
NewtypeD _ _ tvbs con _ -> case tvbs of
[] -> return StarT
xs -> return (foldr1 AppT (map tvb2kind xs))
#endif
PrimTyConI Name
name Int
arity Bool
unlifted -> case Int
arity of
Int
0 -> Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
StarT
Int
n -> Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return ((Type -> Type -> Type) -> [Type] -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Type
x Type
y -> Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
ArrowT Type
x) Type
y) (Int -> Type -> [Type]
forall a. Int -> a -> [a]
replicate Int
arity Type
StarT))
getTypeConstructor :: Type -> Type
getTypeConstructor :: Type -> Type
getTypeConstructor (AppT Type
a1 Type
a2) = Type -> Type
getTypeConstructor Type
a1
getTypeConstructor Type
a = Type
a