+\begin{code}
+runAnnotation target expr = do
+ expr_ty <- newFlexiTyVarTy liftedTypeKind
+
+ -- Find the classes we want instances for in order to call toAnnotationWrapper
+ data_class <- tcLookupClass dataClassName
+
+ -- 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
+ ((wrapper, expr'), const_binds) <- tcSimplifyStagedExpr topAnnStage $ do
+ expr' <- tcPolyExprNC expr expr_ty
+ -- By instantiating the call >here< it gets registered in the
+ -- LIE consulted by tcSimplifyStagedExpr
+ -- and hence ensures the appropriate dictionary is bound by const_binds
+ wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
+ return (wrapper, expr')
+
+ -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
+ loc <- getSrcSpanM
+ to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
+ let specialised_to_annotation_wrapper_expr = L loc (HsWrap wrapper (HsVar to_annotation_wrapper_id))
+ wrapped_expr' = mkHsDictLet const_binds $
+ L loc (HsApp specialised_to_annotation_wrapper_expr expr')
+
+ -- If we have type checking problems then potentially zonking
+ -- (and certainly compilation) may fail. Give up NOW!
+ failIfErrsM
+
+ -- Zonk the type variables out of that raw expression. Note that
+ -- in particular we don't call recordThUse, since we don't
+ -- necessarily use any code or definitions from that package.
+ zonked_wrapped_expr' <- zonkTopLExpr wrapped_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}
+
+
+%************************************************************************
+%* *
+ Quasi-quoting
+%* *
+%************************************************************************
+
+Note [Quasi-quote overview]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The GHC "quasi-quote" extension is described by Geoff Mainland's paper
+"Why it's nice to be quoted: quasiquoting for Haskell" (Haskell
+Workshop 2007).
+
+Briefly, one writes
+ [:p| stuff |]
+and the arbitrary string "stuff" gets parsed by the parser 'p', whose
+type should be Language.Haskell.TH.Quote.QuasiQuoter. 'p' must be
+defined in another module, because we are going to run it here. It's
+a bit like a TH splice:
+ $(p "stuff")
+
+However, you can do this in patterns as well as terms. Becuase of this,
+the splice is run by the *renamer* rather than the type checker.
+
+\begin{code}
+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)
+ -> TcM hs_syn
+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 is_local = case nameModule_maybe quoter of
+ Just mod | mod == this_mod -> True
+ | otherwise -> False
+ Nothing -> True
+ ; traceTc (text "runQQ" <+> ppr quoter <+> ppr is_local)
+ ; checkTc (not is_local) (quoteStageError quoter)
+
+ -- Build the expression
+ ; let quoterExpr = L q_span $! HsVar $! quoter
+ ; let quoteExpr = L q_span $! HsLit $! HsString quote
+ ; 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
+
+ -- Run the expression
+ ; traceTc (text "About to run" <+> ppr zonked_q_expr)
+ ; result <- runMetaQ convert zonked_q_expr
+ ; traceTc (text "Got result" <+> ppr result)
+ ; showSplice desc zonked_q_expr (ppr result)
+ ; return result
+ }
+
+runQuasiQuoteExpr quasiquote
+ = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr
+
+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"))]