th-extras-0.0.0.4/0000755000000000000000000000000012715720050011755 5ustar0000000000000000th-extras-0.0.0.4/Setup.lhs0000644000000000000000000000011612715720050013563 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain th-extras-0.0.0.4/th-extras.cabal0000644000000000000000000000266112715720050014665 0ustar0000000000000000name: th-extras version: 0.0.0.4 stability: experimental cabal-version: >= 1.6 build-type: Simple author: James Cook maintainer: James Cook license: PublicDomain homepage: https://github.com/mokus0/th-extras category: Template Haskell synopsis: A grab bag of functions for use with Template Haskell description: A grab bag of functions for use with Template Haskell. . This is basically the place I put all my ugly CPP hacks to support the ever-changing interface of the template haskell system by providing high-level operations and making sure they work on as many versions of Template Haskell as I can. tested-with: GHC == 6.8.3, GHC == 6.10.4, GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1, GHC == 7.2.2 source-repository head type: git location: https://github.com/mokus0/th-extras.git flag base4 default: True Library hs-source-dirs: src exposed-modules: Language.Haskell.TH.Extras build-depends: base >= 3 && < 5, template-haskell if flag(base4) build-depends: base >= 4, syb th-extras-0.0.0.4/src/0000755000000000000000000000000012715720050012544 5ustar0000000000000000th-extras-0.0.0.4/src/Language/0000755000000000000000000000000012715720050014267 5ustar0000000000000000th-extras-0.0.0.4/src/Language/Haskell/0000755000000000000000000000000012715720050015652 5ustar0000000000000000th-extras-0.0.0.4/src/Language/Haskell/TH/0000755000000000000000000000000012715720050016165 5ustar0000000000000000th-extras-0.0.0.4/src/Language/Haskell/TH/Extras.hs0000644000000000000000000001263112715720050017772 0ustar0000000000000000{-# 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 = toInteger (maxBound :: Int) > 2^32 replace :: (a -> Maybe a) -> (a -> a) replace = ap fromMaybe composeExprs :: [ExpQ] -> ExpQ composeExprs [] = [| id |] composeExprs [f] = f composeExprs (f:fs) = [| $f . $(composeExprs fs) |] nameOfCon :: Con -> Name nameOfCon (NormalC name _) = name nameOfCon (RecC name _) = name nameOfCon (InfixC _ name _) = name nameOfCon (ForallC _ _ con) = nameOfCon con #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 nameOfCon (GadtC [name] _ _) = name nameOfCon (RecGadtC [name] _ _) = name #endif -- |WARNING: discards binders in GADTs and existentially-quantified constructors argTypesOfCon :: Con -> [Type] argTypesOfCon (NormalC _ args) = map snd args argTypesOfCon (RecC _ args) = [t | (_,_,t) <- args] argTypesOfCon (InfixC x _ y) = map snd [x,y] argTypesOfCon (ForallC _ _ con) = argTypesOfCon con #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 argTypesOfCon (GadtC _ args _) = map snd args argTypesOfCon (RecGadtC _ args _) = [t | (_,_,t) <- args] #endif nameOfBinder :: TyVarBndr -> Name #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 700 nameOfBinder (PlainTV n) = n nameOfBinder (KindedTV n _) = n #else nameOfBinder = id type TyVarBndr = Name #endif varsBoundInCon :: Con -> [TyVarBndr] varsBoundInCon (ForallC bndrs _ con) = bndrs ++ varsBoundInCon con varsBoundInCon _ = [] namesBoundInPat :: Pat -> [Name] namesBoundInPat (VarP name) = [name] namesBoundInPat (TupP pats) = pats >>= namesBoundInPat namesBoundInPat (ConP _ pats) = pats >>= namesBoundInPat namesBoundInPat (InfixP p1 _ p2) = namesBoundInPat p1 ++ namesBoundInPat p2 namesBoundInPat (TildeP pat) = namesBoundInPat pat namesBoundInPat (AsP name pat) = name : namesBoundInPat pat namesBoundInPat (RecP _ fieldPats) = map snd fieldPats >>= namesBoundInPat namesBoundInPat (ListP pats) = pats >>= namesBoundInPat namesBoundInPat (SigP pat _) = namesBoundInPat pat #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612 namesBoundInPat (BangP pat) = namesBoundInPat pat #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 700 namesBoundInPat (ViewP _ pat) = namesBoundInPat pat #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 namesBoundInPat (UnboxedTupP pats) = pats >>= namesBoundInPat #endif namesBoundInPat _ = [] namesBoundInDec :: Dec -> [Name] namesBoundInDec (FunD name _) = [name] namesBoundInDec (ValD pat _ _) = namesBoundInPat pat #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 namesBoundInDec (DataD _ name _ _ _ _) = [name] namesBoundInDec (NewtypeD _ name _ _ _ _) = [name] #else namesBoundInDec (DataD _ name _ _ _) = [name] namesBoundInDec (NewtypeD _ name _ _ _) = [name] #endif namesBoundInDec (TySynD name _ _) = [name] namesBoundInDec (ClassD _ name _ _ _) = [name] namesBoundInDec (ForeignD (ImportF _ _ _ name _)) = [name] #if defined(__GLASGOW_HASKELL__) #if __GLASGOW_HASKELL__ >= 800 namesBoundInDec (OpenTypeFamilyD (TypeFamilyHead name _ _ _)) = [name] namesBoundInDec (ClosedTypeFamilyD (TypeFamilyHead name _ _ _) _) = [name] #elif __GLASGOW_HASKELL__ >= 612 namesBoundInDec (FamilyD _ name _ _) = [name] #endif #endif namesBoundInDec _ = [] genericalizeName :: Name -> Name genericalizeName = mkName . 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 decs = everywhere (mkT fixName) decs where -- get all names bound in the decs and make them generic -- at every occurence in decs. names = decs >>= namesBoundInDec genericalizedNames = [ (n, genericalizeName n) | n <- names] fixName = replace (`lookup` genericalizedNames) headOfType :: Type -> Name headOfType (ForallT _ _ ty) = headOfType ty headOfType (VarT name) = name headOfType (ConT name) = name headOfType (TupleT n) = tupleTypeName n headOfType ArrowT = ''(->) headOfType ListT = ''[] headOfType (AppT t _) = headOfType t #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612 headOfType (SigT t _) = headOfType t #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 headOfType (UnboxedTupleT n) = unboxedTupleTypeName n #endif occursInType :: Name -> Type -> Bool occursInType var ty = case ty of ForallT bndrs _ ty | any (var ==) (map nameOfBinder bndrs) -> False | otherwise -> occursInType var ty VarT name | name == var -> True | otherwise -> False AppT ty1 ty2 -> occursInType var ty1 || occursInType var ty2 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612 SigT ty _ -> occursInType var ty #endif _ -> False