{-# LANGUAGE CPP, TemplateHaskell #-}
module Language.Haskell.TH.Extras where
import Control.Monad
import Data.Generics
import Data.Maybe
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
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
replace :: (a -> Maybe a) -> (a -> a)
replace :: (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) = [| $f . $(composeExprs fs) |]
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]
_ Cxt
_ Con
con) = Con -> Name
nameOfCon Con
con
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800
nameOfCon (GadtC [Name
name] [BangType]
_ Type
_) = Name
name
nameOfCon (RecGadtC [Name
name] [VarBangType]
_ Type
_) = Name
name
#endif
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]
_ 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 -> Name
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 700
nameOfBinder :: TyVarBndr -> Name
nameOfBinder (PlainTV Name
n) = Name
n
nameOfBinder (KindedTV Name
n Type
_) = Name
n
#else
nameOfBinder = id
type TyVarBndr = Name
#endif
varsBoundInCon :: Con -> [TyVarBndr]
varsBoundInCon :: Con -> [TyVarBndr]
varsBoundInCon (ForallC [TyVarBndr]
bndrs Cxt
_ Con
con) = [TyVarBndr]
bndrs [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ Con -> [TyVarBndr]
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pat -> [Name]
namesBoundInPat
namesBoundInPat (ConP Name
_ [Pat]
pats) = [Pat]
pats [Pat] -> (Pat -> [Name]) -> [Name]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pat -> [Name]
namesBoundInPat
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 (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 (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 (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
_ String
_ 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 = String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
genericalizeDecs :: [Dec] -> [Dec]
genericalizeDecs :: [Dec] -> [Dec]
genericalizeDecs [Dec]
decs = (forall a. Data a => a -> a) -> [Dec] -> [Dec]
(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
names :: [Name]
names = [Dec]
decs [Dec] -> (Dec -> [Name]) -> [Name]
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]
_ 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
occursInType :: Name -> Type -> Bool
occursInType :: Name -> Type -> Bool
occursInType Name
var Type
ty = case Type
ty of
ForallT [TyVarBndr]
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 -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
nameOfBinder [TyVarBndr]
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