X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=70eaca8cec7cde7ff38961176ebcc907035d5719;hb=2662dbc5b2c30fc11ccb99e7f9b2dba794d680ba;hp=f65dc29ad73fabf15d7f59613ce19cb6ead5fb6a;hpb=aa9a4f1053d3c554629a2ec25955e7530c95b892;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index f65dc29..70eaca8 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -5,6 +5,7 @@ TcSplice: Template Haskell splices + \begin{code} {-# OPTIONS -fno-warn-unused-imports -fno-warn-unused-binds #-} -- The above warning supression flag is a temporary kludge. @@ -13,8 +14,9 @@ TcSplice: Template Haskell splices -- 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, + runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where #include "HsVersions.h" @@ -41,12 +43,15 @@ import TcIface import TypeRep import Name import NameEnv +import PrelNames import HscTypes import OccName import Var import Module +import Annotations import TcRnMonad import Class +import Inst import TyCon import DataCon import Id @@ -55,23 +60,139 @@ import TysWiredIn import DsMeta import DsExpr import DsMonad hiding (Splice) +import Serialized import ErrUtils import SrcLoc import Outputable import Unique -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 qualified Exception ( userErrors ) +import System.IO.Error \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) @@ -81,7 +202,7 @@ Note [Template Haskell levels] * 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 [| |] @@ -163,8 +284,11 @@ 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 tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x) @@ -172,8 +296,11 @@ 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) +runAnnotation _ q = pprPanic "Cant do runAnnotation without GHCi" (ppr q) #else \end{code} @@ -183,54 +310,46 @@ runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q) %* * %************************************************************************ -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 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) } _ -> pprPanic "th_bracket" (ppr name) @@ -239,17 +358,17 @@ tc_bracket use_lvl (VarBr name) -- Note [Quoting names] 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 _ (TypBr typ) - = do { tcHsSigType ExprSigCtxt typ + = do { _ <- tcHsSigTypeNC ThBrackCtxt typ ; tcMetaTy typeQTyConName } -- Result type is Type (= Q Typ) tc_bracket _ (DecBr decls) - = do { tcTopSrcDecls emptyModDetails decls + = do { _ <- tcTopSrcDecls emptyModDetails decls -- Typecheck the declarations, dicarding the result -- We'll get all that stuff later, when we splice it in @@ -278,88 +397,215 @@ quotedNameStageErr v \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) + ; ps <- readMutVar ps_var + ; writeMutVar ps_var ((name,expr') : ps) - return (panic "tcSpliceExpr") -- The returned expression is ignored + ; return (panic "tcSpliceExpr") -- The returned expression is ignored + }}} - ; Splice {} -> panic "tcSpliceExpr Splice" - }} - --- 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 - -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 "Got result" <+> ppr expr2) - - showSplice "expression" - zonked_q_expr (ppr expr2) + ; expr2 <- runMetaE zonked_q_expr + ; 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) + ; addErrCtxt (spliceResultDoc expr) $ do + { (exp3, _fvs) <- checkNoErrs (rnLExpr expr2) - tcMonoExpr exp3 res_ty + ; exp4 <- tcMonoExpr exp3 res_ty + ; return (unLoc exp4) } } +spliceResultDoc :: LHsExpr Name -> SDoc +spliceResultDoc expr + = sep [ ptext (sLit "In the result of the splice:") + , nest 2 (char '$' <> pprParendExpr expr) + , ptext (sLit "To see what the splice expanded to, use -ddump-splices")] -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 + ; hs_ty2 <- runMetaT zonked_q_expr + ; showSplice "type" expr (ppr hs_ty2) + + -- Rename it, but bale out if there are errors + -- otherwise the type checker just gives more spurious errors + ; addErrCtxt (spliceResultDoc expr) $ do + { 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 + ; decls <- runMetaD zonked_q_expr + ; 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} @@ -390,11 +636,10 @@ the splice is run by the *renamer* rather than the type checker. runQuasiQuote :: Outputable hs_syn => HsQuasiQuote Name -- Contains term of type QuasiQuoter, and the String -> Name -- Of type QuasiQuoter -> String -> Q th_syn - -> String -- Documentation string only -> Name -- Name of th_syn type - -> (SrcSpan -> th_syn -> Either Message hs_syn) + -> MetaOps th_syn 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 meta_ty meta_ops = do { -- Check that the quoter is not locally defined, otherwise the TH -- machinery will not be able to run the quasiquote. ; this_mod <- getModule @@ -411,25 +656,19 @@ runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ ; 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 - ; traceTc (text "Got result" <+> ppr result) - ; showSplice desc zonked_q_expr (ppr result) - ; return result - } + ; result <- runMetaQ meta_ops zonked_q_expr + ; showSplice (mt_desc meta_ops) quoteExpr (ppr result) -runQuasiQuoteExpr quasiquote - = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr + ; return result } -runQuasiQuotePat quasiquote - = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat +runQuasiQuoteExpr quasiquote = runQuasiQuote quasiquote quoteExpName expQTyConName exprMetaOps +runQuasiQuotePat quasiquote = runQuasiQuote quasiquote quotePatName patQTyConName patMetaOps quoteStageError :: Name -> SDoc quoteStageError quoter @@ -440,128 +679,75 @@ quoteStageError quoter %************************************************************************ %* * - Splicing a type +\subsection{Running an expression} %* * %************************************************************************ -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 +data MetaOps th_syn hs_syn + = MT { mt_desc :: String -- Type of beast (expression, type etc) + , mt_show :: th_syn -> String -- How to show the th_syn thing + , mt_cvt :: SrcSpan -> th_syn -> Either Message hs_syn + -- How to convert to hs_syn } - ; Splice {} -> panic "kcSpliceType Splice" - }}}} - -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 } -\end{code} - - -%************************************************************************ -%* * -\subsection{Running an expression} -%* * -%************************************************************************ +exprMetaOps :: MetaOps TH.Exp (LHsExpr RdrName) +exprMetaOps = MT { mt_desc = "expression", mt_show = TH.pprint, mt_cvt = convertToHsExpr } + +patMetaOps :: MetaOps TH.Pat (LPat RdrName) +patMetaOps = MT { mt_desc = "pattern", mt_show = TH.pprint, mt_cvt = convertToPat } + +typeMetaOps :: MetaOps TH.Type (LHsType RdrName) +typeMetaOps = MT { mt_desc = "type", mt_show = TH.pprint, mt_cvt = convertToHsType } + +declMetaOps :: MetaOps [TH.Dec] [LHsDecl RdrName] +declMetaOps = MT { mt_desc = "declarations", mt_show = TH.pprint, mt_cvt = convertToHsDecls } + +---------------- +runMetaAW :: Outputable output + => (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 + +----------------- +runMetaQ :: Outputable hs_syn + => MetaOps th_syn hs_syn + -> LHsExpr Id + -> TcM hs_syn +runMetaQ (MT { mt_show = show_th, mt_cvt = cvt }) expr + = runMeta True run_and_cvt expr + where + run_and_cvt expr_span hval + = do { th_result <- TH.runQ hval + ; traceTc (text "Got TH result:" <+> text (show_th th_result)) + ; return (cvt expr_span th_result) } -\begin{code} -runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)) - -> LHsExpr Id -- Of type (Q Exp) +runMetaE :: LHsExpr Id -- Of type (Q Exp) -> TcM (LHsExpr RdrName) -runMetaE = runMeta +runMetaE = runMetaQ exprMetaOps -runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName)) - -> LHsExpr Id -- Of type (Q Pat) - -> TcM (Pat RdrName) -runMetaP = runMeta - -runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName)) - -> LHsExpr Id -- Of type (Q Type) +runMetaT :: LHsExpr Id -- Of type (Q Type) -> TcM (LHsType RdrName) -runMetaT = runMeta +runMetaT = runMetaQ typeMetaOps -runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName]) - -> LHsExpr Id -- Of type Q [Dec] +runMetaD :: LHsExpr Id -- Of type Q [Dec] -> TcM [LHsDecl RdrName] -runMetaD = runMeta +runMetaD = runMetaQ declMetaOps -runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn) - -> LHsExpr Id -- Of type X +--------------- +runMeta :: (Outputable hs_syn) + => Bool -- Whether code should be printed in the exception message + -> (SrcSpan -> x -> TcM (Either Message hs_syn)) -- How to run x + -> LHsExpr Id -- Of type x; typically x = Q TH.Exp, or something like that -> TcM hs_syn -- Of type t -runMeta convert expr - = do { -- Desugar - ds_expr <- initDsTc (dsLExpr expr) +runMeta show_code run_and_convert expr + = do { traceTc (text "About to run" <+> ppr expr) + + -- Desugar + ; ds_expr <- initDsTc (dsLExpr expr) -- Compile and link it; might fail if linking fails ; hsc_env <- getTopEnv ; src_span <- getSrcSpanM @@ -586,22 +772,22 @@ runMeta convert expr ; 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 -> do { traceTc (ptext (sLit "Got HsSyn result:") <+> ppr 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] @@ -625,11 +811,10 @@ like that. Here's how it's processed: * 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 @@ -644,7 +829,7 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where ; return (TH.mkNameU s i) } qReport True msg = addErr (text msg) - qReport False msg = addReport (text msg) + qReport False msg = addReport (text msg) empty qLocation = do { m <- getModule ; l <- getSrcSpanM @@ -677,22 +862,21 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where %************************************************************************ \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 :: ThStage -> SDoc -illegalBracket level - = ptext (sLit "Illegal bracket at level") <+> ppr level - -illegalSplice :: ThStage -> SDoc -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} @@ -721,14 +905,17 @@ reify th_name ppr_ns _ = panic "reify/ppr_ns" lookupThName :: TH.Name -> TcM Name -lookupThName th_name@(TH.Name occ flavour) - = do { mb_ns <- mapM lookup [ thRdrName gns occ_str flavour - | gns <- guessed_nss] - ; case catMaybes mb_ns of - [] -> failWithTc (notInScope th_name) - (n:_) -> return n } -- Pick the first that works - -- E.g. reify (mkName "A") will pick the class A - -- in preference to the data constructor A +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 lookup rdr_name = do { -- Repeat much of lookupOccRn, becase we want @@ -736,16 +923,7 @@ lookupThName th_name@(TH.Name occ flavour) ; rdr_env <- getLocalRdrEnv ; case lookupLocalRdrEnv rdr_env rdr_name of Just name -> return (Just name) - Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig - -> do { name <- lookupImportedName rdr_name - ; return (Just name) } - | otherwise -- Unqual, Qual - -> lookupSrcOcc_maybe rdr_name } - - -- guessed_ns are the name spaces guessed from looking at the TH name - guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName] - | otherwise = [OccName.varName, OccName.tvName] - occ_str = TH.occString occ + Nothing -> lookupGlobalOccRn_maybe rdr_name } tcLookupTh :: Name -> TcM TcTyThing -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that @@ -792,9 +970,9 @@ reifyThing (AGlobal (AnId id)) = do { ty <- reifyType (idType id) ; fix <- reifyFixity (idName id) ; let v = reifyName id - ; case globalIdDetails id of - ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix) - _ -> return (TH.VarI v ty Nothing fix) + ; case idDetails id of + ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix) + _ -> return (TH.VarI v ty Nothing fix) } reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc @@ -803,7 +981,9 @@ reifyThing (AGlobal (ADataCon dc)) = 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 @@ -822,13 +1002,26 @@ 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) @@ -838,7 +1031,7 @@ reifyTyCon 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 @@ -860,7 +1053,7 @@ reifyDataCon tys dc 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)) ------------------------------ @@ -890,23 +1083,55 @@ reifyType (PredTy {}) = panic "reifyType PredTy" reifyTypes :: [Type] -> TcM [TH.Type] reifyTypes = mapM reifyType -reifyCxt :: [PredType] -> TcM [TH.Type] + +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 :: 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 {}) = panic "reifyPred EqPred" +reifyPred (EqPred ty1 ty2) + = do { ty1' <- reifyType ty1 + ; ty2' <- reifyType ty2 + ; return $ TH.EqualP ty1' ty2' + } ------------------------------ @@ -920,7 +1145,7 @@ reifyName thing -- 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