X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=6da5741037196fb8207de34c47ce44994914899a;hp=d59b0f885296c1b7bf666dcda4456c7ef7c6b2d4;hb=HEAD;hpb=3e83dfb21b2f2220dce97427fff5c19459ae68d1 diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index d59b0f8..6da5741 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -1,79 +1,284 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[TcSplice]{Template Haskell splices} + +TcSplice: Template Haskell splices + \begin{code} -module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket ) where +{-# OPTIONS -fno-warn-unused-imports -fno-warn-unused-binds #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + +module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket, + lookupThName_maybe, + runQuasiQuoteExpr, runQuasiQuotePat, + runQuasiQuoteDecl, runQuasiQuoteType, + runAnnotation ) where #include "HsVersions.h" -import HscMain ( compileExpr ) -import TcRnDriver ( tcTopSrcDecls ) +import HscMain +import TcRnDriver -- These imports are the reason that TcSplice -- is very high up the module hierarchy -import qualified Language.Haskell.TH as TH --- THSyntax gives access to internal functions and data types -import qualified Language.Haskell.TH.Syntax as TH - -import HsSyn ( HsBracket(..), HsExpr(..), HsSplice(..), LHsExpr, LHsDecl, - HsType, LHsType ) -import Convert ( convertToHsExpr, convertToHsDecls, convertToHsType, thRdrName ) -import RnExpr ( rnLExpr ) -import RnEnv ( lookupFixityRn, lookupSrcOcc_maybe, lookupImportedName ) -import RdrName ( RdrName, lookupLocalRdrEnv, isSrcRdrName ) -import RnTypes ( rnLHsType ) -import TcExpr ( tcMonoExpr ) -import TcHsSyn ( mkHsDictLet, zonkTopLExpr ) -import TcSimplify ( tcSimplifyTop, tcSimplifyBracket ) -import TcUnify ( boxyUnify, unBox ) -import TcType ( TcType, TcKind, BoxyRhoType, liftedTypeKind, mkAppTy, tcSplitSigmaTy ) -import TcEnv ( spliceOK, tcMetaTy, bracketOK ) -import TcMType ( newFlexiTyVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType ) -import TcHsType ( tcHsSigType, kcHsType ) -import TcIface ( tcImportDecl ) -import TypeRep ( Type(..), PredType(..), TyThing(..) ) -- For reification -import PrelNames ( thFAKE ) -import Name ( Name, NamedThing(..), nameOccName, nameModule, isExternalName, - nameIsLocalOrFrom ) -import NameEnv ( lookupNameEnv ) -import HscTypes ( lookupType, ExternalPackageState(..), emptyModDetails ) +import HsSyn +import Convert +import RnExpr +import RnEnv +import RdrName +import RnTypes +import TcPat +import TcExpr +import TcHsSyn +import TcSimplify +import TcUnify +import TcType +import TcEnv +import TcMType +import TcHsType +import TcIface +import TypeRep +import InstEnv +import Name +import NameEnv +import NameSet +import PrelNames +import HscTypes import OccName -import Var ( Id, TyVar, idType ) -import Module ( moduleName, moduleNameString, modulePackageId ) +import Var +import Module +import Annotations import TcRnMonad -import IfaceEnv ( lookupOrig ) -import Class ( Class, classExtraBigSig ) -import TyCon ( TyCon, tyConTyVars, synTyConDefn, - isSynTyCon, isNewTyCon, tyConDataCons, isPrimTyCon, isFunTyCon, - tyConArity, tyConStupidTheta, isUnLiftedTyCon ) -import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConStrictMarks, - dataConName, dataConFieldLabels, dataConWrapId, dataConIsInfix, - isVanillaDataCon ) -import Id ( idName, globalIdDetails ) -import IdInfo ( GlobalIdDetails(..) ) -import TysWiredIn ( mkListTy ) -import DsMeta ( expQTyConName, typeQTyConName, decTyConName, qTyConName, nameTyConName ) -import DsExpr ( dsLExpr ) -import DsMonad ( initDsTc ) -import ErrUtils ( Message ) -import SrcLoc ( SrcSpan, noLoc, unLoc, getLoc ) +import Class +import Inst +import TyCon +import DataCon +import Id +import IdInfo +import TysWiredIn +import DsMeta +import DsExpr +import DsMonad hiding (Splice) +import Serialized +import ErrUtils +import SrcLoc import Outputable -import Unique ( Unique, Uniquable(..), getKey, mkUniqueGrimily ) -import PackageConfig ( packageIdString ) -import BasicTypes ( StrictnessMark(..), Fixity(..), FixityDirection(..) ) -import Panic ( showException ) -import FastString ( LitString ) +import Util ( dropList ) +import Data.List ( mapAccumL ) +import Pair +import Unique +import Data.Maybe +import BasicTypes +import Panic +import FastString +import Exception +import Control.Monad ( when ) -import GHC.Base ( unsafeCoerce#, Int#, Int(..) ) -- Should have a better home in the module hierarchy -import Monad ( liftM ) +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 -import FastString ( mkFastString ) +-- 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 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) + +* In GHCi, variables bound by a previous command are treated + as impLevel, because we have bytecode for them. + +* Variables are bound at the "current level" + +* The current level starts off at outerLevel (= 1) + +* The level is decremented by splicing $(..) + incremented by brackets [| |] + incremented by name-quoting 'f + +When a variable is used, we compare + bind: binding level, and + use: current level at usage site + + Generally + bind > use Always error (bound later than used) + [| \x -> $(f x) |] + + bind = use Always OK (bound same stage as used) + [| \x -> $(f [| x |]) |] + + bind < use Inside brackets, it depends + Inside splice, OK + Inside neither, OK + + For (bind < use) inside brackets, there are three cases: + - Imported things OK f = [| map |] + - Top-level things OK g = [| f |] + - Non-top-level Only if there is a liftable instance + h = \(x:Int) -> [| x |] + +See Note [What is a top-level Id?] + +Note [Quoting names] +~~~~~~~~~~~~~~~~~~~~ +A quoted name 'n is a bit like a quoted expression [| n |], except that we +have no cross-stage lifting (c.f. TcExpr.thBrackId). So, after incrementing +the use-level to account for the brackets, the cases are: + + bind > use Error + bind = use OK + bind < use + Imported things OK + Top-level things OK + Non-top-level Error + +See Note [What is a top-level Id?] in TcEnv. Examples: + + f 'map -- OK; also for top-level defns of this module + + \x. f 'x -- Not ok (whereas \x. f [| x |] might have been ok, by + -- cross-stage lifting + + \y. [| \x. $(f 'y) |] -- Not ok (same reason) + + [| \x. $(f 'x) |] -- OK + + +Note [What is a top-level Id?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the level-control criteria above, we need to know what a "top level Id" is. +There are three kinds: + * Imported from another module (GlobalId, ExternalName) + * Bound at the top level of this module (ExternalName) + * In GHCi, bound by a previous stmt (GlobalId) +It's strange that there is no one criterion tht picks out all three, but that's +how it is right now. (The obvious thing is to give an ExternalName to GHCi Ids +bound in an earlier Stmt, but what module would you choose? See +Note [Interactively-bound Ids in GHCi] in TcRnDriver.) + +The predicate we use is TcEnv.thTopLevelId. + %************************************************************************ %* * @@ -82,13 +287,34 @@ import FastString ( mkFastString ) %************************************************************************ \begin{code} +tcBracket :: HsBracket Name -> TcRhoType -> TcM (LHsExpr TcId) tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] -tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId) -kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind) +tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) +kcSpliceType :: HsSplice Name -> FreeVars -> TcM (HsType Name, TcKind) + -- None of these functions add constraints to the LIE + +lookupThName_maybe :: TH.Name -> TcM (Maybe Name) + +runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName) +runQuasiQuotePat :: HsQuasiQuote RdrName -> RnM (LPat RdrName) +runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName) +runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName] + +runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation #ifndef GHCI -tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) -tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e) +tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x) +tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) +tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x) +kcSpliceType x fvs = 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) +runQuasiQuoteType q = pprPanic "Cant do runQuasiQuoteType without GHCi" (ppr q) +runQuasiQuoteDecl q = pprPanic "Cant do runQuasiQuoteDecl without GHCi" (ppr q) +runAnnotation _ q = pprPanic "Cant do runAnnotation without GHCi" (ppr q) #else \end{code} @@ -98,62 +324,103 @@ tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e) %* * %************************************************************************ + \begin{code} -tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId) -tcBracket brack res_ty - = getStage `thenM` \ level -> - case bracketOK level of { - Nothing -> failWithTc (illegalBracket level) ; - Just next_level -> +-- 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 `thenM_` - newMutVar [] `thenM` \ pending_splices -> - getLIEVar `thenM` \ lie_var -> - - setStage (Brack next_level pending_splices lie_var) ( - getLIE (tc_bracket brack) - ) `thenM` \ (meta_ty, lie) -> - tcSimplifyBracket lie `thenM_` + ; pending_splices <- newMutVar [] + ; lie_var <- getConstraintVar + ; let brack_stage = Brack cur_stage pending_splices lie_var + + -- We want to check that there aren't any constraints that + -- can't be satisfied (e.g. Show Foo, where Foo has no Show + -- instance), but we aren't otherwise interested in the + -- results. Nor do we care about ambiguous dictionaries etc. + -- We will type check this bracket again at its usage site. + -- + -- We build a single implication constraint with a BracketSkol; + -- that in turn tells simplifyCheck to report only definite + -- errors + ; (_,lie) <- captureConstraints $ + newImplication BracketSkol [] [] $ + setStage brack_stage $ + do { meta_ty <- tc_bracket cur_stage brack + ; unifyType meta_ty res_ty } + + -- It's best to simplify the constraint now, even though in + -- principle some later unification might be useful for it, + -- because we don't want these essentially-junk TH implication + -- contraints floating around nested inside other constraints + -- See for example Trac #4949 + ; _ <- simplifyTop lie + + -- Return the original expression, not the type-decorated one + ; pendings <- readMutVar pending_splices + ; return (noLoc (HsBracketOut brack pendings)) } + +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 TcExpr.checkCrossStageLifting + -> keepAliveTc id + | otherwise + -> do { checkTc (thLevel outer_stage + 1 == bind_lvl) + (quotedNameStageErr name) } + _ -> pprPanic "th_bracket" (ppr name) + + ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic) + } - -- Make the expected type have the right shape - boxyUnify meta_ty res_ty `thenM_` +tc_bracket _ (ExpBr expr) + = do { any_ty <- newFlexiTyVarTy openTypeKind + ; _ <- tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that + ; tcMetaTy expQTyConName } + -- Result type is ExpQ (= Q Exp) - -- Return the original expression, not the type-decorated one - readMutVar pending_splices `thenM` \ pendings -> - returnM (noLoc (HsBracketOut brack pendings)) - } +tc_bracket _ (TypBr typ) + = do { _ <- tcHsSigTypeNC ThBrackCtxt typ + ; tcMetaTy typeQTyConName } + -- Result type is Type (= Q Typ) -tc_bracket :: HsBracket Name -> TcM TcType -tc_bracket (VarBr v) - = tcMetaTy nameTyConName -- Result type is Var (not Q-monadic) +tc_bracket _ (DecBrG decls) + = do { _ <- tcTopSrcDecls emptyModDetails decls + -- Typecheck the declarations, dicarding the result + -- We'll get all that stuff later, when we splice it in -tc_bracket (ExpBr expr) - = newFlexiTyVarTy liftedTypeKind `thenM` \ any_ty -> - tcMonoExpr expr any_ty `thenM_` - tcMetaTy expQTyConName - -- Result type is Expr (= Q Exp) + -- Top-level declarations in the bracket get unqualified names + -- See Note [Top-level Names in Template Haskell decl quotes] in RnNames -tc_bracket (TypBr typ) - = tcHsSigType ExprSigCtxt typ `thenM_` - tcMetaTy typeQTyConName - -- Result type is Type (= Q Typ) + ; tcMetaTy decsQTyConName } -- Result type is Q [Dec] -tc_bracket (DecBr decls) - = do { tcTopSrcDecls emptyModDetails decls - -- Typecheck the declarations, dicarding the result - -- We'll get all that stuff later, when we splice it in +tc_bracket _ (PatBr pat) + = do { any_ty <- newFlexiTyVarTy openTypeKind + ; _ <- tcPat ThPatQuote pat any_ty $ + return () + ; tcMetaTy patQTyConName } + -- Result type is PatQ (= Q Pat) - ; decl_ty <- tcMetaTy decTyConName - ; q_ty <- tcMetaTy qTyConName - ; return (mkAppTy q_ty (mkListTy decl_ty)) - -- Result type is Q [Dec] - } +tc_bracket _ (DecBrL _) + = panic "tc_bracket: Unexpected DecBrL" -tc_bracket (PatBr _) - = failWithTc (ptext SLIT("Tempate Haskell pattern brackets are not supported yet")) +quotedNameStageErr :: Name -> SDoc +quotedNameStageErr v + = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v) + , ptext (sLit "must be used at the same stage at which is is bound")] \end{code} @@ -165,87 +432,82 @@ tc_bracket (PatBr _) \begin{code} tcSpliceExpr (HsSplice name expr) res_ty - = setSrcSpan (getLoc expr) $ - getStage `thenM` \ level -> - case spliceOK level of { - Nothing -> failWithTc (illegalSplice level) ; - Just next_level -> + = setSrcSpan (getLoc expr) $ do + { 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 - ; returnM (unLoc e) } ; - Brack _ ps_var lie_var -> + 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 `thenM_` - tcMetaTy expQTyConName `thenM` \ meta_exp_ty -> - setStage (Splice next_level) ( - setLIEVar lie_var $ - tcMonoExpr expr meta_exp_ty - ) `thenM` \ expr' -> + { meta_exp_ty <- tcMetaTy expQTyConName + ; expr' <- setStage pop_stage $ + setConstraintVar lie_var $ + tcMonoExpr expr meta_exp_ty -- Write the pending splice into the bucket - readMutVar ps_var `thenM` \ ps -> - writeMutVar ps_var ((name,expr') : ps) `thenM_` + ; ps <- readMutVar ps_var + ; writeMutVar ps_var ((name,expr') : ps) - returnM (panic "tcSpliceExpr") -- The returned expression is ignored - }} + ; return (panic "tcSpliceExpr") -- The returned expression is ignored + }}} --- 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 :: LHsExpr Name -> TcRhoType -> TcM (HsExpr Id) +-- Note [How top-level splices are handled] tcTopSplice expr res_ty - = tcMetaTy expQTyConName `thenM` \ meta_exp_ty -> + = do { meta_exp_ty <- tcMetaTy expQTyConName - -- Typecheck the expression - tcTopSpliceExpr expr meta_exp_ty `thenM` \ zonked_q_expr -> + -- Typecheck the expression + ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_exp_ty) - -- Run the expression - traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_` - runMetaE convertToHsExpr zonked_q_expr `thenM` \ expr2 -> - - traceTc (text "Got result" <+> ppr expr2) `thenM_` + -- Run the expression + ; expr2 <- runMetaE zonked_q_expr + ; showSplice "expression" expr (ppr expr2) - showSplice "expression" - zonked_q_expr (ppr expr2) `thenM_` + -- Rename it, but bale out if there are errors + -- otherwise the type checker just gives more spurious errors + ; addErrCtxt (spliceResultDoc expr) $ do + { (exp3, _fvs) <- checkNoErrs (rnLExpr expr2) - -- Rename it, but bale out if there are errors - -- otherwise the type checker just gives more spurious errors - checkNoErrs (rnLExpr expr2) `thenM` \ (exp3, fvs) -> + ; exp4 <- tcMonoExpr exp3 res_ty + ; return (unLoc exp4) } } - tcMonoExpr exp3 res_ty +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) <- captureConstraints tc_action + -- Solve the constraints - ; const_binds <- tcSimplifyTop lie + ; const_binds <- simplifyTop lie - -- And zonk it - ; zonkTopLExpr (mkHsDictLet const_binds expr') } + -- Zonk it and tie the knot of dictionary bindings + ; zonkTopLExpr (mkHsDictLet (EvBinds const_binds) expr') } \end{code} @@ -258,56 +520,52 @@ tcTopSpliceExpr expr meta_ty Very like splicing an expression, but we don't yet share code. \begin{code} -kcSpliceType (HsSplice name hs_expr) +kcSpliceType splice@(HsSplice name hs_expr) fvs = 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 - ; returnM (panic "kcSpliceType", kind) -- The returned type is ignored - }}}}} - -kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind) + { 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 $ + setConstraintVar 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 + + ; kind <- newKindVar + ; return (HsSpliceTy splice fvs 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 expr meta_ty + ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_ty) -- Run the expression - ; traceTc (text "About to run" <+> ppr zonked_q_expr) - ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr + ; hs_ty2 <- runMetaT zonked_q_expr + ; showSplice "type" expr (ppr hs_ty2) - ; 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 + ; addErrCtxt (spliceResultDoc expr) $ do + { let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2 ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2) - - ; kcHsType hs_ty3 } + ; (ty4, kind) <- kcLHsType hs_ty3 + ; return (unLoc ty4, kind) }} \end{code} %************************************************************************ @@ -317,30 +575,170 @@ kcTopSpliceType expr %************************************************************************ \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 expr list_q + = do { list_q <- tcMetaTy decsQTyConName -- Q [Dec] + ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr list_q) -- Run the expression - ; traceTc (text "About to run" <+> ppr zonked_q_expr) - ; decls <- runMetaD convertToHsDecls zonked_q_expr - - ; traceTc (text "Got result" <+> vcat (map ppr decls)) - ; showSplice "declarations" - zonked_q_expr + ; decls <- runMetaD zonked_q_expr + ; showSplice "declarations" expr (ppr (getLoc expr) $$ (vcat (map ppr decls))) - ; returnM decls } - where handleErrors :: [Either a Message] -> TcM [a] - handleErrors [] = return [] - handleErrors (Left x:xs) = liftM (x:) (handleErrors xs) - handleErrors (Right m:xs) = do addErrTc m - handleErrors xs + ; 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} + + +%************************************************************************ +%* * + 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. + +%************************************************************************ +%* * +\subsubsection{Quasiquotation} +%* * +%************************************************************************ + +See Note [Quasi-quote overview] in TcSplice. + +\begin{code} +runQuasiQuote :: Outputable hs_syn + => HsQuasiQuote RdrName -- Contains term of type QuasiQuoter, and the String + -> Name -- Of type QuasiQuoter -> String -> Q th_syn + -> Name -- Name of th_syn type + -> MetaOps th_syn hs_syn + -> RnM hs_syn +runQuasiQuote (HsQuasiQuote quoter q_span quote) quote_selector meta_ty meta_ops + = do { -- Drop the leading "$" from the quoter name, if present + -- This is old-style syntax, now deprecated + -- NB: when removing this backward-compat, remove + -- the matching code in Lexer.x (around line 310) + let occ_str = occNameString (rdrNameOcc quoter) + ; quoter <- ASSERT( not (null occ_str) ) -- Lexer ensures this + if head occ_str /= '$' then return quoter + else do { addWarn (deprecatedDollar quoter) + ; return (mkRdrUnqual (mkVarOcc (tail occ_str))) } + + ; quoter' <- lookupOccRn quoter + -- We use lookupOcc rather than lookupGlobalOcc because in the + -- erroneous case of \x -> [x| ...|] we get a better error message + -- (stage restriction rather than out of scope). + + ; when (isUnboundName quoter') failM + -- If 'quoter' is not in scope, proceed no further + -- The error message was generated by lookupOccRn, but it then + -- succeeds with an "unbound name", which makes the subsequent + -- attempt to run the quote fail in a confusing way + + -- 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 = nameIsLocalOrFrom this_mod quoter' + ; checkTc (not is_local) (quoteStageError quoter') + + ; traceTc "runQQ" (ppr quoter <+> ppr is_local) + + -- 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 + ; meta_exp_ty <- tcMetaTy meta_ty + + -- Typecheck the expression + ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_exp_ty) + + -- Run the expression + ; result <- runMetaQ meta_ops zonked_q_expr + ; showSplice (mt_desc meta_ops) quoteExpr (ppr result) + + ; return result } + +runQuasiQuoteExpr qq = runQuasiQuote qq quoteExpName expQTyConName exprMetaOps +runQuasiQuotePat qq = runQuasiQuote qq quotePatName patQTyConName patMetaOps +runQuasiQuoteType qq = runQuasiQuote qq quoteTypeName typeQTyConName typeMetaOps +runQuasiQuoteDecl qq = runQuasiQuote qq quoteDecName decsQTyConName declMetaOps + +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"))] + +deprecatedDollar :: RdrName -> SDoc +deprecatedDollar quoter + = hang (ptext (sLit "Deprecated syntax:")) + 2 (ptext (sLit "quasiquotes no longer need a dollar sign:") + <+> ppr quoter) \end{code} @@ -351,38 +749,81 @@ tcSpliceDecls expr %************************************************************************ \begin{code} -runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)) - -> LHsExpr Id -- Of type (Q Exp) +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 + } + +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 "Got TH result:" (text (show_th th_result)) + ; return (cvt expr_span th_result) } + +runMetaE :: LHsExpr Id -- Of type (Q Exp) -> TcM (LHsExpr RdrName) -runMetaE = runMeta +runMetaE = runMetaQ exprMetaOps -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 "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 - ; either_hval <- tryM $ ioToTcRn $ - HscMain.compileExpr hsc_env src_span ds_expr + ; either_hval <- tryM $ liftIO $ + HscMain.hscCompileCoreExpr hsc_env src_span ds_expr ; case either_hval of { Left exn -> failWithTc (mk_msg "compile and link" exn) ; Right hval -> do { -- Coerce it to Q t, and run it + -- Running might fail if it throws an exception of any kind (hence tryAllM) -- including, say, a pattern-match exception in the code we are running -- @@ -390,23 +831,60 @@ runMeta convert expr -- exception-cacthing thing so that if there are any lurking -- exceptions in the data structure returned by hval, we'll -- encounter them inside the try - either_tval <- tryAllM $ do - { th_syn <- TH.runQ (unsafeCoerce# hval) - ; case convert (getLoc expr) th_syn of - Left err -> do { addErrTc err; return Nothing } - Right hs_syn -> return (Just hs_syn) } + -- + -- See Note [Exceptions in TH] + let expr_span = getLoc expr + ; either_tval <- tryAllM $ + setSrcSpan expr_span $ -- Set the span so that qLocation can + -- see where this splice is + do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval) + ; case mb_result of + Left err -> failWithTc err + Right result -> do { traceTc "Got HsSyn result:" (ppr result) + ; return $! result } } ; case either_tval of - Right (Just v) -> return v - Right Nothing -> failM -- Error already in Tc monad - Left exn -> failWithTc (mk_msg "run" exn) -- Exception - }}} + Right v -> return v + 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] +~~~~~~~~~~~~~~~~~~~~~~~ +Supppose we have something like this + $( f 4 ) +where + f :: Int -> Q [Dec] + f n | n>3 = fail "Too many declarations" + | otherwise = ... + +The 'fail' is a user-generated failure, and should be displayed as a +perfectly ordinary compiler error message, not a panic or anything +like that. Here's how it's processed: + + * 'fail' is the monad fail. The monad instance for Q in TH.Syntax + effectively transforms (fail s) to + qReport True s >> fail + where 'qReport' comes from the Quasi class and fail from its monad + superclass. + + * 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 an IOEnvFailure exception + + * So, when running a splice, we catch all exceptions; then for + - 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 + + To call runQ in the Tc monad, we need to make TcM an instance of Quasi: \begin{code} @@ -416,13 +894,22 @@ 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) - - qCurrentModule = do { m <- getModule; - return (moduleNameString (moduleName m)) } - -- ToDo: is throwing away the package name ok here? + qReport False msg = addReport (text msg) empty + + qLocation = do { m <- getModule + ; l <- getSrcSpanM + ; r <- case l of + UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" + (ppr l) + RealSrcSpan s -> return s + ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) + , TH.loc_module = moduleNameString (moduleName m) + , TH.loc_package = packageIdString (modulePackageId m) + , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) + , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } qReify v = reify v + qClassInstances = lookupClassInstances -- For qRecover, discard error messages if -- the recovery action is chosen. Otherwise @@ -434,7 +921,7 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where Nothing -> recover -- Discard all msgs } - qRunIO io = ioToTcRn io + qRunIO io = liftIO io \end{code} @@ -445,21 +932,48 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where %************************************************************************ \begin{code} -showSplice :: String -> LHsExpr Id -> SDoc -> TcM () +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 - = getSrcSpanM `thenM` \ loc -> - traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what, - nest 2 (sep [nest 2 (ppr before), - text "======>", - nest 2 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} -illegalBracket level - = ptext SLIT("Illegal bracket at level") <+> ppr level -illegalSplice level - = ptext SLIT("Illegal splice at level") <+> ppr level +%************************************************************************ +%* * + Instance Testing +%* * +%************************************************************************ -#endif /* GHCI */ +\begin{code} +lookupClassInstances :: TH.Name -> [TH.Type] -> TcM [TH.ClassInstance] +lookupClassInstances c ts + = do { loc <- getSrcSpanM + ; case convertToHsPred loc (TH.ClassP c ts) of { + Left msg -> failWithTc msg; + Right rdr_pred -> do + { rn_pred <- rnLPred doc rdr_pred -- Rename + ; kc_pred <- kcHsLPred rn_pred -- Kind check + ; ClassP cls tys <- dsHsLPred kc_pred -- Type check + + -- Now look up instances + ; inst_envs <- tcGetInstEnvs + ; let (matches, unifies) = lookupInstEnv inst_envs cls tys + ; mapM reifyClassInstance (map fst matches ++ unifies) } } } + where + doc = ptext (sLit "TcSplice.classInstances") \end{code} @@ -484,30 +998,28 @@ reify th_name ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data" ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc" ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var" + ppr_ns _ = panic "reify/ppr_ns" lookupThName :: TH.Name -> TcM Name -lookupThName th_name@(TH.Name occ flavour) - = do { let rdr_name = thRdrName guessed_ns occ_str flavour - - -- Repeat much of lookupOccRn, becase we want - -- to report errors in a TH-relevant way - ; rdr_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv rdr_env rdr_name of - Just name -> return name - Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig - -> lookupImportedName rdr_name - | otherwise -- Unqual, Qual - -> do { - mb_name <- lookupSrcOcc_maybe rdr_name - ; case mb_name of - Just name -> return name - Nothing -> failWithTc (notInScope th_name) } - } +lookupThName th_name = do + mb_name <- lookupThName_maybe th_name + case mb_name of + Nothing -> failWithTc (notInScope th_name) + Just name -> return name + +lookupThName_maybe th_name + = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name) + -- Pick the first that works + -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A + ; return (listToMaybe names) } where - -- guessed_ns is the name space guessed from looking at the TH name - guessed_ns | isLexCon (mkFastString occ_str) = OccName.dataName - | otherwise = OccName.varName - occ_str = TH.occString occ + lookup rdr_name + = do { -- Repeat much of lookupOccRn, becase we want + -- to report errors in a TH-relevant way + ; rdr_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv rdr_env rdr_name of + Just name -> return (Just name) + Nothing -> lookupGlobalOccRn_maybe rdr_name } tcLookupTh :: Name -> TcM TcTyThing -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that @@ -516,7 +1028,7 @@ tcLookupTh :: Name -> TcM TcTyThing tcLookupTh name = do { (gbl_env, lcl_env) <- getEnvs ; case lookupNameEnv (tcl_env lcl_env) name of { - Just thing -> returnM thing; + Just thing -> return thing; Nothing -> do { if nameIsLocalOrFrom (tcg_mod gbl_env) name then -- It's defined in this module @@ -537,12 +1049,12 @@ tcLookupTh name notInScope :: TH.Name -> SDoc notInScope th_name = quotes (text (TH.pprint th_name)) <+> - ptext SLIT("is not in scope at a reify") + ptext (sLit "is not in scope at a reify") -- Ugh! Rather an indirect way to display the name notInEnv :: Name -> SDoc notInEnv name = quotes (ppr name) <+> - ptext SLIT("is not in the type environment at a reify") + ptext (sLit "is not in the type environment at a reify") ------------------------------ reifyThing :: TcTyThing -> TcM TH.Info @@ -554,22 +1066,25 @@ 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) - other -> 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 -reifyThing (AGlobal (AClass cls)) = reifyClass cls +reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc +reifyThing (AGlobal (ACoAxiom ax)) = reifyAxiom ax +reifyThing (AGlobal (AClass cls)) = reifyClass cls 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_ty = ty}) - = do { ty1 <- zonkTcType ty -- Make use of all the info we have, even - -- though it may be incomplete +reifyThing (ATcId {tct_id = id}) + = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even + -- though it may be incomplete ; ty2 <- reifyType ty1 ; fix <- reifyFixity (idName id) ; return (TH.VarI (reifyName id) ty2 Nothing fix) } @@ -579,88 +1094,192 @@ reifyThing (ATyVar tv ty) ; ty2 <- reifyType ty1 ; return (TH.TyVarI (reifyName tv) ty2) } +reifyThing (AThing {}) = panic "reifyThing AThing" + ------------------------------ +reifyAxiom :: CoAxiom -> TcM TH.Info +reifyAxiom ax@(CoAxiom { co_ax_lhs = lhs, co_ax_rhs = rhs }) + | Just (tc, args) <- tcSplitTyConApp_maybe lhs + = do { args' <- mapM reifyType args + ; rhs' <- reifyType rhs + ; return (TH.TyConI $ TH.TySynInstD (reifyName tc) args' rhs') } + | otherwise + = failWith (ptext (sLit "Can't reify the axiom") <+> ppr ax + <+> dcolon <+> pprEqPred (Pair lhs rhs)) + 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)) + + | isFamilyTyCon 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') } + = do { let (tvs, rhs) = synTyConDefn tc + ; rhs' <- reifyType rhs + ; return (TH.TyConI $ + TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') + } -reifyTyCon tc + | otherwise = do { cxt <- reifyCxt (tyConStupidTheta tc) - ; cons <- mapM reifyDataCon (tyConDataCons tc) + ; let tvs = tyConTyVars tc + ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc) ; let name = reifyName tc - tvs = reifyTyVars (tyConTyVars tc) + r_tvs = reifyTyVars tvs deriv = [] -- Don't know about deriving - decl | isNewTyCon tc = TH.NewtypeD cxt name tvs (head cons) deriv - | otherwise = TH.DataD cxt name tvs cons deriv + decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv + | otherwise = TH.DataD cxt name r_tvs cons deriv ; return (TH.TyConI decl) } -reifyDataCon :: DataCon -> TcM TH.Con -reifyDataCon dc - | isVanillaDataCon dc - = do { arg_tys <- reifyTypes (dataConOrigArgTys dc) - ; let stricts = map reifyStrict (dataConStrictMarks dc) - fields = dataConFieldLabels dc - name = reifyName dc - [a1,a2] = arg_tys - [s1,s2] = stricts - ; ASSERT( length arg_tys == length stricts ) - if not (null fields) then - return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys)) - else - if dataConIsInfix dc then - ASSERT( length arg_tys == 2 ) - return (TH.InfixC (s1,a1) name (s2,a2)) - else - return (TH.NormalC name (stricts `zip` arg_tys)) } - | otherwise - = failWithTc (ptext SLIT("Can't reify a non-Haskell-98 data constructor:") - <+> quotes (ppr dc)) +reifyDataCon :: [Type] -> DataCon -> TcM TH.Con +-- For GADTs etc, see Note [Reifying data constructors] +reifyDataCon tys dc + = do { let (tvs, theta, arg_tys, _) = dataConSig dc + subst = mkTopTvSubst (tvs `zip` tys) -- Dicard ex_tvs + (subst', ex_tvs') = mapAccumL substTyVarBndr subst (dropList tys tvs) + theta' = substTheta subst' theta + arg_tys' = substTys subst' arg_tys + stricts = map reifyStrict (dataConStrictMarks dc) + fields = dataConFieldLabels dc + name = reifyName dc + + ; r_arg_tys <- reifyTypes arg_tys' + + ; let main_con | not (null fields) + = TH.RecC name (zip3 (map reifyName fields) stricts r_arg_tys) + | dataConIsInfix dc + = ASSERT( length arg_tys == 2 ) + TH.InfixC (s1,r_a1) name (s2,r_a2) + | otherwise + = TH.NormalC name (stricts `zip` r_arg_tys) + [r_a1, r_a2] = r_arg_tys + [s1, s2] = stricts + + ; ASSERT( length arg_tys == length stricts ) + if null ex_tvs' && null theta then + return main_con + else do + { cxt <- reifyCxt theta' + ; return (TH.ForallC (reifyTyVars ex_tvs') cxt main_con) } } ------------------------------ reifyClass :: Class -> TcM TH.Info reifyClass cls = do { cxt <- reifyCxt theta + ; inst_envs <- tcGetInstEnvs + ; insts <- mapM reifyClassInstance (InstEnv.classInstances inst_envs cls) ; ops <- mapM reify_op op_stuff - ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) } + ; let dec = TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops + ; return (TH.ClassI dec insts ) } where - (tvs, fds, theta, _, op_stuff) = classExtraBigSig cls + (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls fds' = map reifyFunDep fds reify_op (op, _) = do { ty <- reifyType (idType op) ; return (TH.SigD (reifyName op) ty) } ------------------------------ +reifyClassInstance :: Instance -> TcM TH.ClassInstance +reifyClassInstance i + = do { cxt <- reifyCxt theta + ; thtypes <- reifyTypes types + ; return $ (TH.ClassInstance { + TH.ci_tvs = reifyTyVars tvs, + TH.ci_cxt = cxt, + TH.ci_tys = thtypes, + TH.ci_cls = reifyName cls, + TH.ci_dfun = reifyName (is_dfun i) }) } + where + (tvs, theta, cls, types) = instanceHead i + +------------------------------ reifyType :: TypeRep.Type -> TcM TH.Type +-- Monadic only because of failure +reifyType ty@(ForAllTy _ _) = reify_for_all ty +reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty -- Types like ((?x::Int) => Char -> Char) reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) -reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys -reifyType (NoteTy _ ty) = reifyType ty +reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) } reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } -reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt; - ; tau' <- reifyType tau - ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') } - where - (tvs, cxt, tau) = tcSplitSigmaTy ty +reifyType ty@(PredTy {}) = pprPanic "reifyType PredTy" (ppr ty) + +reify_for_all :: TypeRep.Type -> TcM TH.Type +reify_for_all ty + = do { cxt' <- reifyCxt cxt; + ; tau' <- reifyType tau + ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') } + where + (tvs, cxt, tau) = tcSplitSigmaTy ty + +reifyTypes :: [Type] -> TcM [TH.Type] reifyTypes = mapM reifyType + +reifyKind :: Kind -> TH.Kind +reifyKind ki + = let (kis, ki') = splitKindFunTys ki + kis_rep = map reifyKind kis + ki'_rep = reifyNonArrowKind ki' + in + foldr 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 | isSynFamilyTyCon tc = TH.TypeFam + | isFamilyTyCon tc = TH.DataFam + | otherwise + = panic "TcSplice.reifyFamFlavour: not a type family" -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') } +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 :: TyCon -> [TypeRep.Type] -> TcM TH.Type +reify_tc_app tc tys + = do { tys' <- reifyTypes tys + ; return (foldl TH.AppT r_tc tys') } + where + n_tys = length tys + r_tc | isTupleTyCon tc = TH.TupleT n_tys + | tc `hasKey` listTyConKey = TH.ListT + | otherwise = TH.ConT (reifyName tc) -reifyPred :: TypeRep.PredType -> TcM TH.Type -reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys -reifyPred p@(IParam _ _) = noTH SLIT("implicit parameters") (ppr p) +reifyPred :: TypeRep.PredType -> TcM TH.Pred +reifyPred (ClassP cls tys) + = do { tys' <- reifyTypes tys + ; return $ TH.ClassP (reifyName cls) tys' } + +reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p) +reifyPred (EqPred ty1 ty2) + = do { ty1' <- reifyType ty1 + ; ty2' <- reifyType ty2 + ; return $ TH.EqualP ty1' ty2' + } ------------------------------ @@ -674,7 +1293,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 @@ -695,14 +1314,29 @@ reifyFixity name conv_dir BasicTypes.InfixL = TH.InfixL conv_dir BasicTypes.InfixN = TH.InfixN -reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict -reifyStrict MarkedStrict = TH.IsStrict -reifyStrict MarkedUnboxed = TH.IsStrict -reifyStrict NotMarkedStrict = TH.NotStrict +reifyStrict :: BasicTypes.HsBang -> TH.Strict +reifyStrict bang | isBanged bang = TH.IsStrict + | otherwise = TH.NotStrict ------------------------------ noTH :: LitString -> SDoc -> TcM a -noTH s d = failWithTc (hsep [ptext SLIT("Can't represent") <+> ptext s <+> - ptext SLIT("in Template Haskell:"), +noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+> + ptext (sLit "in Template Haskell:"), nest 2 d]) \end{code} + +Note [Reifying data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Template Haskell syntax is rich enough to express even GADTs, +provided we do so in the equality-predicate form. So a GADT +like + + data T a where + MkT1 :: a -> T [a] + MkT2 :: T Int + +will appear in TH syntax like this + + data T a = forall b. (a ~ [b]) => MkT1 b + | (a ~ Int) => MkT2 +