module Language.Haskell.TH.Utils(
rename, rename', rename'', nameToExp,
appExp, appExp', unappExp, unappExp',
appConT, appConT', unappConT, unappConT',
curryType, curryType', uncurryType, uncurryType',
genBT, genBT',
genPE, genPE',
appKind, unappKind,
curryKind, uncurryKind,
getTypeNames, getTVBName ,
getCompositeType,getConName,
seqTup2, seqTup3,seqTup4, unsequence,
printQ, pprintQ, printiQ, printi,
module Text.PrettyPrint.GenericPretty
)
where
import Language.Haskell.TH
import Language.Haskell.TH.Lib hiding (Role)
import Data.List (foldl1,foldr1)
import Debug.Trace
import Control.Monad
import Language.Haskell.TH.Syntax
import Text.PrettyPrint.GenericPretty
import GHC.Generics hiding (Fixity)
import GHC.Word
import GHC.Types
import Data.List
import System.IO.Unsafe
instance Out Name
instance Out Type
instance Out TyVarBndr
instance Out TyLit
instance Out Exp
instance Out Lit
instance Out Pat
instance Out Dec
instance Out Clause
instance Out FunDep
instance Out Foreign
instance Out Fixity
instance Out Pragma
instance Out FamFlavour
instance Out TySynEqn
instance Out Role
instance Out Loc
instance Out Info
instance Out Module
instance Out ModuleInfo
instance Out Strict
instance Out Callconv
instance Out Safety
instance Out Stmt
instance Out Range
instance (Generic a,Out a) => Out (TExp a)
instance Out FixityDirection
instance Out Match
instance Out Guard
instance Out Body
instance Out ModName
instance Out NameFlavour
instance Out Con
instance Out Inline
instance Out RuleBndr
instance Out RuleMatch
instance Out Pred
instance Out Phases
instance Out PkgName
instance Out OccName
instance Out AnnTarget
instance Out Word8
deriving instance Generic FixityDirection
deriving instance Generic Inline
deriving instance Generic RuleBndr
deriving instance Generic Match
deriving instance Generic Name
deriving instance Generic RuleMatch
deriving instance Generic Pred
deriving instance Generic Phases
deriving instance Generic Con
deriving instance Generic Module
deriving instance Generic AnnTarget
deriving instance Generic Type
deriving instance Generic TyVarBndr
deriving instance Generic TyLit
deriving instance Generic Exp
deriving instance Generic Lit
deriving instance Generic Pat
deriving instance Generic Dec
deriving instance Generic Clause
deriving instance Generic FunDep
deriving instance Generic Foreign
deriving instance Generic Fixity
deriving instance Generic Pragma
deriving instance Generic FamFlavour
deriving instance Generic TySynEqn
deriving instance Generic Role
deriving instance Generic Loc
deriving instance Generic Info
deriving instance Generic ModuleInfo
deriving instance Generic Strict
deriving instance Generic Callconv
deriving instance Generic Safety
deriving instance Generic Stmt
deriving instance Generic Range
deriving instance Generic a => Generic (TExp a)
deriving instance Generic Guard
deriving instance Generic Body
deriving instance Generic ModName
deriving instance Generic PkgName
deriving instance Generic OccName
data C_Word8
data D_Word8
instance Datatype D_Word8 where
datatypeName _ = "Word"
moduleName _ = "GHC.Word"
instance Constructor C_Word8 where
conName _ = ""
deriving instance Generic NameSpace
instance Out NameSpace
instance Generic Word8 where
type Rep Word8 = D1 D_Word8 (C1 C_Word8 (S1 NoSelector (Rec0 Word8)))
from x = M1 (M1 (M1 (K1 x)))
to (M1 (M1 (M1 (K1 x)))) = x
instance Generic NameFlavour where
type Rep NameFlavour = (Rep NameFlavour')
from (NameS) = from NameS'
from (NameQ m) = from (NameQ' m)
from (NameU i) = from (NameU' (I# i))
from (NameL i) = from (NameL' (I# i))
from (NameG ns p m) = from (NameG' ns p m)
to M1 {unM1 = L1 (L1 (M1 {unM1 = U1}))} = NameS
to M1 {unM1 = L1 (R1 (M1 {unM1 = M1 {unM1 = K1 {unK1 = ModName mn }}}))} = NameQ (ModName mn)
to M1 {unM1 = R1 (L1 (M1 {unM1 = M1 {unM1 = K1 {unK1 = (I# n)}}}))} = NameU n
to M1 {unM1 = R1 (R1 (L1 (M1 {unM1 = M1 {unM1 = K1 {unK1 = (I# n)}}})))} = NameL n
to M1 {unM1 = R1 (R1 (R1 (M1 {unM1 = M1 {unM1 = K1 {unK1 = ns}} :*: (M1 {unM1 = K1 {unK1 = PkgName p}} :*: M1 {unM1 = K1 {unK1 = ModName m}})})))} = NameG ns (PkgName p) (ModName m)
data NameFlavour' = NameS'
| NameQ' ModName
| NameU' Int
| NameL' Int
| NameG' NameSpace PkgName ModName
deriving (Generic,Show)
deriving instance Show NameSpace
pprintQ :: Ppr a => Q a -> IO ()
pprintQ q = runQ q >>= putStrLn.pprint
printiQ :: Out a => Q a -> IO ()
printiQ q = runQ q >>= pp
printi :: Out a => a -> IO ()
printi a = pp a
printQ :: Show a => Q a -> IO ()
printQ q = runQ q >>= putStrLn.show
dprint :: Show a => String -> Q a -> Q a
dprint str q = do
a <- q
trace (str ++ ": " ++ show a) q
seqTup2 :: (Q a, Q b) -> Q (a, b)
seqTup2 (a,b) = liftM2 (,) a b
seqTup3 :: (Q a, Q b, Q c) -> Q (a, b, c)
seqTup3 (a,b,c) = liftM3 (,,) a b c
seqTup4 :: (Q a, Q b, Q c, Q d) -> Q (a, b, c, d)
seqTup4 (a,b,c,d) = liftM4 (,,,) a b c d
unsequence :: Q [a] -> Q [Q a]
unsequence qs = do
s <- qs
return $ map return s
rename :: Q Name -> (String -> String) -> Q Name
rename n f = do
bn <- n
let nameStr = f $ nameBase bn
return $ mkName nameStr
rename' :: Name -> (String -> String) -> Name
rename' n f = mkName $ f $ nameBase n
rename'' :: Name -> (String -> String) -> Q Name
rename'' n f = do
let nameStr = f $ nameBase n
return $ mkName nameStr
nameToExp :: (String -> String)
-> Name
-> Q Exp
nameToExp f = litE . stringL . f . nameBase
conNameExp :: Con -> Q Exp
conNameExp = litE . stringL . nameBase . getConName
appExp :: [ExpQ] -> ExpQ
appExp = appsE
appExp' :: [Exp] -> Exp
appExp' = foldl1 AppE
unappExp :: ExpQ -> Q [Exp]
unappExp = fmap unappExp'
unappExp' :: Exp -> [Exp]
unappExp' a@(AppE e1 e2) = reverse $ unfold (not.isAppE) unappE restUnappE a
unappExp' e = [e]
foo = (AppE (AppE (VarE 'const) (LitE (IntegerL 3))) (ConE (mkName "True")))
isAppE :: Exp -> Bool
isAppE (AppE _ _) = True
isAppE _ = False
unappE :: Exp -> Exp
unappE (AppE e1 e2) = e2
unappE x = x
restUnappE :: Exp -> Exp
restUnappE (AppE e1 e2) = e1
restunappE x = x
unfold :: (t1 -> Bool) -> (t1 -> t1) -> (t1 -> t1) -> t1 -> [t1]
unfold p h t x | p x = [x]
| otherwise = h x : unfold p h t (t x)
appConT :: [TypeQ] -> TypeQ
appConT = foldl1 appT
unappConT' :: Type -> [Type]
unappConT' a@(AppT t1 t2) = reverse $ unfold (not.isAppT) unappT restUnappT a
unappConT' a@(ForallT tvbs cxt t) = reverse $ unfold (not.isAppT) unappT restUnappT t
unappConT' x = [x]
unappConT :: TypeQ -> Q [Type]
unappConT = fmap unappConT'
isAppT :: Type -> Bool
isAppT (AppT _ _ ) = True
isAppT _ = False
unappT :: Type -> Type
unappT (AppT t1 t2) = t2
unappT x = x
restUnappT :: Type -> Type
restUnappT (AppT t1 t2) = t1
restUnappT x = x
appConT' :: [Type] -> Type
appConT' = foldl1 AppT
curryType :: [TypeQ] -> TypeQ
curryType = foldr1 (\t1 -> appT (appT arrowT t1))
curryType' :: [Type] -> Type
curryType' = foldr1 (\t1 -> AppT (AppT ArrowT t1))
uncurryType :: TypeQ -> Q [Type]
uncurryType = fmap uncurryType'
uncurryType' :: Type -> [Type]
uncurryType' t@(AppT (AppT ArrowT t1) t2) = t1 : helper t2
uncurryType' t@(ForallT tyvs cxt ty) = helper ty
uncurryType' x = [x]
helper :: Type -> [Type]
helper t@(AppT (AppT ArrowT t1) t2) = t1 : helper t2
helper t = [t]
genBT :: String -> Int -> Q ([TyVarBndr], [TypeQ])
genBT name n = do
let ns = [name++ (show i) | i <- [1..n]]
tvb <- sequence $ map (return.plainTV.mkName) ns
typ <- sequence $ map (return.varT.mkName) ns
return (tvb,typ)
genBT' :: String -> Int -> ([TyVarBndr], [Type])
genBT' name n = let ns = [name++ (show i) | i <- [1..n]]
in (map (plainTV.mkName) ns, map (VarT . mkName) ns)
genPE :: String -> Int -> Q ([PatQ],[ExpQ])
genPE name n = do
let ns = [name++ (show i) | i <- [1..n]]
pat <- sequence $ map (return.varP.mkName) ns
exp <- sequence $ map (return.varE.mkName) ns
return (pat,exp)
genPE' :: String -> Int -> ([Pat], [Exp])
genPE' name n = let ns = [name++ (show i) | i <- [1..n]]
in (map (VarP . mkName) ns,map (VarE . mkName) ns)
appKind :: [Kind] -> Kind
appKind = foldr1 AppT
unappKind :: Kind -> [Kind]
unappKind = unappConT'
curryKind :: [Kind] -> Kind
curryKind = curryType'
uncurryKind :: Kind -> [Kind]
uncurryKind = uncurryType'
getConName :: Con -> Name
getConName (NormalC name _) = name
getConName (RecC name _) = name
getConName (InfixC _ name _) = name
getConName (ForallC _ _ con) = getConName con
getTypeNames :: Type -> [Name]
getTypeNames (ForallT tvbs cxt t) = getTypeNames t
getTypeNames (ConT n) = [n]
getTypeNames (AppT t1 t2) = getTypeNames t1 ++ getTypeNames t2
getTypeNames _ = []
getTVBName :: TyVarBndr -> Name
getTVBName (PlainTV name ) = name
getTVBName (KindedTV name _) = name
third (a,b,c) = c
getCompositeType :: Con -> [Name]
getCompositeType (NormalC n sts) = concatMap getTypeNames (map snd sts)
getCompositeType (RecC n vars) = concatMap getTypeNames (map third vars)
getCompositeType (InfixC st1 n st2) = concatMap getTypeNames [snd st1 , snd st2]
getCompositeType (ForallC tvbs cxt con) = getCompositeType con