diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/deSugar/DsExpr.hs | 8 | ||||
| -rw-r--r-- | compiler/ghc.cabal.in | 4 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 27 | ||||
| -rw-r--r-- | compiler/main/HscMain.hs | 4 | ||||
| -rw-r--r-- | compiler/rename/RnSplice.hs | 308 | ||||
| -rw-r--r-- | compiler/typecheck/TcExpr.hs | 10 | ||||
| -rw-r--r-- | compiler/typecheck/TcSplice.hs | 173 |
7 files changed, 245 insertions, 289 deletions
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 42aa22245e..78a6d11632 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -24,11 +24,7 @@ import Name import NameEnv import FamInstEnv( topNormaliseType ) -#ifdef GHCI - -- Template Haskell stuff iff bootstrapped import DsMeta -#endif - import HsSyn import Platform @@ -645,11 +641,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) -- Template Haskell stuff dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut" -#ifdef GHCI dsExpr (HsTcBracketOut x ps) = dsBracket x ps -#else -dsExpr (HsTcBracketOut _ _) = panic "dsExpr HsBracketOut" -#endif dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s) -- Arrow notation extension diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index c39c83e22c..09c252b3df 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -52,6 +52,7 @@ Library containers >= 0.5 && < 0.6, array >= 0.1 && < 0.6, filepath >= 1 && < 1.5, + template-haskell, hpc, transformers, bin-package-db, @@ -65,7 +66,6 @@ Library GHC-Options: -Wall -fno-warn-name-shadowing if flag(ghci) - Build-Depends: template-haskell CPP-Options: -DGHCI Include-Dirs: ../rts/dist/build @FFIIncludeDir@ @@ -164,6 +164,7 @@ Library IdInfo Lexeme Literal + DsMeta Llvm Llvm.AbsSyn Llvm.MetaData @@ -566,7 +567,6 @@ Library if flag(ghci) Exposed-Modules: - DsMeta Convert ByteCodeAsm ByteCodeGen diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 6e55622331..a0bd8a56dd 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -3009,7 +3009,7 @@ fLangFlags = [ -- See Note [Supporting CLI completion] flagSpec' "th" Opt_TemplateHaskell (\on -> deprecatedForExtension "TemplateHaskell" on - >> checkTemplateHaskellOk on), + >> setTemplateHaskellLoc on), flagSpec' "fi" Opt_ForeignFunctionInterface (deprecatedForExtension "ForeignFunctionInterface"), flagSpec' "ffi" Opt_ForeignFunctionInterface @@ -3179,7 +3179,7 @@ xFlags = [ flagSpec "StandaloneDeriving" Opt_StandaloneDeriving, flagSpec "StaticPointers" Opt_StaticPointers, flagSpec' "TemplateHaskell" Opt_TemplateHaskell - checkTemplateHaskellOk, + setTemplateHaskellLoc, flagSpec "TraditionalRecordSyntax" Opt_TraditionalRecordSyntax, flagSpec "TransformListComp" Opt_TransformListComp, flagSpec "TupleSections" Opt_TupleSections, @@ -3500,28 +3500,9 @@ setIncoherentInsts True = do l <- getCurLoc upd (\d -> d { incoherentOnLoc = l }) -checkTemplateHaskellOk :: TurnOnFlag -> DynP () -#ifdef GHCI -checkTemplateHaskellOk turn_on - | turn_on && rtsIsProfiled - = addErr "You can't use Template Haskell with a profiled compiler" - | otherwise +setTemplateHaskellLoc :: TurnOnFlag -> DynP () +setTemplateHaskellLoc _ = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l }) -#else --- In stage 1, Template Haskell is simply illegal, except with -M --- We don't bleat with -M because there's no problem with TH there, --- and in fact GHC's build system does ghc -M of the DPH libraries --- with a stage1 compiler -checkTemplateHaskellOk turn_on - | turn_on = do dfs <- liftEwM getCmdLineState - case ghcMode dfs of - MkDepend -> return () - _ -> addErr msg - | otherwise = return () - where - msg = "Template Haskell requires GHC with interpreter support\n " ++ - "Perhaps you are using a stage-1 compiler?" -#endif {- ********************************************************************** %* * diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 381b902018..eb772bae27 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -94,7 +94,6 @@ import Type ( Type ) import PrelNames import {- Kind parts of -} Type ( Kind ) import CoreLint ( lintInteractiveExpr ) -import DsMeta ( templateHaskellNames ) import VarEnv ( emptyTidyEnv ) import Panic import ConLike @@ -102,6 +101,7 @@ import ConLike import GHC.Exts #endif +import DsMeta ( templateHaskellNames ) import Module import Packages import RdrName @@ -196,9 +196,7 @@ knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, knownKeyNames = -- where templateHaskellNames are defined map getName wiredInThings ++ basicKnownKeyNames -#ifdef GHCI ++ templateHaskellNames -#endif -- ----------------------------------------------------------------------------- diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index 5306b6e800..5d12720e2c 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -19,37 +19,172 @@ import RdrName import TcRnMonad import Kind -#ifdef GHCI -import ErrUtils ( dumpIfSet_dyn_printer ) -import Control.Monad ( unless, when ) -import DynFlags -import DsMeta ( decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, liftName ) -import LoadIface ( loadInterfaceForName ) -import Module import RnEnv -import RnPat ( rnPat ) import RnSource ( rnSrcDecls, findSplice ) -import RnTypes ( rnLHsType ) -import PrelNames ( isUnboundName ) -import SrcLoc -import TcEnv ( checkWellStaged, tcMetaTy ) -import Outputable +import RnPat ( rnPat ) +import LoadIface ( loadInterfaceForName ) import BasicTypes ( TopLevelFlag, isTopLevel ) +import Outputable +import Module +import SrcLoc +import DynFlags import FastString +import RnTypes ( rnLHsType ) + +import Control.Monad ( unless, when ) + +import {-# SOURCE #-} RnExpr ( rnLExpr ) + +import PrelNames ( isUnboundName ) +import TcEnv ( checkWellStaged ) +import DsMeta ( liftName ) + +#ifdef GHCI +import ErrUtils ( dumpIfSet_dyn_printer ) +import DsMeta ( decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) +import TcEnv ( tcMetaTy ) import Hooks import Var ( Id ) import DsMeta ( quoteExpName, quotePatName, quoteDecName, quoteTypeName ) import Util -import {-# SOURCE #-} RnExpr ( rnLExpr ) import {-# SOURCE #-} TcExpr ( tcMonoExpr ) import {-# SOURCE #-} TcSplice ( runMetaD, runMetaE, runMetaP, runMetaT, tcTopSpliceExpr ) #endif -#ifndef GHCI +{- +************************************************************************ +* * + Template Haskell brackets +* * +************************************************************************ +-} + rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars) -rnBracket e _ = failTH e "Template Haskell bracket" +rnBracket e br_body + = addErrCtxt (quotationCtxtDoc br_body) $ + do { -- Check that Template Haskell is enabled and available + thEnabled <- xoptM Opt_TemplateHaskell + ; unless thEnabled $ + failWith ( vcat [ ptext (sLit "Syntax error on") <+> ppr e + , ptext (sLit "Perhaps you intended to use TemplateHaskell") ] ) + + -- Check for nested brackets + ; cur_stage <- getStage + ; case cur_stage of + { Splice True -> checkTc (isTypedBracket br_body) illegalUntypedBracket + ; Splice False -> checkTc (not (isTypedBracket br_body)) illegalTypedBracket + ; Comp -> return () + ; Brack {} -> failWithTc illegalBracket + } + + -- Brackets are desugared to code that mentions the TH package + ; recordThUse + + ; case isTypedBracket br_body of + True -> do { (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $ + rn_bracket cur_stage br_body + ; return (HsBracket body', fvs_e) } + + False -> do { ps_var <- newMutVar [] + ; (body', fvs_e) <- setStage (Brack cur_stage (RnPendingUntyped ps_var)) $ + rn_bracket cur_stage br_body + ; pendings <- readMutVar ps_var + ; return (HsRnBracketOut body' pendings, fvs_e) } + } + +rn_bracket :: ThStage -> HsBracket RdrName -> RnM (HsBracket Name, FreeVars) +rn_bracket outer_stage br@(VarBr flg rdr_name) + = do { name <- lookupOccRn rdr_name + ; this_mod <- getModule + + ; case flg of + { -- Type variables can be quoted in TH. See #5721. + False -> return () + ; True | nameIsLocalOrFrom this_mod name -> + do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name + ; case mb_bind_lvl of + { Nothing -> return () -- Can happen for data constructors, + -- but nothing needs to be done for them + + ; Just (top_lvl, bind_lvl) -- See Note [Quoting names] + | isTopLevel top_lvl + -> when (isExternalName name) (keepAlive name) + | otherwise + -> do { traceRn (text "rn_bracket VarBr" <+> ppr name <+> ppr bind_lvl <+> ppr outer_stage) + ; checkTc (thLevel outer_stage + 1 == bind_lvl) + (quotedNameStageErr br) } + } + } + ; True | otherwise -> -- Imported thing + discardResult (loadInterfaceForName msg name) + -- Reason for loadInterface: deprecation checking + -- assumes that the home interface is loaded, and + -- this is the only way that is going to happen + } + ; return (VarBr flg name, unitFV name) } + where + msg = ptext (sLit "Need interface for Template Haskell quoted Name") + +rn_bracket _ (ExpBr e) = do { (e', fvs) <- rnLExpr e + ; return (ExpBr e', fvs) } + +rn_bracket _ (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs) + +rn_bracket _ (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t + ; return (TypBr t', fvs) } + +rn_bracket _ (DecBrL decls) + = do { group <- groupDecls decls + ; gbl_env <- getGblEnv + ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs } + -- The emptyDUs is so that we just collect uses for this + -- group alone in the call to rnSrcDecls below + ; (tcg_env, group') <- setGblEnv new_gbl_env $ + rnSrcDecls Nothing group + + -- Discard the tcg_env; it contains only extra info about fixity + ; traceRn (text "rn_bracket dec" <+> (ppr (tcg_dus tcg_env) $$ + ppr (duUses (tcg_dus tcg_env)))) + ; return (DecBrG group', duUses (tcg_dus tcg_env)) } + where + groupDecls :: [LHsDecl RdrName] -> RnM (HsGroup RdrName) + groupDecls decls + = do { (group, mb_splice) <- findSplice decls + ; case mb_splice of + { Nothing -> return group + ; Just (splice, rest) -> + do { group' <- groupDecls rest + ; let group'' = appendGroups group group' + ; return group'' { hs_splcds = noLoc splice : hs_splcds group' } + } + }} + +rn_bracket _ (DecBrG _) = panic "rn_bracket: unexpected DecBrG" + +rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e + ; return (TExpBr e', fvs) } + +quotationCtxtDoc :: HsBracket RdrName -> SDoc +quotationCtxtDoc br_body + = hang (ptext (sLit "In the Template Haskell quotation")) + 2 (ppr br_body) + +illegalBracket :: SDoc +illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (without intervening splices)") +illegalTypedBracket :: SDoc +illegalTypedBracket = ptext (sLit "Typed brackets may only appear in typed slices.") + +illegalUntypedBracket :: SDoc +illegalUntypedBracket = ptext (sLit "Untyped brackets may only appear in untyped slices.") + +quotedNameStageErr :: HsBracket RdrName -> SDoc +quotedNameStageErr br + = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr br + , ptext (sLit "must be used at the same stage at which is is bound")] + +#ifndef GHCI rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars) rnTopSpliceDecls e = failTH e "Template Haskell top splice" @@ -363,120 +498,6 @@ Pat RdrName (the result of running a top-level splice) or a Pat Name rnSplicePat. -} -{- -************************************************************************ -* * - Template Haskell brackets -* * -************************************************************************ --} - -rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars) -rnBracket e br_body - = addErrCtxt (quotationCtxtDoc br_body) $ - do { -- Check that Template Haskell is enabled and available - thEnabled <- xoptM Opt_TemplateHaskell - ; unless thEnabled $ - failWith ( vcat [ ptext (sLit "Syntax error on") <+> ppr e - , ptext (sLit "Perhaps you intended to use TemplateHaskell") ] ) - ; checkTH e "Template Haskell bracket" - - -- Check for nested brackets - ; cur_stage <- getStage - ; case cur_stage of - { Splice True -> checkTc (isTypedBracket br_body) illegalUntypedBracket - ; Splice False -> checkTc (not (isTypedBracket br_body)) illegalTypedBracket - ; Comp -> return () - ; Brack {} -> failWithTc illegalBracket - } - - -- Brackets are desugared to code that mentions the TH package - ; recordThUse - - ; case isTypedBracket br_body of - True -> do { (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $ - rn_bracket cur_stage br_body - ; return (HsBracket body', fvs_e) } - - False -> do { ps_var <- newMutVar [] - ; (body', fvs_e) <- setStage (Brack cur_stage (RnPendingUntyped ps_var)) $ - rn_bracket cur_stage br_body - ; pendings <- readMutVar ps_var - ; return (HsRnBracketOut body' pendings, fvs_e) } - } - -rn_bracket :: ThStage -> HsBracket RdrName -> RnM (HsBracket Name, FreeVars) -rn_bracket outer_stage br@(VarBr flg rdr_name) - = do { name <- lookupOccRn rdr_name - ; this_mod <- getModule - - ; case flg of - { -- Type variables can be quoted in TH. See #5721. - False -> return () - ; True | nameIsLocalOrFrom this_mod name -> - do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name - ; case mb_bind_lvl of - { Nothing -> return () -- Can happen for data constructors, - -- but nothing needs to be done for them - - ; Just (top_lvl, bind_lvl) -- See Note [Quoting names] - | isTopLevel top_lvl - -> when (isExternalName name) (keepAlive name) - | otherwise - -> do { traceRn (text "rn_bracket VarBr" <+> ppr name <+> ppr bind_lvl <+> ppr outer_stage) - ; checkTc (thLevel outer_stage + 1 == bind_lvl) - (quotedNameStageErr br) } - } - } - ; True | otherwise -> -- Imported thing - discardResult (loadInterfaceForName msg name) - -- Reason for loadInterface: deprecation checking - -- assumes that the home interface is loaded, and - -- this is the only way that is going to happen - } - ; return (VarBr flg name, unitFV name) } - where - msg = ptext (sLit "Need interface for Template Haskell quoted Name") - -rn_bracket _ (ExpBr e) = do { (e', fvs) <- rnLExpr e - ; return (ExpBr e', fvs) } - -rn_bracket _ (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs) - -rn_bracket _ (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t - ; return (TypBr t', fvs) } - -rn_bracket _ (DecBrL decls) - = do { group <- groupDecls decls - ; gbl_env <- getGblEnv - ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs } - -- The emptyDUs is so that we just collect uses for this - -- group alone in the call to rnSrcDecls below - ; (tcg_env, group') <- setGblEnv new_gbl_env $ - rnSrcDecls Nothing group - - -- Discard the tcg_env; it contains only extra info about fixity - ; traceRn (text "rn_bracket dec" <+> (ppr (tcg_dus tcg_env) $$ - ppr (duUses (tcg_dus tcg_env)))) - ; return (DecBrG group', duUses (tcg_dus tcg_env)) } - where - groupDecls :: [LHsDecl RdrName] -> RnM (HsGroup RdrName) - groupDecls decls - = do { (group, mb_splice) <- findSplice decls - ; case mb_splice of - { Nothing -> return group - ; Just (splice, rest) -> - do { group' <- groupDecls rest - ; let group'' = appendGroups group group' - ; return group'' { hs_splcds = noLoc splice : hs_splcds group' } - } - }} - -rn_bracket _ (DecBrG _) = panic "rn_bracket: unexpected DecBrG" - -rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e - ; return (TExpBr e', fvs) } - spliceCtxt :: HsSplice RdrName -> SDoc spliceCtxt splice = hang (ptext (sLit "In the") <+> what) 2 (ppr splice) @@ -533,31 +554,12 @@ traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd , gen ] -illegalBracket :: SDoc -illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (without intervening splices)") - -illegalTypedBracket :: SDoc -illegalTypedBracket = ptext (sLit "Typed brackets may only appear in typed slices.") - -illegalUntypedBracket :: SDoc -illegalUntypedBracket = ptext (sLit "Untyped brackets may only appear in untyped slices.") - illegalTypedSplice :: SDoc illegalTypedSplice = ptext (sLit "Typed splices may not appear in untyped brackets") illegalUntypedSplice :: SDoc illegalUntypedSplice = ptext (sLit "Untyped splices may not appear in typed brackets") -quotedNameStageErr :: HsBracket RdrName -> SDoc -quotedNameStageErr br - = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr br - , ptext (sLit "must be used at the same stage at which is is bound")] - -quotationCtxtDoc :: HsBracket RdrName -> SDoc -quotationCtxtDoc br_body - = hang (ptext (sLit "In the Template Haskell quotation")) - 2 (ppr br_body) - -- spliceResultDoc :: OutputableBndr id => LHsExpr id -> SDoc -- spliceResultDoc expr -- = vcat [ hang (ptext (sLit "In the splice:")) @@ -566,13 +568,6 @@ quotationCtxtDoc br_body #endif checkThLocalName :: Name -> RnM () -#ifndef GHCI /* GHCI and TH is off */ --------------------------------------- --- Check for cross-stage lifting -checkThLocalName _name - = return () - -#else /* GHCI and TH is on */ checkThLocalName name | isUnboundName name -- Do not report two errors for = return () -- $(not_in_scope args) @@ -638,7 +633,6 @@ check_cross_stage_lifting top_lvl name ps_var -- Update the pending splices ; ps <- readMutVar ps_var ; writeMutVar ps_var (pend_splice : ps) } -#endif /* GHCI */ {- Note [Keeping things alive for Template Haskell] diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 353b2b71fa..155cdb42be 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -16,9 +16,7 @@ module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, #include "HsVersions.h" import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket ) -#ifdef GHCI import DsMeta( liftStringName, liftName ) -#endif import HsSyn import TcHsSyn @@ -1234,13 +1232,6 @@ tcTagToEnum loc fun_name arg res_ty -} checkThLocalId :: Id -> TcM () -#ifndef GHCI /* GHCI and TH is off */ --------------------------------------- --- Check for cross-stage lifting -checkThLocalId _id - = return () - -#else /* GHCI and TH is on */ checkThLocalId id = do { mb_local_use <- getStageAndBindLevel (idName id) ; case mb_local_use of @@ -1303,7 +1294,6 @@ checkCrossStageLifting _ _ = return () polySpliceErr :: Id -> SDoc polySpliceErr id = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id) -#endif /* GHCI */ {- Note [Lifting strings] diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index b73f20b283..f6b10838b8 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -34,6 +34,14 @@ import Name import TcRnMonad import TcType +import Outputable +import TcExpr +import SrcLoc +import FastString +import DsMeta +import TcUnify +import TcEnv + #ifdef GHCI import HscMain -- These imports are the reason that TcSplice @@ -45,14 +53,11 @@ import Convert import RnExpr import RnEnv import RnTypes -import TcExpr import TcHsSyn import TcSimplify -import TcUnify import Type import Kind import NameSet -import TcEnv import TcMType import TcHsType import TcIface @@ -81,7 +86,6 @@ import DsExpr import DsMonad import Serialized import ErrUtils -import SrcLoc import Util import Data.List ( mapAccumL ) import Unique @@ -92,10 +96,7 @@ import Maybes( MaybeErr(..) ) import DynFlags import Panic import Lexeme -import FastString -import Outputable -import DsMeta import qualified Language.Haskell.TH as TH -- THSyntax gives access to internal functions and data types import qualified Language.Haskell.TH.Syntax as TH @@ -129,10 +130,87 @@ tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) -- runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName] runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation +{- +************************************************************************ +* * +\subsection{Quoting an expression} +* * +************************************************************************ +-} + +-- See Note [How brackets and nested splices are handled] +-- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId) +tcTypedBracket brack@(TExpBr expr) res_ty + = addErrCtxt (quotationCtxtDoc brack) $ + do { cur_stage <- getStage + ; ps_ref <- newMutVar [] + ; lie_var <- getConstraintVar -- Any constraints arising from nested splices + -- should get thrown into the constraint set + -- from outside the bracket + + -- Typecheck expr to make sure it is valid, + -- Throw away the typechecked expression but return its type. + -- We'll typecheck it again when we splice it in somewhere + ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $ + tcInferRhoNC expr + -- NC for no context; tcBracket does that + + ; meta_ty <- tcTExpTy expr_ty + ; co <- unifyType meta_ty res_ty + ; ps' <- readMutVar ps_ref + ; texpco <- tcLookupId unsafeTExpCoerceName + ; return (mkHsWrapCo co (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty]) + (noLoc (HsTcBracketOut brack ps'))))) } +tcTypedBracket other_brack _ + = pprPanic "tcTypedBracket" (ppr other_brack) + +-- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> TcRhoType -> TcM (HsExpr TcId) +tcUntypedBracket brack ps res_ty + = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps) + ; ps' <- mapM tcPendingSplice ps + ; meta_ty <- tcBrackTy brack + ; co <- unifyType meta_ty res_ty + ; traceTc "tc_bracket done untyped" (ppr meta_ty) + ; return (mkHsWrapCo co (HsTcBracketOut brack ps')) } + +--------------- +tcBrackTy :: HsBracket Name -> TcM TcType +tcBrackTy (VarBr _ _) = tcMetaTy nameTyConName -- Result type is Var (not Q-monadic) +tcBrackTy (ExpBr _) = tcMetaTy expQTyConName -- Result type is ExpQ (= Q Exp) +tcBrackTy (TypBr _) = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ) +tcBrackTy (DecBrG _) = tcMetaTy decsQTyConName -- Result type is Q [Dec] +tcBrackTy (PatBr _) = tcMetaTy patQTyConName -- Result type is PatQ (= Q Pat) +tcBrackTy (DecBrL _) = panic "tcBrackTy: Unexpected DecBrL" +tcBrackTy (TExpBr _) = panic "tcUntypedBracket: Unexpected TExpBr" + +--------------- +tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice +tcPendingSplice (PendingRnSplice flavour splice_name expr) + = do { res_ty <- tcMetaTy meta_ty_name + ; expr' <- tcMonoExpr expr res_ty + ; return (PendingTcSplice splice_name expr') } + where + meta_ty_name = case flavour of + UntypedExpSplice -> expQTyConName + UntypedPatSplice -> patQTyConName + UntypedTypeSplice -> typeQTyConName + UntypedDeclSplice -> decsQTyConName + +--------------- +-- Takes a type tau and returns the type Q (TExp tau) +tcTExpTy :: TcType -> TcM TcType +tcTExpTy tau + = do { q <- tcLookupTyCon qTyConName + ; texp <- tcLookupTyCon tExpTyConName + ; return (mkTyConApp q [mkTyConApp texp [tau]]) } + +quotationCtxtDoc :: HsBracket Name -> SDoc +quotationCtxtDoc br_body + = hang (ptext (sLit "In the Template Haskell quotation")) + 2 (ppr br_body) + #ifndef GHCI -tcTypedBracket x _ = failTH x "Template Haskell bracket" -tcUntypedBracket x _ _ = failTH x "Template Haskell bracket" tcSpliceExpr e _ = failTH e "Template Haskell splice" -- runQuasiQuoteExpr q = failTH q "quasiquote" @@ -325,80 +403,8 @@ When a variable is used, we compare g1 = $(map ...) is OK g2 = $(f ...) is not OK; because we havn't compiled f yet - -************************************************************************ -* * -\subsection{Quoting an expression} -* * -************************************************************************ -} --- See Note [How brackets and nested splices are handled] --- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId) -tcTypedBracket brack@(TExpBr expr) res_ty - = addErrCtxt (quotationCtxtDoc brack) $ - do { cur_stage <- getStage - ; ps_ref <- newMutVar [] - ; lie_var <- getConstraintVar -- Any constraints arising from nested splices - -- should get thrown into the constraint set - -- from outside the bracket - - -- Typecheck expr to make sure it is valid, - -- Throw away the typechecked expression but return its type. - -- We'll typecheck it again when we splice it in somewhere - ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $ - tcInferRhoNC expr - -- NC for no context; tcBracket does that - - ; meta_ty <- tcTExpTy expr_ty - ; co <- unifyType meta_ty res_ty - ; ps' <- readMutVar ps_ref - ; texpco <- tcLookupId unsafeTExpCoerceName - ; return (mkHsWrapCo co (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty]) - (noLoc (HsTcBracketOut brack ps'))))) } -tcTypedBracket other_brack _ - = pprPanic "tcTypedBracket" (ppr other_brack) - --- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> TcRhoType -> TcM (HsExpr TcId) -tcUntypedBracket brack ps res_ty - = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps) - ; ps' <- mapM tcPendingSplice ps - ; meta_ty <- tcBrackTy brack - ; co <- unifyType meta_ty res_ty - ; traceTc "tc_bracket done untyped" (ppr meta_ty) - ; return (mkHsWrapCo co (HsTcBracketOut brack ps')) } - ---------------- -tcBrackTy :: HsBracket Name -> TcM TcType -tcBrackTy (VarBr _ _) = tcMetaTy nameTyConName -- Result type is Var (not Q-monadic) -tcBrackTy (ExpBr _) = tcMetaTy expQTyConName -- Result type is ExpQ (= Q Exp) -tcBrackTy (TypBr _) = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ) -tcBrackTy (DecBrG _) = tcMetaTy decsQTyConName -- Result type is Q [Dec] -tcBrackTy (PatBr _) = tcMetaTy patQTyConName -- Result type is PatQ (= Q Pat) -tcBrackTy (DecBrL _) = panic "tcBrackTy: Unexpected DecBrL" -tcBrackTy (TExpBr _) = panic "tcUntypedBracket: Unexpected TExpBr" - ---------------- -tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice -tcPendingSplice (PendingRnSplice flavour splice_name expr) - = do { res_ty <- tcMetaTy meta_ty_name - ; expr' <- tcMonoExpr expr res_ty - ; return (PendingTcSplice splice_name expr') } - where - meta_ty_name = case flavour of - UntypedExpSplice -> expQTyConName - UntypedPatSplice -> patQTyConName - UntypedTypeSplice -> typeQTyConName - UntypedDeclSplice -> decsQTyConName - ---------------- --- Takes a type tau and returns the type Q (TExp tau) -tcTExpTy :: TcType -> TcM TcType -tcTExpTy tau - = do { q <- tcLookupTyCon qTyConName - ; texp <- tcLookupTyCon tExpTyConName - ; return (mkTyConApp q [mkTyConApp texp [tau]]) } - {- ************************************************************************ * * @@ -469,11 +475,6 @@ tcTopSplice expr res_ty ************************************************************************ -} -quotationCtxtDoc :: HsBracket Name -> SDoc -quotationCtxtDoc br_body - = hang (ptext (sLit "In the Template Haskell quotation")) - 2 (ppr br_body) - spliceCtxtDoc :: HsSplice Name -> SDoc spliceCtxtDoc splice = hang (ptext (sLit "In the Template Haskell splice")) |