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,
18 runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where
20 #include "HsVersions.h"
24 -- These imports are the reason that TcSplice
25 -- is very high up the module hierarchy
61 import DsMonad hiding (Splice)
73 import qualified Language.Haskell.TH as TH
74 -- THSyntax gives access to internal functions and data types
75 import qualified Language.Haskell.TH.Syntax as TH
78 -- Because GHC.Desugar might not be in the base library of the bootstrapping compiler
79 import GHC.Desugar ( AnnotationWrapper(..) )
82 import GHC.Exts ( unsafeCoerce#, Int#, Int(..) )
83 import System.IO.Error
86 Note [Template Haskell levels]
87 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
88 * Imported things are impLevel (= 0)
90 * In GHCi, variables bound by a previous command are treated
91 as impLevel, because we have bytecode for them.
93 * Variables are bound at the "current level"
95 * The current level starts off at topLevel (= 1)
97 * The level is decremented by splicing $(..)
98 incremented by brackets [| |]
99 incremented by name-quoting 'f
101 When a variable is used, we compare
102 bind: binding level, and
103 use: current level at usage site
106 bind > use Always error (bound later than used)
109 bind = use Always OK (bound same stage as used)
110 [| \x -> $(f [| x |]) |]
112 bind < use Inside brackets, it depends
116 For (bind < use) inside brackets, there are three cases:
117 - Imported things OK f = [| map |]
118 - Top-level things OK g = [| f |]
119 - Non-top-level Only if there is a liftable instance
120 h = \(x:Int) -> [| x |]
122 See Note [What is a top-level Id?]
126 A quoted name 'n is a bit like a quoted expression [| n |], except that we
127 have no cross-stage lifting (c.f. TcExpr.thBrackId). So, after incrementing
128 the use-level to account for the brackets, the cases are:
137 See Note [What is a top-level Id?] in TcEnv. Examples:
139 f 'map -- OK; also for top-level defns of this module
141 \x. f 'x -- Not ok (whereas \x. f [| x |] might have been ok, by
142 -- cross-stage lifting
144 \y. [| \x. $(f 'y) |] -- Not ok (same reason)
146 [| \x. $(f 'x) |] -- OK
149 Note [What is a top-level Id?]
150 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
151 In the level-control criteria above, we need to know what a "top level Id" is.
152 There are three kinds:
153 * Imported from another module (GlobalId, ExternalName)
154 * Bound at the top level of this module (ExternalName)
155 * In GHCi, bound by a previous stmt (GlobalId)
156 It's strange that there is no one criterion tht picks out all three, but that's
157 how it is right now. (The obvious thing is to give an ExternalName to GHCi Ids
158 bound in an earlier Stmt, but what module would you choose? See
159 Note [Interactively-bound Ids in GHCi] in TcRnDriver.)
161 The predicate we use is TcEnv.thTopLevelId.
164 %************************************************************************
166 \subsection{Main interface + stubs for the non-GHCI case
168 %************************************************************************
171 tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
172 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
173 tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
174 kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
175 -- None of these functions add constraints to the LIE
177 lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
179 runQuasiQuoteExpr :: HsQuasiQuote Name -> TcM (LHsExpr RdrName)
180 runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName)
181 runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
184 tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x)
185 tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
186 tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
187 kcSpliceType x = pprPanic "Cant do kcSpliceType without GHCi" (ppr x)
189 lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n)
191 runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q)
192 runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q)
193 runAnnotation _ q = pprPanic "Cant do runAnnotation without GHCi" (ppr q)
197 %************************************************************************
199 \subsection{Quoting an expression}
201 %************************************************************************
203 Note [Handling brackets]
204 ~~~~~~~~~~~~~~~~~~~~~~~~
205 Source: f = [| Just $(g 3) |]
206 The [| |] part is a HsBracket
208 Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
209 The [| |] part is a HsBracketOut, containing *renamed* (not typechecked) expression
210 The "s7" is the "splice point"; the (g Int 3) part is a typechecked expression
212 Desugared: f = do { s7 <- g Int 3
213 ; return (ConE "Data.Maybe.Just" s7) }
216 tcBracket brack res_ty
217 = addErrCtxt (hang (ptext (sLit "In the Template Haskell quotation"))
219 do { level <- getStage
220 ; case bracketOK level of {
221 Nothing -> failWithTc (illegalBracket level) ;
222 Just next_level -> do {
224 -- Typecheck expr to make sure it is valid,
225 -- but throw away the results. We'll type check
226 -- it again when we actually use it.
228 ; pending_splices <- newMutVar []
229 ; lie_var <- getLIEVar
231 ; (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
232 (getLIE (tc_bracket next_level brack))
233 ; tcSimplifyBracket lie
235 -- Make the expected type have the right shape
236 ; boxyUnify meta_ty res_ty
238 -- Return the original expression, not the type-decorated one
239 ; pendings <- readMutVar pending_splices
240 ; return (noLoc (HsBracketOut brack pendings)) }}}
242 tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType
243 tc_bracket use_lvl (VarBr name) -- Note [Quoting names]
244 = do { thing <- tcLookup name
246 AGlobal _ -> return ()
247 ATcId { tct_level = bind_lvl, tct_id = id }
248 | thTopLevelId id -- C.f thTopLevelId case of
249 -> keepAliveTc id -- TcExpr.thBrackId
251 -> do { checkTc (use_lvl == bind_lvl)
252 (quotedNameStageErr name) }
253 _ -> pprPanic "th_bracket" (ppr name)
255 ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
258 tc_bracket _ (ExpBr expr)
259 = do { any_ty <- newFlexiTyVarTy liftedTypeKind
260 ; tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that
261 ; tcMetaTy expQTyConName }
262 -- Result type is Expr (= Q Exp)
264 tc_bracket _ (TypBr typ)
265 = do { tcHsSigTypeNC ThBrackCtxt typ
266 ; tcMetaTy typeQTyConName }
267 -- Result type is Type (= Q Typ)
269 tc_bracket _ (DecBr decls)
270 = do { tcTopSrcDecls emptyModDetails decls
271 -- Typecheck the declarations, dicarding the result
272 -- We'll get all that stuff later, when we splice it in
274 ; decl_ty <- tcMetaTy decTyConName
275 ; q_ty <- tcMetaTy qTyConName
276 ; return (mkAppTy q_ty (mkListTy decl_ty))
277 -- Result type is Q [Dec]
280 tc_bracket _ (PatBr _)
281 = failWithTc (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
283 quotedNameStageErr :: Name -> SDoc
285 = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
286 , ptext (sLit "must be used at the same stage at which is is bound")]
290 %************************************************************************
292 \subsection{Splicing an expression}
294 %************************************************************************
297 tcSpliceExpr (HsSplice name expr) res_ty
298 = setSrcSpan (getLoc expr) $ do
300 case spliceOK level of {
301 Nothing -> failWithTc (illegalSplice level) ;
305 Comp _ -> do { e <- tcTopSplice expr res_ty
306 ; return (unLoc e) } ;
307 Brack _ ps_var lie_var -> do
309 -- A splice inside brackets
310 -- NB: ignore res_ty, apart from zapping it to a mono-type
311 -- e.g. [| reverse $(h 4) |]
312 -- Here (h 4) :: Q Exp
313 -- but $(h 4) :: forall a.a i.e. anything!
316 meta_exp_ty <- tcMetaTy expQTyConName
317 expr' <- setStage (Splice next_level) (
319 tcMonoExpr expr meta_exp_ty
322 -- Write the pending splice into the bucket
323 ps <- readMutVar ps_var
324 writeMutVar ps_var ((name,expr') : ps)
326 return (panic "tcSpliceExpr") -- The returned expression is ignored
328 ; Splice {} -> panic "tcSpliceExpr Splice"
331 -- tcTopSplice used to have this:
332 -- Note that we do not decrement the level (to -1) before
333 -- typechecking the expression. For example:
334 -- f x = $( ...$(g 3) ... )
335 -- The recursive call to tcMonoExpr will simply expand the
336 -- inner escape before dealing with the outer one
338 tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id)
339 tcTopSplice expr res_ty = do
340 meta_exp_ty <- tcMetaTy expQTyConName
342 -- Typecheck the expression
343 zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
345 -- Run the expression
346 traceTc (text "About to run" <+> ppr zonked_q_expr)
347 expr2 <- runMetaE convertToHsExpr zonked_q_expr
349 traceTc (text "Got result" <+> ppr expr2)
351 showSplice "expression"
352 zonked_q_expr (ppr expr2)
354 -- Rename it, but bale out if there are errors
355 -- otherwise the type checker just gives more spurious errors
356 (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
358 tcMonoExpr exp3 res_ty
361 tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id)
362 -- Type check an expression that is the body of a top-level splice
363 -- (the caller will compile and run it)
364 tcTopSpliceExpr expr meta_ty
365 = checkNoErrs $ -- checkNoErrs: must not try to run the thing
366 -- if the type checker fails!
367 do { (expr', const_binds) <- tcSimplifyStagedExpr topSpliceStage $
368 (recordThUse >> tcMonoExpr expr meta_ty)
369 -- Zonk it and tie the knot of dictionary bindings
370 ; zonkTopLExpr (mkHsDictLet const_binds expr') }
374 %************************************************************************
378 %************************************************************************
381 runAnnotation target expr = do
382 expr_ty <- newFlexiTyVarTy liftedTypeKind
384 -- Find the classes we want instances for in order to call toAnnotationWrapper
385 data_class <- tcLookupClass dataClassName
387 -- Check the instances we require live in another module (we want to execute it..)
388 -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
389 -- also resolves the LIE constraints to detect e.g. instance ambiguity
390 ((wrapper, expr'), const_binds) <- tcSimplifyStagedExpr topAnnStage $ do
391 expr' <- tcPolyExprNC expr expr_ty
392 -- By instantiating the call >here< it gets registered in the
393 -- LIE consulted by tcSimplifyStagedExpr
394 -- and hence ensures the appropriate dictionary is bound by const_binds
395 wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
396 return (wrapper, expr')
398 -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
400 to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
401 let specialised_to_annotation_wrapper_expr = L loc (HsWrap wrapper (HsVar to_annotation_wrapper_id))
402 wrapped_expr' = mkHsDictLet const_binds $
403 L loc (HsApp specialised_to_annotation_wrapper_expr expr')
405 -- If we have type checking problems then potentially zonking
406 -- (and certainly compilation) may fail. Give up NOW!
409 -- Zonk the type variables out of that raw expression. Note that
410 -- in particular we don't call recordThUse, since we don't
411 -- necessarily use any code or definitions from that package.
412 zonked_wrapped_expr' <- zonkTopLExpr wrapped_expr'
414 -- Run the appropriately wrapped expression to get the value of
415 -- the annotation and its dictionaries. The return value is of
416 -- type AnnotationWrapper by construction, so this conversion is
418 flip runMetaAW zonked_wrapped_expr' $ \annotation_wrapper ->
419 case annotation_wrapper of
420 AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
421 -- Got the value and dictionaries: build the serialized value and
422 -- call it a day. We ensure that we seq the entire serialized value
423 -- in order that any errors in the user-written code for the
424 -- annotation are exposed at this point. This is also why we are
425 -- doing all this stuff inside the context of runMeta: it has the
426 -- facilities to deal with user error in a meta-level expression
427 seqSerialized serialized `seq` Annotation {
429 ann_value = serialized
434 %************************************************************************
438 %************************************************************************
440 Note [Quasi-quote overview]
441 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
442 The GHC "quasi-quote" extension is described by Geoff Mainland's paper
443 "Why it's nice to be quoted: quasiquoting for Haskell" (Haskell
448 and the arbitrary string "stuff" gets parsed by the parser 'p', whose
449 type should be Language.Haskell.TH.Quote.QuasiQuoter. 'p' must be
450 defined in another module, because we are going to run it here. It's
451 a bit like a TH splice:
454 However, you can do this in patterns as well as terms. Becuase of this,
455 the splice is run by the *renamer* rather than the type checker.
458 runQuasiQuote :: Outputable hs_syn
459 => HsQuasiQuote Name -- Contains term of type QuasiQuoter, and the String
460 -> Name -- Of type QuasiQuoter -> String -> Q th_syn
461 -> String -- Documentation string only
462 -> Name -- Name of th_syn type
463 -> (SrcSpan -> th_syn -> Either Message hs_syn)
465 runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ty convert
466 = do { -- Check that the quoter is not locally defined, otherwise the TH
467 -- machinery will not be able to run the quasiquote.
468 ; this_mod <- getModule
469 ; let is_local = case nameModule_maybe quoter of
470 Just mod | mod == this_mod -> True
473 ; traceTc (text "runQQ" <+> ppr quoter <+> ppr is_local)
474 ; checkTc (not is_local) (quoteStageError quoter)
476 -- Build the expression
477 ; let quoterExpr = L q_span $! HsVar $! quoter
478 ; let quoteExpr = L q_span $! HsLit $! HsString quote
479 ; let expr = L q_span $
481 HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr
483 ; meta_exp_ty <- tcMetaTy meta_ty
485 -- Typecheck the expression
486 ; zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
488 -- Run the expression
489 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
490 ; result <- runMetaQ convert zonked_q_expr
491 ; traceTc (text "Got result" <+> ppr result)
492 ; showSplice desc zonked_q_expr (ppr result)
496 runQuasiQuoteExpr quasiquote
497 = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr
499 runQuasiQuotePat quasiquote
500 = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat
502 quoteStageError :: Name -> SDoc
503 quoteStageError quoter
504 = sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter,
505 nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))]
509 %************************************************************************
513 %************************************************************************
515 Very like splicing an expression, but we don't yet share code.
518 kcSpliceType (HsSplice name hs_expr)
519 = setSrcSpan (getLoc hs_expr) $ do
521 ; case spliceOK level of {
522 Nothing -> failWithTc (illegalSplice level) ;
523 Just next_level -> do
526 Comp _ -> do { (t,k) <- kcTopSpliceType hs_expr
527 ; return (unLoc t, k) } ;
528 Brack _ ps_var lie_var -> do
530 { -- A splice inside brackets
531 ; meta_ty <- tcMetaTy typeQTyConName
532 ; expr' <- setStage (Splice next_level) $
534 tcMonoExpr hs_expr meta_ty
536 -- Write the pending splice into the bucket
537 ; ps <- readMutVar ps_var
538 ; writeMutVar ps_var ((name,expr') : ps)
540 -- e.g. [| Int -> $(h 4) |]
541 -- Here (h 4) :: Q Type
542 -- but $(h 4) :: forall a.a i.e. any kind
544 ; return (panic "kcSpliceType", kind) -- The returned type is ignored
546 ; Splice {} -> panic "kcSpliceType Splice"
549 kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
551 = do { meta_ty <- tcMetaTy typeQTyConName
553 -- Typecheck the expression
554 ; zonked_q_expr <- tcTopSpliceExpr expr meta_ty
556 -- Run the expression
557 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
558 ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
560 ; traceTc (text "Got result" <+> ppr hs_ty2)
562 ; showSplice "type" zonked_q_expr (ppr hs_ty2)
564 -- Rename it, but bale out if there are errors
565 -- otherwise the type checker just gives more spurious errors
566 ; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
567 ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
572 %************************************************************************
574 \subsection{Splicing an expression}
576 %************************************************************************
579 -- Always at top level
580 -- Type sig at top of file:
581 -- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
583 = do { meta_dec_ty <- tcMetaTy decTyConName
584 ; meta_q_ty <- tcMetaTy qTyConName
585 ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
586 ; zonked_q_expr <- tcTopSpliceExpr expr list_q
588 -- Run the expression
589 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
590 ; decls <- runMetaD convertToHsDecls zonked_q_expr
592 ; traceTc (text "Got result" <+> vcat (map ppr decls))
593 ; showSplice "declarations"
595 (ppr (getLoc expr) $$ (vcat (map ppr decls)))
600 %************************************************************************
602 \subsection{Running an expression}
604 %************************************************************************
607 runMetaAW :: (AnnotationWrapper -> output)
608 -> LHsExpr Id -- Of type AnnotationWrapper
610 runMetaAW k = runMeta False (\_ -> return . Right . k)
611 -- We turn off showing the code in meta-level exceptions because doing so exposes
612 -- the toAnnotationWrapper function that we slap around the users code
614 runQThen :: (SrcSpan -> input -> Either Message output)
617 -> TcM (Either Message output)
618 runQThen f expr_span what = TH.runQ what >>= (return . f expr_span)
620 runMetaQ :: (SrcSpan -> input -> Either Message output)
623 runMetaQ = runMeta True . runQThen
625 runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
626 -> LHsExpr Id -- Of type (Q Exp)
627 -> TcM (LHsExpr RdrName)
630 runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName))
631 -> LHsExpr Id -- Of type (Q Pat)
635 runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
636 -> LHsExpr Id -- Of type (Q Type)
637 -> TcM (LHsType RdrName)
640 runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
641 -> LHsExpr Id -- Of type Q [Dec]
642 -> TcM [LHsDecl RdrName]
645 runMeta :: Bool -- Whether code should be printed in the exception message
646 -> (SrcSpan -> input -> TcM (Either Message output))
647 -> LHsExpr Id -- Of type X
648 -> TcM output -- Of type t
649 runMeta show_code run_and_convert expr
651 ds_expr <- initDsTc (dsLExpr expr)
652 -- Compile and link it; might fail if linking fails
653 ; hsc_env <- getTopEnv
654 ; src_span <- getSrcSpanM
655 ; either_hval <- tryM $ liftIO $
656 HscMain.compileExpr hsc_env src_span ds_expr
657 ; case either_hval of {
658 Left exn -> failWithTc (mk_msg "compile and link" exn) ;
661 { -- Coerce it to Q t, and run it
663 -- Running might fail if it throws an exception of any kind (hence tryAllM)
664 -- including, say, a pattern-match exception in the code we are running
666 -- We also do the TH -> HS syntax conversion inside the same
667 -- exception-cacthing thing so that if there are any lurking
668 -- exceptions in the data structure returned by hval, we'll
669 -- encounter them inside the try
671 -- See Note [Exceptions in TH]
672 let expr_span = getLoc expr
673 ; either_tval <- tryAllM $
674 setSrcSpan expr_span $ -- Set the span so that qLocation can
675 -- see where this splice is
676 do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval)
678 Left err -> failWithTc err
679 Right result -> return $! result }
681 ; case either_tval of
684 case fromException se of
686 failM -- Error already in Tc monad
687 _ -> failWithTc (mk_msg "run" se) -- Exception
690 mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
691 nest 2 (text (Panic.showException exn)),
692 if show_code then nest 2 (text "Code:" <+> ppr expr) else empty]
695 Note [Exceptions in TH]
696 ~~~~~~~~~~~~~~~~~~~~~~~
697 Supppose we have something like this
701 f n | n>3 = fail "Too many declarations"
704 The 'fail' is a user-generated failure, and should be displayed as a
705 perfectly ordinary compiler error message, not a panic or anything
706 like that. Here's how it's processed:
708 * 'fail' is the monad fail. The monad instance for Q in TH.Syntax
709 effectively transforms (fail s) to
710 qReport True s >> fail
711 where 'qReport' comes from the Quasi class and fail from its monad
714 * The TcM monad is an instance of Quasi (see TcSplice), and it implements
715 (qReport True s) by using addErr to add an error message to the bag of errors.
716 The 'fail' in TcM raises an IOEnvFailure exception
718 * So, when running a splice, we catch all exceptions; then for
719 - an IOEnvFailure exception, we assume the error is already
720 in the error-bag (above)
721 - other errors, we add an error to the bag
725 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
728 instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
729 qNewName s = do { u <- newUnique
731 ; return (TH.mkNameU s i) }
733 qReport True msg = addErr (text msg)
734 qReport False msg = addReport (text msg)
736 qLocation = do { m <- getModule
738 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l)
739 , TH.loc_module = moduleNameString (moduleName m)
740 , TH.loc_package = packageIdString (modulePackageId m)
741 , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l)
742 , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) }
746 -- For qRecover, discard error messages if
747 -- the recovery action is chosen. Otherwise
748 -- we'll only fail higher up. c.f. tryTcLIE_
749 qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
751 Just val -> do { addMessages msgs -- There might be warnings
753 Nothing -> recover -- Discard all msgs
756 qRunIO io = liftIO io
760 %************************************************************************
762 \subsection{Errors and contexts}
764 %************************************************************************
767 showSplice :: String -> LHsExpr Id -> SDoc -> TcM ()
768 showSplice what before after = do
770 traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
771 nest 2 (sep [nest 2 (ppr before),
775 illegalBracket :: ThStage -> SDoc
777 = ptext (sLit "Illegal bracket at level") <+> ppr level
779 illegalSplice :: ThStage -> SDoc
781 = ptext (sLit "Illegal splice at level") <+> ppr level
787 %************************************************************************
791 %************************************************************************
795 reify :: TH.Name -> TcM TH.Info
797 = do { name <- lookupThName th_name
798 ; thing <- tcLookupTh name
799 -- ToDo: this tcLookup could fail, which would give a
800 -- rather unhelpful error message
801 ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
805 ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
806 ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
807 ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
808 ppr_ns _ = panic "reify/ppr_ns"
810 lookupThName :: TH.Name -> TcM Name
811 lookupThName th_name = do
812 mb_name <- lookupThName_maybe th_name
814 Nothing -> failWithTc (notInScope th_name)
815 Just name -> return name
817 lookupThName_maybe th_name
818 = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
819 -- Pick the first that works
820 -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
821 ; return (listToMaybe names) }
824 = do { -- Repeat much of lookupOccRn, becase we want
825 -- to report errors in a TH-relevant way
826 ; rdr_env <- getLocalRdrEnv
827 ; case lookupLocalRdrEnv rdr_env rdr_name of
828 Just name -> return (Just name)
829 Nothing -> lookupGlobalOccRn_maybe rdr_name }
831 tcLookupTh :: Name -> TcM TcTyThing
832 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
833 -- it gives a reify-related error message on failure, whereas in the normal
834 -- tcLookup, failure is a bug.
836 = do { (gbl_env, lcl_env) <- getEnvs
837 ; case lookupNameEnv (tcl_env lcl_env) name of {
838 Just thing -> return thing;
840 { if nameIsLocalOrFrom (tcg_mod gbl_env) name
841 then -- It's defined in this module
842 case lookupNameEnv (tcg_type_env gbl_env) name of
843 Just thing -> return (AGlobal thing)
844 Nothing -> failWithTc (notInEnv name)
846 else do -- It's imported
847 { (eps,hpt) <- getEpsAndHpt
849 ; case lookupType dflags hpt (eps_PTE eps) name of
850 Just thing -> return (AGlobal thing)
851 Nothing -> do { thing <- tcImportDecl name
852 ; return (AGlobal thing) }
853 -- Imported names should always be findable;
854 -- if not, we fail hard in tcImportDecl
857 notInScope :: TH.Name -> SDoc
858 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
859 ptext (sLit "is not in scope at a reify")
860 -- Ugh! Rather an indirect way to display the name
862 notInEnv :: Name -> SDoc
863 notInEnv name = quotes (ppr name) <+>
864 ptext (sLit "is not in the type environment at a reify")
866 ------------------------------
867 reifyThing :: TcTyThing -> TcM TH.Info
868 -- The only reason this is monadic is for error reporting,
869 -- which in turn is mainly for the case when TH can't express
870 -- some random GHC extension
872 reifyThing (AGlobal (AnId id))
873 = do { ty <- reifyType (idType id)
874 ; fix <- reifyFixity (idName id)
875 ; let v = reifyName id
876 ; case idDetails id of
877 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
878 _ -> return (TH.VarI v ty Nothing fix)
881 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
882 reifyThing (AGlobal (AClass cls)) = reifyClass cls
883 reifyThing (AGlobal (ADataCon dc))
884 = do { let name = dataConName dc
885 ; ty <- reifyType (idType (dataConWrapId dc))
886 ; fix <- reifyFixity name
887 ; return (TH.DataConI (reifyName name) ty
888 (reifyName (dataConOrigTyCon dc)) fix)
891 reifyThing (ATcId {tct_id = id, tct_type = ty})
892 = do { ty1 <- zonkTcType ty -- Make use of all the info we have, even
893 -- though it may be incomplete
894 ; ty2 <- reifyType ty1
895 ; fix <- reifyFixity (idName id)
896 ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
898 reifyThing (ATyVar tv ty)
899 = do { ty1 <- zonkTcType ty
900 ; ty2 <- reifyType ty1
901 ; return (TH.TyVarI (reifyName tv) ty2) }
903 reifyThing (AThing {}) = panic "reifyThing AThing"
905 ------------------------------
906 reifyTyCon :: TyCon -> TcM TH.Info
909 = return (TH.PrimTyConI (reifyName tc) 2 False)
911 = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
913 = let flavour = reifyFamFlavour tc
917 | isLiftedTypeKind kind = Nothing
918 | otherwise = Just $ reifyKind kind
921 TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
923 = do { let (tvs, rhs) = synTyConDefn tc
924 ; rhs' <- reifyType rhs
925 ; return (TH.TyConI $
926 TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs')
930 = do { cxt <- reifyCxt (tyConStupidTheta tc)
931 ; let tvs = tyConTyVars tc
932 ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
933 ; let name = reifyName tc
934 r_tvs = reifyTyVars tvs
935 deriv = [] -- Don't know about deriving
936 decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
937 | otherwise = TH.DataD cxt name r_tvs cons deriv
938 ; return (TH.TyConI decl) }
940 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
942 | isVanillaDataCon dc
943 = do { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
944 ; let stricts = map reifyStrict (dataConStrictMarks dc)
945 fields = dataConFieldLabels dc
949 ; ASSERT( length arg_tys == length stricts )
950 if not (null fields) then
951 return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
953 if dataConIsInfix dc then
954 ASSERT( length arg_tys == 2 )
955 return (TH.InfixC (s1,a1) name (s2,a2))
957 return (TH.NormalC name (stricts `zip` arg_tys)) }
959 = failWithTc (ptext (sLit "Can't reify a GADT data constructor:")
962 ------------------------------
963 reifyClass :: Class -> TcM TH.Info
965 = do { cxt <- reifyCxt theta
966 ; ops <- mapM reify_op op_stuff
967 ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
969 (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
970 fds' = map reifyFunDep fds
971 reify_op (op, _) = do { ty <- reifyType (idType op)
972 ; return (TH.SigD (reifyName op) ty) }
974 ------------------------------
975 reifyType :: TypeRep.Type -> TcM TH.Type
976 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
977 reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
978 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
979 reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
980 reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
981 ; tau' <- reifyType tau
982 ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
984 (tvs, cxt, tau) = tcSplitSigmaTy ty
985 reifyType (PredTy {}) = panic "reifyType PredTy"
987 reifyTypes :: [Type] -> TcM [TH.Type]
988 reifyTypes = mapM reifyType
990 reifyKind :: Kind -> TH.Kind
992 = let (kis, ki') = splitKindFunTys ki
993 kis_rep = map reifyKind kis
994 ki'_rep = reifyNonArrowKind ki'
996 foldl TH.ArrowK ki'_rep kis_rep
998 reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK
999 | otherwise = pprPanic "Exotic form of kind"
1002 reifyCxt :: [PredType] -> TcM [TH.Pred]
1003 reifyCxt = mapM reifyPred
1005 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
1006 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
1008 reifyFamFlavour :: TyCon -> TH.FamFlavour
1009 reifyFamFlavour tc | isOpenSynTyCon tc = TH.TypeFam
1010 | isOpenTyCon tc = TH.DataFam
1012 = panic "TcSplice.reifyFamFlavour: not a type family"
1014 reifyTyVars :: [TyVar] -> [TH.TyVarBndr]
1015 reifyTyVars = map reifyTyVar
1017 reifyTyVar tv | isLiftedTypeKind kind = TH.PlainTV name
1018 | otherwise = TH.KindedTV name (reifyKind kind)
1023 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
1024 reify_tc_app tc tys = do { tys' <- reifyTypes tys
1025 ; return (foldl TH.AppT (TH.ConT tc) tys') }
1027 reifyPred :: TypeRep.PredType -> TcM TH.Pred
1028 reifyPred (ClassP cls tys)
1029 = do { tys' <- reifyTypes tys
1030 ; return $ TH.ClassP (reifyName cls) tys'
1032 reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p)
1033 reifyPred (EqPred ty1 ty2)
1034 = do { ty1' <- reifyType ty1
1035 ; ty2' <- reifyType ty2
1036 ; return $ TH.EqualP ty1' ty2'
1040 ------------------------------
1041 reifyName :: NamedThing n => n -> TH.Name
1043 | isExternalName name = mk_varg pkg_str mod_str occ_str
1044 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
1045 -- Many of the things we reify have local bindings, and
1046 -- NameL's aren't supposed to appear in binding positions, so
1047 -- we use NameU. When/if we start to reify nested things, that
1048 -- have free variables, we may need to generate NameL's for them.
1050 name = getName thing
1051 mod = ASSERT( isExternalName name ) nameModule name
1052 pkg_str = packageIdString (modulePackageId mod)
1053 mod_str = moduleNameString (moduleName mod)
1054 occ_str = occNameString occ
1055 occ = nameOccName name
1056 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
1057 | OccName.isVarOcc occ = TH.mkNameG_v
1058 | OccName.isTcOcc occ = TH.mkNameG_tc
1059 | otherwise = pprPanic "reifyName" (ppr name)
1061 ------------------------------
1062 reifyFixity :: Name -> TcM TH.Fixity
1064 = do { fix <- lookupFixityRn name
1065 ; return (conv_fix fix) }
1067 conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
1068 conv_dir BasicTypes.InfixR = TH.InfixR
1069 conv_dir BasicTypes.InfixL = TH.InfixL
1070 conv_dir BasicTypes.InfixN = TH.InfixN
1072 reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
1073 reifyStrict MarkedStrict = TH.IsStrict
1074 reifyStrict MarkedUnboxed = TH.IsStrict
1075 reifyStrict NotMarkedStrict = TH.NotStrict
1077 ------------------------------
1078 noTH :: LitString -> SDoc -> TcM a
1079 noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
1080 ptext (sLit "in Template Haskell:"),