{-# LANGUAGE CPP #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Defines a utility function for deriving 'Quasi' instances for monad
-- transformer data types.
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  -- ^ The instance head. For example, this might be of the form:
             --
             --   > [t| forall r m. Quasi m => Proxy2 (ReaderT r m) |]
             --
             --   Why use 'Proxy2' instead of 'Quasi'? Sadly, GHC 7.0/7.2 will
             --   not accept it if you use the latter due to old TH bugs, so we
             --   use 'Proxy2' as an ugly workaround.
  -> Q Exp   -- ^ The implementation of 'qRecover'
  -> Q [Dec] -- ^ The 'Quasi' instance declaration
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 (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
conT ''Quasi Q Type -> Q Type -> Q Type
`appT` Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instTy
                   Type
_ -> String -> Q Type
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 -> [DecQ] -> DecQ
instanceD Q Cxt
qInstCxt Q Type
qInstTy [DecQ]
qInstMethDecs
  [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
instDec]
  where
    decomposeType :: Type -> (Cxt, Type)
    decomposeType :: Type -> (Cxt, Type)
decomposeType (ForallT [TyVarBndr]
_tvbs Cxt
ctxt Type
ty) = (Cxt
ctxt, Type
ty)
    decomposeType Type
ty                      = ([],   Type
ty)

    qInstMethDecs :: [Q Dec]
    qInstMethDecs :: [DecQ]
qInstMethDecs =
      let instMeths :: [(Name, Q Exp)]
          instMeths :: [(Name, Q Exp)]
instMeths =
            [ -- qRecover is different for each instance
              ('qRecover,            Q Exp
qRecoverExpr)

              -- The remaining methods are straightforward
            , ('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 -> DecQ
mkDec Name
methName Q Exp
methRhs = PatQ -> BodyQ -> [DecQ] -> DecQ
valD (Name -> PatQ
varP Name
methName) (Q Exp -> BodyQ
normalB Q Exp
methRhs) []

      in ((Name, Q Exp) -> DecQ) -> [(Name, Q Exp)] -> [DecQ]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> Q Exp -> DecQ) -> (Name, Q Exp) -> DecQ
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Q Exp -> DecQ
mkDec) [(Name, Q Exp)]
instMeths

-- | See the Haddocks for 'deriveQuasiTrans' for an explanation of why this
-- type needs to exist.
data Proxy2 (m :: * -> *)