module Language.Haskell.TH.Utils(
appExp, appExp',
appConT, appConT',
curryType, curryType',
genBT, genBT',
genPE, genPE',
appKinds,
curryKind,
getTypeNames,
getTVBName ,
getCompositeType,getConName,
seqTuple2, seqTuple3,seqTuple4,
rename, rename', rename'',
nameToExp, printQ
)
where
import Language.Haskell.TH
import Language.Haskell.TH.Lib
import Data.List (foldl1,foldr1)
import Control.Monad
import Language.Haskell.TH.Syntax
pprintQ :: Ppr a => Q a -> IO ()
pprintQ q = runQ q >>= putStrLn.pprint
printQ :: Show a => Q a -> IO ()
printQ q = runQ q >>= putStrLn.show
seqTuple2 :: (Q a, Q b) -> Q (a, b)
seqTuple2 (a,b) = liftM2 (,) a b
seqTuple3 :: (Q a, Q b, Q c) -> Q (a, b, c)
seqTuple3 (a,b,c) = liftM3 (,,) a b c
seqTuple4 :: (Q a, Q b, Q c, Q d) -> Q (a, b, c, d)
seqTuple4 (a,b,c,d) = liftM4 (,,,) a b c d
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
rename :: Q Name -> (String -> String) -> Q Name
rename n f = do
bn <- n
let nameStr = f $ nameBase bn
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
appConT :: [TypeQ] -> TypeQ
appConT = foldl1 appT
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))
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)
appKinds :: [Kind] -> Kind
appKinds = foldr1 AppT
curryKind :: [Kind] -> Kind
curryKind = curryType'
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