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"
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 --------------------
-- 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) } ;
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
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 _)
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)
; 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)
; 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)]
= 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))
; 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 _ }))
; (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}))
; 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)
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
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")
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
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
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
conQTyConKey = mkPreludeTyConUnique 110
typeQTyConKey = mkPreludeTyConUnique 111
typeTyConKey = mkPreludeTyConUnique 112
-tyVarBndrTyConKey = mkPreludeTyConUnique 125
decTyConKey = mkPreludeTyConUnique 113
varStrictTypeQTyConKey = mkPreludeTyConUnique 114
strictTypeQTyConKey = mkPreludeTyConUnique 115
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
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
| RuleD (RuleDecl id)
| SpliceD (SpliceDecl id)
| DocD (DocDecl)
+ | QuasiQuoteD (HsQuasiQuote id)
-- NB: all top-level fixity decls are contained EITHER
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,
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
-- 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
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,
= 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
-- 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
matchSeparator PatBindRhs = ptext (sLit "=")
matchSeparator (StmtCtxt _) = ptext (sLit "<-")
matchSeparator RecUpd = panic "unused"
+matchSeparator ThPatQuote = panic "unused"
\end{code}
\begin{code}
<+> 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")
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")
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)
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
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)
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)
HsExplicitForAll(..),
HsContext, LHsContext,
HsPred(..), LHsPred,
+ HsQuasiQuote(..),
LBangType, BangType, HsBang(..),
getBangType, getBangStrictness,
%************************************************************************
%* *
+ 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}
%* *
%************************************************************************
Kind -- A type with a kind signature
| HsSpliceTy (HsSplice name)
+ | HsQuasiQuoteTy (HsQuasiQuote name)
| HsDocTy (LHsType name) LHsDocString -- A documented type
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
-- 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"))
| '[:' 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)) }
-----------------------------------------------------------------------------
-- 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 }
(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)) }
| '[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) }
cvBindGroup,
cvBindsAndSigs,
cvTopDecls,
- findSplice, checkDecBrGroup,
placeHolderPunRhs,
-- Stuff to do with Foreign declarations
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
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
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}
%************************************************************************
-- 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}
import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr )
#endif /* GHCI */
-import RnSource ( rnSrcDecls )
+import RnSource ( rnSrcDecls, findSplice )
import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS,
rnMatchGroup, makeMiniFixityEnv)
import HsSyn
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 */
---------------------------------------------
\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)
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 $
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}
%************************************************************************
-- 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) }}
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
\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,
-- Literals
rnLit, rnOverLit,
- -- Quasiquotation
- rnQuasiQuote,
-
-- Pattern Error messages that are also used elsewhere
checkTupSize, patSigErr
) where
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 }
= 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 */
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
\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 )
\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
) where
import {-# SOURCE #-} RnExpr( rnLExpr )
+#ifdef GHCI
+import {-# SOURCE #-} TcSplice( runQuasiQuoteType )
+#endif /* GHCI */
import DynFlags
import HsSyn
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]
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
= 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
import DynFlags
import StaticFlags
import HsSyn
-import RdrHsSyn
import PrelNames
import RdrName
import TcHsSyn
-- 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
\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 {
module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
lookupThName_maybe,
- runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where
+ runQuasiQuoteExpr, runQuasiQuotePat,
+ runQuasiQuoteDecl, runQuasiQuoteType,
+ runAnnotation ) where
#include "HsVersions.h"
import RnEnv
import RdrName
import RnTypes
+import TcPat
import TcExpr
import TcHsSyn
import TcSimplify
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
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}
= 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
-- 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
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
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 $
; 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
\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 )
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}
projects / ghc-hetmet.git / commitdiff