Commit e7394be2 authored by gmainlan@microsoft.com's avatar gmainlan@microsoft.com
Browse files

Merge New Template Haskell branch.

parents 17457791 5e1fda81
......@@ -39,7 +39,8 @@ module RdrName (
-- * Local mapping of 'RdrName' to 'Name.Name'
LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList,
lookupLocalRdrEnv, lookupLocalRdrOcc, elemLocalRdrEnv, inLocalRdrEnvScope,
lookupLocalRdrEnv, lookupLocalRdrThLvl, lookupLocalRdrOcc,
elemLocalRdrEnv, inLocalRdrEnvScope,
localRdrEnvElts, delLocalRdrEnvList,
-- * Global mapping of 'RdrName' to 'GlobalRdrElt's
......@@ -328,40 +329,51 @@ instance Ord RdrName where
-- It is keyed by OccName, because we never use it for qualified names
-- We keep the current mapping, *and* the set of all Names in scope
-- Reason: see Note [Splicing Exact Names] in RnEnv
type LocalRdrEnv = (OccEnv Name, NameSet)
type ThLevel = Int
type LocalRdrEnv = (OccEnv Name, OccEnv ThLevel, NameSet)
emptyLocalRdrEnv :: LocalRdrEnv
emptyLocalRdrEnv = (emptyOccEnv, emptyNameSet)
extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv
extendLocalRdrEnv (env, ns) name
= (extendOccEnv env (nameOccName name) name, addOneToNameSet ns name)
extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv
extendLocalRdrEnvList (env, ns) names
= (extendOccEnvList env [(nameOccName n, n) | n <- names], addListToNameSet ns names)
emptyLocalRdrEnv = (emptyOccEnv, emptyOccEnv, emptyNameSet)
extendLocalRdrEnv :: LocalRdrEnv -> ThLevel -> Name -> LocalRdrEnv
extendLocalRdrEnv (env, thenv, ns) thlvl name
= ( extendOccEnv env (nameOccName name) name
, extendOccEnv thenv (nameOccName name) thlvl
, addOneToNameSet ns name
)
extendLocalRdrEnvList :: LocalRdrEnv -> ThLevel -> [Name] -> LocalRdrEnv
extendLocalRdrEnvList (env, thenv, ns) thlvl names
= ( extendOccEnvList env [(nameOccName n, n) | n <- names]
, extendOccEnvList thenv [(nameOccName n, thlvl) | n <- names]
, addListToNameSet ns names
)
lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name
lookupLocalRdrEnv (env, _) (Unqual occ) = lookupOccEnv env occ
lookupLocalRdrEnv _ _ = Nothing
lookupLocalRdrEnv (env, _, _) (Unqual occ) = lookupOccEnv env occ
lookupLocalRdrEnv _ _ = Nothing
lookupLocalRdrThLvl :: LocalRdrEnv -> RdrName -> Maybe ThLevel
lookupLocalRdrThLvl (_, thenv, _) (Unqual occ) = lookupOccEnv thenv occ
lookupLocalRdrThLvl _ _ = Nothing
lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name
lookupLocalRdrOcc (env, _) occ = lookupOccEnv env occ
lookupLocalRdrOcc (env, _, _) occ = lookupOccEnv env occ
elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool
elemLocalRdrEnv rdr_name (env, _)
elemLocalRdrEnv rdr_name (env, _, _)
| isUnqual rdr_name = rdrNameOcc rdr_name `elemOccEnv` env
| otherwise = False
localRdrEnvElts :: LocalRdrEnv -> [Name]
localRdrEnvElts (env, _) = occEnvElts env
localRdrEnvElts (env, _, _) = occEnvElts env
inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool
-- This is the point of the NameSet
inLocalRdrEnvScope name (_, ns) = name `elemNameSet` ns
inLocalRdrEnvScope name (_, _, ns) = name `elemNameSet` ns
delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv
delLocalRdrEnvList (env, ns) occs = (delListFromOccEnv env occs, ns)
delLocalRdrEnvList (env, thenv, ns) occs = (delListFromOccEnv env occs, delListFromOccEnv thenv occs, ns)
\end{code}
%************************************************************************
......
......@@ -152,6 +152,7 @@ untidy b (L loc p) = L loc (untidy' b p)
untidy' _ (BangPat {}) = panic "Check.untidy: BangPat"
untidy' _ (ConPatOut {}) = panic "Check.untidy: ConPatOut"
untidy' _ (ViewPat {}) = panic "Check.untidy: ViewPat"
untidy' _ (SplicePat {}) = panic "Check.untidy: SplicePat"
untidy' _ (QuasiQuotePat {}) = panic "Check.untidy: QuasiQuotePat"
untidy' _ (NPat {}) = panic "Check.untidy: NPat"
untidy' _ (NPlusKPat {}) = panic "Check.untidy: NPlusKPat"
......@@ -713,6 +714,7 @@ tidy_pat (NPat lit mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq
tidy_pat (LitPat lit) = tidy_lit_pat lit
tidy_pat (ConPatIn {}) = panic "Check.tidy_pat: ConPatIn"
tidy_pat (SplicePat {}) = panic "Check.tidy_pat: SplicePat"
tidy_pat (QuasiQuotePat {}) = panic "Check.tidy_pat: QuasiQuotePat"
tidy_pat (SigPatIn {}) = panic "Check.tidy_pat: SigPatIn"
......
......@@ -1171,6 +1171,7 @@ collectl (L _ pat) bndrs
go (SigPatOut pat _) = collectl pat bndrs
go (CoPat _ pat _) = collectl (noLoc pat) bndrs
go (ViewPat _ pat _) = collectl pat bndrs
go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p)
go p@(QuasiQuotePat {}) = pprPanic "collectl/go" (ppr p)
collectEvBinders :: TcEvBinds -> [Id]
......
......@@ -556,6 +556,7 @@ Here is where we desugar the Template Haskell brackets and escapes
\begin{code}
-- Template Haskell stuff
dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"
#ifdef GHCI
dsExpr (HsBracketOut x ps) = dsBracket x ps
#else
......
......@@ -18,7 +18,9 @@ module DsMeta( dsBracket,
liftName, liftStringName, expQTyConName, patQTyConName,
decQTyConName, decsQTyConName, typeQTyConName,
decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
quoteExpName, quotePatName, quoteDecName, quoteTypeName
quoteExpName, quotePatName, quoteDecName, quoteTypeName,
tExpTyConName, tExpDataConName, unTypeName, unTypeQName,
unsafeTExpCoerceName
) where
#include "HsVersions.h"
......@@ -73,7 +75,7 @@ dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
dsBracket brack splices
= dsExtendMetaEnv new_bit (do_brack brack)
where
new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]
new_bit = mkNameEnv [(n, Splice (unLoc e)) | PendingTcSplice 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 }
......@@ -81,6 +83,7 @@ dsBracket brack splices
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"
do_brack (TExpBr e) = do { MkC e1 <- repLE e ; return e1 }
{- -------------- Examples --------------------
......@@ -900,7 +903,7 @@ repRole (L _ Nothing) = rep2 inferRName []
repSplice :: HsSplice Name -> DsM (Core a)
-- See Note [How brackets and nested splices are handled] in TcSplice
-- We return a CoreExpr of any old type; the context should know
repSplice (HsSplice n _)
repSplice (HsSplice _ n _)
= do { mb_val <- dsLookupMetaEnv n
; case mb_val of
Just (Splice e) -> do { e' <- dsExpr e
......@@ -1322,6 +1325,8 @@ repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
-- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
-- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
repP (SplicePat splice) = repSplice splice
repP other = notHandled "Exotic pattern" (ppr other)
----------------------------------------------------------
......@@ -2019,6 +2024,9 @@ templateHaskellNames = [
returnQName, bindQName, sequenceQName, newNameName, liftName,
mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
liftStringName,
unTypeName,
unTypeQName,
unsafeTExpCoerceName,
-- Lit
charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
......@@ -2094,6 +2102,8 @@ templateHaskellNames = [
conLikeDataConName, funLikeDataConName,
-- Phases
allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName,
-- TExp
tExpDataConName,
-- RuleBndr
ruleVarName, typedRuleVarName,
-- FunDep
......@@ -2111,7 +2121,7 @@ templateHaskellNames = [
typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,
roleTyConName,
roleTyConName, tExpTyConName,
-- Quasiquoting
quoteDecName, quoteTypeName, quoteExpName, quotePatName]
......@@ -2136,7 +2146,7 @@ qqFun = mk_known_key_name OccName.varName qqLib
qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
predTyConName :: Name
predTyConName, tExpTyConName :: Name
qTyConName = thTc (fsLit "Q") qTyConKey
nameTyConName = thTc (fsLit "Name") nameTyConKey
fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
......@@ -2150,10 +2160,12 @@ matchTyConName = thTc (fsLit "Match") matchTyConKey
clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey
predTyConName = thTc (fsLit "Pred") predTyConKey
tExpTyConName = thTc (fsLit "TExp") tExpTyConKey
returnQName, bindQName, sequenceQName, newNameName, liftName,
mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
mkNameLName, liftStringName :: Name
mkNameLName, liftStringName, unTypeName, unTypeQName,
unsafeTExpCoerceName :: Name
returnQName = thFun (fsLit "returnQ") returnQIdKey
bindQName = thFun (fsLit "bindQ") bindQIdKey
sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
......@@ -2165,6 +2177,9 @@ mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey
mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey
mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey
unTypeName = thFun (fsLit "unType") unTypeIdKey
unTypeQName = thFun (fsLit "unTypeQ") unTypeQIdKey
unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey
-------------------- TH.Lib -----------------------
......@@ -2409,6 +2424,10 @@ allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey
fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey
beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey
-- newtype TExp a = ...
tExpDataConName :: Name
tExpDataConName = thCon (fsLit "TExp") tExpDataConKey
-- data RuleBndr = ...
ruleVarName, typedRuleVarName :: Name
ruleVarName = libFun (fsLit ("ruleVar")) ruleVarIdKey
......@@ -2467,7 +2486,7 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey,
roleTyConKey :: Unique
roleTyConKey, tExpTyConKey :: Unique
expTyConKey = mkPreludeTyConUnique 200
matchTyConKey = mkPreludeTyConUnique 201
clauseTyConKey = mkPreludeTyConUnique 202
......@@ -2498,13 +2517,14 @@ decsQTyConKey = mkPreludeTyConUnique 226
ruleBndrQTyConKey = mkPreludeTyConUnique 227
tySynEqnQTyConKey = mkPreludeTyConUnique 228
roleTyConKey = mkPreludeTyConUnique 229
tExpTyConKey = mkPreludeTyConUnique 230
-- IdUniques available: 200-499
-- If you want to change this, make sure you check in PrelNames
returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
mkNameLIdKey :: Unique
mkNameLIdKey, unTypeIdKey, unTypeQIdKey, unsafeTExpCoerceIdKey :: Unique
returnQIdKey = mkPreludeMiscIdUnique 200
bindQIdKey = mkPreludeMiscIdUnique 201
sequenceQIdKey = mkPreludeMiscIdUnique 202
......@@ -2515,6 +2535,9 @@ mkNameG_vIdKey = mkPreludeMiscIdUnique 206
mkNameG_dIdKey = mkPreludeMiscIdUnique 207
mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
mkNameLIdKey = mkPreludeMiscIdUnique 209
unTypeIdKey = mkPreludeMiscIdUnique 210
unTypeQIdKey = mkPreludeMiscIdUnique 211
unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 212
-- data Lit = ...
......@@ -2759,6 +2782,10 @@ allPhasesDataConKey = mkPreludeDataConUnique 45
fromPhaseDataConKey = mkPreludeDataConUnique 46
beforePhaseDataConKey = mkPreludeDataConUnique 47
-- newtype TExp a = ...
tExpDataConKey :: Unique
tExpDataConKey = mkPreludeDataConUnique 48
-- data FunDep = ...
funDepIdKey :: Unique
funDepIdKey = mkPreludeMiscIdUnique 419
......
......@@ -90,6 +90,7 @@ matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs
incomplete_flag RecUpd = wopt Opt_WarnIncompletePatternsRecUpd dflags
incomplete_flag ThPatSplice = False
incomplete_flag ThPatQuote = False
incomplete_flag (StmtCtxt {}) = False -- Don't warn about incomplete patterns
-- in list comprehensions, pattern guards
......
......@@ -325,6 +325,7 @@ Library
RnNames
RnPat
RnSource
RnSplice
RnTypes
CoreMonad
CSE
......
......@@ -42,8 +42,8 @@ module HsDecls (
lvectDeclName, lvectInstDecl,
-- ** @default@ declarations
DefaultDecl(..), LDefaultDecl,
-- ** Top-level template haskell splice
SpliceDecl(..),
-- ** Template haskell declaration splice
SpliceDecl(..), LSpliceDecl,
-- ** Foreign function interface declarations
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
noForeignImportCoercionYet, noForeignExportCoercionYet,
......@@ -67,7 +67,7 @@ module HsDecls (
) where
-- friends:
import {-# SOURCE #-} HsExpr( LHsExpr, HsExpr, pprExpr )
import {-# SOURCE #-} HsExpr( LHsExpr, HsExpr, HsSplice, pprExpr )
-- Because Expr imports Decls via HsBracket
import HsBinds
......@@ -142,6 +142,7 @@ data HsDecl id
data HsGroup id
= HsGroup {
hs_valds :: HsValBinds id,
hs_splcds :: [LSpliceDecl id],
hs_tyclds :: [TyClGroup id],
-- A list of mutually-recursive groups
......@@ -177,12 +178,14 @@ emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [],
hs_fixds = [], hs_defds = [], hs_annds = [],
hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [],
hs_valds = error "emptyGroup hs_valds: Can't happen",
hs_splcds = [],
hs_docs = [] }
appendGroups :: HsGroup a -> HsGroup a -> HsGroup a
appendGroups
HsGroup {
hs_valds = val_groups1,
hs_splcds = spliceds1,
hs_tyclds = tyclds1,
hs_instds = instds1,
hs_derivds = derivds1,
......@@ -196,6 +199,7 @@ appendGroups
hs_docs = docs1 }
HsGroup {
hs_valds = val_groups2,
hs_splcds = spliceds2,
hs_tyclds = tyclds2,
hs_instds = instds2,
hs_derivds = derivds2,
......@@ -210,6 +214,7 @@ appendGroups
=
HsGroup {
hs_valds = val_groups1 `plusHsValBinds` val_groups2,
hs_splcds = spliceds1 ++ spliceds2,
hs_tyclds = tyclds1 ++ tyclds2,
hs_instds = instds1 ++ instds2,
hs_derivds = derivds1 ++ derivds2,
......@@ -276,15 +281,16 @@ instance OutputableBndr name => Outputable (HsGroup name) where
vcat_mb gap (Nothing : ds) = vcat_mb gap ds
vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds
type LSpliceDecl name = Located (SpliceDecl name)
data SpliceDecl id
= SpliceDecl -- Top level splice
(Located (HsExpr id))
(Located (HsSplice id))
HsExplicitFlag -- Explicit <=> $(f x y)
-- Implicit <=> f x y, i.e. a naked top level expression
deriving (Data, Typeable)
instance OutputableBndr name => Outputable (SpliceDecl name) where
ppr (SpliceDecl e _) = ptext (sLit "$") <> parens (pprExpr (unLoc e))
ppr (SpliceDecl e _) = ppr e
\end{code}
......@@ -1436,4 +1442,4 @@ instance OutputableBndr name => Outputable (RoleAnnotDecl name) where
roleAnnotDeclName :: RoleAnnotDecl name -> name
roleAnnotDeclName (RoleAnnotDecl (L _ name) _) = name
\end{code}
\ No newline at end of file
\end{code}
......@@ -246,6 +246,13 @@ data HsExpr id
| HsBracket (HsBracket id)
-- See Note [Pending Renamer Splices]
| HsRnBracketOut (HsBracket Name) -- Output of the renamer is
-- the *original*
[PendingSplice] -- renamed expression, plus
-- _renamed_ splices to be
-- type checked
| HsBracketOut (HsBracket Name) -- Output of the type checker is
-- the *original*
[PendingSplice] -- renamed expression, plus
......@@ -338,12 +345,56 @@ tupArgPresent :: HsTupArg id -> Bool
tupArgPresent (Present {}) = True
tupArgPresent (Missing {}) = False
-- | Typechecked splices, waiting to be
-- pasted back in by the desugarer
type PendingSplice = (Name, LHsExpr Id)
-- See Note [Pending Splices]
data PendingSplice
= PendingRnExpSplice Name (LHsExpr Name)
| PendingRnPatSplice Name (LHsExpr Name)
| PendingRnTypeSplice Name (LHsExpr Name)
| PendingRnDeclSplice Name (LHsExpr Name)
| PendingRnCrossStageSplice Name
| PendingTcSplice Name (LHsExpr Id)
deriving (Data, Typeable)
\end{code}
Note [Pending Splices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Now that untyped brackets are not type checked, we need a mechanism to ensure
that splices contained in untyped brackets *are* type checked. Therefore the
renamer now renames every HsBracket into a HsRnBracketOut, which contains the
splices that need to be type checked. There are three varieties of pending
splices generated by the renamer:
* Pending expression splices (PendingRnExpSplice), e.g.,
[|$(f x) + 2|]
* Pending pattern splices (PendingRnPatSplice), e.g.,
[|\ $(f x) -> x|]
* Pending type splices (PendingRnTypeSplice), e.g.,
[|f :: $(g x)|]
* Pending cross-stage splices (PendingRnCrossStageSplice), e.g.,
\x -> [| x |]
There is a fourth variety of pending splice, which is generated by the type
checker:
* Pending *typed* expression splices, (PendingTcSplice), e.g.,
[||1 + $$(f 2)||]
It would be possible to eliminate HsRnBracketOut and use HsBracketOut for the
output of the renamer. However, when pretty printing the output of the renamer,
e.g., in a type error message, we *do not* want to print out the pending
splices. In contrast, when pretty printing the output of the type checker, we
*do* want to print the pending splices. So splitting them up seems to make
sense, although I hate to add another constructor to HsExpr.
Note [Parens in HsSyn]
~~~~~~~~~~~~~~~~~~~~~~
HsPar (and ParPat in patterns, HsParTy in types) is used as follows
......@@ -548,11 +599,12 @@ ppr_expr (HsSCC lbl expr)
ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn
ppr_expr (HsType id) = ppr id
ppr_expr (HsSpliceE s) = pprSplice s
ppr_expr (HsBracket b) = pprHsBracket b
ppr_expr (HsBracketOut e []) = ppr e
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext (sLit "pending") <+> ppr ps
ppr_expr (HsQuasiQuoteE qq) = ppr qq
ppr_expr (HsSpliceE s) = pprSplice s
ppr_expr (HsBracket b) = pprHsBracket b
ppr_expr (HsRnBracketOut e _) = ppr e
ppr_expr (HsBracketOut e []) = ppr e
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext (sLit "pending") <+> ppr ps
ppr_expr (HsQuasiQuoteE qq) = ppr qq
ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
= hsep [ptext (sLit "proc"), ppr pat, ptext (sLit "->"), ppr cmd]
......@@ -634,6 +686,7 @@ hsExprNeedsParens (ExplicitList {}) = False
hsExprNeedsParens (ExplicitPArr {}) = False
hsExprNeedsParens (HsPar {}) = False
hsExprNeedsParens (HsBracket {}) = False
hsExprNeedsParens (HsRnBracketOut {}) = False
hsExprNeedsParens (HsBracketOut _ []) = False
hsExprNeedsParens (HsDo sc _ _)
| isListCompExpr sc = False
......@@ -1318,6 +1371,7 @@ pprQuals quals = interpp'SP quals
\begin{code}
data HsSplice id = HsSplice -- $z or $(f 4)
Bool -- True if typed, False if untyped
id -- The id is just a unique name to
(LHsExpr id) -- identify this splice point
deriving (Data, Typeable)
......@@ -1326,8 +1380,9 @@ instance OutputableBndr id => Outputable (HsSplice id) where
ppr = pprSplice
pprSplice :: OutputableBndr id => HsSplice id -> SDoc
pprSplice (HsSplice n e)
= char '$' <> ifPprDebug (brackets (ppr n)) <> eDoc
pprSplice (HsSplice isTyped n e)
= (if isTyped then ptext (sLit "$$") else char '$')
<> ifPprDebug (brackets (ppr n)) <> eDoc
where
-- We use pprLExpr to match pprParendExpr:
-- Using pprLExpr makes sure that we go 'deeper'
......@@ -1345,8 +1400,13 @@ data HsBracket id = ExpBr (LHsExpr id) -- [| expr |]
| TypBr (LHsType id) -- [t| type |]
| VarBr Bool id -- True: 'x, False: ''T
-- (The Bool flag is used only in pprHsBracket)
| TExpBr (LHsExpr id) -- [|| expr ||]
deriving (Data, Typeable)
isTypedBracket :: HsBracket id -> Bool
isTypedBracket (TExpBr {}) = True
isTypedBracket _ = False
instance OutputableBndr id => Outputable (HsBracket id) where
ppr = pprHsBracket
......@@ -1359,10 +1419,22 @@ pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds))
pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t)
pprHsBracket (VarBr True n) = char '\'' <> ppr n
pprHsBracket (VarBr False n) = ptext (sLit "''") <> ppr n
pprHsBracket (TExpBr e) = thTyBrackets (ppr e)
thBrackets :: SDoc -> SDoc -> SDoc
thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+>
pp_body <+> ptext (sLit "|]")
thTyBrackets :: SDoc -> SDoc
thTyBrackets pp_body = ptext (sLit "[||") <+> pp_body <+> ptext (sLit "||]")
instance Outputable PendingSplice where
ppr (PendingRnExpSplice name expr) = ppr (name, expr)
ppr (PendingRnPatSplice name expr) = ppr (name, expr)
ppr (PendingRnTypeSplice name expr) = ppr (name, expr)
ppr (PendingRnDeclSplice name expr) = ppr (name, expr)
ppr (PendingRnCrossStageSplice name) = ppr name
ppr (PendingTcSplice name expr) = ppr (name, expr)
\end{code}
%************************************************************************
......@@ -1419,6 +1491,7 @@ data HsMatchContext id -- Context of a Match
| StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt, list comprehension,
-- pattern guard, etc
| ThPatSplice -- A Template Haskell pattern splice
| ThPatQuote -- A Template Haskell pattern quotation [p| (a,b) |]
deriving (Data, Typeable)
......@@ -1465,6 +1538,7 @@ matchSeparator ProcExpr = ptext (sLit "->")
matchSeparator PatBindRhs = ptext (sLit "=")
matchSeparator (StmtCtxt _) = ptext (sLit "<-")
matchSeparator RecUpd = panic "unused"
matchSeparator ThPatSplice = panic "unused"
matchSeparator ThPatQuote = panic "unused"
\end{code}
......@@ -1484,6 +1558,7 @@ pprMatchContextNoun (FunRhs fun _) = ptext (sLit "equation for")
pprMatchContextNoun CaseAlt = ptext (sLit "case alternative")
pprMatchContextNoun IfAlt = ptext (sLit "multi-way if alternative")
pprMatchContextNoun RecUpd = ptext (sLit "record-update construct")
pprMatchContextNoun ThPatSplice = ptext (sLit "Template Haskell pattern splice")
pprMatchContextNoun ThPatQuote = ptext (sLit "Template Haskell pattern quotation")
pprMatchContextNoun PatBindRhs = ptext (sLit "pattern binding")
pprMatchContextNoun LambdaExpr = ptext (sLit "lambda abstraction")
......@@ -1536,6 +1611,7 @@ matchContextErrString PatBindRhs = ptext (sLit "pattern binding"
matchContextErrString RecUpd = ptext (sLit "record update")
matchContextErrString LambdaExpr = ptext (sLit "lambda")
matchContextErrString ProcExpr = ptext (sLit "proc")
matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime
matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime
matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)
......
......@@ -33,6 +33,7 @@ instance Data i => Data (HsCmd i)
instance (Data i, Data body) => Data (MatchGroup i body)
instance (Data i, Data body) => Data (GRHSs i body)
instance OutputableBndr id => Outputable (HsSplice id)
instance OutputableBndr id => Outputable (HsExpr id)
instance OutputableBndr id => Outputable (HsCmd id)
......
......@@ -23,7 +23,7 @@ module HsPat (
pprParendLPat
) where
import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, pprLExpr)
import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr)
-- friends:
import HsBinds
......@@ -114,6 +114,9 @@ data Pat id
-- (= the argument type of the view function)
-- for hsPatType.
------------ Pattern splices ---------------
| SplicePat (HsSplice id)
------------ Quasiquoted patterns ---------------
-- See Note [Quasi-quote overview] in TcSplice
| QuasiQuotePat (HsQuasiQuote id)
......@@ -268,6 +271,7 @@ 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 (SplicePat splice) = ppr splice
pprPat (QuasiQuotePat qq) = ppr qq
pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co
pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
......@@ -419,13 +423,16 @@ isIrrefutableHsPat pat
go1 (NPat {}) = False
go1 (NPlusKPat {}) = False
go1 (QuasiQuotePat {}) = urk pat -- Gotten rid of by renamer, before
-- isIrrefutablePat is called
-- Both should be gotten rid of by renamer before
-- isIrrefutablePat is called
go1 (SplicePat {}) = urk pat
go1 (QuasiQuotePat {}) = urk pat
urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat)
hsPatNeedsParens :: Pat a -> Bool
hsPatNeedsParens (NPlusKPat {}) = True
hsPatNeedsParens (SplicePat {}) = False
hsPatNeedsParens (QuasiQuotePat {}) = True
hsPatNeedsParens (ConPatIn _ ds) = conPatNeedsParens ds
hsPatNeedsParens p@(ConPatOut {}) = conPatNeedsParens (pat_args p)
......
......@@ -54,7 +54,7 @@ module HsUtils(
emptyRecStmt, mkRecStmt,
-- Template Haskell
unqualSplice, mkHsSpliceTy, mkHsSplice, mkHsQuasiQuote, unqualQuasiQuote,
unqualSplice, mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkHsQuasiQuote, unqualQuasiQuote,
-- Flags
noRebindableInfo,
......@@ -246,11 +246,17 @@ mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName
mkHsSplice e = HsSplice unqualSplice e
mkHsSplice :: Bool -> LHsExpr RdrName -> HsSplice RdrName
mkHsSplice isTyped e = HsSplice isTyped unqualSplice e
mkHsSpliceE :: LHsExpr RdrName -> HsExpr RdrName
mkHsSpliceE e = HsSpliceE (mkHsSplice False e)
mkHsSpliceTE :: LHsExpr RdrName -> HsExpr RdrName
mkHsSpliceTE e = HsSpliceE (mkHsSplice True e)
mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) emptyFVs placeHolderKind
mkHsSpliceTy e = HsSpliceTy (mkHsSplice False e) emptyFVs placeHolderKind
unqualSplice :: RdrName
unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
......@@ -582,6 +588,7 @@ collect_lpat (L _ pat) bndrs
go (SigPatIn pat _) = collect_lpat pat bndrs
go (SigPatOut pat _) = collect_lpat pat bndrs
go (SplicePat _) = bndrs