{-# 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` in template library does not work with polymorphic types.

-- The follwoing is an isInstance function with polymorphic type replaced by Any in GHC.Exts so that it can work with polymorphic type.

-- This is inspired by Ryan Scott

-- see https://ghc.haskell.org/trac/ghc/ticket/10607

-- isInstance will not work with Typeable.

-- See https://ghc.haskell.org/trac/ghc/ticket/11251


-- For fixing deriving Typeable problem, I use Data type calss to replace Typeable since the are always pairing with each other.

-- So if the data type is already an instance of Typeable and not an instance of Data, this might not work.

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]
-- get all free variablein a forall type expression.

#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 n2r  (UnboxedTupleT i) = undefined

-- constructorTypesVars n2r  (UnboxedSumT t) = undefined -- ghc 8.2.1

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 n2r  (WildCardT lit) = undefined

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])
-- need to remove types which contains scoped variables

#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

-- In the future of GHC, this will be removed.

-- See https://ghc.haskell.org/trac/ghc/ticket/13324

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) []
                            -- Need to remove phantom types

                            [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
                                  -- Eq a, Eq b ...

                                  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
                                  -- (Eq a, Eq b ...)

                                  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


-- A function which is not used

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
                                                 -- Unlifted types are not considered here.

                                                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