{-# LANGUAGE CPP, TemplateHaskell #-}
module Language.Haskell.TH.Extras where

import Control.Monad
import Data.Generics
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Datatype.TyVarBndr

intIs64 :: Bool
intIs64 :: Bool
intIs64 = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
forall a. Bounded a => a
maxBound :: Int) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
32 :: Integer)

replace :: (a -> Maybe a) -> (a -> a)
replace :: forall a. (a -> Maybe a) -> a -> a
replace = (a -> Maybe a -> a) -> (a -> Maybe a) -> a -> a
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe

composeExprs :: [ExpQ] -> ExpQ
composeExprs :: [ExpQ] -> ExpQ
composeExprs [] = [| id |]
composeExprs [ExpQ
f] = ExpQ
f
composeExprs (ExpQ
f:[ExpQ]
fs) = [| $ExpQ
f . $([ExpQ] -> ExpQ
composeExprs [ExpQ]
fs) |]

-- | Determines the name of a data constructor. It's an error if the 'Con' binds more than one name (which
-- happens in the case where you use GADT syntax, and give multiple data constructor names separated by commas
-- in a type signature in the where clause).
nameOfCon :: Con -> Name
nameOfCon :: Con -> Name
nameOfCon (NormalC  Name
name [BangType]
_) = Name
name
nameOfCon (RecC     Name
name [VarBangType]
_) = Name
name
nameOfCon (InfixC BangType
_ Name
name BangType
_) = Name
name
nameOfCon (ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
con) = Con -> Name
nameOfCon Con
con
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800
nameOfCon (GadtC [Name
name] [BangType]
_ Type
_)    = Name
name
nameOfCon (GadtC [Name]
_ [BangType]
_ Type
_)    = [Char] -> Name
forall a. HasCallStack => [Char] -> a
error ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char]
"nameOfCon: GadtC: only single constructor names are supported"
nameOfCon (RecGadtC [Name
name] [VarBangType]
_ Type
_) = Name
name
nameOfCon (RecGadtC [Name]
_ [VarBangType]
_ Type
_)    = [Char] -> Name
forall a. HasCallStack => [Char] -> a
error ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char]
"nameOfCon: RecGadtC: only single constructor names are supported"
#endif

-- |WARNING: discards binders in GADTs and existentially-quantified constructors
argTypesOfCon :: Con -> [Type]
argTypesOfCon :: Con -> Cxt
argTypesOfCon (NormalC  Name
_ [BangType]
args) = (BangType -> Type) -> [BangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType]
args
argTypesOfCon (RecC     Name
_ [VarBangType]
args) = [Type
t | (Name
_,Bang
_,Type
t) <- [VarBangType]
args]
argTypesOfCon (InfixC BangType
x Name
_ BangType
y)    = (BangType -> Type) -> [BangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType
x,BangType
y]
argTypesOfCon (ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
con) = Con -> Cxt
argTypesOfCon Con
con
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800
argTypesOfCon (GadtC [Name]
_ [BangType]
args Type
_)    = (BangType -> Type) -> [BangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType]
args
argTypesOfCon (RecGadtC [Name]
_ [VarBangType]
args Type
_) = [Type
t | (Name
_,Bang
_,Type
t) <- [VarBangType]
args]
#endif

nameOfBinder :: TyVarBndr_ a -> Name
nameOfBinder :: forall a. TyVarBndr_ a -> Name
nameOfBinder = TyVarBndr_ a -> Name
forall a. TyVarBndr_ a -> Name
tvName

varsBoundInCon :: Con -> [TyVarBndrSpec]
varsBoundInCon :: Con -> [TyVarBndr Specificity]
varsBoundInCon (ForallC [TyVarBndr Specificity]
bndrs Cxt
_ Con
con) = [TyVarBndr Specificity]
bndrs [TyVarBndr Specificity]
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. [a] -> [a] -> [a]
++ Con -> [TyVarBndr Specificity]
varsBoundInCon Con
con
varsBoundInCon Con
_ = []

namesBoundInPat :: Pat -> [Name]
namesBoundInPat :: Pat -> [Name]
namesBoundInPat (VarP Name
name)             = [Name
name]
namesBoundInPat (TupP [Pat]
pats)             = [Pat]
pats [Pat] -> (Pat -> [Name]) -> [Name]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pat -> [Name]
namesBoundInPat
#if MIN_VERSION_template_haskell(2,18,0)
namesBoundInPat (ConP Name
_ Cxt
_ [Pat]
pats)         = [Pat]
pats [Pat] -> (Pat -> [Name]) -> [Name]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pat -> [Name]
namesBoundInPat
#else
namesBoundInPat (ConP _ pats)           = pats >>= namesBoundInPat
#endif
namesBoundInPat (InfixP Pat
p1 Name
_ Pat
p2)        = Pat -> [Name]
namesBoundInPat Pat
p1 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Pat -> [Name]
namesBoundInPat Pat
p2
namesBoundInPat (TildeP Pat
pat)            = Pat -> [Name]
namesBoundInPat Pat
pat
namesBoundInPat (AsP Name
name Pat
pat)          = Name
name Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: Pat -> [Name]
namesBoundInPat Pat
pat
namesBoundInPat (RecP Name
_ [FieldPat]
fieldPats)      = (FieldPat -> Pat) -> [FieldPat] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map FieldPat -> Pat
forall a b. (a, b) -> b
snd [FieldPat]
fieldPats [Pat] -> (Pat -> [Name]) -> [Name]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pat -> [Name]
namesBoundInPat
namesBoundInPat (ListP [Pat]
pats)            = [Pat]
pats [Pat] -> (Pat -> [Name]) -> [Name]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pat -> [Name]
namesBoundInPat
namesBoundInPat (SigP Pat
pat Type
_)            = Pat -> [Name]
namesBoundInPat Pat
pat

#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612
namesBoundInPat (BangP Pat
pat)             = Pat -> [Name]
namesBoundInPat Pat
pat
#endif

#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 700
namesBoundInPat (ViewP Exp
_ Pat
pat)           = Pat -> [Name]
namesBoundInPat Pat
pat
#endif

#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702
namesBoundInPat (UnboxedTupP [Pat]
pats)      = [Pat]
pats [Pat] -> (Pat -> [Name]) -> [Name]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pat -> [Name]
namesBoundInPat
#endif

namesBoundInPat Pat
_                       = []


namesBoundInDec :: Dec -> [Name]
namesBoundInDec :: Dec -> [Name]
namesBoundInDec (FunD Name
name [Clause]
_)                       = [Name
name]
namesBoundInDec (ValD Pat
pat Body
_ [Dec]
_)                      = Pat -> [Name]
namesBoundInPat Pat
pat

#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800
namesBoundInDec (DataD Cxt
_ Name
name [TyVarBndr ()]
_ Maybe Type
_ [Con]
_ [DerivClause]
_)              = [Name
name]
namesBoundInDec (NewtypeD Cxt
_ Name
name [TyVarBndr ()]
_ Maybe Type
_ Con
_ [DerivClause]
_)           = [Name
name]
#else
namesBoundInDec (DataD _ name _ _ _)                = [name]
namesBoundInDec (NewtypeD _ name _ _ _)             = [name]
#endif

namesBoundInDec (TySynD Name
name [TyVarBndr ()]
_ Type
_)                   = [Name
name]
namesBoundInDec (ClassD Cxt
_ Name
name [TyVarBndr ()]
_ [FunDep]
_ [Dec]
_)               = [Name
name]
namesBoundInDec (ForeignD (ImportF Callconv
_ Safety
_ [Char]
_ Name
name Type
_))   = [Name
name]

#if defined(__GLASGOW_HASKELL__)
#if __GLASGOW_HASKELL__ >= 800
namesBoundInDec (OpenTypeFamilyD (TypeFamilyHead Name
name [TyVarBndr ()]
_ FamilyResultSig
_ Maybe InjectivityAnn
_))     = [Name
name]
namesBoundInDec (ClosedTypeFamilyD (TypeFamilyHead Name
name [TyVarBndr ()]
_ FamilyResultSig
_ Maybe InjectivityAnn
_) [TySynEqn]
_) = [Name
name]
#elif __GLASGOW_HASKELL__ >= 612
namesBoundInDec (FamilyD _ name _ _)                = [name]
#endif
#endif

namesBoundInDec Dec
_                                   = []

genericalizeName :: Name -> Name
genericalizeName :: Name -> Name
genericalizeName = [Char] -> Name
mkName ([Char] -> Name) -> (Name -> [Char]) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
nameBase

-- Genericalize all names defined at the top level, to fix the lunacy introduced in GHC 7.2.
-- Why they should be fresh is beyond me; it really seems absurd because there is no way whatsoever
-- to refer to names known to be bound in [d||] quotes other than to scrounge around inside the
-- generated 'Dec's.
genericalizeDecs :: [Dec] -> [Dec]
genericalizeDecs :: [Dec] -> [Dec]
genericalizeDecs [Dec]
decs = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Name -> Name) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Name -> Name
fixName) [Dec]
decs
    where
        -- get all names bound in the decs and make them generic
        -- at every occurrence in decs.
        names :: [Name]
names = [Dec]
decs [Dec] -> (Dec -> [Name]) -> [Name]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Dec -> [Name]
namesBoundInDec
        genericalizedNames :: [(Name, Name)]
genericalizedNames = [ (Name
n, Name -> Name
genericalizeName Name
n) | Name
n <- [Name]
names]
        fixName :: Name -> Name
fixName = (Name -> Maybe Name) -> Name -> Name
forall a. (a -> Maybe a) -> a -> a
replace (Name -> [(Name, Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(Name, Name)]
genericalizedNames)

headOfType :: Type -> Name
headOfType :: Type -> Name
headOfType (ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
ty) = Type -> Name
headOfType Type
ty
headOfType (VarT Name
name) = Name
name
headOfType (ConT Name
name) = Name
name
headOfType (TupleT Int
n) = Int -> Name
tupleTypeName Int
n
headOfType Type
ArrowT = ''(->)
headOfType Type
ListT = ''[]
headOfType (AppT Type
t Type
_) = Type -> Name
headOfType Type
t
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612
headOfType (SigT Type
t Type
_) = Type -> Name
headOfType Type
t
#endif
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702
headOfType (UnboxedTupleT Int
n) = Int -> Name
unboxedTupleTypeName Int
n
#endif
#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704
headOfType Type
ty = [Char] -> Name
forall a. HasCallStack => [Char] -> a
error ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char]
"headOfType: Unhandled type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
ty
#endif

occursInType :: Name -> Type -> Bool
occursInType :: Name -> Type -> Bool
occursInType Name
var Type
ty = case Type
ty of
        ForallT [TyVarBndr Specificity]
bndrs Cxt
_ Type
ty'
            | (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name
var Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
==) ((TyVarBndr Specificity -> Name)
-> [TyVarBndr Specificity] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr Specificity -> Name
forall a. TyVarBndr_ a -> Name
tvName [TyVarBndr Specificity]
bndrs)
                -> Bool
False
            | Bool
otherwise
                -> Name -> Type -> Bool
occursInType Name
var Type
ty'
        VarT Name
name
            | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
var -> Bool
True
            | Bool
otherwise   -> Bool
False
        AppT Type
ty1 Type
ty2 -> Name -> Type -> Bool
occursInType Name
var Type
ty1 Bool -> Bool -> Bool
|| Name -> Type -> Bool
occursInType Name
var Type
ty2
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612
        SigT Type
ty' Type
_ -> Name -> Type -> Bool
occursInType Name
var Type
ty'
#endif
        Type
_ -> Bool
False

-- | Assuming that we're building an instance of the form C (T v_1 ... v_(n-1)) for some GADT T, this function
-- takes a list of the variables v_1 ... v_(n-1) used in the instance head, as well as the result type of some data
-- constructor, say T x_1 ... x_(n-1) x_n, as well as the type t of some argument to it, and substitutes any of
-- x_i (1 <= i <= n-1) occurring in t for the corresponding v_i, taking care to avoid name capture by foralls in t.
substVarsWith
  :: [Name] -- Names of variables used in the instance head in argument order
  -> Type -- Result type of constructor
  -> Type -- Type of argument to the constructor
  -> Type -- Type of argument with variables substituted for instance head variables.
substVarsWith :: [Name] -> Type -> Type -> Type
substVarsWith [Name]
topVars Type
resultType Type
argType = Set Name -> Type -> Type
subst Set Name
forall a. Set a
Set.empty Type
argType
  where
    topVars' :: [Name]
topVars' = [Name] -> [Name]
forall a. [a] -> [a]
reverse [Name]
topVars
    AppT Type
resultType' Type
_indexType = Type
resultType
    subst :: Set Name -> Type -> Type
    subst :: Set Name -> Type -> Type
subst Set Name
bs Type
ty = case Type
ty of
      -- Several of the following cases could all be covered by an "x -> x" case, but
      -- I'd rather know if new cases need to be handled specially in future versions
      -- of Template Haskell.
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 710
      ForallT [TyVarBndr Specificity]
bndrs Cxt
cxt Type
t ->
        let bs' :: Set Name
bs' = Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Name
bs ([Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ((TyVarBndr Specificity -> Name)
-> [TyVarBndr Specificity] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr Specificity -> Name
forall a. TyVarBndr_ a -> Name
tvName [TyVarBndr Specificity]
bndrs))
        in [TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT [TyVarBndr Specificity]
bndrs ((Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Set Name -> Type -> Type
subst Set Name
bs') Cxt
cxt) (Set Name -> Type -> Type
subst Set Name
bs' Type
t)
#else
      ForallT {} -> error "substVarsWith: ForallT substitutions have not been implemented for GHCs prior to 7.10"
#endif
      AppT Type
f Type
x -> Type -> Type -> Type
AppT (Set Name -> Type -> Type
subst Set Name
bs Type
f) (Set Name -> Type -> Type
subst Set Name
bs Type
x)
      SigT Type
t Type
k -> Type -> Type -> Type
SigT (Set Name -> Type -> Type
subst Set Name
bs Type
t) Type
k
      VarT Name
v -> if Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Name
v Set Name
bs
        then Name -> Type
VarT Name
v
        else Name -> Type
VarT (Name -> [Name] -> Type -> Name
forall {a}. Name -> [a] -> Type -> a
findVar Name
v [Name]
topVars' Type
resultType')
      ConT Name
n -> Name -> Type
ConT Name
n
      TupleT Int
k -> Int -> Type
TupleT Int
k
      Type
ArrowT -> Type
ArrowT
      Type
ListT -> Type
ListT
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800
      InfixT Type
t1 Name
x Type
t2 -> Type -> Name -> Type -> Type
InfixT (Set Name -> Type -> Type
subst Set Name
bs Type
t1) Name
x (Set Name -> Type -> Type
subst Set Name
bs Type
t2)
      ParensT Type
t -> Type -> Type
ParensT (Set Name -> Type -> Type
subst Set Name
bs Type
t)
      UInfixT Type
t1 Name
x Type
t2 -> Type -> Name -> Type -> Type
UInfixT (Set Name -> Type -> Type
subst Set Name
bs Type
t1) Name
x (Set Name -> Type -> Type
subst Set Name
bs Type
t2)
      Type
WildCardT -> Type
WildCardT
#endif
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 802
      UnboxedSumT Int
k -> Int -> Type
UnboxedSumT Int
k
#endif
#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 710
      Type
EqualityT -> Type
EqualityT
#endif
#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706
      Type
ConstraintT -> Type
ConstraintT
      LitT TyLit
l -> TyLit -> Type
LitT TyLit
l
      Type
PromotedConsT -> Type
PromotedConsT
      Type
PromotedNilT -> Type
PromotedNilT
      PromotedT Name
n -> Name -> Type
PromotedT Name
n
      PromotedTupleT Int
k -> Int -> Type
PromotedTupleT Int
k
      Type
StarT -> Type
StarT
#endif
#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 700
      UnboxedTupleT Int
k -> Int -> Type
UnboxedTupleT Int
k
#endif
    findVar :: Name -> [a] -> Type -> a
findVar Name
v (a
tv:[a]
_) (AppT Type
_ (VarT Name
v')) | Name
v Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
v' = a
tv
    findVar Name
v (a
_:[a]
tvs) (AppT Type
t (VarT Name
_)) = Name -> [a] -> Type -> a
findVar Name
v [a]
tvs Type
t
    findVar Name
v [a]
_ Type
_ = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
"substVarsWith: couldn't look up variable substitution for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
v
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" with topVars: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Name] -> [Char]
forall a. Show a => a -> [Char]
show [Name]
topVars [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" resultType: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
resultType [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" argType: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
argType

-- | Determine the arity of a kind.
-- Starting in template-haskell 2.8.0.0, 'Kind' and 'Type' became synonymous.
kindArity :: Kind -> Int
#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706
kindArity k = case k of
  StarK -> 0
  ArrowK _ k2 -> 1 + kindArity k2
#else
kindArity :: Type -> Int
kindArity Type
k = case Type
k of
  ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
t -> Type -> Int
kindArity Type
t
  AppT (AppT Type
ArrowT Type
_) Type
t -> Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Type -> Int
kindArity Type
t
  SigT Type
t Type
_ -> Type -> Int
kindArity Type
t
#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800
  ParensT Type
t -> Type -> Int
kindArity Type
t
#endif
  Type
_ -> Int
0
#endif

-- | Given the name of a type constructor, determine its full arity
tyConArity :: Name -> Q Int
tyConArity :: Name -> Q Int
tyConArity Name
n = do
  ([TyVarBndr ()]
ts, Int
ka) <- Name -> Q ([TyVarBndr ()], Int)
tyConArity' Name
n
  Int -> Q Int
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr ()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndr ()]
ts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ka)

-- | Given the name of a type constructor, determine a list of type variables bound as parameters by
-- its declaration, and the arity of the kind of type being defined (i.e. how many more arguments would
-- need to be supplied in addition to the bound parameters in order to obtain an ordinary type of kind *).
-- If the supplied 'Name' is anything other than a data or newtype, produces an error.
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 908
tyConArity' :: Name -> Q ([TyVarBndrUnit], Int)
#else
tyConArity' :: Name -> Q ([TyVarBndr BndrVis], Int)
#endif
tyConArity' :: Name -> Q ([TyVarBndr ()], Int)
tyConArity' Name
n = do
  Info
r <- Name -> Q Info
reify Name
n
  ([TyVarBndr ()], Int) -> Q ([TyVarBndr ()], Int)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (([TyVarBndr ()], Int) -> Q ([TyVarBndr ()], Int))
-> ([TyVarBndr ()], Int) -> Q ([TyVarBndr ()], Int)
forall a b. (a -> b) -> a -> b
$ case Info
r of
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800
    TyConI (DataD Cxt
_ Name
_ [TyVarBndr ()]
ts Maybe Type
mk [Con]
_ [DerivClause]
_) -> ([TyVarBndr ()]
ts, Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 ((Type -> Int) -> Maybe Type -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Int
kindArity Maybe Type
mk))
    TyConI (NewtypeD Cxt
_ Name
_ [TyVarBndr ()]
ts Maybe Type
mk Con
_ [DerivClause]
_) -> ([TyVarBndr ()]
ts, Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 ((Type -> Int) -> Maybe Type -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Int
kindArity Maybe Type
mk))
#else
    TyConI (DataD _ _ ts _ _) -> (ts, 0)
    TyConI (NewtypeD _ _ ts _ _) -> (ts, 0)
#endif
    Info
_ -> [Char] -> ([TyVarBndr ()], Int)
forall a. HasCallStack => [Char] -> a
error ([Char] -> ([TyVarBndr ()], Int))
-> [Char] -> ([TyVarBndr ()], Int)
forall a b. (a -> b) -> a -> b
$ [Char]
"tyConArity': Supplied name reified to something other than a data declaration: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
n

-- | Determine the constructors bound by a data or newtype declaration. Errors out if supplied with another
-- sort of declaration.
decCons :: Dec -> [Con]
decCons :: Dec -> [Con]
decCons Dec
d = case Dec
d of
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800
  DataD Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Type
_ [Con]
cs [DerivClause]
_ -> [Con]
cs
  NewtypeD Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Type
_ Con
c [DerivClause]
_ -> [Con
c]
#else
  DataD _ _ _ cs _ -> cs
  NewtypeD _ _ _ c _ -> [c]
#endif
  Dec
_ -> [Char] -> [Con]
forall a. HasCallStack => [Char] -> a
error [Char]
"decCons: Declaration found was not a data or newtype declaration."

-- | Determine the arity of a data constructor.
conArity :: Con -> Int
conArity :: Con -> Int
conArity Con
c = case Con
c of
  NormalC Name
_ [BangType]
ts -> [BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
ts
  RecC Name
_ [VarBangType]
ts -> [VarBangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
ts
  InfixC BangType
_ Name
_ BangType
_ -> Int
2
  ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
c' -> Con -> Int
conArity Con
c'
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800
  GadtC [Name]
_ [BangType]
ts Type
_ -> [BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
ts
  RecGadtC [Name]
_ [VarBangType]
ts Type
_ -> [VarBangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
ts
#endif