From 6a1c05f01429511984b63c49e6d802673ca5f4a1 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Tue, 4 Nov 2014 14:58:13 +0000 Subject: [PATCH] A little refactoring of HsSplice and friends Plus adding comments. The most substantive change is that PendingTcSplice becomes a proper data type rather than a pair; and PendingRnSplice uses it --- compiler/deSugar/DsMeta.hs | 2 +- compiler/hsSyn/HsExpr.lhs | 140 +++++++++++++++++++------------ compiler/hsSyn/HsUtils.lhs | 8 +- compiler/rename/RnSplice.lhs | 53 ++++++------ compiler/typecheck/TcExpr.lhs | 3 +- compiler/typecheck/TcHsSyn.lhs | 4 +- compiler/typecheck/TcRnTypes.lhs | 4 +- compiler/typecheck/TcSplice.lhs | 16 ++-- 8 files changed, 134 insertions(+), 96 deletions(-) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index ca04099081..24785c257f 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -77,7 +77,7 @@ dsBracket :: HsBracket Name -> [PendingTcSplice] -> DsM CoreExpr dsBracket brack splices = dsExtendMetaEnv new_bit (do_brack brack) where - new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n, e) <- splices] + new_bit = mkNameEnv [(n, Splice (unLoc e)) | PendSplice n e <- splices] do_brack (VarBr _ n) = do { MkC e1 <- lookupOcc n ; return e1 } do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 } diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index c61e0c719c..eaac719df9 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -350,57 +350,8 @@ deriving instance (DataId id) => Data (HsTupArg id) tupArgPresent :: HsTupArg id -> Bool tupArgPresent (Present {}) = True tupArgPresent (Missing {}) = False - --- See Note [Pending Splices] -data PendingRnSplice - = PendingRnExpSplice (HsSplice Name) - | PendingRnPatSplice (HsSplice Name) - | PendingRnTypeSplice (HsSplice Name) - | PendingRnDeclSplice (HsSplice Name) - | PendingRnCrossStageSplice Name - deriving (Data, Typeable) - -type PendingTcSplice = (Name, LHsExpr Id) \end{code} -Note [Pending Splices] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Now that untyped brackets are not type checked, we need a mechanism to ensure -that splices contained in untyped brackets *are* type checked. Therefore the -renamer now renames every HsBracket into a HsRnBracketOut, which contains the -splices that need to be type checked. There are four varieties of pending -splices generated by the renamer: - - * Pending expression splices (PendingRnExpSplice), e.g., - - [|$(f x) + 2|] - - * Pending pattern splices (PendingRnPatSplice), e.g., - - [|\ $(f x) -> x|] - - * Pending type splices (PendingRnTypeSplice), e.g., - - [|f :: $(g x)|] - - * Pending cross-stage splices (PendingRnCrossStageSplice), e.g., - - \x -> [| x |] - -There is a fifth variety of pending splice, which is generated by the type -checker: - - * Pending *typed* expression splices, (PendingTcSplice), e.g., - - [||1 + $$(f 2)||] - -It would be possible to eliminate HsRnBracketOut and use HsBracketOut for the -output of the renamer. However, when pretty printing the output of the renamer, -e.g., in a type error message, we *do not* want to print out the pending -splices. In contrast, when pretty printing the output of the type checker, we -*do* want to print the pending splices. So splitting them up seems to make -sense, although I hate to add another constructor to HsExpr. - Note [Parens in HsSyn] ~~~~~~~~~~~~~~~~~~~~~~ HsPar (and ParPat in patterns, HsParTy in types) is used as follows @@ -1387,15 +1338,98 @@ pprQuals quals = interpp'SP quals %************************************************************************ \begin{code} -data HsSplice id = HsSplice -- $z or $(f 4) - id -- The id is just a unique name to - (LHsExpr id) -- identify this splice point - deriving (Typeable) +data HsSplice id + = HsSplice -- $z or $(f 4) + id -- A unique name to identify this splice point + (LHsExpr id) -- See Note [Pending Splices] + deriving (Typeable ) + +-- See Note [Pending Splices] +data PendingSplice id + = PendSplice Name (LHsExpr id) + deriving( Typeable ) + -- It'd be convenient to re-use HsSplice, but the splice-name + -- really is a Name, never an Id. Using (PostRn id Name) is + -- nearly OK, but annoyingly we can't pretty-print it. + +data PendingRnSplice + = PendingRnExpSplice (PendingSplice Name) + | PendingRnPatSplice (PendingSplice Name) + | PendingRnTypeSplice (PendingSplice Name) + | PendingRnDeclSplice (PendingSplice Name) + | PendingRnCrossStageSplice Name + deriving (Data, Typeable) + +type PendingTcSplice = PendingSplice Id + deriving instance (DataId id) => Data (HsSplice id) +deriving instance (DataId id) => Data (PendingSplice id) +\end{code} + +Note [Pending Splices] +~~~~~~~~~~~~~~~~~~~~~~ +When we rename an untyped bracket, we name and lift out all the nested +splices, so that when the typechecker hits the bracket, it can +typecheck those nested splices without having to walk over the untyped +bracket code. So for example + [| f $(g x) |] +looks like + + HsBracket (HsApp (HsVar "f") (HsSpliceE _ (g x))) + +which the renamer rewrites to + + HsRnBracketOut (HsApp (HsVar f) (HsSpliceE sn (g x))) + [PendingRnExpSplice (HsSplice sn (g x))] + +* The 'sn' is the Name of the splice point. + +* The PendingRnExpSplice gives the splice that splice-point name maps to; + and the typechecker can now conveniently find these sub-expressions + +* The other copy of the splice, in the second argument of HsSpliceE + in the renamed first arg of HsRnBracketOut + is used only for pretty printing + +There are four varieties of pending splices generated by the renamer: + + * Pending expression splices (PendingRnExpSplice), e.g., + + [|$(f x) + 2|] + + * Pending pattern splices (PendingRnPatSplice), e.g., + + [|\ $(f x) -> x|] + + * Pending type splices (PendingRnTypeSplice), e.g., + [|f :: $(g x)|] + + * Pending cross-stage splices (PendingRnCrossStageSplice), e.g., + + \x -> [| x |] + +There is a fifth variety of pending splice, which is generated by the type +checker: + + * Pending *typed* expression splices, (PendingTcSplice), e.g., + + [||1 + $$(f 2)||] + +It would be possible to eliminate HsRnBracketOut and use HsBracketOut for the +output of the renamer. However, when pretty printing the output of the renamer, +e.g., in a type error message, we *do not* want to print out the pending +splices. In contrast, when pretty printing the output of the type checker, we +*do* want to print the pending splices. So splitting them up seems to make +sense, although I hate to add another constructor to HsExpr. + +\begin{code} instance OutputableBndr id => Outputable (HsSplice id) where ppr (HsSplice n e) = angleBrackets (ppr n <> comma <+> ppr e) +instance OutputableBndr id => Outputable (PendingSplice id) where + ppr (PendSplice n e) = angleBrackets (ppr n <> comma <+> ppr e) + pprUntypedSplice :: OutputableBndr id => HsSplice id -> SDoc pprUntypedSplice = pprSplice False diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index eb348d1eba..12e2388684 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -282,6 +282,9 @@ mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2 mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName mkHsSplice e = HsSplice unqualSplice e +unqualSplice :: RdrName +unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) + mkHsSpliceE :: LHsExpr RdrName -> HsExpr RdrName mkHsSpliceE e = HsSpliceE False (mkHsSplice e) @@ -291,11 +294,6 @@ mkHsSpliceTE e = HsSpliceE True (mkHsSplice e) mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) placeHolderKind -unqualSplice :: RdrName -unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) - -- A name (uniquified later) to - -- identify the splice - mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName mkHsQuasiQuote quoter span quote = HsQuasiQuote quoter span quote diff --git a/compiler/rename/RnSplice.lhs b/compiler/rename/RnSplice.lhs index 94e3fc2b3e..59c8c6294d 100644 --- a/compiler/rename/RnSplice.lhs +++ b/compiler/rename/RnSplice.lhs @@ -68,19 +68,21 @@ rnSpliceDecl e = failTH e "Template Haskell declaration splice" %* * %********************************************************* -Note [Splices] -~~~~~~~~~~~~~~ -Consider +Note [Free variables of typed splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider renaming this: f = ... h = ...$(thing "f")... -The splice can expand into literally anything, so when we do dependency -analysis we must assume that it might mention 'f'. So we simply treat -all locally-defined names as mentioned by any splice. This is terribly -brutal, but I don't see what else to do. For example, it'll mean -that every locally-defined thing will appear to be used, so no unused-binding -warnings. But if we miss the dependency, then we might typecheck 'h' before 'f', -and that will crash the type checker because 'f' isn't in scope. +where the splice is a *typed* splice. The splice can expand into +literally anything, so when we do dependency analysis we must assume +that it might mention 'f'. So we simply treat all locally-defined +names as mentioned by any splice. This is terribly brutal, but I +don't see what else to do. For example, it'll mean that every +locally-defined thing will appear to be used, so no unused-binding +warnings. But if we miss the dependency, then we might typecheck 'h' +before 'f', and that will crash the type checker because 'f' isn't in +scope. Currently, I'm not treating a splice as also mentioning every import, which is a bit inconsistent -- but there are a lot of them. We might @@ -130,28 +132,27 @@ rnSpliceGen is_typed_splice run_splice pend_splice splice@(HsSplice _ expr) --------------------- rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) -- Not exported...used for all -rnSplice (HsSplice n expr) +rnSplice (HsSplice splice_name expr) = do { checkTH expr "Template Haskell splice" ; loc <- getSrcSpanM - ; n' <- newLocalBndrRn (L loc n) + ; n' <- newLocalBndrRn (L loc splice_name) ; (expr', fvs) <- rnLExpr expr ; return (HsSplice n' expr', fvs) } - --------------------- rnSpliceExpr :: Bool -> HsSplice RdrName -> RnM (HsExpr Name, FreeVars) rnSpliceExpr is_typed splice = rnSpliceGen is_typed run_expr_splice pend_expr_splice splice where pend_expr_splice :: HsSplice Name -> (PendingRnSplice, HsExpr Name) - pend_expr_splice rn_splice - = (PendingRnExpSplice rn_splice, HsSpliceE is_typed rn_splice) + pend_expr_splice rn_splice@(HsSplice n e) + = (PendingRnExpSplice (PendSplice n e), HsSpliceE is_typed rn_splice) run_expr_splice :: HsSplice Name -> RnM (HsExpr Name, FreeVars) run_expr_splice rn_splice@(HsSplice _ expr') | is_typed -- Run it later, in the type checker = do { -- Ugh! See Note [Splices] above - lcl_rdr <- getLocalRdrEnv + lcl_rdr <- getLocalRdrEnv ; gbl_rdr <- getGlobalRdrEnv ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr , isLocalGRE gre] @@ -161,7 +162,7 @@ rnSpliceExpr is_typed splice | otherwise -- Run it here = do { expr <- getHooked runRnSpliceHook return >>= ($ expr') - + -- The splice must have type ExpQ ; meta_exp_ty <- tcMetaTy expQTyConName @@ -183,12 +184,12 @@ rnSpliceType :: HsSplice RdrName -> PostTc Name Kind rnSpliceType splice k = rnSpliceGen False run_type_splice pend_type_splice splice where - pend_type_splice rn_splice - = (PendingRnTypeSplice rn_splice, HsSpliceTy rn_splice k) + pend_type_splice rn_splice@(HsSplice n e) + = (PendingRnTypeSplice (PendSplice n e), HsSpliceTy rn_splice k) - run_type_splice (HsSplice _ expr') + run_type_splice (HsSplice _ expr') = do { expr <- getHooked runRnSpliceHook return >>= ($ expr') - + ; meta_exp_ty <- tcMetaTy typeQTyConName -- Typecheck the expression @@ -210,12 +211,12 @@ rnSplicePat :: HsSplice RdrName -> RnM (Pat Name, FreeVars) rnSplicePat splice = rnSpliceGen False run_pat_splice pend_pat_splice splice where - pend_pat_splice rn_splice - = (PendingRnPatSplice rn_splice, SplicePat rn_splice) + pend_pat_splice rn_splice@(HsSplice n e) + = (PendingRnPatSplice (PendSplice n e), SplicePat rn_splice) run_pat_splice (HsSplice _ expr') = do { expr <- getHooked runRnSpliceHook return >>= ($ expr') - + ; meta_exp_ty <- tcMetaTy patQTyConName -- Typecheck the expression @@ -236,8 +237,8 @@ rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars) rnSpliceDecl (SpliceDecl (L loc splice) flg) = rnSpliceGen False run_decl_splice pend_decl_splice splice where - pend_decl_splice rn_splice - = (PendingRnDeclSplice rn_splice, SpliceDecl(L loc rn_splice) flg) + pend_decl_splice rn_splice@(HsSplice n e) + = (PendingRnDeclSplice (PendSplice n e), SpliceDecl(L loc rn_splice) flg) run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice) \end{code} diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 487ee4f356..5ebe6ee286 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -1319,7 +1319,8 @@ checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var)) -- Update the pending splices ; ps <- readMutVar ps_var - ; writeMutVar ps_var ((idName id, nlHsApp (noLoc lift) (nlHsVar id)) : ps) + ; let pending_splice = PendSplice (idName id) (nlHsApp (noLoc lift) (nlHsVar id)) + ; writeMutVar ps_var (pending_splice : ps) ; return () } diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index f65efc0da2..1a91f10e66 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -602,8 +602,8 @@ zonkExpr env (HsTcBracketOut body bs) = do bs' <- mapM zonk_b bs return (HsTcBracketOut body bs') where - zonk_b (n, e) = do e' <- zonkLExpr env e - return (n, e') + zonk_b (PendSplice n e) = do e' <- zonkLExpr env e + return (PendSplice n e') zonkExpr _ (HsSpliceE t s) = WARN( True, ppr s ) -- Should not happen return (HsSpliceE t s) diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index cf1e851ed3..83f9a40351 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -590,7 +590,7 @@ pass it inwards. --------------------------- data ThStage -- See Note [Template Haskell state diagram] in TcSplice - = Splice -- Top-level splicing + = Splice -- Inside a top-level splice splice -- This code will be run *at compile time*; -- the result replaces the splice -- Binding level = 0 @@ -609,7 +609,7 @@ data PendingStuff | RnPendingTyped -- Renaming the inside of a *typed* bracket - | TcPending -- Typechecking the iniside of a typed bracket + | TcPending -- Typechecking the inside of a typed bracket (TcRef [PendingTcSplice]) -- Accumulate pending splices here (TcRef WantedConstraints) -- and type constraints here diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 2f952db3fb..ea467f0ad0 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -248,7 +248,11 @@ Note [Template Haskell state diagram] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here are the ThStages, s, their corresponding level numbers (the result of (thLevel s)), and their state transitions. +The top level of the program is stage Comp: + Start here + | + V ----------- $ ------------ $ | Comp | ---------> | Splice | -----| | 1 | | 0 | <----| @@ -378,16 +382,16 @@ tcBrackTy (TExpBr _) = panic "tcUntypedBracket: Unexpected TExpBr" --------------- tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice -tcPendingSplice (PendingRnExpSplice (HsSplice n expr)) +tcPendingSplice (PendingRnExpSplice (PendSplice n expr)) = do { res_ty <- tcMetaTy expQTyConName ; tc_pending_splice n expr res_ty } -tcPendingSplice (PendingRnPatSplice (HsSplice n expr)) +tcPendingSplice (PendingRnPatSplice (PendSplice n expr)) = do { res_ty <- tcMetaTy patQTyConName ; tc_pending_splice n expr res_ty } -tcPendingSplice (PendingRnTypeSplice (HsSplice n expr)) +tcPendingSplice (PendingRnTypeSplice (PendSplice n expr)) = do { res_ty <- tcMetaTy typeQTyConName ; tc_pending_splice n expr res_ty } -tcPendingSplice (PendingRnDeclSplice (HsSplice n expr)) +tcPendingSplice (PendingRnDeclSplice (PendSplice n expr)) = do { res_ty <- tcMetaTy decsQTyConName ; tc_pending_splice n expr res_ty } @@ -400,7 +404,7 @@ tcPendingSplice (PendingRnCrossStageSplice n) tc_pending_splice :: Name -> LHsExpr Name -> TcRhoType -> TcM PendingTcSplice tc_pending_splice splice_name expr res_ty = do { expr' <- tcMonoExpr expr res_ty - ; return (splice_name, expr') } + ; return (PendSplice splice_name expr') } --------------- -- Takes a type tau and returns the type Q (TExp tau) @@ -440,7 +444,7 @@ tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty ; untypeq <- tcLookupId unTypeQName ; let expr'' = mkHsApp (nlHsTyApp untypeq [res_ty]) expr' ; ps <- readMutVar ps_var - ; writeMutVar ps_var ((splice_name, expr'') : ps) + ; writeMutVar ps_var (PendSplice splice_name expr'' : ps) -- The returned expression is ignored; it's in the pending splices ; return (panic "tcSpliceExpr") } -- GitLab