X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=bafddf8e3582334039af4bbb7353f85176f17ce0;hp=70eaca8cec7cde7ff38961176ebcc907035d5719;hb=215ce9f15215399ce30ae55c9521087847d78646;hpb=830f4b00a7299dfa742c89e13e861f310d804642 diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 70eaca8..bafddf8 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -16,7 +16,9 @@ TcSplice: Template Haskell splices module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket, lookupThName_maybe, - runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where + runQuasiQuoteExpr, runQuasiQuotePat, + runQuasiQuoteDecl, runQuasiQuoteType, + runAnnotation ) where #include "HsVersions.h" @@ -31,6 +33,7 @@ import RnExpr import RnEnv import RdrName import RnTypes +import TcPat import TcExpr import TcHsSyn import TcSimplify @@ -43,6 +46,7 @@ import TcIface import TypeRep import Name import NameEnv +import NameSet import PrelNames import HscTypes import OccName @@ -70,6 +74,7 @@ import BasicTypes import Panic import FastString import Exception +import Control.Monad ( when ) import qualified Language.Haskell.TH as TH -- THSyntax gives access to internal functions and data types @@ -281,25 +286,30 @@ The predicate we use is TcEnv.thTopLevelId. tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId) tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId) -kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind) +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 Name -> TcM (LHsExpr RdrName) -runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName) +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 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 = pprPanic "Cant do kcSpliceType 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} @@ -360,26 +370,28 @@ tc_bracket _ (ExpBr expr) = do { any_ty <- newFlexiTyVarTy liftedTypeKind ; _ <- tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that ; tcMetaTy expQTyConName } - -- Result type is Expr (= Q Exp) + -- Result type is ExpQ (= Q Exp) tc_bracket _ (TypBr typ) = do { _ <- tcHsSigTypeNC ThBrackCtxt typ ; tcMetaTy typeQTyConName } -- Result type is Type (= Q Typ) -tc_bracket _ (DecBr decls) +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 + -- Typecheck the declarations, dicarding the result + -- We'll get all that stuff later, when we splice it in + ; tcMetaTy decsQTyConName } -- Result type is Q [Dec] - ; decl_ty <- tcMetaTy decTyConName - ; q_ty <- tcMetaTy qTyConName - ; return (mkAppTy q_ty (mkListTy decl_ty)) - -- Result type is Q [Dec] - } +tc_bracket _ (PatBr pat) + = do { any_ty <- newFlexiTyVarTy liftedTypeKind + ; _ <- tcPat ThPatQuote pat any_ty unitTy $ \_ -> + return () + ; tcMetaTy patQTyConName } + -- Result type is PatQ (= Q Pat) -tc_bracket _ (PatBr _) - = failWithTc (ptext (sLit "Tempate Haskell pattern brackets are not supported yet")) +tc_bracket _ (DecBrL _) + = panic "tc_bracket: Unexpected DecBrL" quotedNameStageErr :: Name -> SDoc quotedNameStageErr v @@ -485,7 +497,7 @@ tcTopSpliceExpr tc_action 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 { stage <- getStage ; case stage of { @@ -508,11 +520,8 @@ kcSpliceType (HsSplice name hs_expr) -- Here (h 4) :: Q Type -- but $(h 4) :: a i.e. any type, of any kind - -- We return a HsSpliceTyOut, which serves to convey the kind to - -- the ensuing TcHsType.dsHsType, which makes up a non-committal - -- type variable of a suitable kind ; kind <- newKindVar - ; return (HsSpliceTyOut kind, kind) + ; return (HsSpliceTy splice fvs kind, kind) }}} kcTopSpliceType :: LHsExpr Name -> TcM (HsType Name, TcKind) @@ -548,9 +557,7 @@ kcTopSpliceType expr -- 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) + = do { list_q <- tcMetaTy decsQTyConName -- Q [Dec] ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr list_q) -- Run the expression @@ -622,7 +629,7 @@ The GHC "quasi-quote" extension is described by Geoff Mainland's paper Workshop 2007). Briefly, one writes - [:p| stuff |] + [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 @@ -632,26 +639,43 @@ a bit like a TH splice: 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 Name -- Contains term of type QuasiQuoter, and the String + => 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 - -> TcM hs_syn -runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector meta_ty meta_ops - = do { -- Check that the quoter is not locally defined, otherwise the TH + -> RnM hs_syn +runQuasiQuote (HsQuasiQuote quoter q_span quote) quote_selector meta_ty meta_ops + = do { 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 = case nameModule_maybe quoter of - Just mod | mod == this_mod -> True - | otherwise -> False - Nothing -> True + ; this_mod <- getModule + ; let is_local = nameIsLocalOrFrom this_mod quoter' + ; checkTc (not is_local) (quoteStageError quoter') + ; 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 quoterExpr = L q_span $! HsVar $! quoter' ; let quoteExpr = L q_span $! HsLit $! HsString quote ; let expr = L q_span $ HsApp (L q_span $ @@ -667,8 +691,10 @@ runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector meta_ty me ; return result } -runQuasiQuoteExpr quasiquote = runQuasiQuote quasiquote quoteExpName expQTyConName exprMetaOps -runQuasiQuotePat quasiquote = runQuasiQuote quasiquote quotePatName patQTyConName patMetaOps +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 @@ -1070,17 +1096,22 @@ reifyClass cls ------------------------------ reifyType :: TypeRep.Type -> TcM TH.Type +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 (TyConApp tc tys) = reify_tc_app (reifyName 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 (PredTy {}) = panic "reifyType PredTy" +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 @@ -1090,7 +1121,7 @@ reifyKind ki kis_rep = map reifyKind kis ki'_rep = reifyNonArrowKind ki' in - foldl TH.ArrowK ki'_rep kis_rep + foldr TH.ArrowK ki'_rep kis_rep where reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK | otherwise = pprPanic "Exotic form of kind" @@ -1166,10 +1197,9 @@ 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