From 6f8ff0bbad3b9fa389c960ad1b5a267a1ae502f1 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 10 Feb 2010 09:39:10 +0000 Subject: [PATCH] Several TH/quasiquote changes a) Added quasi-quote forms for declarations types e.g. f :: [$qq| ... |] b) Allow Template Haskell pattern quotes (but not splices) e.g. f x = [p| Int -> $x |] c) Improve pretty-printing for HsPat to remove superfluous parens. (This isn't TH related really, but it affects some of the same code.) A consequence of (a) is that when gathering and grouping declarations in RnSource.findSplice, we must expand quasiquotes as we do so. Otherwise it's all fairly straightforward. I did a little bit of refactoring in TcSplice. User-manual changes still to come. --- compiler/deSugar/DsMeta.hs | 77 ++++++++++++++++----------- compiler/hsSyn/HsDecls.lhs | 2 + compiler/hsSyn/HsExpr.lhs | 44 +++++++++------ compiler/hsSyn/HsPat.lhs | 71 ++++++++++++------------- compiler/hsSyn/HsPat.lhs-boot | 5 +- compiler/hsSyn/HsTypes.lhs | 25 +++++++++ compiler/hsSyn/HsUtils.lhs | 2 +- compiler/parser/Parser.y.pp | 18 ++++--- compiler/parser/RdrHsSyn.lhs | 97 ++++------------------------------ compiler/rename/RnExpr.lhs | 33 +++++++----- compiler/rename/RnHsSyn.lhs | 1 + compiler/rename/RnPat.lhs | 35 +++--------- compiler/rename/RnSource.lhs | 85 ++++++++++++++++++++++++++++- compiler/rename/RnTypes.lhs | 9 ++++ compiler/typecheck/TcHsType.lhs | 6 ++- compiler/typecheck/TcRnDriver.lhs | 5 +- compiler/typecheck/TcSplice.lhs | 88 +++++++++++++++++++----------- compiler/typecheck/TcSplice.lhs-boot | 8 +-- 18 files changed, 346 insertions(+), 265 deletions(-) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 902eeb8..7718e4f 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -15,9 +15,10 @@ module DsMeta( dsBracket, templateHaskellNames, qTyConName, nameTyConName, - liftName, liftStringName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName, + liftName, liftStringName, expQTyConName, patQTyConName, + decQTyConName, decsQTyConName, typeQTyConName, decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName, - quoteExpName, quotePatName + quoteExpName, quotePatName, quoteDecName, quoteTypeName ) where #include "HsVersions.h" @@ -72,11 +73,12 @@ dsBracket brack splices where new_bit = mkNameEnv [(n, Splice (unLoc e)) | (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 } - do_brack (PatBr p) = do { MkC p1 <- repLP p ; return p1 } - do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 } - do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 } + do_brack (VarBr n) = do { MkC e1 <- lookupOcc n ; return e1 } + do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 } + do_brack (PatBr p) = do { MkC p1 <- repTopP p ; return p1 } + do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 } + do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 } + do_brack (DecBrL _) = panic "dsBracket: unexpected DecBrL" {- -------------- Examples -------------------- @@ -97,6 +99,11 @@ dsBracket brack splices -- Declarations ------------------------------------------------------- +repTopP :: LPat Name -> DsM (Core TH.PatQ) +repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat) + ; pat' <- addBinds ss (repLP pat) + ; wrapNongenSyms ss pat' } + repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec])) repTopDs group = do { let { bndrs = map unLoc (groupBinders group) } ; @@ -511,7 +518,7 @@ addTyVarBinds tvs m = bndrs <- mapM lookupBinder names kindedBndrs <- zipWithM ($) mkWithKinds bndrs m kindedBndrs - wrapGenSyns freshNames term + wrapGenSyms freshNames term -- Look up a list of type variables; the computations passed as the second -- argument gets the *new* names on Core-level as an argument @@ -713,7 +720,7 @@ repE (HsIf x y z) = do repE (HsLet bs e) = do { (ss,ds) <- repBinds bs ; e2 <- addBinds ss (repLE e) ; z <- repLetE ds e2 - ; wrapGenSyns ss z } + ; wrapGenSyms ss z } -- FIXME: I haven't got the types here right yet repE e@(HsDo ctxt sts body _) @@ -722,14 +729,14 @@ repE e@(HsDo ctxt sts body _) body' <- addBinds ss $ repLE body; ret <- repNoBindSt body'; e' <- repDoE (nonEmptyCoreList (zs ++ [ret])); - wrapGenSyns ss e' } + wrapGenSyms ss e' } | ListComp <- ctxt = do { (ss,zs) <- repLSts sts; body' <- addBinds ss $ repLE body; ret <- repNoBindSt body'; e' <- repComp (nonEmptyCoreList (zs ++ [ret])); - wrapGenSyns ss e' } + wrapGenSyms ss e' } | otherwise = notHandled "mdo and [: :]" (ppr e) @@ -788,7 +795,7 @@ repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) = ; addBinds ss2 $ do { ; gs <- repGuards guards ; match <- repMatch p1 gs ds - ; wrapGenSyns (ss1++ss2) match }}} + ; wrapGenSyms (ss1++ss2) match }}} repMatchTup _ = panic "repMatchTup: case alt with more than one arg" repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ) @@ -800,7 +807,7 @@ repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) = ; addBinds ss2 $ do { gs <- repGuards guards ; clause <- repClause ps1 gs ds - ; wrapGenSyns (ss1++ss2) clause }}} + ; wrapGenSyms (ss1++ss2) clause }}} repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ) repGuards [L _ (GRHS [] e)] @@ -809,7 +816,7 @@ repGuards other = do { zs <- mapM process other; let {(xs, ys) = unzip zs}; gd <- repGuarded (nonEmptyCoreList ys); - wrapGenSyns (concat xs) gd } + wrapGenSyms (concat xs) gd } where process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2)) @@ -932,7 +939,7 @@ rep_bind (L loc (FunBind { fun_id = fn, ; fn' <- lookupLBinder fn ; p <- repPvar fn' ; ans <- repVal p guardcore wherecore - ; ans' <- wrapGenSyns ss ans + ; ans' <- wrapGenSyms ss ans ; return (loc, ans') } rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ })) @@ -946,7 +953,7 @@ rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres })) ; (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; ans <- repVal patcore guardcore wherecore - ; ans' <- wrapGenSyns ss ans + ; ans' <- wrapGenSyms ss ans ; return (loc, ans') } rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) @@ -990,7 +997,7 @@ repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds))) ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( do { xs <- repLPs ps; body <- repLE e; repLam xs body }) - ; wrapGenSyns ss lam } + ; wrapGenSyms ss lam } repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m) @@ -1164,14 +1171,14 @@ lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ) lookupType tc_name = do { tc <- dsLookupTyCon tc_name ; return (mkTyConApp tc []) } -wrapGenSyns :: [GenSymBind] +wrapGenSyms :: [GenSymBind] -> Core (TH.Q a) -> DsM (Core (TH.Q a)) --- wrapGenSyns [(nm1,id1), (nm2,id2)] y +-- wrapGenSyms [(nm1,id1), (nm2,id2)] y -- --> bindQ (gensym nm1) (\ id1 -> -- bindQ (gensym nm2 (\ id2 -> -- y)) -wrapGenSyns binds body@(MkC b) +wrapGenSyms binds body@(MkC b) = do { var_ty <- lookupType nameTyConName ; go var_ty binds } where @@ -1729,10 +1736,10 @@ templateHaskellNames = [ varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName, typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName, patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, - predQTyConName, + predQTyConName, decsQTyConName, -- Quasiquoting - quoteExpName, quotePatName] + quoteDecName, quoteTypeName, quoteExpName, quotePatName] thSyn, thLib, qqLib :: Module thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax") @@ -1980,13 +1987,14 @@ dataFamName = libFun (fsLit "dataFam") dataFamIdKey matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName, varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName, - patQTyConName, fieldPatQTyConName, predQTyConName :: Name + patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName :: Name matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey expQTyConName = libTc (fsLit "ExpQ") expQTyConKey stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey decQTyConName = libTc (fsLit "DecQ") decQTyConKey -conQTyConName = libTc (fsLit "ConQ") conQTyConKey +decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec] +conQTyConName = libTc (fsLit "ConQ") conQTyConKey strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey @@ -1996,9 +2004,11 @@ fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey predQTyConName = libTc (fsLit "PredQ") predQTyConKey -- quasiquoting -quoteExpName, quotePatName :: Name -quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey -quotePatName = qqFun (fsLit "quotePat") quotePatKey +quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name +quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey +quotePatName = qqFun (fsLit "quotePat") quotePatKey +quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey +quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey -- TyConUniques available: 100-129 -- Check in PrelNames if you want to change this @@ -2009,7 +2019,7 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey, fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey, - predQTyConKey :: Unique + predQTyConKey, decsQTyConKey :: Unique expTyConKey = mkPreludeTyConUnique 100 matchTyConKey = mkPreludeTyConUnique 101 clauseTyConKey = mkPreludeTyConUnique 102 @@ -2023,7 +2033,6 @@ stmtQTyConKey = mkPreludeTyConUnique 109 conQTyConKey = mkPreludeTyConUnique 110 typeQTyConKey = mkPreludeTyConUnique 111 typeTyConKey = mkPreludeTyConUnique 112 -tyVarBndrTyConKey = mkPreludeTyConUnique 125 decTyConKey = mkPreludeTyConUnique 113 varStrictTypeQTyConKey = mkPreludeTyConUnique 114 strictTypeQTyConKey = mkPreludeTyConUnique 115 @@ -2036,6 +2045,8 @@ fieldExpQTyConKey = mkPreludeTyConUnique 121 funDepTyConKey = mkPreludeTyConUnique 122 predTyConKey = mkPreludeTyConUnique 123 predQTyConKey = mkPreludeTyConUnique 124 +tyVarBndrTyConKey = mkPreludeTyConUnique 125 +decsQTyConKey = mkPreludeTyConUnique 126 -- IdUniques available: 200-399 -- If you want to change this, make sure you check in PrelNames @@ -2250,6 +2261,8 @@ typeFamIdKey = mkPreludeMiscIdUnique 344 dataFamIdKey = mkPreludeMiscIdUnique 345 -- quasiquoting -quoteExpKey, quotePatKey :: Unique -quoteExpKey = mkPreludeMiscIdUnique 321 -quotePatKey = mkPreludeMiscIdUnique 322 +quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique +quoteExpKey = mkPreludeMiscIdUnique 321 +quotePatKey = mkPreludeMiscIdUnique 322 +quoteDecKey = mkPreludeMiscIdUnique 323 +quoteTypeKey = mkPreludeMiscIdUnique 324 diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 607b319..000ed19 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -102,6 +102,7 @@ data HsDecl id | RuleD (RuleDecl id) | SpliceD (SpliceDecl id) | DocD (DocDecl) + | QuasiQuoteD (HsQuasiQuote id) -- NB: all top-level fixity decls are contained EITHER @@ -204,6 +205,7 @@ instance OutputableBndr name => Outputable (HsDecl name) where ppr (AnnD ad) = ppr ad ppr (SpliceD dd) = ppr dd ppr (DocD doc) = ppr doc + ppr (QuasiQuoteD qq) = ppr qq instance OutputableBndr name => Outputable (HsGroup name) where ppr (HsGroup { hs_valds = val_decls, diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 10c106d..fd4f6db 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -744,7 +744,7 @@ pprPatBind pat ty@(grhss) pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc pprMatch ctxt (Match pats maybe_ty grhss) - = herald <+> sep [sep (map ppr other_pats), + = herald <+> sep [sep (map pprParendLPat other_pats), ppr_maybe_ty, nest 2 (pprGRHSs ctxt grhss)] where @@ -756,18 +756,21 @@ pprMatch ctxt (Match pats maybe_ty grhss) -- Not pprBndr; the AbsBinds will -- have printed the signature - | null pats3 -> (pp_infix, []) + | null pats2 -> (pp_infix, []) -- x &&& y = e - | otherwise -> (parens pp_infix, pats3) + | otherwise -> (parens pp_infix, pats2) -- (x &&& y) z = e where - (pat1:pat2:pats3) = pats - pp_infix = ppr pat1 <+> ppr fun <+> ppr pat2 + pp_infix = pprParendLPat pat1 <+> ppr fun <+> pprParendLPat pat2 LambdaExpr -> (char '\\', pats) - _ -> (empty, pats) + + _ -> ASSERT( null pats1 ) + (ppr pat1, []) -- No parens around the single pat + (pat1:pats1) = pats + (pat2:pats2) = pats1 ppr_maybe_ty = case maybe_ty of Just ty -> dcolon <+> ppr ty Nothing -> empty @@ -975,10 +978,11 @@ pprGroupByClause (GroupBySomething eitherUsingExpr byExpr) = hsep [ptext (sLit " pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc pprDo DoExpr stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body +pprDo GhciStmt stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body pprDo (MDoExpr _) stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body pprDo ListComp stmts body = pprComp brackets stmts body pprDo PArrComp stmts body = pprComp pa_brackets stmts body -pprDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt, GhciStmt +pprDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt ppr_do_stmts :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc -- Print a bunch of do stmts, with explicit braces and semicolons, @@ -1013,22 +1017,24 @@ pprSplice (HsSplice n e) = char '$' <> ifPprDebug (brackets (ppr n)) <> pprParendExpr e -data HsBracket id = ExpBr (LHsExpr id) -- [| expr |] - | PatBr (LPat id) -- [p| pat |] - | DecBr (HsGroup id) -- [d| decls |] - | TypBr (LHsType id) -- [t| type |] - | VarBr id -- 'x, ''T +data HsBracket id = ExpBr (LHsExpr id) -- [| expr |] + | PatBr (LPat id) -- [p| pat |] + | DecBrL [LHsDecl id] -- [d| decls |]; result of parser + | DecBrG (HsGroup id) -- [d| decls |]; result of renamer + | TypBr (LHsType id) -- [t| type |] + | VarBr id -- 'x, ''T instance OutputableBndr id => Outputable (HsBracket id) where ppr = pprHsBracket pprHsBracket :: OutputableBndr id => HsBracket id -> SDoc -pprHsBracket (ExpBr e) = thBrackets empty (ppr e) -pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p) -pprHsBracket (DecBr d) = thBrackets (char 'd') (ppr d) -pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t) -pprHsBracket (VarBr n) = char '\'' <> ppr n +pprHsBracket (ExpBr e) = thBrackets empty (ppr e) +pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p) +pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp) +pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds)) +pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t) +pprHsBracket (VarBr n) = char '\'' <> ppr n -- Infelicity: can't show ' vs '', because -- we can't ask n what its OccName is, because the -- pretty-printer for HsExpr doesn't ask for NamedThings @@ -1087,6 +1093,7 @@ data HsMatchContext id -- Context of a Match -- tell matchWrapper what sort of -- runtime error message to generate] | StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt or list comprehension + | ThPatQuote -- A Template Haskell pattern quotation [p| (a,b) |] deriving () data HsStmtContext id @@ -1123,6 +1130,7 @@ matchSeparator ProcExpr = ptext (sLit "->") matchSeparator PatBindRhs = ptext (sLit "=") matchSeparator (StmtCtxt _) = ptext (sLit "<-") matchSeparator RecUpd = panic "unused" +matchSeparator ThPatQuote = panic "unused" \end{code} \begin{code} @@ -1131,6 +1139,7 @@ pprMatchContext (FunRhs fun _) = ptext (sLit "the definition of") <+> quotes (ppr fun) pprMatchContext CaseAlt = ptext (sLit "a case alternative") pprMatchContext RecUpd = ptext (sLit "a record-update construct") +pprMatchContext ThPatQuote = ptext (sLit "a Template Haskell pattern quotation") pprMatchContext PatBindRhs = ptext (sLit "a pattern binding") pprMatchContext LambdaExpr = ptext (sLit "a lambda abstraction") pprMatchContext ProcExpr = ptext (sLit "an arrow abstraction") @@ -1173,6 +1182,7 @@ matchContextErrString PatBindRhs = ptext (sLit "pattern binding" matchContextErrString RecUpd = ptext (sLit "record update") matchContextErrString LambdaExpr = ptext (sLit "lambda") matchContextErrString ProcExpr = ptext (sLit "proc") +matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard") diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index af921de..5065375 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -19,13 +19,13 @@ module HsPat ( HsConPatDetails, hsConPatArgs, HsRecFields(..), HsRecField(..), hsRecFields, - HsQuasiQuote(..), - mkPrefixConPat, mkCharLitPat, mkNilPat, mkCoPat, mkCoPatCoI, isBangHsBind, hsPatNeedsParens, patsAreAllCons, isConPat, isSigPat, isWildPat, - patsAreAllLits, isLitPat, isIrrefutableHsPat + patsAreAllLits, isLitPat, isIrrefutableHsPat, + + pprParendLPat ) where import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, pprLExpr) @@ -215,24 +215,6 @@ hsRecFields :: HsRecFields id arg -> [id] hsRecFields rbinds = map (unLoc . hsRecFieldId) (rec_flds rbinds) \end{code} -\begin{code} -data HsQuasiQuote id = HsQuasiQuote - id - id - SrcSpan - FastString - -instance OutputableBndr id => Outputable (HsQuasiQuote id) where - ppr = ppr_qq - -ppr_qq :: OutputableBndr id => HsQuasiQuote id -> SDoc -ppr_qq (HsQuasiQuote name quoter _ quote) = - char '$' <> brackets (ppr name) <> - ptext (sLit "[:") <> ppr quoter <> ptext (sLit "|") <> - ppr quote <> ptext (sLit "|]") -\end{code} - - %************************************************************************ %* * %* Printing patterns @@ -252,14 +234,30 @@ pprPatBndr var -- Print with type info if -dppr-debug is on else ppr var +pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc +pprParendLPat (L _ p) = pprParendPat p + +pprParendPat :: (OutputableBndr name) => Pat name -> SDoc +pprParendPat p | patNeedsParens p = parens (pprPat p) + | otherwise = pprPat p + +patNeedsParens :: Pat name -> Bool +patNeedsParens (ConPatIn _ d) = not (null (hsConPatArgs d)) +patNeedsParens (ConPatOut { pat_args = d }) = not (null (hsConPatArgs d)) +patNeedsParens (SigPatIn {}) = True +patNeedsParens (SigPatOut {}) = True +patNeedsParens (ViewPat {}) = True +patNeedsParens (CoPat {}) = True +patNeedsParens _ = False + pprPat :: (OutputableBndr name) => Pat name -> SDoc pprPat (VarPat var) = pprPatBndr var -pprPat (VarPatOut var bs) = parens (pprPatBndr var <+> braces (ppr bs)) +pprPat (VarPatOut var bs) = pprPatBndr var <+> braces (ppr bs) pprPat (WildPat _) = char '_' -pprPat (LazyPat pat) = char '~' <> ppr pat -pprPat (BangPat pat) = char '!' <> ppr pat -pprPat (AsPat name pat) = parens (hcat [ppr name, char '@', ppr pat]) -pprPat (ViewPat expr pat _) = parens (hcat [pprLExpr expr, text " -> ", ppr pat]) +pprPat (LazyPat pat) = char '~' <> pprParendLPat pat +pprPat (BangPat pat) = char '!' <> pprParendLPat pat +pprPat (AsPat name pat) = hcat [ppr name, char '@', pprParendLPat pat] +pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat] pprPat (ParPat pat) = parens (ppr pat) pprPat (ListPat pats _) = brackets (interpp'SP pats) pprPat (PArrPat pats _) = pabrackets (interpp'SP pats) @@ -275,26 +273,23 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, pprLHsBinds binds, pprConArgs details] else pprUserCon con details -pprPat (LitPat s) = ppr s +pprPat (LitPat s) = ppr s pprPat (NPat l Nothing _) = ppr l pprPat (NPat l (Just _) _) = char '-' <> ppr l -pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k] -pprPat (QuasiQuotePat (HsQuasiQuote name quoter _ quote)) - = char '$' <> brackets (ppr name) <> - ptext (sLit "[:") <> ppr quoter <> ptext (sLit "|") <> - ppr quote <> ptext (sLit "|]") -pprPat (TypePat ty) = ptext (sLit "{|") <> ppr ty <> ptext (sLit "|}") -pprPat (CoPat co pat _) = parens (pprHsWrapper (ppr pat) co) -pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty -pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty +pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k] +pprPat (QuasiQuotePat qq) = ppr qq +pprPat (TypePat ty) = ptext (sLit "{|") <> ppr ty <> ptext (sLit "|}") +pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co +pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty +pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty pprUserCon :: (Outputable con, OutputableBndr id) => con -> HsConPatDetails id -> SDoc pprUserCon c (InfixCon p1 p2) = ppr p1 <+> ppr c <+> ppr p2 pprUserCon c details = ppr c <+> pprConArgs details pprConArgs :: OutputableBndr id => HsConPatDetails id -> SDoc -pprConArgs (PrefixCon pats) = interppSP pats -pprConArgs (InfixCon p1 p2) = interppSP [p1,p2] +pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats) +pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2] pprConArgs (RecCon rpats) = ppr rpats instance (OutputableBndr id, Outputable arg) diff --git a/compiler/hsSyn/HsPat.lhs-boot b/compiler/hsSyn/HsPat.lhs-boot index f5d250e..d5b685c 100644 --- a/compiler/hsSyn/HsPat.lhs-boot +++ b/compiler/hsSyn/HsPat.lhs-boot @@ -1,9 +1,6 @@ \begin{code} module HsPat where -import SrcLoc( Located, SrcSpan ) -import FastString ( FastString ) - -data HsQuasiQuote i = HsQuasiQuote i i SrcSpan FastString +import SrcLoc( Located ) data Pat i type LPat i = Located (Pat i) diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 4e6e5ab..4417751 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -12,6 +12,7 @@ module HsTypes ( HsExplicitForAll(..), HsContext, LHsContext, HsPred(..), LHsPred, + HsQuasiQuote(..), LBangType, BangType, HsBang(..), getBangType, getBangStrictness, @@ -61,6 +62,28 @@ placeHolderType = panic "Evaluated the place holder for a PostTcType" %************************************************************************ %* * + Quasi quotes; used in types and elsewhere +%* * +%************************************************************************ + +\begin{code} +data HsQuasiQuote id = HsQuasiQuote + id -- The quasi-quoter + SrcSpan -- The span of the enclosed string + FastString -- The enclosed string + +instance OutputableBndr id => Outputable (HsQuasiQuote id) where + ppr = ppr_qq + +ppr_qq :: OutputableBndr id => HsQuasiQuote id -> SDoc +ppr_qq (HsQuasiQuote quoter _ quote) = + char '[' <> ppr quoter <> ptext (sLit "|") <> + ppr quote <> ptext (sLit "|]") +\end{code} + + +%************************************************************************ +%* * \subsection{Bang annotations} %* * %************************************************************************ @@ -157,6 +180,7 @@ data HsType name Kind -- A type with a kind signature | HsSpliceTy (HsSplice name) + | HsQuasiQuoteTy (HsQuasiQuote name) | HsDocTy (LHsType name) LHsDocString -- A documented type @@ -374,6 +398,7 @@ ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty) sep [pprHsForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty] ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr ty +ppr_mono_ty _ (HsQuasiQuoteTy qq) = ppr qq ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds ppr_mono_ty _ (HsTyVar name) = ppr name ppr_mono_ty prec (HsFunTy ty1 ty2) = ppr_fun_ty prec ty1 ty2 diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index d629bae..37a7205 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -189,7 +189,7 @@ unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) -- identify the splice mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName -mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualQuasiQuote quoter span quote +mkHsQuasiQuote quoter span quote = HsQuasiQuote quoter span quote unqualQuasiQuote :: RdrName unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index e7c991b..c56b0c1 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -1013,10 +1013,12 @@ atype :: { LHsType RdrName } | '[:' ctype ':]' { LL $ HsPArrTy $2 } | '(' ctype ')' { LL $ HsParTy $2 } | '(' ctype '::' kind ')' { LL $ HsKindSig $2 (unLoc $4) } + | quasiquote { L1 (HsQuasiQuoteTy (unLoc $1)) } | '$(' exp ')' { LL $ HsSpliceTy (mkHsSplice $2 ) } | TH_ID_SPLICE { LL $ HsSpliceTy (mkHsSplice (L1 $ HsVar (mkUnqual varName (getTH_ID_SPLICE $1)))) } -- $x + -- Generics | INTEGER { L1 (HsNumTy (getINTEGER $1)) } @@ -1245,6 +1247,12 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) } ----------------------------------------------------------------------------- -- Expressions +quasiquote :: { Located (HsQuasiQuote RdrName) } + : TH_QUASIQUOTE { let { loc = getLoc $1 + ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1 + ; quoterId = mkUnqual varName quoter } + in L1 (mkHsQuasiQuote quoterId quoteSpan quote) } + exp :: { LHsExpr RdrName } : infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 } | infixexp '-<' exp { LL $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True } @@ -1359,11 +1367,7 @@ aexp2 :: { LHsExpr RdrName } (getTH_ID_SPLICE $1)))) } -- $x | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } -- $( exp ) - | TH_QUASIQUOTE { let { loc = getLoc $1 - ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1 - ; quoterId = mkUnqual varName quoter - } - in sL loc $ HsQuasiQuoteE (mkHsQuasiQuote quoterId quoteSpan quote) } + | TH_VAR_QUOTE qvar { LL $ HsBracket (VarBr (unLoc $2)) } | TH_VAR_QUOTE qcon { LL $ HsBracket (VarBr (unLoc $2)) } | TH_TY_QUOTE tyvar { LL $ HsBracket (VarBr (unLoc $2)) } @@ -1372,8 +1376,8 @@ aexp2 :: { LHsExpr RdrName } | '[t|' ctype '|]' { LL $ HsBracket (TypBr $2) } | '[p|' infixexp '|]' {% checkPattern $2 >>= \p -> return (LL $ HsBracket (PatBr p)) } - | '[d|' cvtopbody '|]' {% checkDecBrGroup $2 >>= \g -> - return (LL $ HsBracket (DecBr g)) } + | '[d|' cvtopbody '|]' { LL $ HsBracket (DecBrL $2) } + | quasiquote { L1 (HsQuasiQuoteE (unLoc $1)) } -- arrow notation extension | '(|' aexp2 cmdargs '|)' { LL $ HsArrForm $2 Nothing (reverse $3) } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index b86068c..e0e8c3c 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -18,7 +18,6 @@ module RdrHsSyn ( cvBindGroup, cvBindsAndSigs, cvTopDecls, - findSplice, checkDecBrGroup, placeHolderPunRhs, -- Stuff to do with Foreign declarations @@ -65,7 +64,7 @@ import PrelNames ( forall_tv_RDR ) import DynFlags import SrcLoc import OrdList ( OrdList, fromOL ) -import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag ) +import Bag ( Bag, emptyBag, consBag, foldrBag ) import Outputable import FastString import Maybes @@ -127,6 +126,7 @@ extract_lty (L loc ty) acc HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc)) HsParTy ty -> extract_lty ty acc HsNumTy _ -> acc + HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables HsSpliceTy {} -> acc -- Type splices mention no type variables HsSpliceTyOut {} -> acc -- Type splices mention no type variables HsKindSig ty _ -> extract_lty ty acc @@ -226,17 +226,14 @@ mkTyFamily loc flavour lhs ksig mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName -- If the user wrote --- $(e) --- then that's the splice, but if she wrote, say, --- f x --- then behave as if she'd written --- $(f x) -mkTopSpliceDecl expr - = SpliceD (SpliceDecl expr') - where - expr' = case expr of - (L _ (HsSpliceE (HsSplice _ expr))) -> expr - _other -> expr +-- [pads| ... ] then return a QuasiQuoteD +-- $(e) then return a SpliceD +-- but if she wrote, say, +-- f x then behave as if she'd written $(f x) +-- ie a SpliceD +mkTopSpliceDecl (L _ (HsQuasiQuoteE qq)) = QuasiQuoteD qq +mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr) +mkTopSpliceDecl other_expr = SpliceD (SpliceDecl other_expr) \end{code} %************************************************************************ @@ -334,80 +331,6 @@ has_args ((L _ (Match args _ _)) : _) = not (null args) -- than pattern bindings (tests/rename/should_fail/rnfail002). \end{code} -\begin{code} -findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a])) -findSplice ds = addl emptyRdrGroup ds - -checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a) --- Turn the body of a [d| ... |] into a HsGroup --- There should be no splices in the "..." -checkDecBrGroup decls - = case addl emptyRdrGroup decls of - (group, Nothing) -> return group - (_, Just (SpliceDecl (L loc _), _)) -> - parseError loc "Declaration splices are not permitted inside declaration brackets" - -- Why not? See Section 7.3 of the TH paper. - -addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a])) - -- This stuff reverses the declarations (again) but it doesn't matter - --- Base cases -addl gp [] = (gp, Nothing) -addl gp (L l d : ds) = add gp l d ds - - -add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a] - -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a])) - -add gp _ (SpliceD e) ds = (gp, Just (e, ds)) - --- Class declarations: pull out the fixity signatures to the top -add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) - l (TyClD d) ds - | isClassDecl d = - let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in - addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds - | otherwise = - addl (gp { hs_tyclds = L l d : ts }) ds - --- Signatures: fixity sigs go a different place than all others -add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds - = addl (gp {hs_fixds = L l f : ts}) ds -add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds - = addl (gp {hs_valds = add_sig (L l d) ts}) ds - --- Value declarations: use add_bind -add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds - = addl (gp { hs_valds = add_bind (L l d) ts }) ds - --- The rest are routine -add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds - = addl (gp { hs_instds = L l d : ts }) ds -add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds - = addl (gp { hs_derivds = L l d : ts }) ds -add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds - = addl (gp { hs_defds = L l d : ts }) ds -add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds - = addl (gp { hs_fords = L l d : ts }) ds -add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds - = addl (gp { hs_warnds = L l d : ts }) ds -add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds - = addl (gp { hs_annds = L l d : ts }) ds -add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds - = addl (gp { hs_ruleds = L l d : ts }) ds - -add gp l (DocD d) ds - = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds - -add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a -add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs -add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind" - -add_sig :: LSig a -> HsValBinds a -> HsValBinds a -add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) -add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig" -\end{code} - %************************************************************************ %* * \subsection[PrefixToHS-utils]{Utilities for conversion} diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index a269dd5..6dc6801 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -20,7 +20,7 @@ module RnExpr ( import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr ) #endif /* GHCI */ -import RnSource ( rnSrcDecls ) +import RnSource ( rnSrcDecls, findSplice ) import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS, rnMatchGroup, makeMiniFixityEnv) import HsSyn @@ -171,10 +171,8 @@ rnExpr (HsSpliceE splice) rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e) #else rnExpr (HsQuasiQuoteE qq) - = rnQuasiQuote qq `thenM` \ (qq', fvs_qq) -> - runQuasiQuoteExpr qq' `thenM` \ (L _ expr') -> - rnExpr expr' `thenM` \ (expr'', fvs_expr) -> - return (expr'', fvs_qq `plusFV` fvs_expr) + = runQuasiQuoteExpr qq `thenM` \ (L _ expr') -> + rnExpr expr' #endif /* GHCI */ --------------------------------------------- @@ -306,7 +304,7 @@ rnExpr e@(ELazyPat {}) = patSynErr e \begin{code} rnExpr (HsProc pat body) = newArrowScope $ - rnPats ProcExpr [pat] $ \ [pat'] -> + rnPat ProcExpr pat $ \ pat' -> rnCmdTop body `thenM` \ (body',fvBody) -> return (HsProc pat' body', fvBody) @@ -597,15 +595,24 @@ rnBracket (VarBr n) = do { name <- lookupOccRn n rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e ; return (ExpBr e', fvs) } -rnBracket (PatBr _) = failWith (ptext (sLit "Tempate Haskell pattern brackets are not supported yet")) +rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs) + rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t ; return (TypBr t', fvs) } where doc = ptext (sLit "In a Template-Haskell quoted type") -rnBracket (DecBr group) - = do { gbl_env <- getGblEnv - ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs } +rnBracket (DecBrL decls) + = do { (group, mb_splice) <- findSplice decls + ; case mb_splice of + Nothing -> return () + Just (SpliceDecl (L loc _), _) + -> setSrcSpan loc $ + addErr (ptext (sLit "Declaration splices are not permitted inside declaration brackets")) + -- Why not? See Section 7.3 of the TH paper. + + ; 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 $ @@ -613,7 +620,9 @@ rnBracket (DecBr group) rnSrcDecls group -- Discard the tcg_env; it contains only extra info about fixity - ; return (DecBr group', allUses (tcg_dus tcg_env)) } + ; return (DecBrG group', allUses (tcg_dus tcg_env)) } + +rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG" \end{code} %************************************************************************ @@ -661,7 +670,7 @@ rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside -- The binders do not scope over the expression ; (bind_op, fvs1) <- lookupSyntaxName bindMName ; (fail_op, fvs2) <- lookupSyntaxName failMName - ; rnPats (StmtCtxt ctxt) [pat] $ \ [pat'] -> do + ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do { (thing, fvs3) <- thing_inside ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs index 5fbe7f7..cb0727b 100644 --- a/compiler/rename/RnHsSyn.lhs +++ b/compiler/rename/RnHsSyn.lhs @@ -70,6 +70,7 @@ extractHsTyNames ty get (HsTyVar tv) = unitNameSet tv get (HsSpliceTy {}) = emptyNameSet -- Type splices mention no type variables get (HsSpliceTyOut {}) = emptyNameSet -- Ditto + get (HsQuasiQuoteTy {}) = emptyNameSet -- Ditto get (HsKindSig ty _) = getl ty get (HsForAllTy _ tvs ctxt ty) = (extractHsCtxtTyNames ctxt diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index c06aa38..bc17495 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -11,7 +11,7 @@ free variables. \begin{code} module RnPat (-- main entry points - rnPats, rnBindPat, + rnPat, rnPats, rnBindPat, NameMaker, applyNameMaker, -- a utility for making names: localRecNameMaker, topRecNameMaker, -- sometimes we want to make local names, @@ -22,9 +22,6 @@ module RnPat (-- main entry points -- Literals rnLit, rnOverLit, - -- Quasiquotation - rnQuasiQuote, - -- Pattern Error messages that are also used elsewhere checkTupSize, patSigErr ) where @@ -233,6 +230,12 @@ rnPats ctxt pats thing_inside where doc_pat = ptext (sLit "In") <+> pprMatchContext ctxt +rnPat :: HsMatchContext Name -- for error messages + -> LPat RdrName + -> (LPat Name -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnPat ctxt pat thing_inside + = rnPats ctxt [pat] (\[pat'] -> thing_inside pat') applyNameMaker :: NameMaker -> Located RdrName -> RnM Name applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newName mk rdr); return n } @@ -363,8 +366,7 @@ rnPatAndThen _ p@(QuasiQuotePat {}) = pprPanic "Can't do QuasiQuotePat without GHCi" (ppr p) #else rnPatAndThen mk (QuasiQuotePat qq) - = do { qq' <- liftCpsFV $ rnQuasiQuote qq - ; pat <- liftCps $ runQuasiQuotePat qq' + = do { pat <- liftCps $ runQuasiQuotePat qq ; L _ pat' <- rnLPatAndThen mk pat ; return pat' } #endif /* GHCI */ @@ -565,27 +567,6 @@ rnOverLit lit@(OverLit {ol_val=val}) %************************************************************************ %* * -\subsubsection{Quasiquotation} -%* * -%************************************************************************ - -See Note [Quasi-quote overview] in TcSplice. - -\begin{code} -rnQuasiQuote :: HsQuasiQuote RdrName -> RnM (HsQuasiQuote Name, FreeVars) -rnQuasiQuote (HsQuasiQuote n quoter quoteSpan quote) - = do { loc <- getSrcSpanM - ; n' <- newLocalBndrRn (L loc n) - ; quoter' <- lookupOccRn quoter - -- If 'quoter' is not in scope, proceed no further - -- Otherwise lookupOcc adds an error messsage and returns - -- an "unubound name", which makes the subsequent attempt to - -- run the quote fail - ; return (HsQuasiQuote n' quoter' quoteSpan quote, unitFV quoter') } -\end{code} - -%************************************************************************ -%* * \subsubsection{Errors} %* * %************************************************************************ diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 6984a4b..c01afec 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -5,12 +5,15 @@ \begin{code} module RnSource ( - rnSrcDecls, addTcgDUs, rnTyClDecls + rnSrcDecls, addTcgDUs, rnTyClDecls, findSplice ) where #include "HsVersions.h" import {-# SOURCE #-} RnExpr( rnLExpr ) +#ifdef GHCI +import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl ) +#endif /* GHCI */ import HsSyn import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc ) @@ -1096,3 +1099,83 @@ rnHsTyVar _doc tyvar = lookupOccRn tyvar \end{code} +%********************************************************* +%* * + findSplice +%* * +%********************************************************* + +This code marches down the declarations, looking for the first +Template Haskell splice. As it does so it + a) groups the declarations into a HsGroup + b) runs any top-level quasi-quotes + +\begin{code} +findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) +findSplice ds = addl emptyRdrGroup ds + +addl :: HsGroup RdrName -> [LHsDecl RdrName] + -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) +-- This stuff reverses the declarations (again) but it doesn't matter +addl gp [] = return (gp, Nothing) +addl gp (L l d : ds) = add gp l d ds + + +add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName] + -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) + +add gp _ (SpliceD e) ds = return (gp, Just (e, ds)) + +#ifndef GHCI +add _ _ (QuasiQuoteD qq) _ + = pprPanic "Can't do QuasiQuote declarations without GHCi" (ppr qq) +#else +add gp _ (QuasiQuoteD qq) ds -- Expand quasiquotes + = do { ds' <- runQuasiQuoteDecl qq + ; addl gp (ds' ++ ds) } +#endif + +-- Class declarations: pull out the fixity signatures to the top +add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds + | isClassDecl d + = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in + addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds + | otherwise + = addl (gp { hs_tyclds = L l d : ts }) ds + +-- Signatures: fixity sigs go a different place than all others +add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds + = addl (gp {hs_fixds = L l f : ts}) ds +add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds + = addl (gp {hs_valds = add_sig (L l d) ts}) ds + +-- Value declarations: use add_bind +add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds + = addl (gp { hs_valds = add_bind (L l d) ts }) ds + +-- The rest are routine +add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds + = addl (gp { hs_instds = L l d : ts }) ds +add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds + = addl (gp { hs_derivds = L l d : ts }) ds +add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds + = addl (gp { hs_defds = L l d : ts }) ds +add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds + = addl (gp { hs_fords = L l d : ts }) ds +add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds + = addl (gp { hs_warnds = L l d : ts }) ds +add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds + = addl (gp { hs_annds = L l d : ts }) ds +add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds + = addl (gp { hs_ruleds = L l d : ts }) ds +add gp l (DocD d) ds + = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds + +add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a +add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs +add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind" + +add_sig :: LSig a -> HsValBinds a -> HsValBinds a +add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) +add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig" +\end{code} \ No newline at end of file diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index cb60b93..ed3e6d0 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -18,6 +18,9 @@ module RnTypes ( ) where import {-# SOURCE #-} RnExpr( rnLExpr ) +#ifdef GHCI +import {-# SOURCE #-} TcSplice( runQuasiQuoteType ) +#endif /* GHCI */ import DynFlags import HsSyn @@ -191,6 +194,12 @@ rnHsType doc (HsDocTy ty haddock_doc) = do haddock_doc' <- rnLHsDoc haddock_doc return (HsDocTy ty' haddock_doc') +#ifndef GHCI +rnHsType _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty) +#else +rnHsType doc (HsQuasiQuoteTy qq) = do { ty <- runQuasiQuoteType qq + ; rnHsType doc (unLoc ty) } +#endif rnHsType _ (HsSpliceTyOut {}) = panic "rnHsType" rnLHsTypes :: SDoc -> [LHsType RdrName] diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 11288dc..64da3c0 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -424,7 +424,8 @@ kc_hs_type (HsSpliceTy sp) = kcSpliceType sp kc_hs_type ty@(HsSpliceTy {}) = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty) #endif -kc_hs_type (HsSpliceTyOut {}) = panic "kc_hs_type" -- Should not happen at all +kc_hs_type (HsSpliceTyOut {}) = panic "kc_hs_type" -- Should not happen at all +kc_hs_type (HsQuasiQuoteTy {}) = panic "kc_hs_type" -- Eliminated by renamer -- remove the doc nodes here, no need to worry about the location since -- its the same for a doc node and it's child type node @@ -627,7 +628,8 @@ ds_type (HsSpliceTyOut kind) = do { kind' <- zonkTcKindToKind kind ; newFlexiTyVarTy kind' } -ds_type (HsSpliceTy {}) = panic "ds_type" +ds_type (HsSpliceTy {}) = panic "ds_type" +ds_type (HsQuasiQuoteTy {}) = panic "ds_type" -- Eliminated by renamer dsHsTypes :: [LHsType Name] -> TcM [Type] dsHsTypes arg_tys = mapM dsHsType arg_tys diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 1dcd819..42e98b2 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -25,7 +25,6 @@ import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) import DynFlags import StaticFlags import HsSyn -import RdrHsSyn import PrelNames import RdrName import TcHsSyn @@ -411,7 +410,7 @@ tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) -- Loops around dealing with each top level inter-splice group -- in turn, until it's dealt with the entire module tc_rn_src_decls boot_details ds - = do { let { (first_group, group_tail) = findSplice ds } ; + = do { (first_group, group_tail) <- findSplice ds ; -- If ds is [] we get ([], Nothing) -- Deal with decls up to, but not including, the first splice @@ -461,7 +460,7 @@ tc_rn_src_decls boot_details ds \begin{code} tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv tcRnHsBootDecls decls - = do { let { (first_group, group_tail) = findSplice decls } + = do { (first_group, group_tail) <- findSplice decls -- Rename the declarations ; (tcg_env, HsGroup { diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 76e0312..8ee43f5 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 @@ -286,8 +289,11 @@ kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind) 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 @@ -300,6 +306,8 @@ 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 +368,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 @@ -548,9 +558,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 +630,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 +640,42 @@ 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 + -- If 'quoter' is not in scope, proceed no further + -- Otherwise lookupOcc adds an error messsage and returns + -- an "unubound name", which makes the subsequent attempt to + -- run the quote fail + -- + -- 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). + + -- 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 diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot index 11606da..32d3e5a 100644 --- a/compiler/typecheck/TcSplice.lhs-boot +++ b/compiler/typecheck/TcSplice.lhs-boot @@ -1,7 +1,7 @@ \begin{code} module TcSplice where import HsSyn ( HsSplice, HsBracket, HsQuasiQuote, - HsExpr, HsType, LHsExpr, LPat, LHsDecl ) + HsExpr, HsType, LHsType, LHsExpr, LPat, LHsDecl ) import Name ( Name ) import RdrName ( RdrName ) import TcRnTypes( TcM, TcId ) @@ -24,7 +24,9 @@ tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] lookupThName_maybe :: TH.Name -> TcM (Maybe Name) -runQuasiQuoteExpr :: HsQuasiQuote Name.Name -> TcM (LHsExpr RdrName) -runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName) +runQuasiQuoteDecl :: HsQuasiQuote RdrName -> TcM [LHsDecl RdrName] +runQuasiQuoteExpr :: HsQuasiQuote RdrName -> TcM (LHsExpr RdrName) +runQuasiQuoteType :: HsQuasiQuote RdrName -> TcM (LHsType RdrName) +runQuasiQuotePat :: HsQuasiQuote RdrName -> TcM (LPat RdrName) runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation \end{code} -- 1.7.10.4