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
This diff is collapsed.
......@@ -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 _), _)) ->
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}
......
......@@ -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) }}
......
......@@ -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
......
......@@ -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 */
......@@ -563,27 +565,6 @@ rnOverLit lit@(OverLit {ol_val=val})
, ol_rebindable = rebindable }, fvs) }
\end{code}
%************************************************************************
%* *
\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}
......
......@@ -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