X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=5ea37dae881beabcc13c75c9d12ed1fa01264d55;hb=4c6a3f787abcaed009a574196d82237d9ae64fc8;hp=9ec400d7226d7cc4e4c5d876a128b81be5961018;hpb=3f1b316d7035c55cd712cd39a9981339bcef2e8c;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 9ec400d..5ea37da 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -13,7 +13,8 @@ TcSplice: Template Haskell splices -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details -module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket ) where +module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket, + runQuasiQuoteExpr, runQuasiQuotePat ) where #include "HsVersions.h" @@ -165,9 +166,15 @@ tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId) kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind) -- None of these functions add constraints to the LIE +runQuasiQuoteExpr :: HsQuasiQuote Name -> TcM (LHsExpr RdrName) +runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName) + #ifndef GHCI tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e) + +runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q) +runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q) #else \end{code} @@ -191,30 +198,29 @@ Desugared: f = do { s7 <- g Int 3 \begin{code} tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId) -tcBracket brack res_ty - = getStage `thenM` \ level -> - case bracketOK level of { +tcBracket brack res_ty = do + level <- getStage + case bracketOK level of { Nothing -> failWithTc (illegalBracket level) ; - Just next_level -> + Just next_level -> do -- 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 -> + recordThUse + pending_splices <- newMutVar [] + lie_var <- getLIEVar - setStage (Brack next_level pending_splices lie_var) ( - getLIE (tc_bracket next_level brack) - ) `thenM` \ (meta_ty, lie) -> - tcSimplifyBracket lie `thenM_` + (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var) + (getLIE (tc_bracket next_level brack)) + tcSimplifyBracket lie -- Make the expected type have the right shape - boxyUnify meta_ty res_ty `thenM_` + boxyUnify meta_ty res_ty -- Return the original expression, not the type-decorated one - readMutVar pending_splices `thenM` \ pendings -> - returnM (noLoc (HsBracketOut brack pendings)) + pendings <- readMutVar pending_splices + return (noLoc (HsBracketOut brack pendings)) } tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType @@ -272,16 +278,16 @@ quotedNameStageErr v \begin{code} tcSpliceExpr (HsSplice name expr) res_ty - = setSrcSpan (getLoc expr) $ - getStage `thenM` \ level -> + = setSrcSpan (getLoc expr) $ do + level <- getStage case spliceOK level of { Nothing -> failWithTc (illegalSplice level) ; Just next_level -> - case level of { + case level of { Comp -> do { e <- tcTopSplice expr res_ty - ; returnM (unLoc e) } ; - Brack _ ps_var lie_var -> + ; return (unLoc e) } ; + Brack _ ps_var lie_var -> do -- A splice inside brackets -- NB: ignore res_ty, apart from zapping it to a mono-type @@ -289,19 +295,19 @@ tcSpliceExpr (HsSplice name expr) res_ty -- 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' -> + unBox res_ty + meta_exp_ty <- tcMetaTy expQTyConName + expr' <- setStage (Splice next_level) ( + setLIEVar 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 @@ -311,24 +317,24 @@ tcSpliceExpr (HsSplice name expr) res_ty -- inner escape before dealing with the outer one tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id) -tcTopSplice expr res_ty - = tcMetaTy expQTyConName `thenM` \ meta_exp_ty -> +tcTopSplice expr res_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 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 + traceTc (text "About to run" <+> ppr zonked_q_expr) + expr2 <- runMetaE convertToHsExpr zonked_q_expr + + traceTc (text "Got result" <+> ppr expr2) showSplice "expression" - zonked_q_expr (ppr expr2) `thenM_` + zonked_q_expr (ppr 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) -> + -- Rename it, but bale out if there are errors + -- otherwise the type checker just gives more spurious errors + (exp3, fvs) <- checkNoErrs (rnLExpr expr2) tcMonoExpr exp3 res_ty @@ -358,6 +364,80 @@ tcTopSpliceExpr expr meta_ty %************************************************************************ %* * + Quasi-quoting +%* * +%************************************************************************ + +Note [Quasi-quote overview] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The GHC "quasi-quote" extension is described by Geoff Mainland's paper +"Why it's nice to be quoted: quasiquoting for Haskell" (Haskell +Workshop 2007). + +Briefly, one writes + [:p| stuff |] +and the arbitrary string "stuff" gets parsed by the parser 'p', whose +type should be Language.Haskell.TH.Quote.QuasiQuoter. 'p' must be +defined in another module, because we are going to run it here. It's +a bit like a TH splice: + $(p "stuff") + +However, you can do this in patterns as well as terms. Becuase of this, +the splice is run by the *renamer* rather than the type checker. + +\begin{code} +runQuasiQuote :: Outputable hs_syn + => HsQuasiQuote Name -- Contains term of type QuasiQuoter, and the String + -> Name -- Of type QuasiQuoter -> String -> Q th_syn + -> String -- Documentation string only + -> Name -- Name of th_syn type + -> (SrcSpan -> th_syn -> Either Message hs_syn) + -> TcM hs_syn +runQuasiQuote (HsQuasiQuote name quoter q_span quote) quote_selector desc meta_ty convert + = do { -- Check that the quoter is not locally defined, otherwise the TH + -- machinery will not be able to run the quasiquote. + ; this_mod <- getModule + ; let is_local = case nameModule_maybe quoter of + Just mod | mod == this_mod -> True + | otherwise -> False + Nothing -> True + ; traceTc (text "runQQ" <+> ppr quoter <+> ppr is_local) + ; checkTc (not is_local) (quoteStageError quoter) + + -- Build the expression + ; let quoterExpr = L q_span $! HsVar $! quoter + ; let quoteExpr = L q_span $! HsLit $! HsString quote + ; let expr = L q_span $ + HsApp (L q_span $ + HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr + ; recordThUse + ; meta_exp_ty <- tcMetaTy meta_ty + + -- Typecheck the expression + ; zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty + + -- Run the expression + ; traceTc (text "About to run" <+> ppr zonked_q_expr) + ; result <- runMeta convert zonked_q_expr + ; traceTc (text "Got result" <+> ppr result) + ; showSplice desc zonked_q_expr (ppr result) + ; return result + } + +runQuasiQuoteExpr quasiquote + = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr + +runQuasiQuotePat quasiquote + = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat + +quoteStageError 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"))] +\end{code} + + +%************************************************************************ +%* * Splicing a type %* * %************************************************************************ @@ -391,7 +471,7 @@ kcSpliceType (HsSplice name hs_expr) -- 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 + ; return (panic "kcSpliceType", kind) -- The returned type is ignored }}}}} kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind) @@ -441,7 +521,7 @@ tcSpliceDecls expr ; showSplice "declarations" zonked_q_expr (ppr (getLoc expr) $$ (vcat (map ppr decls))) - ; returnM decls } + ; return decls } where handleErrors :: [Either a Message] -> TcM [a] handleErrors [] = return [] @@ -463,6 +543,11 @@ runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)) -> TcM (LHsExpr RdrName) runMetaE = runMeta +runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName)) + -> LHsExpr Id -- Of type (Q Pat) + -> TcM (Pat RdrName) +runMetaP = runMeta + runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName)) -> LHsExpr Id -- Of type (Q Type) -> TcM (LHsType RdrName) @@ -482,7 +567,7 @@ runMeta convert expr -- Compile and link it; might fail if linking fails ; hsc_env <- getTopEnv ; src_span <- getSrcSpanM - ; either_hval <- tryM $ ioToTcRn $ + ; either_hval <- tryM $ liftIO $ HscMain.compileExpr hsc_env src_span ds_expr ; case either_hval of { Left exn -> failWithTc (mk_msg "compile and link" exn) ; @@ -499,9 +584,12 @@ runMeta convert expr -- encounter them inside the try -- -- See Note [Exceptions in TH] - either_tval <- tryAllM $ do - { th_syn <- TH.runQ (unsafeCoerce# hval) - ; case convert (getLoc expr) th_syn of + let expr_span = getLoc expr + ; either_tval <- tryAllM $ + setSrcSpan expr_span $ -- Set the span so that qLocation can + -- see where this splice is + do { th_syn <- TH.runQ (unsafeCoerce# hval) + ; case convert expr_span th_syn of Left err -> failWithTc err Right hs_syn -> return hs_syn } @@ -560,10 +648,14 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where 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? - + qLocation = do { m <- getModule + ; l <- getSrcSpanM + ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l) + , TH.loc_module = moduleNameString (moduleName m) + , TH.loc_package = packageIdString (modulePackageId m) + , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l) + , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) } + qReify v = reify v -- For qRecover, discard error messages if @@ -576,7 +668,7 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where Nothing -> recover -- Discard all msgs } - qRunIO io = ioToTcRn io + qRunIO io = liftIO io \end{code} @@ -588,8 +680,8 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where \begin{code} showSplice :: String -> LHsExpr Id -> SDoc -> TcM () -showSplice what before after - = getSrcSpanM `thenM` \ loc -> +showSplice what before after = do + loc <- getSrcSpanM traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what, nest 2 (sep [nest 2 (ppr before), text "======>", @@ -657,7 +749,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 @@ -780,7 +872,6 @@ reifyClass cls reifyType :: TypeRep.Type -> TcM TH.Type reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys -reifyType (NoteTy _ ty) = reifyType ty 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;