{-# 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 :: Q Type -> Q Exp -> Q [Dec]
deriveQuasiTrans Q Type
qInstHead Q Exp
qRecoverExpr = do
Type
instHead <- Q Type
qInstHead
let (Cxt
instCxt, Type
mangledInstTy) = Type -> (Cxt, Type)
decomposeType Type
instHead
qInstCxt :: Q Cxt
qInstCxt = Cxt -> Q Cxt
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instCxt
qInstTy :: Q Type
qInstTy = case Type
mangledInstTy of
ConT Name
proxy2 `AppT` Type
instTy
| Name
proxy2 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Proxy2
-> Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Quasi Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instTy
Type
_ -> String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String
"Unexpected type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
mangledInstTy
Dec
instDec <- Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD Q Cxt
qInstCxt Q Type
qInstTy [Q Dec]
qInstMethDecs
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
instDec]
where
decomposeType :: Type -> (Cxt, Type)
decomposeType :: Type -> (Cxt, Type)
decomposeType (ForallT [TyVarBndr Specificity]
_tvbs Cxt
ctxt Type
ty) = (Cxt
ctxt, Type
ty)
decomposeType Type
ty = ([], Type
ty)
qInstMethDecs :: [Q Dec]
qInstMethDecs :: [Q Dec]
qInstMethDecs =
let instMeths :: [(Name, Q Exp)]
instMeths :: [(Name, Q Exp)]
instMeths =
[
('qRecover, Q Exp
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
#if MIN_VERSION_template_haskell(2,18,0)
, ('qGetDoc, [| MTL.lift . qGetDoc |])
, ('qPutDoc, [| \a b -> MTL.lift $ qPutDoc a b |])
#endif
#if MIN_VERSION_template_haskell(2,19,0)
, ('qGetPackageRoot, [| MTL.lift qGetPackageRoot |])
#endif
]
mkDec :: Name -> Q Exp -> Q Dec
mkDec :: Name -> Q Exp -> Q Dec
mkDec Name
methName Q Exp
methRhs = Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
methName) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
methRhs) []
in ((Name, Q Exp) -> Q Dec) -> [(Name, Q Exp)] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> Q Exp -> Q Dec) -> (Name, Q Exp) -> Q Dec
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Q Exp -> Q Dec
mkDec) [(Name, Q Exp)]
instMeths
data Proxy2 (m :: * -> *)