TcSplice: Template Haskell splices
+
\begin{code}
-{-# OPTIONS -w #-}
+{-# OPTIONS -fno-warn-unused-imports -fno-warn-unused-binds #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
-module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket,
- runQuasiQuoteExpr, runQuasiQuotePat ) where
+module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
+ lookupThName_maybe,
+todoSession, todoTcM,
+ runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where
#include "HsVersions.h"
import TypeRep
import Name
import NameEnv
+import PrelNames
import HscTypes
import OccName
import Var
import Module
+import Annotations
import TcRnMonad
-import IfaceEnv
import Class
+import Inst
import TyCon
import DataCon
import Id
import DsMeta
import DsExpr
import DsMonad hiding (Splice)
+import Serialized
import ErrUtils
import SrcLoc
import Outputable
import Unique
-import DynFlags
-import PackageConfig
-import Maybe
+import Data.Maybe
import BasicTypes
import Panic
import FastString
+import Exception
import qualified Language.Haskell.TH as TH
-- THSyntax gives access to internal functions and data types
import qualified Language.Haskell.TH.Syntax as TH
+#ifdef GHCI
+-- Because GHC.Desugar might not be in the base library of the bootstrapping compiler
+import GHC.Desugar ( AnnotationWrapper(..) )
+#endif
+
import GHC.Exts ( unsafeCoerce#, Int#, Int(..) )
-import Control.Monad ( liftM )
-import qualified Control.Exception as Exception( userErrors )
+import System.IO.Error
+
+
+--here for every bad reason :-)
+import InstEnv
+import FamInstEnv
+--Session
+todoSession :: HscEnv -> Name -> IO (Messages, Maybe (LHsDecl RdrName))
+todoSession hsc_env name
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ setInteractiveContext hsc_env (hsc_IC hsc_env) $
+ todoTcM name
+
+
+todoTcM :: Name -> TcM (LHsDecl RdrName)
+todoTcM name = do
+ tcTyThing <- TcEnv.tcLookup name
+ thInfo <- TcSplice.reifyThing tcTyThing
+ let Just thDec = thGetDecFromInfo thInfo --BUG!
+ let Right [hsdecl] = Convert.convertToHsDecls
+ (error "srcspan of different package?")
+ [thDec]
+ return hsdecl
+
+thGetDecFromInfo :: TH.Info -> Maybe TH.Dec
+thGetDecFromInfo (TH.ClassI dec) = Just dec
+thGetDecFromInfo (TH.ClassOpI {}) = error "classop"
+thGetDecFromInfo (TH.TyConI dec) = Just dec
+thGetDecFromInfo (TH.PrimTyConI {}) = Nothing --error "sometimes we can invent a signature? or it's better not to?"
+thGetDecFromInfo (TH.DataConI {}) = error "datacon"
+thGetDecFromInfo (TH.VarI _name _type (Just dec) _fixity) = Just dec
+thGetDecFromInfo (TH.VarI _name _type Nothing _fixity) = error "vari"
+thGetDecFromInfo (TH.TyVarI {}) = Nothing --tyvars don't have decls? they kinda have a type though...
+
+setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
+setInteractiveContext hsc_env icxt thing_inside
+ = let -- Initialise the tcg_inst_env with instances from all home modules.
+ -- This mimics the more selective call to hptInstances in tcRnModule.
+ (home_insts, home_fam_insts) = hptInstances hsc_env (\_mod -> True)
+ in
+ updGblEnv (\env -> env {
+ tcg_rdr_env = ic_rn_gbl_env icxt,
+ tcg_inst_env = extendInstEnvList (tcg_inst_env env) home_insts,
+ tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env env)
+ home_fam_insts
+ }) $
+
+ tcExtendGhciEnv (ic_tmp_ids icxt) $
+ -- tcExtendGhciEnv does lots:
+ -- - it extends the local type env (tcl_env) with the given Ids,
+ -- - it extends the local rdr env (tcl_rdr) with the Names from
+ -- the given Ids
+ -- - it adds the free tyvars of the Ids to the tcl_tyvars
+ -- set.
+ --
+ -- later ids in ic_tmp_ids must shadow earlier ones with the same
+ -- OccName, and tcExtendIdEnv implements this behaviour.
+
+ do { traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt))
+ ; thing_inside }
\end{code}
+Note [How top-level splices are handled]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Top-level splices (those not inside a [| .. |] quotation bracket) are handled
+very straightforwardly:
+
+ 1. tcTopSpliceExpr: typecheck the body e of the splice $(e)
+
+ 2. runMetaT: desugar, compile, run it, and convert result back to
+ HsSyn RdrName (of the appropriate flavour, eg HsType RdrName,
+ HsExpr RdrName etc)
+
+ 3. treat the result as if that's what you saw in the first place
+ e.g for HsType, rename and kind-check
+ for HsExpr, rename and type-check
+
+ (The last step is different for decls, becuase they can *only* be
+ top-level: we return the result of step 2.)
+
+Note [How brackets and nested splices are handled]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Nested splices (those inside a [| .. |] quotation bracket), are treated
+quite differently.
+
+ * After typechecking, the bracket [| |] carries
+
+ a) A mutable list of PendingSplice
+ type PendingSplice = (Name, LHsExpr Id)
+
+ b) The quoted expression e, *renamed*: (HsExpr Name)
+ The expression e has been typechecked, but the result of
+ that typechecking is discarded.
+
+ * The brakcet is desugared by DsMeta.dsBracket. It
+
+ a) Extends the ds_meta environment with the PendingSplices
+ attached to the bracket
+
+ b) Converts the quoted (HsExpr Name) to a CoreExpr that, when
+ run, will produce a suitable TH expression/type/decl. This
+ is why we leave the *renamed* expression attached to the bracket:
+ the quoted expression should not be decorated with all the goop
+ added by the type checker
+
+ * Each splice carries a unique Name, called a "splice point", thus
+ ${n}(e). The name is initialised to an (Unqual "splice") when the
+ splice is created; the renamer gives it a unique.
+
+ * When the type checker type-checks a nested splice ${n}(e), it
+ - typechecks e
+ - adds the typechecked expression (of type (HsExpr Id))
+ as a pending splice to the enclosing bracket
+ - returns something non-committal
+ Eg for [| f ${n}(g x) |], the typechecker
+ - attaches the typechecked term (g x) to the pending splices for n
+ in the outer bracket
+ - returns a non-committal type \alpha.
+ Remember that the bracket discards the typechecked term altogether
+
+ * When DsMeta (used to desugar the body of the bracket) comes across
+ a splice, it looks up the splice's Name, n, in the ds_meta envt,
+ to find an (HsExpr Id) that should be substituted for the splice;
+ it just desugars it to get a CoreExpr (DsMeta.repSplice).
+
+Example:
+ Source: f = [| Just $(g 3) |]
+ The [| |] part is a HsBracket
+
+ Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
+ The [| |] part is a HsBracketOut, containing *renamed*
+ (not typechecked) expression
+ The "s7" is the "splice point"; the (g Int 3) part
+ is a typechecked expression
+
+ Desugared: f = do { s7 <- g Int 3
+ ; return (ConE "Data.Maybe.Just" s7) }
+
+
+Note [Template Haskell state diagram]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here are the ThStages, s, their corresponding level numbers
+(the result of (thLevel s)), and their state transitions.
+
+ ----------- $ ------------ $
+ | Comp | ---------> | Splice | -----|
+ | 1 | | 0 | <----|
+ ----------- ------------
+ ^ | ^ |
+ $ | | [||] $ | | [||]
+ | v | v
+ -------------- ----------------
+ | Brack Comp | | Brack Splice |
+ | 2 | | 1 |
+ -------------- ----------------
+
+* Normal top-level declarations start in state Comp
+ (which has level 1).
+ Annotations start in state Splice, since they are
+ treated very like a splice (only without a '$')
+
+* Code compiled in state Splice (and only such code)
+ will be *run at compile time*, with the result replacing
+ the splice
+
+* The original paper used level -1 instead of 0, etc.
+
+* The original paper did not allow a splice within a
+ splice, but there is no reason not to. This is the
+ $ transition in the top right.
+
Note [Template Haskell levels]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* Imported things are impLevel (= 0)
* Variables are bound at the "current level"
-* The current level starts off at topLevel (= 1)
+* The current level starts off at outerLevel (= 1)
* The level is decremented by splicing $(..)
incremented by brackets [| |]
%************************************************************************
\begin{code}
+tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
-- None of these functions add constraints to the LIE
+lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
+
runQuasiQuoteExpr :: HsQuasiQuote Name -> TcM (LHsExpr RdrName)
runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName)
+runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
#ifndef GHCI
-tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
-tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e)
+tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x)
+tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
+tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
+kcSpliceType x = pprPanic "Cant do kcSpliceType without GHCi" (ppr x)
+
+lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n)
-runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q)
-runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q)
+runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q)
+runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q)
+runAnnotation _ q = pprPanic "Cant do runAnnotation without GHCi" (ppr q)
#else
\end{code}
%* *
%************************************************************************
-Note [Handling brackets]
-~~~~~~~~~~~~~~~~~~~~~~~~
-Source: f = [| Just $(g 3) |]
- The [| |] part is a HsBracket
-
-Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
- The [| |] part is a HsBracketOut, containing *renamed* (not typechecked) expression
- The "s7" is the "splice point"; the (g Int 3) part is a typechecked expression
-
-Desugared: f = do { s7 <- g Int 3
- ; return (ConE "Data.Maybe.Just" s7) }
\begin{code}
-tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
-tcBracket brack res_ty = do
- level <- getStage
- case bracketOK level of {
- Nothing -> failWithTc (illegalBracket level) ;
- Just next_level -> do
+-- See Note [How brackets and nested splices are handled]
+tcBracket brack res_ty
+ = addErrCtxt (hang (ptext (sLit "In the Template Haskell quotation"))
+ 2 (ppr brack)) $
+ do { -- Check for nested brackets
+ cur_stage <- getStage
+ ; checkTc (not (isBrackStage cur_stage)) illegalBracket
+
+ -- Brackets are desugared to code that mentions the TH package
+ ; recordThUse
-- Typecheck expr to make sure it is valid,
-- but throw away the results. We'll type check
-- it again when we actually use it.
- recordThUse
- pending_splices <- newMutVar []
- lie_var <- getLIEVar
+ ; pending_splices <- newMutVar []
+ ; lie_var <- getLIEVar
- (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
- (getLIE (tc_bracket next_level brack))
- tcSimplifyBracket lie
+ ; (meta_ty, lie) <- setStage (Brack cur_stage pending_splices lie_var)
+ (getLIE (tc_bracket cur_stage brack))
+ ; tcSimplifyBracket lie
-- Make the expected type have the right shape
- boxyUnify meta_ty res_ty
+ ; _ <- boxyUnify meta_ty res_ty
-- Return the original expression, not the type-decorated one
- pendings <- readMutVar pending_splices
- return (noLoc (HsBracketOut brack pendings))
- }
+ ; pendings <- readMutVar pending_splices
+ ; return (noLoc (HsBracketOut brack pendings)) }
-tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType
-tc_bracket use_lvl (VarBr name) -- Note [Quoting names]
+tc_bracket :: ThStage -> HsBracket Name -> TcM TcType
+tc_bracket outer_stage (VarBr name) -- Note [Quoting names]
= do { thing <- tcLookup name
; case thing of
AGlobal _ -> return ()
ATcId { tct_level = bind_lvl, tct_id = id }
- | thTopLevelId id -- C.f thTopLevelId case of
- -> keepAliveTc id -- TcExpr.thBrackId
+ | thTopLevelId id -- C.f TcExpr.checkCrossStageLifting
+ -> keepAliveTc id
| otherwise
- -> do { checkTc (use_lvl == bind_lvl)
+ -> do { checkTc (thLevel outer_stage + 1 == bind_lvl)
(quotedNameStageErr name) }
- other -> pprPanic "th_bracket" (ppr name)
+ _ -> pprPanic "th_bracket" (ppr name)
; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
}
-tc_bracket use_lvl (ExpBr expr)
+tc_bracket _ (ExpBr expr)
= do { any_ty <- newFlexiTyVarTy liftedTypeKind
- ; tcMonoExpr expr any_ty
+ ; _ <- tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that
; tcMetaTy expQTyConName }
-- Result type is Expr (= Q Exp)
-tc_bracket use_lvl (TypBr typ)
- = do { tcHsSigType ExprSigCtxt typ
+tc_bracket _ (TypBr typ)
+ = do { _ <- tcHsSigTypeNC ThBrackCtxt typ
; tcMetaTy typeQTyConName }
-- Result type is Type (= Q Typ)
-tc_bracket use_lvl (DecBr decls)
- = do { tcTopSrcDecls emptyModDetails decls
+tc_bracket _ (DecBr decls)
+ = do { _ <- tcTopSrcDecls emptyModDetails decls
-- Typecheck the declarations, dicarding the result
-- We'll get all that stuff later, when we splice it in
-- Result type is Q [Dec]
}
-tc_bracket use_lvl (PatBr _)
- = failWithTc (ptext SLIT("Tempate Haskell pattern brackets are not supported yet"))
+tc_bracket _ (PatBr _)
+ = failWithTc (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
+quotedNameStageErr :: Name -> SDoc
quotedNameStageErr v
- = sep [ ptext SLIT("Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
- , ptext SLIT("must be used at the same stage at which is is bound")]
+ = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
+ , ptext (sLit "must be used at the same stage at which is is bound")]
\end{code}
\begin{code}
tcSpliceExpr (HsSplice name expr) res_ty
= setSrcSpan (getLoc expr) $ do
- level <- getStage
- case spliceOK level of {
- Nothing -> failWithTc (illegalSplice level) ;
- Just next_level ->
+ { stage <- getStage
+ ; case stage of {
+ Splice -> tcTopSplice expr res_ty ;
+ Comp -> tcTopSplice expr res_ty ;
- case level of {
- Comp -> do { e <- tcTopSplice expr res_ty
- ; return (unLoc e) } ;
- Brack _ ps_var lie_var -> do
+ Brack pop_stage ps_var lie_var -> do
+ -- See Note [How brackets and nested splices are handled]
-- A splice inside brackets
-- NB: ignore res_ty, apart from zapping it to a mono-type
-- e.g. [| reverse $(h 4) |]
-- Here (h 4) :: Q Exp
-- but $(h 4) :: forall a.a i.e. anything!
- unBox res_ty
- meta_exp_ty <- tcMetaTy expQTyConName
- expr' <- setStage (Splice next_level) (
- setLIEVar lie_var $
- tcMonoExpr expr meta_exp_ty
- )
+ { _ <- unBox res_ty
+ ; meta_exp_ty <- tcMetaTy expQTyConName
+ ; expr' <- setStage pop_stage $
+ setLIEVar lie_var $
+ tcMonoExpr expr meta_exp_ty
-- Write the pending splice into the bucket
- ps <- readMutVar ps_var
- writeMutVar ps_var ((name,expr') : ps)
-
- return (panic "tcSpliceExpr") -- The returned expression is ignored
- }}
+ ; ps <- readMutVar ps_var
+ ; writeMutVar ps_var ((name,expr') : ps)
--- tcTopSplice used to have this:
--- Note that we do not decrement the level (to -1) before
--- typechecking the expression. For example:
--- f x = $( ...$(g 3) ... )
--- The recursive call to tcMonoExpr will simply expand the
--- inner escape before dealing with the outer one
+ ; return (panic "tcSpliceExpr") -- The returned expression is ignored
+ }}}
-tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id)
-tcTopSplice expr res_ty = do
- meta_exp_ty <- tcMetaTy expQTyConName
+tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (HsExpr Id)
+-- Note [How top-level splices are handled]
+tcTopSplice expr res_ty
+ = do { meta_exp_ty <- tcMetaTy expQTyConName
-- Typecheck the expression
- zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
+ ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_exp_ty)
-- Run the expression
- traceTc (text "About to run" <+> ppr zonked_q_expr)
- expr2 <- runMetaE convertToHsExpr zonked_q_expr
+ ; traceTc (text "About to run" <+> ppr zonked_q_expr)
+ ; expr2 <- runMetaE convertToHsExpr zonked_q_expr
- traceTc (text "Got result" <+> ppr expr2)
+ ; traceTc (text "Got result" <+> ppr expr2)
- showSplice "expression"
- zonked_q_expr (ppr expr2)
+ ; showSplice "expression" expr (ppr expr2)
-- Rename it, but bale out if there are errors
-- otherwise the type checker just gives more spurious errors
- (exp3, fvs) <- checkNoErrs (rnLExpr expr2)
+ ; (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
- tcMonoExpr exp3 res_ty
+ ; exp4 <- tcMonoExpr exp3 res_ty
+ ; return (unLoc exp4) }
-
-tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id)
+-------------------
+tcTopSpliceExpr :: TcM (LHsExpr Id) -> TcM (LHsExpr Id)
+-- Note [How top-level splices are handled]
-- Type check an expression that is the body of a top-level splice
-- (the caller will compile and run it)
-tcTopSpliceExpr expr meta_ty
- = checkNoErrs $ -- checkNoErrs: must not try to run the thing
- -- if the type checker fails!
-
- setStage topSpliceStage $ do
-
-
- do { recordThUse -- Record that TH is used (for pkg depdendency)
+-- Note that set the level to Splice, regardless of the original level,
+-- before typechecking the expression. For example:
+-- f x = $( ...$(g 3) ... )
+-- The recursive call to tcMonoExpr will simply expand the
+-- inner escape before dealing with the outer one
- -- Typecheck the expression
- ; (expr', lie) <- getLIE (tcMonoExpr expr meta_ty)
-
+tcTopSpliceExpr tc_action
+ = checkNoErrs $ -- checkNoErrs: must not try to run the thing
+ -- if the type checker fails!
+ setStage Splice $
+ do { -- Typecheck the expression
+ (expr', lie) <- getLIE tc_action
+
-- Solve the constraints
; const_binds <- tcSimplifyTop lie
- -- And zonk it
- ; zonkTopLExpr (mkHsDictLet const_binds expr') }
+ -- Zonk it and tie the knot of dictionary bindings
+ ; zonkTopLExpr (mkHsDictLet const_binds expr') }
+\end{code}
+
+
+%************************************************************************
+%* *
+ Splicing a type
+%* *
+%************************************************************************
+
+Very like splicing an expression, but we don't yet share code.
+
+\begin{code}
+kcSpliceType (HsSplice name hs_expr)
+ = setSrcSpan (getLoc hs_expr) $ do
+ { stage <- getStage
+ ; case stage of {
+ Splice -> kcTopSpliceType hs_expr ;
+ Comp -> kcTopSpliceType hs_expr ;
+
+ Brack pop_level ps_var lie_var -> do
+ -- See Note [How brackets and nested splices are handled]
+ -- A splice inside brackets
+ { meta_ty <- tcMetaTy typeQTyConName
+ ; expr' <- setStage pop_level $
+ setLIEVar lie_var $
+ tcMonoExpr hs_expr meta_ty
+
+ -- Write the pending splice into the bucket
+ ; ps <- readMutVar ps_var
+ ; writeMutVar ps_var ((name,expr') : ps)
+
+ -- e.g. [| f (g :: Int -> $(h 4)) |]
+ -- Here (h 4) :: Q Type
+ -- but $(h 4) :: a i.e. any type, of any kind
+
+ -- We return a HsSpliceTyOut, which serves to convey the kind to
+ -- the ensuing TcHsType.dsHsType, which makes up a non-committal
+ -- type variable of a suitable kind
+ ; kind <- newKindVar
+ ; return (HsSpliceTyOut kind, kind)
+ }}}
+
+kcTopSpliceType :: LHsExpr Name -> TcM (HsType Name, TcKind)
+-- Note [How top-level splices are handled]
+kcTopSpliceType expr
+ = do { meta_ty <- tcMetaTy typeQTyConName
+
+ -- Typecheck the expression
+ ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_ty)
+
+ -- Run the expression
+ ; traceTc (text "About to run" <+> ppr zonked_q_expr)
+ ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
+
+ ; traceTc (text "Got result" <+> ppr hs_ty2)
+
+ ; showSplice "type" expr (ppr hs_ty2)
+
+ -- Rename it, but bale out if there are errors
+ -- otherwise the type checker just gives more spurious errors
+ ; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
+ ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
+
+ ; (ty4, kind) <- kcLHsType hs_ty3
+ ; return (unLoc ty4, kind) }
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Splicing an expression}
+%* *
+%************************************************************************
+
+\begin{code}
+-- Note [How top-level splices are handled]
+-- Always at top level
+-- Type sig at top of file:
+-- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
+tcSpliceDecls expr
+ = do { meta_dec_ty <- tcMetaTy decTyConName
+ ; meta_q_ty <- tcMetaTy qTyConName
+ ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
+ ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr list_q)
+
+ -- Run the expression
+ ; traceTc (text "About to run" <+> ppr zonked_q_expr)
+ ; decls <- runMetaD convertToHsDecls zonked_q_expr
+
+ ; traceTc (text "Got result" <+> vcat (map ppr decls))
+ ; showSplice "declarations"
+ expr
+ (ppr (getLoc expr) $$ (vcat (map ppr decls)))
+ ; return decls }
+\end{code}
+
+
+%************************************************************************
+%* *
+ Annotations
+%* *
+%************************************************************************
+
+\begin{code}
+runAnnotation target expr = do
+ -- Find the classes we want instances for in order to call toAnnotationWrapper
+ loc <- getSrcSpanM
+ data_class <- tcLookupClass dataClassName
+ to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
+
+ -- Check the instances we require live in another module (we want to execute it..)
+ -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
+ -- also resolves the LIE constraints to detect e.g. instance ambiguity
+ zonked_wrapped_expr' <- tcTopSpliceExpr $
+ do { (expr', expr_ty) <- tcInferRhoNC expr
+ -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
+ -- By instantiating the call >here< it gets registered in the
+ -- LIE consulted by tcTopSpliceExpr
+ -- and hence ensures the appropriate dictionary is bound by const_binds
+ ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
+ ; let specialised_to_annotation_wrapper_expr
+ = L loc (HsWrap wrapper (HsVar to_annotation_wrapper_id))
+ ; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) }
+
+ -- Run the appropriately wrapped expression to get the value of
+ -- the annotation and its dictionaries. The return value is of
+ -- type AnnotationWrapper by construction, so this conversion is
+ -- safe
+ flip runMetaAW zonked_wrapped_expr' $ \annotation_wrapper ->
+ case annotation_wrapper of
+ AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
+ -- Got the value and dictionaries: build the serialized value and
+ -- call it a day. We ensure that we seq the entire serialized value
+ -- in order that any errors in the user-written code for the
+ -- annotation are exposed at this point. This is also why we are
+ -- doing all this stuff inside the context of runMeta: it has the
+ -- facilities to deal with user error in a meta-level expression
+ seqSerialized serialized `seq` Annotation {
+ ann_target = target,
+ ann_value = serialized
+ }
\end{code}
-> Name -- Name of th_syn type
-> (SrcSpan -> th_syn -> Either Message hs_syn)
-> TcM hs_syn
-runQuasiQuote (HsQuasiQuote name quoter q_span quote) quote_selector desc meta_ty convert
+runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ty convert
= do { -- Check that the quoter is not locally defined, otherwise the TH
-- machinery will not be able to run the quasiquote.
; this_mod <- getModule
; let expr = L q_span $
HsApp (L q_span $
HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr
- ; recordThUse
; meta_exp_ty <- tcMetaTy meta_ty
-- Typecheck the expression
- ; zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
+ ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_exp_ty)
-- Run the expression
; traceTc (text "About to run" <+> ppr zonked_q_expr)
- ; result <- runMeta convert zonked_q_expr
+ ; result <- runMetaQ convert zonked_q_expr
; traceTc (text "Got result" <+> ppr result)
- ; showSplice desc zonked_q_expr (ppr result)
+ ; showSplice desc quoteExpr (ppr result)
; return result
}
runQuasiQuotePat quasiquote
= runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat
+quoteStageError :: Name -> SDoc
quoteStageError quoter
- = sep [ptext SLIT("GHC stage restriction:") <+> ppr quoter,
- nest 2 (ptext SLIT("is used in a quasiquote, and must be imported, not defined locally"))]
-\end{code}
-
-
-%************************************************************************
-%* *
- Splicing a type
-%* *
-%************************************************************************
-
-Very like splicing an expression, but we don't yet share code.
-
-\begin{code}
-kcSpliceType (HsSplice name hs_expr)
- = setSrcSpan (getLoc hs_expr) $ do
- { level <- getStage
- ; case spliceOK level of {
- Nothing -> failWithTc (illegalSplice level) ;
- Just next_level -> do
-
- { case level of {
- Comp -> do { (t,k) <- kcTopSpliceType hs_expr
- ; return (unLoc t, k) } ;
- Brack _ ps_var lie_var -> do
-
- { -- A splice inside brackets
- ; meta_ty <- tcMetaTy typeQTyConName
- ; expr' <- setStage (Splice next_level) $
- setLIEVar lie_var $
- tcMonoExpr hs_expr meta_ty
-
- -- Write the pending splice into the bucket
- ; ps <- readMutVar ps_var
- ; writeMutVar ps_var ((name,expr') : ps)
-
- -- e.g. [| Int -> $(h 4) |]
- -- Here (h 4) :: Q Type
- -- but $(h 4) :: forall a.a i.e. any kind
- ; kind <- newKindVar
- ; return (panic "kcSpliceType", kind) -- The returned type is ignored
- }}}}}
-
-kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
-kcTopSpliceType expr
- = do { meta_ty <- tcMetaTy typeQTyConName
-
- -- Typecheck the expression
- ; zonked_q_expr <- tcTopSpliceExpr expr meta_ty
-
- -- Run the expression
- ; traceTc (text "About to run" <+> ppr zonked_q_expr)
- ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
-
- ; traceTc (text "Got result" <+> ppr hs_ty2)
-
- ; showSplice "type" zonked_q_expr (ppr hs_ty2)
-
- -- Rename it, but bale out if there are errors
- -- otherwise the type checker just gives more spurious errors
- ; let doc = ptext SLIT("In the spliced type") <+> ppr hs_ty2
- ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
-
- ; kcHsType hs_ty3 }
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Splicing an expression}
-%* *
-%************************************************************************
-
-\begin{code}
--- Always at top level
--- Type sig at top of file:
--- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
-tcSpliceDecls expr
- = do { meta_dec_ty <- tcMetaTy decTyConName
- ; meta_q_ty <- tcMetaTy qTyConName
- ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
- ; zonked_q_expr <- tcTopSpliceExpr expr list_q
-
- -- Run the expression
- ; traceTc (text "About to run" <+> ppr zonked_q_expr)
- ; decls <- runMetaD convertToHsDecls zonked_q_expr
-
- ; traceTc (text "Got result" <+> vcat (map ppr decls))
- ; showSplice "declarations"
- zonked_q_expr
- (ppr (getLoc expr) $$ (vcat (map ppr decls)))
- ; return decls }
-
- where handleErrors :: [Either a Message] -> TcM [a]
- handleErrors [] = return []
- handleErrors (Left x:xs) = liftM (x:) (handleErrors xs)
- handleErrors (Right m:xs) = do addErrTc m
- handleErrors xs
+ = sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter,
+ nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))]
\end{code}
%************************************************************************
\begin{code}
+runMetaAW :: (AnnotationWrapper -> output)
+ -> LHsExpr Id -- Of type AnnotationWrapper
+ -> TcM output
+runMetaAW k = runMeta False (\_ -> return . Right . k)
+ -- We turn off showing the code in meta-level exceptions because doing so exposes
+ -- the toAnnotationWrapper function that we slap around the users code
+
+runQThen :: (SrcSpan -> input -> Either Message output)
+ -> SrcSpan
+ -> TH.Q input
+ -> TcM (Either Message output)
+runQThen f expr_span what = TH.runQ what >>= (return . f expr_span)
+
+runMetaQ :: (SrcSpan -> input -> Either Message output)
+ -> LHsExpr Id
+ -> TcM output
+runMetaQ = runMeta True . runQThen
+
runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
-> LHsExpr Id -- Of type (Q Exp)
-> TcM (LHsExpr RdrName)
-runMetaE = runMeta
+runMetaE = runMetaQ
runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName))
-> LHsExpr Id -- Of type (Q Pat)
-> TcM (Pat RdrName)
-runMetaP = runMeta
+runMetaP = runMetaQ
runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
-> LHsExpr Id -- Of type (Q Type)
-> TcM (LHsType RdrName)
-runMetaT = runMeta
+runMetaT = runMetaQ
runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
-> LHsExpr Id -- Of type Q [Dec]
-> TcM [LHsDecl RdrName]
-runMetaD = runMeta
+runMetaD = runMetaQ
-runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn)
+runMeta :: Bool -- Whether code should be printed in the exception message
+ -> (SrcSpan -> input -> TcM (Either Message output))
-> LHsExpr Id -- Of type X
- -> TcM hs_syn -- Of type t
-runMeta convert expr
+ -> TcM output -- Of type t
+runMeta show_code run_and_convert expr
= do { -- Desugar
ds_expr <- initDsTc (dsLExpr expr)
-- Compile and link it; might fail if linking fails
; either_tval <- tryAllM $
setSrcSpan expr_span $ -- Set the span so that qLocation can
-- see where this splice is
- do { th_syn <- TH.runQ (unsafeCoerce# hval)
- ; case convert expr_span th_syn of
+ do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval)
+ ; case mb_result of
Left err -> failWithTc err
- Right hs_syn -> return hs_syn }
+ Right result -> return $! result }
; case either_tval of
Right v -> return v
- Left exn | Just s <- Exception.userErrors exn
- , s == "IOEnv failure"
- -> failM -- Error already in Tc monad
- | otherwise -> failWithTc (mk_msg "run" exn) -- Exception
+ Left se ->
+ case fromException se of
+ Just IOEnvFailure ->
+ failM -- Error already in Tc monad
+ _ -> failWithTc (mk_msg "run" se) -- Exception
}}}
where
mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
nest 2 (text (Panic.showException exn)),
- nest 2 (text "Code:" <+> ppr expr)]
+ if show_code then nest 2 (text "Code:" <+> ppr expr) else empty]
\end{code}
Note [Exceptions in TH]
* The TcM monad is an instance of Quasi (see TcSplice), and it implements
(qReport True s) by using addErr to add an error message to the bag of errors.
- The 'fail' in TcM raises a UserError, with the uninteresting string
- "IOEnv failure"
+ The 'fail' in TcM raises an IOEnvFailure exception
* So, when running a splice, we catch all exceptions; then for
- - a UserError "IOEnv failure", we assume the error is already
+ - an IOEnvFailure exception, we assume the error is already
in the error-bag (above)
- other errors, we add an error to the bag
and then fail
%************************************************************************
\begin{code}
-showSplice :: String -> LHsExpr Id -> SDoc -> TcM ()
-showSplice what before after = do
- loc <- getSrcSpanM
- traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
- nest 2 (sep [nest 2 (ppr before),
- text "======>",
- nest 2 after])])
-
-illegalBracket level
- = ptext SLIT("Illegal bracket at level") <+> ppr level
-
-illegalSplice level
- = ptext SLIT("Illegal splice at level") <+> ppr level
-
+showSplice :: String -> LHsExpr Name -> SDoc -> TcM ()
+-- Note that 'before' is *renamed* but not *typechecked*
+-- Reason (a) less typechecking crap
+-- (b) data constructors after type checking have been
+-- changed to their *wrappers*, and that makes them
+-- print always fully qualified
+showSplice what before after
+ = do { loc <- getSrcSpanM
+ ; traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
+ nest 2 (sep [nest 2 (ppr before),
+ text "======>",
+ nest 2 after])]) }
+
+illegalBracket :: SDoc
+illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (without intervening splices)")
#endif /* GHCI */
\end{code}
ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
+ ppr_ns _ = panic "reify/ppr_ns"
lookupThName :: TH.Name -> TcM Name
-lookupThName th_name@(TH.Name occ flavour)
- = do { let rdr_name = thRdrName guessed_ns occ_str flavour
-
- -- Repeat much of lookupOccRn, becase we want
- -- to report errors in a TH-relevant way
- ; rdr_env <- getLocalRdrEnv
- ; case lookupLocalRdrEnv rdr_env rdr_name of
- Just name -> return name
- Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig
- -> lookupImportedName rdr_name
- | otherwise -- Unqual, Qual
- -> do { mb_name <- lookupSrcOcc_maybe rdr_name
- ; case mb_name of
- Just name -> return name
- Nothing -> failWithTc (notInScope th_name) }
- }
+lookupThName th_name = do
+ mb_name <- lookupThName_maybe th_name
+ case mb_name of
+ Nothing -> failWithTc (notInScope th_name)
+ Just name -> return name
+
+lookupThName_maybe th_name
+ = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
+ -- Pick the first that works
+ -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
+ ; return (listToMaybe names) }
where
- -- guessed_ns is the name space guessed from looking at the TH name
- guessed_ns | isLexCon (mkFastString occ_str) = OccName.dataName
- | otherwise = OccName.varName
- occ_str = TH.occString occ
+ lookup rdr_name
+ = do { -- Repeat much of lookupOccRn, becase we want
+ -- to report errors in a TH-relevant way
+ ; rdr_env <- getLocalRdrEnv
+ ; case lookupLocalRdrEnv rdr_env rdr_name of
+ Just name -> return (Just name)
+ Nothing -> lookupGlobalOccRn_maybe rdr_name }
tcLookupTh :: Name -> TcM TcTyThing
-- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
notInScope :: TH.Name -> SDoc
notInScope th_name = quotes (text (TH.pprint th_name)) <+>
- ptext SLIT("is not in scope at a reify")
+ ptext (sLit "is not in scope at a reify")
-- Ugh! Rather an indirect way to display the name
notInEnv :: Name -> SDoc
notInEnv name = quotes (ppr name) <+>
- ptext SLIT("is not in the type environment at a reify")
+ ptext (sLit "is not in the type environment at a reify")
------------------------------
reifyThing :: TcTyThing -> TcM TH.Info
= do { ty <- reifyType (idType id)
; fix <- reifyFixity (idName id)
; let v = reifyName id
- ; case globalIdDetails id of
+ ; case idDetails id of
ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
- other -> return (TH.VarI v ty Nothing fix)
+ _ -> return (TH.VarI v ty Nothing fix)
}
reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
= do { let name = dataConName dc
; ty <- reifyType (idType (dataConWrapId dc))
; fix <- reifyFixity name
- ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
+ ; return (TH.DataConI (reifyName name) ty
+ (reifyName (dataConOrigTyCon dc)) fix)
+ }
reifyThing (ATcId {tct_id = id, tct_type = ty})
= do { ty1 <- zonkTcType ty -- Make use of all the info we have, even
; ty2 <- reifyType ty1
; return (TH.TyVarI (reifyName tv) ty2) }
+reifyThing (AThing {}) = panic "reifyThing AThing"
+
------------------------------
reifyTyCon :: TyCon -> TcM TH.Info
reifyTyCon tc
- | isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False)
- | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
+ | isFunTyCon tc
+ = return (TH.PrimTyConI (reifyName tc) 2 False)
+ | isPrimTyCon tc
+ = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
+ | isOpenTyCon tc
+ = let flavour = reifyFamFlavour tc
+ tvs = tyConTyVars tc
+ kind = tyConKind tc
+ kind'
+ | isLiftedTypeKind kind = Nothing
+ | otherwise = Just $ reifyKind kind
+ in
+ return (TH.TyConI $
+ TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
| isSynTyCon tc
= do { let (tvs, rhs) = synTyConDefn tc
; rhs' <- reifyType rhs
; return (TH.TyConI $
- TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
+ TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs')
+ }
reifyTyCon tc
= do { cxt <- reifyCxt (tyConStupidTheta tc)
r_tvs = reifyTyVars tvs
deriv = [] -- Don't know about deriving
decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
- | otherwise = TH.DataD cxt name r_tvs cons deriv
+ | otherwise = TH.DataD cxt name r_tvs cons deriv
; return (TH.TyConI decl) }
reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
else
return (TH.NormalC name (stricts `zip` arg_tys)) }
| otherwise
- = failWithTc (ptext SLIT("Can't reify a non-Haskell-98 data constructor:")
+ = failWithTc (ptext (sLit "Can't reify a GADT data constructor:")
<+> quotes (ppr dc))
------------------------------
; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
where
(tvs, cxt, tau) = tcSplitSigmaTy ty
+reifyType (PredTy {}) = panic "reifyType PredTy"
+
+reifyTypes :: [Type] -> TcM [TH.Type]
reifyTypes = mapM reifyType
+
+reifyKind :: Kind -> TH.Kind
+reifyKind ki
+ = let (kis, ki') = splitKindFunTys ki
+ kis_rep = map reifyKind kis
+ ki'_rep = reifyNonArrowKind ki'
+ in
+ foldl TH.ArrowK ki'_rep kis_rep
+ where
+ reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK
+ | otherwise = pprPanic "Exotic form of kind"
+ (ppr k)
+
+reifyCxt :: [PredType] -> TcM [TH.Pred]
reifyCxt = mapM reifyPred
reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
-reifyTyVars :: [TyVar] -> [TH.Name]
-reifyTyVars = map reifyName
+reifyFamFlavour :: TyCon -> TH.FamFlavour
+reifyFamFlavour tc | isOpenSynTyCon tc = TH.TypeFam
+ | isOpenTyCon tc = TH.DataFam
+ | otherwise
+ = panic "TcSplice.reifyFamFlavour: not a type family"
+
+reifyTyVars :: [TyVar] -> [TH.TyVarBndr]
+reifyTyVars = map reifyTyVar
+ where
+ reifyTyVar tv | isLiftedTypeKind kind = TH.PlainTV name
+ | otherwise = TH.KindedTV name (reifyKind kind)
+ where
+ kind = tyVarKind tv
+ name = reifyName tv
reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
reify_tc_app tc tys = do { tys' <- reifyTypes tys
; return (foldl TH.AppT (TH.ConT tc) tys') }
-reifyPred :: TypeRep.PredType -> TcM TH.Type
-reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
-reifyPred p@(IParam _ _) = noTH SLIT("implicit parameters") (ppr p)
+reifyPred :: TypeRep.PredType -> TcM TH.Pred
+reifyPred (ClassP cls tys)
+ = do { tys' <- reifyTypes tys
+ ; return $ TH.ClassP (reifyName cls) tys'
+ }
+reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p)
+reifyPred (EqPred ty1 ty2)
+ = do { ty1' <- reifyType ty1
+ ; ty2' <- reifyType ty2
+ ; return $ TH.EqualP ty1' ty2'
+ }
------------------------------
-- have free variables, we may need to generate NameL's for them.
where
name = getName thing
- mod = nameModule name
+ mod = ASSERT( isExternalName name ) nameModule name
pkg_str = packageIdString (modulePackageId mod)
mod_str = moduleNameString (moduleName mod)
occ_str = occNameString occ
------------------------------
noTH :: LitString -> SDoc -> TcM a
-noTH s d = failWithTc (hsep [ptext SLIT("Can't represent") <+> ptext s <+>
- ptext SLIT("in Template Haskell:"),
+noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
+ ptext (sLit "in Template Haskell:"),
nest 2 d])
\end{code}
projects / ghc-hetmet.git / blobdiff