Commit 6f8ff0bb authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

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.
parent 4b357e2a
......@@ -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
......@@ -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,
......
......@@ -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")
......
......@@ -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)
......
\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)
......
......@@ -12,6 +12,7 @@ module HsTypes (
HsExplicitForAll(..),
HsContext, LHsContext,
HsPred(..), LHsPred,
HsQuasiQuote(..),
LBangType, BangType, HsBang(..),
getBangType, getBangStrictness,
......@@ -59,6 +60,28 @@ placeHolderType :: PostTcType -- Used before typechecking
placeHolderType = panic "Evaluated the place holder for a PostTcType"
\end{code}
%************************************************************************
%* *
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
......
......@@ -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"))
......
......@@ -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) }
......
......@@ -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 _), _)) ->