Skip to content

GitLab

GHC
GHC
Commit db6cb113 authored by gmainland's avatar gmainland
Browse files
Options

Add support for pattern splices.

parent 047b3b8c
Hide whitespace changes
Inline Side-by-side
Showing with 154 additions and 9 deletions
compiler/deSugar/Check.lhs
View file @ db6cb113
......@@ -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"
......
compiler/deSugar/DsArrows.lhs
View file @ db6cb113
......@@ -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]
......
compiler/deSugar/DsMeta.hs
View file @ db6cb113
......@@ -1324,6 +1324,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)
----------------------------------------------------------
......
compiler/deSugar/Match.lhs
View file @ db6cb113
......@@ -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
......
compiler/hsSyn/HsExpr.lhs
View file @ db6cb113
......@@ -348,6 +348,7 @@ tupArgPresent (Missing {}) = False
-- See Note [Pending Splices]
data PendingSplice
= PendingRnExpSplice Name (LHsExpr Name)
| PendingRnPatSplice Name (LHsExpr Name)
| PendingRnTypeSplice Name (LHsExpr Name)
| PendingRnCrossStageSplice Name
| PendingTcSplice Name (LHsExpr Id)
......@@ -367,6 +368,10 @@ splices generated by the renamer:
[|$(f x) + 2|]
* Pending pattern splices (PendingRnPatSplice), e.g.,
[|\ $(f x) -> x|]
* Pending type splices (PendingRnTypeSplice), e.g.,
[|f :: $(g x)|]
......@@ -1424,6 +1429,7 @@ 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 (PendingRnCrossStageSplice name) = ppr name
ppr (PendingTcSplice name expr) = ppr (name, expr)
......@@ -1483,6 +1489,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)
......@@ -1529,6 +1536,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}
......@@ -1548,6 +1556,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")
......@@ -1600,6 +1609,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)
......
compiler/hsSyn/HsExpr.lhs-boot
View file @ db6cb113
......@@ -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)
......
compiler/hsSyn/HsPat.lhs
View file @ db6cb113
......@@ -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)
......
compiler/hsSyn/HsUtils.lhs
View file @ db6cb113
......@@ -588,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
go (QuasiQuotePat _) = bndrs
go (CoPat _ pat _) = go pat
\end{code}
......
compiler/parser/RdrHsSyn.lhs
View file @ db6cb113
......@@ -668,6 +668,7 @@ checkAPat msg loc e0 = do
RecordCon c _ (HsRecFields fs dd)
-> do fs <- mapM (checkPatField msg) fs
return (ConPatIn c (RecCon (HsRecFields fs dd)))
HsSpliceE s -> return (SplicePat s)
HsQuasiQuoteE q -> return (QuasiQuotePat q)
_ -> patFail msg loc e0
......
compiler/rename/RnPat.lhs
View file @ db6cb113
......@@ -18,7 +18,7 @@ free variables.
{-# LANGUAGE ScopedTypeVariables #-}
module RnPat (-- main entry points
rnPat, rnPats, rnBindPat,
rnPat, rnPats, rnBindPat, rnPatAndThen,
NameMaker, applyNameMaker, -- a utility for making names:
localRecNameMaker, topRecNameMaker, -- sometimes we want to make local names,
......@@ -26,8 +26,11 @@ module RnPat (-- main entry points
rnHsRecFields1, HsRecFieldContext(..),
-- CpsRn monad
CpsRn, liftCps,
-- Literals
rnLit, rnOverLit,
rnLit, rnOverLit,
-- Pattern Error messages that are also used elsewhere
checkTupSize, patSigErr
......@@ -37,6 +40,7 @@ module RnPat (-- main entry points
import {-# SOURCE #-} RnExpr ( rnLExpr )
#ifdef GHCI
import {-# SOURCE #-} RnSplice ( rnSplicePat )
import {-# SOURCE #-} TcSplice ( runQuasiQuotePat )
#endif /* GHCI */
......@@ -418,9 +422,15 @@ rnPatAndThen mk (TuplePat pats boxed _)
; return (TuplePat pats' boxed placeHolderType) }
#ifndef GHCI
rnPatAndThen _ p@(SplicePat {})
= pprPanic "Can't do SplicePat without GHCi" (ppr p)
rnPatAndThen _ p@(QuasiQuotePat {})
= pprPanic "Can't do QuasiQuotePat without GHCi" (ppr p)
#else
rnPatAndThen _ (SplicePat splice)
= do { -- XXX How to deal with free variables?
(pat, _) <- liftCps $ rnSplicePat splice
; return pat }
rnPatAndThen mk (QuasiQuotePat qq)
= do { pat <- liftCps $ runQuasiQuotePat qq
-- Wrap the result of the quasi-quoter in parens so that we don't
......
compiler/rename/RnSplice.lhs
View file @ db6cb113
\begin{code}
module RnSplice (
rnSpliceType, rnSpliceExpr,
rnSpliceType, rnSpliceExpr, rnSplicePat,
rnBracket, checkTH,
checkThLocalName
) where
......@@ -16,7 +16,7 @@ import TcRnMonad
#ifdef GHCI
import Control.Monad ( unless, when )
import DynFlags
import DsMeta ( expQTyConName, typeQTyConName )
import DsMeta ( expQTyConName, patQTyConName, typeQTyConName )
import LoadIface ( loadInterfaceForName )
import Module
import RnEnv
......@@ -28,7 +28,7 @@ import TcEnv ( checkWellStaged, tcLookup, tcMetaTy, thTopLevelId )
import {-# SOURCE #-} RnExpr ( rnLExpr )
import {-# SOURCE #-} TcExpr ( tcMonoExpr )
import {-# SOURCE #-} TcSplice ( runMetaE, runMetaT, tcTopSpliceExpr )
import {-# SOURCE #-} TcSplice ( runMetaE, runMetaP, runMetaT, tcTopSpliceExpr )
#endif
\end{code}
......@@ -43,6 +43,9 @@ rnSpliceType e _ = failTH e "splice"
rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars)
rnSpliceExpr e = failTH e "splice"
rnSplicePat :: HsSplice RdrName -> RnM (Pat Name, FreeVars)
rnSplicePat e = failTH e "splice"
failTH :: Outputable a => a -> String -> RnM b
failTH e what -- Raise an error in a stage-1 compiler
= failWithTc (vcat [ptext (sLit "Template Haskell") <+> text what <+>
......@@ -209,6 +212,53 @@ rnSpliceExpr splice@(HsSplice isTypedSplice _ expr)
}
\end{code}
\begin{code}
rnSplicePat :: HsSplice RdrName -> RnM (Pat Name, FreeVars)
rnSplicePat (HsSplice True _ _)
= panic "rnSplicePat: encountered typed pattern splice"
rnSplicePat splice@(HsSplice False _ expr)
= addErrCtxt (exprCtxt (HsSpliceE splice)) $
setSrcSpan (getLoc expr) $ do
{ stage <- getStage
; case stage of
{ Brack isTypedBrack pop_stage ps_var _ ->
do { checkTc (not isTypedBrack) illegalUntypedSplice
; (splice'@(HsSplice _ name expr'), fvs) <- setStage pop_stage $
rnSplice splice
; ps <- readMutVar ps_var
; writeMutVar ps_var (PendingRnPatSplice name expr' : ps)
; return (SplicePat splice', fvs)
}
; _ ->
do { (HsSplice _ _ expr', fvs) <- addErrCtxt (spliceResultDoc expr) $
setStage (Splice False) $
rnSplice splice
-- The splice must have type Pat
; meta_exp_ty <- tcMetaTy patQTyConName
-- Typecheck the expression
; zonked_q_expr <- tcTopSpliceExpr False $
tcMonoExpr expr' meta_exp_ty
-- Run the expression
; pat <- runMetaP zonked_q_expr
; showSplice "pattern" expr' (ppr pat)
; (pat', _) <- addErrCtxt (spliceResultDoc expr) $
checkNoErrs $
rnPat ThPatSplice pat $ \pat' -> return (pat', emptyFVs)
; return (unLoc pat', fvs)
}
}
}
\end{code}
%************************************************************************
%* *
Template Haskell brackets
......
compiler/rename/RnSplice.lhs-boot
View file @ db6cb113
......@@ -13,6 +13,7 @@ rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars)
rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars)
rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars)
rnSplicePat :: HsSplice RdrName -> RnM (Pat Name, FreeVars)
checkTH :: Outputable a => a -> String -> RnM ()
\end{code}
compiler/typecheck/TcHsSyn.lhs
View file @ db6cb113
......@@ -563,6 +563,9 @@ zonkExpr env (HsBracketOut body bs)
zonk_b (PendingRnExpSplice _ e)
= pprPanic "zonkExpr: PendingRnExpSplice" (ppr e)
zonk_b (PendingRnPatSplice _ e)
= pprPanic "zonkExpr: PendingRnPatSplice" (ppr e)
zonk_b (PendingRnCrossStageSplice n)
= pprPanic "zonkExpr: PendingRnCrossStageSplice" (ppr n)
......
compiler/typecheck/TcSplice.lhs
View file @ db6cb113
......@@ -14,7 +14,7 @@ module TcSplice( tcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
runQuasiQuoteExpr, runQuasiQuotePat,
runQuasiQuoteDecl, runQuasiQuoteType,
runAnnotation,
runMetaE,runMetaT, runMetaD ) where
runMetaE, runMetaP, runMetaT, runMetaD ) where
#include "HsVersions.h"
......@@ -288,6 +288,7 @@ The predicate we use is TcEnv.thTopLevelId.
tcBracket :: HsBracket Name -> [PendingSplice] -> TcRhoType -> TcM (HsExpr TcId)
tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId)
tcSplicePat :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId)
tcSpliceType :: HsSplice Name -> FreeVars -> TcM (TcType, TcKind)
-- None of these functions add constraints to the LIE
......@@ -303,6 +304,7 @@ runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
#ifndef GHCI
tcBracket x _ _ = pprPanic "Cant do tcBracket without GHCi" (ppr x)
tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
tcSplicePat e = pprPanic "Cant do tcSplicePat without GHCi" (ppr e)
tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
tcSpliceType x fvs = pprPanic "Cant do kcSpliceType without GHCi" (ppr x)
......@@ -394,6 +396,12 @@ tcPendingSplice (PendingRnExpSplice n expr)
; return ()
}
tcPendingSplice (PendingRnPatSplice n expr)
= do { res_ty <- newFlexiTyVarTy openTypeKind
; _ <- tcSplicePat (HsSplice False n expr) res_ty
; return ()
}
tcPendingSplice (PendingRnCrossStageSplice n)
= do { res_ty <- newFlexiTyVarTy openTypeKind
; _ <- tcCheckId n res_ty
......@@ -493,7 +501,49 @@ tcTopSplice expr res_ty
-- checkNoErrs: see Note [Renamer errors]
; exp4 <- tcMonoExpr exp3 res_ty
; return (unLoc exp4) } }
\end{code}
%************************************************************************
%* *
\subsection{Splicing a pattern}
%* *
%************************************************************************
\begin{code}
tcSplicePat splice@(HsSplice True _ _) _
= pprPanic "tcSplicePat: encountered typed pattern splice" (ppr splice)
tcSplicePat splice@(HsSplice False name expr) _
= addErrCtxt (spliceCtxtDoc splice) $
setSrcSpan (getLoc expr) $ do
{ stage <- getStage
; case stage of
{ Splice {} -> pprPanic "tcSplicePat: encountered unexpanded top-level untyped splice" (ppr splice)
; Comp -> pprPanic "tcSplicePat: encountered unexpanded top-level untyped splice" (ppr splice)
; Brack isTypedBrack pop_stage ps_var lie_var -> do
{ checkTc (not isTypedBrack) illegalUntypedSplice
; meta_exp_ty <- tcMetaTy patQTyConName
; expr' <- setStage pop_stage $
setConstraintVar lie_var $
tcMonoExpr expr meta_exp_ty
; ps <- readMutVar ps_var
; writeMutVar ps_var (PendingTcSplice name expr' : ps)
-- The returned expression is ignored
; return (panic "tcSplicePat")
}}}
\end{code}
%************************************************************************
%* *
\subsection{Error messages}
%* *
%************************************************************************
\begin{code}
quotationCtxtDoc :: HsBracket Name -> SDoc
quotationCtxtDoc br_body
= hang (ptext (sLit "In the Template Haskell quotation"))
......@@ -822,6 +872,10 @@ runMetaE :: LHsExpr Id -- Of type (Q Exp)
-> TcM (LHsExpr RdrName)
runMetaE = runMetaQ exprMetaOps
runMetaP :: LHsExpr Id -- Of type (Q Pat)
-> TcM (LPat RdrName)
runMetaP = runMetaQ patMetaOps
runMetaT :: LHsExpr Id -- Of type (Q Type)
-> TcM (LHsType RdrName)
runMetaT = runMetaQ typeMetaOps
......
compiler/typecheck/TcSplice.lhs-boot
View file @ db6cb113
......@@ -36,6 +36,7 @@ runQuasiQuotePat :: HsQuasiQuote RdrName -> TcM (LPat RdrName)
runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
runMetaE :: LHsExpr Id -> TcM (LHsExpr RdrName)
runMetaP :: LHsExpr Id -> TcM (LPat RdrName)
runMetaT :: LHsExpr Id -> TcM (LHsType RdrName)
runMetaD :: LHsExpr Id -> TcM [LHsDecl RdrName]
\end{code}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment