module Language.Haskell.Generate.TH
(
declareFunction
, declareNamedSymbol
, declareNamedFunction
, declareNamedThing
) where
import Data.Char
import Language.Haskell.Exts.Syntax hiding (Name)
import Language.Haskell.Generate.Monad hiding (Name)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
declareNamedFunction :: (Name, String) -> DecsQ
declareNamedFunction (func, name) = declareNamedThing (func, name, 'Ident)
declareNamedThing :: (Name, String, Name) -> DecsQ
declareNamedThing (thing, name, thingClass) = do
info <- reify thing
typ <- case info of
VarI _ t _ _ -> return t
ClassOpI _ t _ _ -> return t
DataConI _ t _ _ -> return t
_ -> fail $ "Not a function: " ++ nameBase thing
md <- maybe (fail "No module name for function!") return $ nameModule thing
sequence
[ sigD (mkName name) $ return $ overQuantifiedType (ConT ''ExpG `AppT`) typ
, funD (mkName name) $ return $ flip (clause []) [] $ normalB
[| useValue $(lift md) $ $(conE thingClass) $(lift $ nameBase thing) |]
]
where overQuantifiedType f (ForallT bnds ctx t) = ForallT (map removeKind bnds) ctx $ overQuantifiedType f t
overQuantifiedType f x = f x
removeKind :: TyVarBndr -> TyVarBndr
removeKind (KindedTV n _) = PlainTV n
removeKind x = x
declareNamedSymbol :: (Name, String) -> DecsQ
declareNamedSymbol (func, name) = declareNamedThing (func, name, 'Symbol)
declareFunction :: Name -> DecsQ
declareFunction func = declareNamedFunction (func, funcName ++ "'")
where funcName = case nameBase func of
(h:t) -> toLower h:t
x -> x