2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 TcSplice: Template Haskell splices
9 {-# OPTIONS -fno-warn-unused-imports -fno-warn-unused-binds #-}
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
19 runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where
21 #include "HsVersions.h"
25 -- These imports are the reason that TcSplice
26 -- is very high up the module hierarchy
62 import DsMonad hiding (Splice)
74 import qualified Language.Haskell.TH as TH
75 -- THSyntax gives access to internal functions and data types
76 import qualified Language.Haskell.TH.Syntax as TH
79 -- Because GHC.Desugar might not be in the base library of the bootstrapping compiler
80 import GHC.Desugar ( AnnotationWrapper(..) )
83 import GHC.Exts ( unsafeCoerce#, Int#, Int(..) )
84 import System.IO.Error
87 --here for every bad reason :-)
91 todoSession :: HscEnv -> Name -> IO (Messages, Maybe (LHsDecl RdrName))
92 todoSession hsc_env name
93 = initTcPrintErrors hsc_env iNTERACTIVE $
94 setInteractiveContext hsc_env (hsc_IC hsc_env) $
98 todoTcM :: Name -> TcM (LHsDecl RdrName)
100 tcTyThing <- TcEnv.tcLookup name
101 thInfo <- TcSplice.reifyThing tcTyThing
102 let Just thDec = thGetDecFromInfo thInfo --BUG!
103 let Right [hsdecl] = Convert.convertToHsDecls
104 (error "srcspan of different package?")
108 thGetDecFromInfo :: TH.Info -> Maybe TH.Dec
109 thGetDecFromInfo (TH.ClassI dec) = Just dec
110 thGetDecFromInfo (TH.ClassOpI {}) = error "classop"
111 thGetDecFromInfo (TH.TyConI dec) = Just dec
112 thGetDecFromInfo (TH.PrimTyConI {}) = Nothing --error "sometimes we can invent a signature? or it's better not to?"
113 thGetDecFromInfo (TH.DataConI {}) = error "datacon"
114 thGetDecFromInfo (TH.VarI _name _type (Just dec) _fixity) = Just dec
115 thGetDecFromInfo (TH.VarI _name _type Nothing _fixity) = error "vari"
116 thGetDecFromInfo (TH.TyVarI {}) = Nothing --tyvars don't have decls? they kinda have a type though...
118 setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
119 setInteractiveContext hsc_env icxt thing_inside
120 = let -- Initialise the tcg_inst_env with instances from all home modules.
121 -- This mimics the more selective call to hptInstances in tcRnModule.
122 (home_insts, home_fam_insts) = hptInstances hsc_env (\_mod -> True)
124 updGblEnv (\env -> env {
125 tcg_rdr_env = ic_rn_gbl_env icxt,
126 tcg_inst_env = extendInstEnvList (tcg_inst_env env) home_insts,
127 tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env env)
131 tcExtendGhciEnv (ic_tmp_ids icxt) $
132 -- tcExtendGhciEnv does lots:
133 -- - it extends the local type env (tcl_env) with the given Ids,
134 -- - it extends the local rdr env (tcl_rdr) with the Names from
136 -- - it adds the free tyvars of the Ids to the tcl_tyvars
139 -- later ids in ic_tmp_ids must shadow earlier ones with the same
140 -- OccName, and tcExtendIdEnv implements this behaviour.
142 do { traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt))
146 Note [Template Haskell levels]
147 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
148 * Imported things are impLevel (= 0)
150 * In GHCi, variables bound by a previous command are treated
151 as impLevel, because we have bytecode for them.
153 * Variables are bound at the "current level"
155 * The current level starts off at topLevel (= 1)
157 * The level is decremented by splicing $(..)
158 incremented by brackets [| |]
159 incremented by name-quoting 'f
161 When a variable is used, we compare
162 bind: binding level, and
163 use: current level at usage site
166 bind > use Always error (bound later than used)
169 bind = use Always OK (bound same stage as used)
170 [| \x -> $(f [| x |]) |]
172 bind < use Inside brackets, it depends
176 For (bind < use) inside brackets, there are three cases:
177 - Imported things OK f = [| map |]
178 - Top-level things OK g = [| f |]
179 - Non-top-level Only if there is a liftable instance
180 h = \(x:Int) -> [| x |]
182 See Note [What is a top-level Id?]
186 A quoted name 'n is a bit like a quoted expression [| n |], except that we
187 have no cross-stage lifting (c.f. TcExpr.thBrackId). So, after incrementing
188 the use-level to account for the brackets, the cases are:
197 See Note [What is a top-level Id?] in TcEnv. Examples:
199 f 'map -- OK; also for top-level defns of this module
201 \x. f 'x -- Not ok (whereas \x. f [| x |] might have been ok, by
202 -- cross-stage lifting
204 \y. [| \x. $(f 'y) |] -- Not ok (same reason)
206 [| \x. $(f 'x) |] -- OK
209 Note [What is a top-level Id?]
210 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
211 In the level-control criteria above, we need to know what a "top level Id" is.
212 There are three kinds:
213 * Imported from another module (GlobalId, ExternalName)
214 * Bound at the top level of this module (ExternalName)
215 * In GHCi, bound by a previous stmt (GlobalId)
216 It's strange that there is no one criterion tht picks out all three, but that's
217 how it is right now. (The obvious thing is to give an ExternalName to GHCi Ids
218 bound in an earlier Stmt, but what module would you choose? See
219 Note [Interactively-bound Ids in GHCi] in TcRnDriver.)
221 The predicate we use is TcEnv.thTopLevelId.
224 %************************************************************************
226 \subsection{Main interface + stubs for the non-GHCI case
228 %************************************************************************
231 tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
232 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
233 tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
234 kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
235 -- None of these functions add constraints to the LIE
237 lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
239 runQuasiQuoteExpr :: HsQuasiQuote Name -> TcM (LHsExpr RdrName)
240 runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName)
241 runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
244 tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x)
245 tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
246 tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
247 kcSpliceType x = pprPanic "Cant do kcSpliceType without GHCi" (ppr x)
249 lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n)
251 runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q)
252 runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q)
253 runAnnotation _ q = pprPanic "Cant do runAnnotation without GHCi" (ppr q)
257 %************************************************************************
259 \subsection{Quoting an expression}
261 %************************************************************************
263 Note [Handling brackets]
264 ~~~~~~~~~~~~~~~~~~~~~~~~
265 Source: f = [| Just $(g 3) |]
266 The [| |] part is a HsBracket
268 Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
269 The [| |] part is a HsBracketOut, containing *renamed* (not typechecked) expression
270 The "s7" is the "splice point"; the (g Int 3) part is a typechecked expression
272 Desugared: f = do { s7 <- g Int 3
273 ; return (ConE "Data.Maybe.Just" s7) }
276 tcBracket brack res_ty
277 = addErrCtxt (hang (ptext (sLit "In the Template Haskell quotation"))
279 do { level <- getStage
280 ; case bracketOK level of {
281 Nothing -> failWithTc (illegalBracket level) ;
282 Just next_level -> do {
284 -- Typecheck expr to make sure it is valid,
285 -- but throw away the results. We'll type check
286 -- it again when we actually use it.
288 ; pending_splices <- newMutVar []
289 ; lie_var <- getLIEVar
291 ; (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
292 (getLIE (tc_bracket next_level brack))
293 ; tcSimplifyBracket lie
295 -- Make the expected type have the right shape
296 ; _ <- boxyUnify meta_ty res_ty
298 -- Return the original expression, not the type-decorated one
299 ; pendings <- readMutVar pending_splices
300 ; return (noLoc (HsBracketOut brack pendings)) }}}
302 tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType
303 tc_bracket use_lvl (VarBr name) -- Note [Quoting names]
304 = do { thing <- tcLookup name
306 AGlobal _ -> return ()
307 ATcId { tct_level = bind_lvl, tct_id = id }
308 | thTopLevelId id -- C.f thTopLevelId case of
309 -> keepAliveTc id -- TcExpr.thBrackId
311 -> do { checkTc (use_lvl == bind_lvl)
312 (quotedNameStageErr name) }
313 _ -> pprPanic "th_bracket" (ppr name)
315 ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
318 tc_bracket _ (ExpBr expr)
319 = do { any_ty <- newFlexiTyVarTy liftedTypeKind
320 ; _ <- tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that
321 ; tcMetaTy expQTyConName }
322 -- Result type is Expr (= Q Exp)
324 tc_bracket _ (TypBr typ)
325 = do { _ <- tcHsSigTypeNC ThBrackCtxt typ
326 ; tcMetaTy typeQTyConName }
327 -- Result type is Type (= Q Typ)
329 tc_bracket _ (DecBr decls)
330 = do { _ <- tcTopSrcDecls emptyModDetails decls
331 -- Typecheck the declarations, dicarding the result
332 -- We'll get all that stuff later, when we splice it in
334 ; decl_ty <- tcMetaTy decTyConName
335 ; q_ty <- tcMetaTy qTyConName
336 ; return (mkAppTy q_ty (mkListTy decl_ty))
337 -- Result type is Q [Dec]
340 tc_bracket _ (PatBr _)
341 = failWithTc (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
343 quotedNameStageErr :: Name -> SDoc
345 = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
346 , ptext (sLit "must be used at the same stage at which is is bound")]
350 %************************************************************************
352 \subsection{Splicing an expression}
354 %************************************************************************
357 tcSpliceExpr (HsSplice name expr) res_ty
358 = setSrcSpan (getLoc expr) $ do
360 case spliceOK level of {
361 Nothing -> failWithTc (illegalSplice level) ;
365 Comp _ -> do { e <- tcTopSplice expr res_ty
366 ; return (unLoc e) } ;
367 Brack _ ps_var lie_var -> do
369 -- A splice inside brackets
370 -- NB: ignore res_ty, apart from zapping it to a mono-type
371 -- e.g. [| reverse $(h 4) |]
372 -- Here (h 4) :: Q Exp
373 -- but $(h 4) :: forall a.a i.e. anything!
376 meta_exp_ty <- tcMetaTy expQTyConName
377 expr' <- setStage (Splice next_level) (
379 tcMonoExpr expr meta_exp_ty
382 -- Write the pending splice into the bucket
383 ps <- readMutVar ps_var
384 writeMutVar ps_var ((name,expr') : ps)
386 return (panic "tcSpliceExpr") -- The returned expression is ignored
388 ; Splice {} -> panic "tcSpliceExpr Splice"
391 -- tcTopSplice used to have this:
392 -- Note that we do not decrement the level (to -1) before
393 -- typechecking the expression. For example:
394 -- f x = $( ...$(g 3) ... )
395 -- The recursive call to tcMonoExpr will simply expand the
396 -- inner escape before dealing with the outer one
398 tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id)
399 tcTopSplice expr res_ty = do
400 meta_exp_ty <- tcMetaTy expQTyConName
402 -- Typecheck the expression
403 zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
405 -- Run the expression
406 traceTc (text "About to run" <+> ppr zonked_q_expr)
407 expr2 <- runMetaE convertToHsExpr zonked_q_expr
409 traceTc (text "Got result" <+> ppr expr2)
411 showSplice "expression" expr (ppr expr2)
413 -- Rename it, but bale out if there are errors
414 -- otherwise the type checker just gives more spurious errors
415 (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
417 tcMonoExpr exp3 res_ty
420 tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id)
421 -- Type check an expression that is the body of a top-level splice
422 -- (the caller will compile and run it)
423 tcTopSpliceExpr expr meta_ty
424 = checkNoErrs $ -- checkNoErrs: must not try to run the thing
425 -- if the type checker fails!
426 do { (expr', const_binds) <- tcSimplifyStagedExpr topSpliceStage $
427 (recordThUse >> tcMonoExpr expr meta_ty)
428 -- Zonk it and tie the knot of dictionary bindings
429 ; zonkTopLExpr (mkHsDictLet const_binds expr') }
433 %************************************************************************
437 %************************************************************************
440 runAnnotation target expr = do
441 expr_ty <- newFlexiTyVarTy liftedTypeKind
443 -- Find the classes we want instances for in order to call toAnnotationWrapper
444 data_class <- tcLookupClass dataClassName
446 -- Check the instances we require live in another module (we want to execute it..)
447 -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
448 -- also resolves the LIE constraints to detect e.g. instance ambiguity
449 ((wrapper, expr'), const_binds) <- tcSimplifyStagedExpr topAnnStage $ do
450 expr' <- tcPolyExprNC expr expr_ty
451 -- By instantiating the call >here< it gets registered in the
452 -- LIE consulted by tcSimplifyStagedExpr
453 -- and hence ensures the appropriate dictionary is bound by const_binds
454 wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
455 return (wrapper, expr')
457 -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
459 to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
460 let specialised_to_annotation_wrapper_expr = L loc (HsWrap wrapper (HsVar to_annotation_wrapper_id))
461 wrapped_expr' = mkHsDictLet const_binds $
462 L loc (HsApp specialised_to_annotation_wrapper_expr expr')
464 -- If we have type checking problems then potentially zonking
465 -- (and certainly compilation) may fail. Give up NOW!
468 -- Zonk the type variables out of that raw expression. Note that
469 -- in particular we don't call recordThUse, since we don't
470 -- necessarily use any code or definitions from that package.
471 zonked_wrapped_expr' <- zonkTopLExpr wrapped_expr'
473 -- Run the appropriately wrapped expression to get the value of
474 -- the annotation and its dictionaries. The return value is of
475 -- type AnnotationWrapper by construction, so this conversion is
477 flip runMetaAW zonked_wrapped_expr' $ \annotation_wrapper ->
478 case annotation_wrapper of
479 AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
480 -- Got the value and dictionaries: build the serialized value and
481 -- call it a day. We ensure that we seq the entire serialized value
482 -- in order that any errors in the user-written code for the
483 -- annotation are exposed at this point. This is also why we are
484 -- doing all this stuff inside the context of runMeta: it has the
485 -- facilities to deal with user error in a meta-level expression
486 seqSerialized serialized `seq` Annotation {
488 ann_value = serialized
493 %************************************************************************
497 %************************************************************************
499 Note [Quasi-quote overview]
500 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
501 The GHC "quasi-quote" extension is described by Geoff Mainland's paper
502 "Why it's nice to be quoted: quasiquoting for Haskell" (Haskell
507 and the arbitrary string "stuff" gets parsed by the parser 'p', whose
508 type should be Language.Haskell.TH.Quote.QuasiQuoter. 'p' must be
509 defined in another module, because we are going to run it here. It's
510 a bit like a TH splice:
513 However, you can do this in patterns as well as terms. Becuase of this,
514 the splice is run by the *renamer* rather than the type checker.
517 runQuasiQuote :: Outputable hs_syn
518 => HsQuasiQuote Name -- Contains term of type QuasiQuoter, and the String
519 -> Name -- Of type QuasiQuoter -> String -> Q th_syn
520 -> String -- Documentation string only
521 -> Name -- Name of th_syn type
522 -> (SrcSpan -> th_syn -> Either Message hs_syn)
524 runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ty convert
525 = do { -- Check that the quoter is not locally defined, otherwise the TH
526 -- machinery will not be able to run the quasiquote.
527 ; this_mod <- getModule
528 ; let is_local = case nameModule_maybe quoter of
529 Just mod | mod == this_mod -> True
532 ; traceTc (text "runQQ" <+> ppr quoter <+> ppr is_local)
533 ; checkTc (not is_local) (quoteStageError quoter)
535 -- Build the expression
536 ; let quoterExpr = L q_span $! HsVar $! quoter
537 ; let quoteExpr = L q_span $! HsLit $! HsString quote
538 ; let expr = L q_span $
540 HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr
542 ; meta_exp_ty <- tcMetaTy meta_ty
544 -- Typecheck the expression
545 ; zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
547 -- Run the expression
548 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
549 ; result <- runMetaQ convert zonked_q_expr
550 ; traceTc (text "Got result" <+> ppr result)
551 ; showSplice desc quoteExpr (ppr result)
555 runQuasiQuoteExpr quasiquote
556 = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr
558 runQuasiQuotePat quasiquote
559 = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat
561 quoteStageError :: Name -> SDoc
562 quoteStageError quoter
563 = sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter,
564 nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))]
568 %************************************************************************
572 %************************************************************************
574 Very like splicing an expression, but we don't yet share code.
577 kcSpliceType (HsSplice name hs_expr)
578 = setSrcSpan (getLoc hs_expr) $ do
580 ; case spliceOK level of {
581 Nothing -> failWithTc (illegalSplice level) ;
582 Just next_level -> do
585 Comp _ -> do { (t,k) <- kcTopSpliceType hs_expr
586 ; return (unLoc t, k) } ;
587 Brack _ ps_var lie_var -> do
589 { -- A splice inside brackets
590 ; meta_ty <- tcMetaTy typeQTyConName
591 ; expr' <- setStage (Splice next_level) $
593 tcMonoExpr hs_expr meta_ty
595 -- Write the pending splice into the bucket
596 ; ps <- readMutVar ps_var
597 ; writeMutVar ps_var ((name,expr') : ps)
599 -- e.g. [| Int -> $(h 4) |]
600 -- Here (h 4) :: Q Type
601 -- but $(h 4) :: forall a.a i.e. any kind
603 ; return (panic "kcSpliceType", kind) -- The returned type is ignored
605 ; Splice {} -> panic "kcSpliceType Splice"
608 kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
610 = do { meta_ty <- tcMetaTy typeQTyConName
612 -- Typecheck the expression
613 ; zonked_q_expr <- tcTopSpliceExpr expr meta_ty
615 -- Run the expression
616 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
617 ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
619 ; traceTc (text "Got result" <+> ppr hs_ty2)
621 ; showSplice "type" expr (ppr hs_ty2)
623 -- Rename it, but bale out if there are errors
624 -- otherwise the type checker just gives more spurious errors
625 ; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
626 ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
631 %************************************************************************
633 \subsection{Splicing an expression}
635 %************************************************************************
638 -- Always at top level
639 -- Type sig at top of file:
640 -- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
642 = do { meta_dec_ty <- tcMetaTy decTyConName
643 ; meta_q_ty <- tcMetaTy qTyConName
644 ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
645 ; zonked_q_expr <- tcTopSpliceExpr expr list_q
647 -- Run the expression
648 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
649 ; decls <- runMetaD convertToHsDecls zonked_q_expr
651 ; traceTc (text "Got result" <+> vcat (map ppr decls))
652 ; showSplice "declarations"
654 (ppr (getLoc expr) $$ (vcat (map ppr decls)))
659 %************************************************************************
661 \subsection{Running an expression}
663 %************************************************************************
666 runMetaAW :: (AnnotationWrapper -> output)
667 -> LHsExpr Id -- Of type AnnotationWrapper
669 runMetaAW k = runMeta False (\_ -> return . Right . k)
670 -- We turn off showing the code in meta-level exceptions because doing so exposes
671 -- the toAnnotationWrapper function that we slap around the users code
673 runQThen :: (SrcSpan -> input -> Either Message output)
676 -> TcM (Either Message output)
677 runQThen f expr_span what = TH.runQ what >>= (return . f expr_span)
679 runMetaQ :: (SrcSpan -> input -> Either Message output)
682 runMetaQ = runMeta True . runQThen
684 runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
685 -> LHsExpr Id -- Of type (Q Exp)
686 -> TcM (LHsExpr RdrName)
689 runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName))
690 -> LHsExpr Id -- Of type (Q Pat)
694 runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
695 -> LHsExpr Id -- Of type (Q Type)
696 -> TcM (LHsType RdrName)
699 runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
700 -> LHsExpr Id -- Of type Q [Dec]
701 -> TcM [LHsDecl RdrName]
704 runMeta :: Bool -- Whether code should be printed in the exception message
705 -> (SrcSpan -> input -> TcM (Either Message output))
706 -> LHsExpr Id -- Of type X
707 -> TcM output -- Of type t
708 runMeta show_code run_and_convert expr
710 ds_expr <- initDsTc (dsLExpr expr)
711 -- Compile and link it; might fail if linking fails
712 ; hsc_env <- getTopEnv
713 ; src_span <- getSrcSpanM
714 ; either_hval <- tryM $ liftIO $
715 HscMain.compileExpr hsc_env src_span ds_expr
716 ; case either_hval of {
717 Left exn -> failWithTc (mk_msg "compile and link" exn) ;
720 { -- Coerce it to Q t, and run it
722 -- Running might fail if it throws an exception of any kind (hence tryAllM)
723 -- including, say, a pattern-match exception in the code we are running
725 -- We also do the TH -> HS syntax conversion inside the same
726 -- exception-cacthing thing so that if there are any lurking
727 -- exceptions in the data structure returned by hval, we'll
728 -- encounter them inside the try
730 -- See Note [Exceptions in TH]
731 let expr_span = getLoc expr
732 ; either_tval <- tryAllM $
733 setSrcSpan expr_span $ -- Set the span so that qLocation can
734 -- see where this splice is
735 do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval)
737 Left err -> failWithTc err
738 Right result -> return $! result }
740 ; case either_tval of
743 case fromException se of
745 failM -- Error already in Tc monad
746 _ -> failWithTc (mk_msg "run" se) -- Exception
749 mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
750 nest 2 (text (Panic.showException exn)),
751 if show_code then nest 2 (text "Code:" <+> ppr expr) else empty]
754 Note [Exceptions in TH]
755 ~~~~~~~~~~~~~~~~~~~~~~~
756 Supppose we have something like this
760 f n | n>3 = fail "Too many declarations"
763 The 'fail' is a user-generated failure, and should be displayed as a
764 perfectly ordinary compiler error message, not a panic or anything
765 like that. Here's how it's processed:
767 * 'fail' is the monad fail. The monad instance for Q in TH.Syntax
768 effectively transforms (fail s) to
769 qReport True s >> fail
770 where 'qReport' comes from the Quasi class and fail from its monad
773 * The TcM monad is an instance of Quasi (see TcSplice), and it implements
774 (qReport True s) by using addErr to add an error message to the bag of errors.
775 The 'fail' in TcM raises an IOEnvFailure exception
777 * So, when running a splice, we catch all exceptions; then for
778 - an IOEnvFailure exception, we assume the error is already
779 in the error-bag (above)
780 - other errors, we add an error to the bag
784 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
787 instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
788 qNewName s = do { u <- newUnique
790 ; return (TH.mkNameU s i) }
792 qReport True msg = addErr (text msg)
793 qReport False msg = addReport (text msg)
795 qLocation = do { m <- getModule
797 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l)
798 , TH.loc_module = moduleNameString (moduleName m)
799 , TH.loc_package = packageIdString (modulePackageId m)
800 , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l)
801 , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) }
805 -- For qRecover, discard error messages if
806 -- the recovery action is chosen. Otherwise
807 -- we'll only fail higher up. c.f. tryTcLIE_
808 qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
810 Just val -> do { addMessages msgs -- There might be warnings
812 Nothing -> recover -- Discard all msgs
815 qRunIO io = liftIO io
819 %************************************************************************
821 \subsection{Errors and contexts}
823 %************************************************************************
826 showSplice :: String -> LHsExpr Name -> SDoc -> TcM ()
827 -- Note that 'before' is *renamed* but not *typechecked*
828 -- Reason (a) less typechecking crap
829 -- (b) data constructors after type checking have been
830 -- changed to their *wrappers*, and that makes them
831 -- print always fully qualified
832 showSplice what before after
833 = do { loc <- getSrcSpanM
834 ; traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
835 nest 2 (sep [nest 2 (ppr before),
839 illegalBracket :: ThStage -> SDoc
841 = ptext (sLit "Illegal bracket at level") <+> ppr level
843 illegalSplice :: ThStage -> SDoc
845 = ptext (sLit "Illegal splice at level") <+> ppr level
851 %************************************************************************
855 %************************************************************************
859 reify :: TH.Name -> TcM TH.Info
861 = do { name <- lookupThName th_name
862 ; thing <- tcLookupTh name
863 -- ToDo: this tcLookup could fail, which would give a
864 -- rather unhelpful error message
865 ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
869 ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
870 ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
871 ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
872 ppr_ns _ = panic "reify/ppr_ns"
874 lookupThName :: TH.Name -> TcM Name
875 lookupThName th_name = do
876 mb_name <- lookupThName_maybe th_name
878 Nothing -> failWithTc (notInScope th_name)
879 Just name -> return name
881 lookupThName_maybe th_name
882 = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
883 -- Pick the first that works
884 -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
885 ; return (listToMaybe names) }
888 = do { -- Repeat much of lookupOccRn, becase we want
889 -- to report errors in a TH-relevant way
890 ; rdr_env <- getLocalRdrEnv
891 ; case lookupLocalRdrEnv rdr_env rdr_name of
892 Just name -> return (Just name)
893 Nothing -> lookupGlobalOccRn_maybe rdr_name }
895 tcLookupTh :: Name -> TcM TcTyThing
896 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
897 -- it gives a reify-related error message on failure, whereas in the normal
898 -- tcLookup, failure is a bug.
900 = do { (gbl_env, lcl_env) <- getEnvs
901 ; case lookupNameEnv (tcl_env lcl_env) name of {
902 Just thing -> return thing;
904 { if nameIsLocalOrFrom (tcg_mod gbl_env) name
905 then -- It's defined in this module
906 case lookupNameEnv (tcg_type_env gbl_env) name of
907 Just thing -> return (AGlobal thing)
908 Nothing -> failWithTc (notInEnv name)
910 else do -- It's imported
911 { (eps,hpt) <- getEpsAndHpt
913 ; case lookupType dflags hpt (eps_PTE eps) name of
914 Just thing -> return (AGlobal thing)
915 Nothing -> do { thing <- tcImportDecl name
916 ; return (AGlobal thing) }
917 -- Imported names should always be findable;
918 -- if not, we fail hard in tcImportDecl
921 notInScope :: TH.Name -> SDoc
922 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
923 ptext (sLit "is not in scope at a reify")
924 -- Ugh! Rather an indirect way to display the name
926 notInEnv :: Name -> SDoc
927 notInEnv name = quotes (ppr name) <+>
928 ptext (sLit "is not in the type environment at a reify")
930 ------------------------------
931 reifyThing :: TcTyThing -> TcM TH.Info
932 -- The only reason this is monadic is for error reporting,
933 -- which in turn is mainly for the case when TH can't express
934 -- some random GHC extension
936 reifyThing (AGlobal (AnId id))
937 = do { ty <- reifyType (idType id)
938 ; fix <- reifyFixity (idName id)
939 ; let v = reifyName id
940 ; case idDetails id of
941 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
942 _ -> return (TH.VarI v ty Nothing fix)
945 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
946 reifyThing (AGlobal (AClass cls)) = reifyClass cls
947 reifyThing (AGlobal (ADataCon dc))
948 = do { let name = dataConName dc
949 ; ty <- reifyType (idType (dataConWrapId dc))
950 ; fix <- reifyFixity name
951 ; return (TH.DataConI (reifyName name) ty
952 (reifyName (dataConOrigTyCon dc)) fix)
955 reifyThing (ATcId {tct_id = id, tct_type = ty})
956 = do { ty1 <- zonkTcType ty -- Make use of all the info we have, even
957 -- though it may be incomplete
958 ; ty2 <- reifyType ty1
959 ; fix <- reifyFixity (idName id)
960 ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
962 reifyThing (ATyVar tv ty)
963 = do { ty1 <- zonkTcType ty
964 ; ty2 <- reifyType ty1
965 ; return (TH.TyVarI (reifyName tv) ty2) }
967 reifyThing (AThing {}) = panic "reifyThing AThing"
969 ------------------------------
970 reifyTyCon :: TyCon -> TcM TH.Info
973 = return (TH.PrimTyConI (reifyName tc) 2 False)
975 = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
977 = let flavour = reifyFamFlavour tc
981 | isLiftedTypeKind kind = Nothing
982 | otherwise = Just $ reifyKind kind
985 TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
987 = do { let (tvs, rhs) = synTyConDefn tc
988 ; rhs' <- reifyType rhs
989 ; return (TH.TyConI $
990 TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs')
994 = do { cxt <- reifyCxt (tyConStupidTheta tc)
995 ; let tvs = tyConTyVars tc
996 ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
997 ; let name = reifyName tc
998 r_tvs = reifyTyVars tvs
999 deriv = [] -- Don't know about deriving
1000 decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
1001 | otherwise = TH.DataD cxt name r_tvs cons deriv
1002 ; return (TH.TyConI decl) }
1004 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
1006 | isVanillaDataCon dc
1007 = do { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
1008 ; let stricts = map reifyStrict (dataConStrictMarks dc)
1009 fields = dataConFieldLabels dc
1013 ; ASSERT( length arg_tys == length stricts )
1014 if not (null fields) then
1015 return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
1017 if dataConIsInfix dc then
1018 ASSERT( length arg_tys == 2 )
1019 return (TH.InfixC (s1,a1) name (s2,a2))
1021 return (TH.NormalC name (stricts `zip` arg_tys)) }
1023 = failWithTc (ptext (sLit "Can't reify a GADT data constructor:")
1024 <+> quotes (ppr dc))
1026 ------------------------------
1027 reifyClass :: Class -> TcM TH.Info
1029 = do { cxt <- reifyCxt theta
1030 ; ops <- mapM reify_op op_stuff
1031 ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
1033 (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
1034 fds' = map reifyFunDep fds
1035 reify_op (op, _) = do { ty <- reifyType (idType op)
1036 ; return (TH.SigD (reifyName op) ty) }
1038 ------------------------------
1039 reifyType :: TypeRep.Type -> TcM TH.Type
1040 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
1041 reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
1042 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
1043 reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
1044 reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
1045 ; tau' <- reifyType tau
1046 ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
1048 (tvs, cxt, tau) = tcSplitSigmaTy ty
1049 reifyType (PredTy {}) = panic "reifyType PredTy"
1051 reifyTypes :: [Type] -> TcM [TH.Type]
1052 reifyTypes = mapM reifyType
1054 reifyKind :: Kind -> TH.Kind
1056 = let (kis, ki') = splitKindFunTys ki
1057 kis_rep = map reifyKind kis
1058 ki'_rep = reifyNonArrowKind ki'
1060 foldl TH.ArrowK ki'_rep kis_rep
1062 reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK
1063 | otherwise = pprPanic "Exotic form of kind"
1066 reifyCxt :: [PredType] -> TcM [TH.Pred]
1067 reifyCxt = mapM reifyPred
1069 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
1070 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
1072 reifyFamFlavour :: TyCon -> TH.FamFlavour
1073 reifyFamFlavour tc | isOpenSynTyCon tc = TH.TypeFam
1074 | isOpenTyCon tc = TH.DataFam
1076 = panic "TcSplice.reifyFamFlavour: not a type family"
1078 reifyTyVars :: [TyVar] -> [TH.TyVarBndr]
1079 reifyTyVars = map reifyTyVar
1081 reifyTyVar tv | isLiftedTypeKind kind = TH.PlainTV name
1082 | otherwise = TH.KindedTV name (reifyKind kind)
1087 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
1088 reify_tc_app tc tys = do { tys' <- reifyTypes tys
1089 ; return (foldl TH.AppT (TH.ConT tc) tys') }
1091 reifyPred :: TypeRep.PredType -> TcM TH.Pred
1092 reifyPred (ClassP cls tys)
1093 = do { tys' <- reifyTypes tys
1094 ; return $ TH.ClassP (reifyName cls) tys'
1096 reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p)
1097 reifyPred (EqPred ty1 ty2)
1098 = do { ty1' <- reifyType ty1
1099 ; ty2' <- reifyType ty2
1100 ; return $ TH.EqualP ty1' ty2'
1104 ------------------------------
1105 reifyName :: NamedThing n => n -> TH.Name
1107 | isExternalName name = mk_varg pkg_str mod_str occ_str
1108 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
1109 -- Many of the things we reify have local bindings, and
1110 -- NameL's aren't supposed to appear in binding positions, so
1111 -- we use NameU. When/if we start to reify nested things, that
1112 -- have free variables, we may need to generate NameL's for them.
1114 name = getName thing
1115 mod = ASSERT( isExternalName name ) nameModule name
1116 pkg_str = packageIdString (modulePackageId mod)
1117 mod_str = moduleNameString (moduleName mod)
1118 occ_str = occNameString occ
1119 occ = nameOccName name
1120 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
1121 | OccName.isVarOcc occ = TH.mkNameG_v
1122 | OccName.isTcOcc occ = TH.mkNameG_tc
1123 | otherwise = pprPanic "reifyName" (ppr name)
1125 ------------------------------
1126 reifyFixity :: Name -> TcM TH.Fixity
1128 = do { fix <- lookupFixityRn name
1129 ; return (conv_fix fix) }
1131 conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
1132 conv_dir BasicTypes.InfixR = TH.InfixR
1133 conv_dir BasicTypes.InfixL = TH.InfixL
1134 conv_dir BasicTypes.InfixN = TH.InfixN
1136 reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
1137 reifyStrict MarkedStrict = TH.IsStrict
1138 reifyStrict MarkedUnboxed = TH.IsStrict
1139 reifyStrict NotMarkedStrict = TH.NotStrict
1141 ------------------------------
1142 noTH :: LitString -> SDoc -> TcM a
1143 noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
1144 ptext (sLit "in Template Haskell:"),