{-# LANGUAGE CPP #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
module Language.Haskell.TH.Instances.Internal
( deriveQuasiTrans
, Proxy2
) where
import qualified Control.Monad.Trans as MTL (lift)
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Ppr (pprint)
import Language.Haskell.TH.Syntax
deriveQuasiTrans ::
Q Type
-> Q Exp
-> Q [Dec]
deriveQuasiTrans qInstHead qRecoverExpr = do
instHead <- qInstHead
let (instCxt, mangledInstTy) = decomposeType instHead
qInstCxt = return instCxt
qInstTy = case mangledInstTy of
ConT proxy2 `AppT` instTy
| proxy2 == ''Proxy2
-> conT ''Quasi `appT` return instTy
_ -> fail $ "Unexpected type " ++ pprint mangledInstTy
instDec <- instanceD qInstCxt qInstTy qInstMethDecs
return [instDec]
where
decomposeType :: Type -> (Cxt, Type)
decomposeType (ForallT _tvbs ctxt ty) = (ctxt, ty)
decomposeType ty = ([], ty)
qInstMethDecs :: [Q Dec]
qInstMethDecs =
let instMeths :: [(Name, Q Exp)]
instMeths =
[
('qRecover, qRecoverExpr)
, ('qNewName, [| MTL.lift . qNewName |])
, ('qReport, [| \a b -> MTL.lift $ qReport a b |])
, ('qReify, [| MTL.lift . qReify |])
, ('qLocation, [| MTL.lift qLocation |])
, ('qRunIO, [| MTL.lift . qRunIO |])
#if MIN_VERSION_template_haskell(2,7,0)
, ('qReifyInstances, [| \a b -> MTL.lift $ qReifyInstances a b |])
, ('qLookupName, [| \a b -> MTL.lift $ qLookupName a b |])
, ('qAddDependentFile, [| MTL.lift . qAddDependentFile |])
# if MIN_VERSION_template_haskell(2,9,0)
, ('qReifyRoles, [| MTL.lift . qReifyRoles |])
, ('qReifyAnnotations, [| MTL.lift . qReifyAnnotations |])
, ('qReifyModule, [| MTL.lift . qReifyModule |])
, ('qAddTopDecls, [| MTL.lift . qAddTopDecls |])
, ('qAddModFinalizer, [| MTL.lift . qAddModFinalizer |])
, ('qGetQ, [| MTL.lift qGetQ |])
, ('qPutQ, [| MTL.lift . qPutQ |])
# endif
# if MIN_VERSION_template_haskell(2,11,0)
, ('qReifyFixity, [| MTL.lift . qReifyFixity |])
, ('qReifyConStrictness, [| MTL.lift . qReifyConStrictness |])
, ('qIsExtEnabled, [| MTL.lift . qIsExtEnabled |])
, ('qExtsEnabled, [| MTL.lift qExtsEnabled |])
# endif
#elif MIN_VERSION_template_haskell(2,5,0)
, ('qClassInstances, [| \a b -> MTL.lift $ qClassInstances a b |])
#endif
#if MIN_VERSION_template_haskell(2,14,0)
, ('qAddForeignFilePath, [| \a b -> MTL.lift $ qAddForeignFilePath a b |])
, ('qAddTempFile, [| MTL.lift . qAddTempFile |])
#elif MIN_VERSION_template_haskell(2,12,0)
, ('qAddForeignFile, [| \a b -> MTL.lift $ qAddForeignFile a b |])
#endif
#if MIN_VERSION_template_haskell(2,13,0)
, ('qAddCorePlugin, [| MTL.lift . qAddCorePlugin |])
#endif
#if MIN_VERSION_template_haskell(2,16,0)
, ('qReifyType, [| MTL.lift . qReifyType |])
#endif
]
mkDec :: Name -> Q Exp -> Q Dec
mkDec methName methRhs = valD (varP methName) (normalB methRhs) []
in map (uncurry mkDec) instMeths
data Proxy2 (m :: * -> *)