{-# 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

-- |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]
_ 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

-- 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) -> [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
        -- get all names bound in the decs and make them generic
        -- at every occurence in decs.
        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