Commit db6cb113 authored by gmainland's avatar gmainland

Add support for pattern splices.

parent 047b3b8c
...@@ -152,6 +152,7 @@ untidy b (L loc p) = L loc (untidy' b p) ...@@ -152,6 +152,7 @@ untidy b (L loc p) = L loc (untidy' b p)
untidy' _ (BangPat {}) = panic "Check.untidy: BangPat" untidy' _ (BangPat {}) = panic "Check.untidy: BangPat"
untidy' _ (ConPatOut {}) = panic "Check.untidy: ConPatOut" untidy' _ (ConPatOut {}) = panic "Check.untidy: ConPatOut"
untidy' _ (ViewPat {}) = panic "Check.untidy: ViewPat" untidy' _ (ViewPat {}) = panic "Check.untidy: ViewPat"
untidy' _ (SplicePat {}) = panic "Check.untidy: SplicePat"
untidy' _ (QuasiQuotePat {}) = panic "Check.untidy: QuasiQuotePat" untidy' _ (QuasiQuotePat {}) = panic "Check.untidy: QuasiQuotePat"
untidy' _ (NPat {}) = panic "Check.untidy: NPat" untidy' _ (NPat {}) = panic "Check.untidy: NPat"
untidy' _ (NPlusKPat {}) = panic "Check.untidy: NPlusKPat" 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 ...@@ -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 (LitPat lit) = tidy_lit_pat lit
tidy_pat (ConPatIn {}) = panic "Check.tidy_pat: ConPatIn" 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 (QuasiQuotePat {}) = panic "Check.tidy_pat: QuasiQuotePat"
tidy_pat (SigPatIn {}) = panic "Check.tidy_pat: SigPatIn" tidy_pat (SigPatIn {}) = panic "Check.tidy_pat: SigPatIn"
......
...@@ -1171,6 +1171,7 @@ collectl (L _ pat) bndrs ...@@ -1171,6 +1171,7 @@ collectl (L _ pat) bndrs
go (SigPatOut pat _) = collectl pat bndrs go (SigPatOut pat _) = collectl pat bndrs
go (CoPat _ pat _) = collectl (noLoc pat) bndrs go (CoPat _ pat _) = collectl (noLoc pat) bndrs
go (ViewPat _ pat _) = collectl pat bndrs go (ViewPat _ pat _) = collectl pat bndrs
go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p)
go p@(QuasiQuotePat {}) = pprPanic "collectl/go" (ppr p) go p@(QuasiQuotePat {}) = pprPanic "collectl/go" (ppr p)
collectEvBinders :: TcEvBinds -> [Id] collectEvBinders :: TcEvBinds -> [Id]
......
...@@ -1324,6 +1324,8 @@ repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p) ...@@ -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 :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
-- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t] -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
repP (SplicePat splice) = repSplice splice
repP other = notHandled "Exotic pattern" (ppr other) repP other = notHandled "Exotic pattern" (ppr other)
---------------------------------------------------------- ----------------------------------------------------------
......
...@@ -90,6 +90,7 @@ matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs ...@@ -90,6 +90,7 @@ matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs
incomplete_flag RecUpd = wopt Opt_WarnIncompletePatternsRecUpd dflags incomplete_flag RecUpd = wopt Opt_WarnIncompletePatternsRecUpd dflags
incomplete_flag ThPatSplice = False
incomplete_flag ThPatQuote = False incomplete_flag ThPatQuote = False
incomplete_flag (StmtCtxt {}) = False -- Don't warn about incomplete patterns incomplete_flag (StmtCtxt {}) = False -- Don't warn about incomplete patterns
-- in list comprehensions, pattern guards -- in list comprehensions, pattern guards
......
...@@ -348,6 +348,7 @@ tupArgPresent (Missing {}) = False ...@@ -348,6 +348,7 @@ tupArgPresent (Missing {}) = False
-- See Note [Pending Splices] -- See Note [Pending Splices]
data PendingSplice data PendingSplice
= PendingRnExpSplice Name (LHsExpr Name) = PendingRnExpSplice Name (LHsExpr Name)
| PendingRnPatSplice Name (LHsExpr Name)
| PendingRnTypeSplice Name (LHsExpr Name) | PendingRnTypeSplice Name (LHsExpr Name)
| PendingRnCrossStageSplice Name | PendingRnCrossStageSplice Name
| PendingTcSplice Name (LHsExpr Id) | PendingTcSplice Name (LHsExpr Id)
...@@ -367,6 +368,10 @@ splices generated by the renamer: ...@@ -367,6 +368,10 @@ splices generated by the renamer:
[|$(f x) + 2|] [|$(f x) + 2|]
* Pending pattern splices (PendingRnPatSplice), e.g.,
[|\ $(f x) -> x|]
* Pending type splices (PendingRnTypeSplice), e.g., * Pending type splices (PendingRnTypeSplice), e.g.,
[|f :: $(g x)|] [|f :: $(g x)|]
...@@ -1424,6 +1429,7 @@ thTyBrackets pp_body = ptext (sLit "[||") <+> pp_body <+> ptext (sLit "||]") ...@@ -1424,6 +1429,7 @@ thTyBrackets pp_body = ptext (sLit "[||") <+> pp_body <+> ptext (sLit "||]")
instance Outputable PendingSplice where instance Outputable PendingSplice where
ppr (PendingRnExpSplice name expr) = ppr (name, expr) ppr (PendingRnExpSplice name expr) = ppr (name, expr)
ppr (PendingRnPatSplice name expr) = ppr (name, expr)
ppr (PendingRnTypeSplice name expr) = ppr (name, expr) ppr (PendingRnTypeSplice name expr) = ppr (name, expr)
ppr (PendingRnCrossStageSplice name) = ppr name ppr (PendingRnCrossStageSplice name) = ppr name
ppr (PendingTcSplice name expr) = ppr (name, expr) ppr (PendingTcSplice name expr) = ppr (name, expr)
...@@ -1483,6 +1489,7 @@ data HsMatchContext id -- Context of a Match ...@@ -1483,6 +1489,7 @@ data HsMatchContext id -- Context of a Match
| StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt, list comprehension, | StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt, list comprehension,
-- pattern guard, etc -- pattern guard, etc
| ThPatSplice -- A Template Haskell pattern splice
| ThPatQuote -- A Template Haskell pattern quotation [p| (a,b) |] | ThPatQuote -- A Template Haskell pattern quotation [p| (a,b) |]
deriving (Data, Typeable) deriving (Data, Typeable)
...@@ -1529,6 +1536,7 @@ matchSeparator ProcExpr = ptext (sLit "->") ...@@ -1529,6 +1536,7 @@ matchSeparator ProcExpr = ptext (sLit "->")
matchSeparator PatBindRhs = ptext (sLit "=") matchSeparator PatBindRhs = ptext (sLit "=")
matchSeparator (StmtCtxt _) = ptext (sLit "<-") matchSeparator (StmtCtxt _) = ptext (sLit "<-")
matchSeparator RecUpd = panic "unused" matchSeparator RecUpd = panic "unused"
matchSeparator ThPatSplice = panic "unused"
matchSeparator ThPatQuote = panic "unused" matchSeparator ThPatQuote = panic "unused"
\end{code} \end{code}
...@@ -1548,6 +1556,7 @@ pprMatchContextNoun (FunRhs fun _) = ptext (sLit "equation for") ...@@ -1548,6 +1556,7 @@ pprMatchContextNoun (FunRhs fun _) = ptext (sLit "equation for")
pprMatchContextNoun CaseAlt = ptext (sLit "case alternative") pprMatchContextNoun CaseAlt = ptext (sLit "case alternative")
pprMatchContextNoun IfAlt = ptext (sLit "multi-way if alternative") pprMatchContextNoun IfAlt = ptext (sLit "multi-way if alternative")
pprMatchContextNoun RecUpd = ptext (sLit "record-update construct") pprMatchContextNoun RecUpd = ptext (sLit "record-update construct")
pprMatchContextNoun ThPatSplice = ptext (sLit "Template Haskell pattern splice")
pprMatchContextNoun ThPatQuote = ptext (sLit "Template Haskell pattern quotation") pprMatchContextNoun ThPatQuote = ptext (sLit "Template Haskell pattern quotation")
pprMatchContextNoun PatBindRhs = ptext (sLit "pattern binding") pprMatchContextNoun PatBindRhs = ptext (sLit "pattern binding")
pprMatchContextNoun LambdaExpr = ptext (sLit "lambda abstraction") pprMatchContextNoun LambdaExpr = ptext (sLit "lambda abstraction")
...@@ -1600,6 +1609,7 @@ matchContextErrString PatBindRhs = ptext (sLit "pattern binding" ...@@ -1600,6 +1609,7 @@ matchContextErrString PatBindRhs = ptext (sLit "pattern binding"
matchContextErrString RecUpd = ptext (sLit "record update") matchContextErrString RecUpd = ptext (sLit "record update")
matchContextErrString LambdaExpr = ptext (sLit "lambda") matchContextErrString LambdaExpr = ptext (sLit "lambda")
matchContextErrString ProcExpr = ptext (sLit "proc") matchContextErrString ProcExpr = ptext (sLit "proc")
matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime
matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime
matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)
......
...@@ -33,6 +33,7 @@ instance Data i => Data (HsCmd i) ...@@ -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 (MatchGroup i body)
instance (Data i, Data body) => Data (GRHSs 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 (HsExpr id)
instance OutputableBndr id => Outputable (HsCmd id) instance OutputableBndr id => Outputable (HsCmd id)
......
...@@ -23,7 +23,7 @@ module HsPat ( ...@@ -23,7 +23,7 @@ module HsPat (
pprParendLPat pprParendLPat
) where ) where
import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, pprLExpr) import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr)
-- friends: -- friends:
import HsBinds import HsBinds
...@@ -114,6 +114,9 @@ data Pat id ...@@ -114,6 +114,9 @@ data Pat id
-- (= the argument type of the view function) -- (= the argument type of the view function)
-- for hsPatType. -- for hsPatType.
------------ Pattern splices ---------------
| SplicePat (HsSplice id)
------------ Quasiquoted patterns --------------- ------------ Quasiquoted patterns ---------------
-- See Note [Quasi-quote overview] in TcSplice -- See Note [Quasi-quote overview] in TcSplice
| QuasiQuotePat (HsQuasiQuote id) | QuasiQuotePat (HsQuasiQuote id)
...@@ -268,6 +271,7 @@ pprPat (LitPat s) = ppr s ...@@ -268,6 +271,7 @@ pprPat (LitPat s) = ppr s
pprPat (NPat l Nothing _) = ppr l pprPat (NPat l Nothing _) = ppr l
pprPat (NPat l (Just _) _) = char '-' <> ppr l pprPat (NPat l (Just _) _) = char '-' <> ppr l
pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k] pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k]
pprPat (SplicePat splice) = ppr splice
pprPat (QuasiQuotePat qq) = ppr qq pprPat (QuasiQuotePat qq) = ppr qq
pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co
pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
...@@ -419,13 +423,16 @@ isIrrefutableHsPat pat ...@@ -419,13 +423,16 @@ isIrrefutableHsPat pat
go1 (NPat {}) = False go1 (NPat {}) = False
go1 (NPlusKPat {}) = False go1 (NPlusKPat {}) = False
go1 (QuasiQuotePat {}) = urk pat -- Gotten rid of by renamer, before -- Both should be gotten rid of by renamer before
-- isIrrefutablePat is called -- isIrrefutablePat is called
go1 (SplicePat {}) = urk pat
go1 (QuasiQuotePat {}) = urk pat
urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat) urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat)
hsPatNeedsParens :: Pat a -> Bool hsPatNeedsParens :: Pat a -> Bool
hsPatNeedsParens (NPlusKPat {}) = True hsPatNeedsParens (NPlusKPat {}) = True
hsPatNeedsParens (SplicePat {}) = False
hsPatNeedsParens (QuasiQuotePat {}) = True hsPatNeedsParens (QuasiQuotePat {}) = True
hsPatNeedsParens (ConPatIn _ ds) = conPatNeedsParens ds hsPatNeedsParens (ConPatIn _ ds) = conPatNeedsParens ds
hsPatNeedsParens p@(ConPatOut {}) = conPatNeedsParens (pat_args p) hsPatNeedsParens p@(ConPatOut {}) = conPatNeedsParens (pat_args p)
......
...@@ -588,6 +588,7 @@ collect_lpat (L _ pat) bndrs ...@@ -588,6 +588,7 @@ collect_lpat (L _ pat) bndrs
go (SigPatIn pat _) = collect_lpat pat bndrs go (SigPatIn pat _) = collect_lpat pat bndrs
go (SigPatOut pat _) = collect_lpat pat bndrs go (SigPatOut pat _) = collect_lpat pat bndrs
go (SplicePat _) = bndrs
go (QuasiQuotePat _) = bndrs go (QuasiQuotePat _) = bndrs
go (CoPat _ pat _) = go pat go (CoPat _ pat _) = go pat
\end{code} \end{code}
......
...@@ -668,6 +668,7 @@ checkAPat msg loc e0 = do ...@@ -668,6 +668,7 @@ checkAPat msg loc e0 = do
RecordCon c _ (HsRecFields fs dd) RecordCon c _ (HsRecFields fs dd)
-> do fs <- mapM (checkPatField msg) fs -> do fs <- mapM (checkPatField msg) fs
return (ConPatIn c (RecCon (HsRecFields fs dd))) return (ConPatIn c (RecCon (HsRecFields fs dd)))
HsSpliceE s -> return (SplicePat s)
HsQuasiQuoteE q -> return (QuasiQuotePat q) HsQuasiQuoteE q -> return (QuasiQuotePat q)
_ -> patFail msg loc e0 _ -> patFail msg loc e0
......
...@@ -18,7 +18,7 @@ free variables. ...@@ -18,7 +18,7 @@ free variables.
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
module RnPat (-- main entry points module RnPat (-- main entry points
rnPat, rnPats, rnBindPat, rnPat, rnPats, rnBindPat, rnPatAndThen,
NameMaker, applyNameMaker, -- a utility for making names: NameMaker, applyNameMaker, -- a utility for making names:
localRecNameMaker, topRecNameMaker, -- sometimes we want to make local names, localRecNameMaker, topRecNameMaker, -- sometimes we want to make local names,
...@@ -26,6 +26,9 @@ module RnPat (-- main entry points ...@@ -26,6 +26,9 @@ module RnPat (-- main entry points
rnHsRecFields1, HsRecFieldContext(..), rnHsRecFields1, HsRecFieldContext(..),
-- CpsRn monad
CpsRn, liftCps,
-- Literals -- Literals
rnLit, rnOverLit, rnLit, rnOverLit,
...@@ -37,6 +40,7 @@ module RnPat (-- main entry points ...@@ -37,6 +40,7 @@ module RnPat (-- main entry points
import {-# SOURCE #-} RnExpr ( rnLExpr ) import {-# SOURCE #-} RnExpr ( rnLExpr )
#ifdef GHCI #ifdef GHCI
import {-# SOURCE #-} RnSplice ( rnSplicePat )
import {-# SOURCE #-} TcSplice ( runQuasiQuotePat ) import {-# SOURCE #-} TcSplice ( runQuasiQuotePat )
#endif /* GHCI */ #endif /* GHCI */
...@@ -418,9 +422,15 @@ rnPatAndThen mk (TuplePat pats boxed _) ...@@ -418,9 +422,15 @@ rnPatAndThen mk (TuplePat pats boxed _)
; return (TuplePat pats' boxed placeHolderType) } ; return (TuplePat pats' boxed placeHolderType) }
#ifndef GHCI #ifndef GHCI
rnPatAndThen _ p@(SplicePat {})
= pprPanic "Can't do SplicePat without GHCi" (ppr p)
rnPatAndThen _ p@(QuasiQuotePat {}) rnPatAndThen _ p@(QuasiQuotePat {})
= pprPanic "Can't do QuasiQuotePat without GHCi" (ppr p) = pprPanic "Can't do QuasiQuotePat without GHCi" (ppr p)
#else #else
rnPatAndThen _ (SplicePat splice)
= do { -- XXX How to deal with free variables?
(pat, _) <- liftCps $ rnSplicePat splice
; return pat }
rnPatAndThen mk (QuasiQuotePat qq) rnPatAndThen mk (QuasiQuotePat qq)
= do { pat <- liftCps $ runQuasiQuotePat qq = do { pat <- liftCps $ runQuasiQuotePat qq
-- Wrap the result of the quasi-quoter in parens so that we don't -- Wrap the result of the quasi-quoter in parens so that we don't
......
\begin{code} \begin{code}
module RnSplice ( module RnSplice (
rnSpliceType, rnSpliceExpr, rnSpliceType, rnSpliceExpr, rnSplicePat,
rnBracket, checkTH, rnBracket, checkTH,
checkThLocalName checkThLocalName
) where ) where
...@@ -16,7 +16,7 @@ import TcRnMonad ...@@ -16,7 +16,7 @@ import TcRnMonad
#ifdef GHCI #ifdef GHCI
import Control.Monad ( unless, when ) import Control.Monad ( unless, when )
import DynFlags import DynFlags
import DsMeta ( expQTyConName, typeQTyConName ) import DsMeta ( expQTyConName, patQTyConName, typeQTyConName )
import LoadIface ( loadInterfaceForName ) import LoadIface ( loadInterfaceForName )
import Module import Module
import RnEnv import RnEnv
...@@ -28,7 +28,7 @@ import TcEnv ( checkWellStaged, tcLookup, tcMetaTy, thTopLevelId ) ...@@ -28,7 +28,7 @@ import TcEnv ( checkWellStaged, tcLookup, tcMetaTy, thTopLevelId )
import {-# SOURCE #-} RnExpr ( rnLExpr ) import {-# SOURCE #-} RnExpr ( rnLExpr )
import {-# SOURCE #-} TcExpr ( tcMonoExpr ) import {-# SOURCE #-} TcExpr ( tcMonoExpr )
import {-# SOURCE #-} TcSplice ( runMetaE, runMetaT, tcTopSpliceExpr ) import {-# SOURCE #-} TcSplice ( runMetaE, runMetaP, runMetaT, tcTopSpliceExpr )
#endif #endif
\end{code} \end{code}
...@@ -43,6 +43,9 @@ rnSpliceType e _ = failTH e "splice" ...@@ -43,6 +43,9 @@ rnSpliceType e _ = failTH e "splice"
rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars) rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars)
rnSpliceExpr e = failTH e "splice" 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 :: Outputable a => a -> String -> RnM b
failTH e what -- Raise an error in a stage-1 compiler failTH e what -- Raise an error in a stage-1 compiler
= failWithTc (vcat [ptext (sLit "Template Haskell") <+> text what <+> = failWithTc (vcat [ptext (sLit "Template Haskell") <+> text what <+>
...@@ -209,6 +212,53 @@ rnSpliceExpr splice@(HsSplice isTypedSplice _ expr) ...@@ -209,6 +212,53 @@ rnSpliceExpr splice@(HsSplice isTypedSplice _ expr)
} }
\end{code} \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 Template Haskell brackets
......
...@@ -13,6 +13,7 @@ rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars) ...@@ -13,6 +13,7 @@ rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars)
rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars) rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars)
rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars) rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars)
rnSplicePat :: HsSplice RdrName -> RnM (Pat Name, FreeVars)
checkTH :: Outputable a => a -> String -> RnM () checkTH :: Outputable a => a -> String -> RnM ()
\end{code} \end{code}
...@@ -563,6 +563,9 @@ zonkExpr env (HsBracketOut body bs) ...@@ -563,6 +563,9 @@ zonkExpr env (HsBracketOut body bs)
zonk_b (PendingRnExpSplice _ e) zonk_b (PendingRnExpSplice _ e)
= pprPanic "zonkExpr: PendingRnExpSplice" (ppr e) = pprPanic "zonkExpr: PendingRnExpSplice" (ppr e)
zonk_b (PendingRnPatSplice _ e)
= pprPanic "zonkExpr: PendingRnPatSplice" (ppr e)
zonk_b (PendingRnCrossStageSplice n) zonk_b (PendingRnCrossStageSplice n)
= pprPanic "zonkExpr: PendingRnCrossStageSplice" (ppr n) = pprPanic "zonkExpr: PendingRnCrossStageSplice" (ppr n)
......
...@@ -14,7 +14,7 @@ module TcSplice( tcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket, ...@@ -14,7 +14,7 @@ module TcSplice( tcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
runQuasiQuoteExpr, runQuasiQuotePat, runQuasiQuoteExpr, runQuasiQuotePat,
runQuasiQuoteDecl, runQuasiQuoteType, runQuasiQuoteDecl, runQuasiQuoteType,
runAnnotation, runAnnotation,
runMetaE,runMetaT, runMetaD ) where runMetaE, runMetaP, runMetaT, runMetaD ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -288,6 +288,7 @@ The predicate we use is TcEnv.thTopLevelId. ...@@ -288,6 +288,7 @@ The predicate we use is TcEnv.thTopLevelId.
tcBracket :: HsBracket Name -> [PendingSplice] -> TcRhoType -> TcM (HsExpr TcId) tcBracket :: HsBracket Name -> [PendingSplice] -> TcRhoType -> TcM (HsExpr TcId)
tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId)
tcSplicePat :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId)
tcSpliceType :: HsSplice Name -> FreeVars -> TcM (TcType, TcKind) tcSpliceType :: HsSplice Name -> FreeVars -> TcM (TcType, TcKind)
-- None of these functions add constraints to the LIE -- None of these functions add constraints to the LIE
...@@ -303,6 +304,7 @@ runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation ...@@ -303,6 +304,7 @@ runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
#ifndef GHCI #ifndef GHCI
tcBracket x _ _ = pprPanic "Cant do tcBracket without GHCi" (ppr x) tcBracket x _ _ = pprPanic "Cant do tcBracket without GHCi" (ppr x)
tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) 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) tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
tcSpliceType x fvs = pprPanic "Cant do kcSpliceType without GHCi" (ppr x) tcSpliceType x fvs = pprPanic "Cant do kcSpliceType without GHCi" (ppr x)
...@@ -394,6 +396,12 @@ tcPendingSplice (PendingRnExpSplice n expr) ...@@ -394,6 +396,12 @@ tcPendingSplice (PendingRnExpSplice n expr)
; return () ; return ()
} }
tcPendingSplice (PendingRnPatSplice n expr)
= do { res_ty <- newFlexiTyVarTy openTypeKind
; _ <- tcSplicePat (HsSplice False n expr) res_ty
; return ()
}
tcPendingSplice (PendingRnCrossStageSplice n) tcPendingSplice (PendingRnCrossStageSplice n)
= do { res_ty <- newFlexiTyVarTy openTypeKind = do { res_ty <- newFlexiTyVarTy openTypeKind
; _ <- tcCheckId n res_ty ; _ <- tcCheckId n res_ty
...@@ -493,7 +501,49 @@ tcTopSplice expr res_ty ...@@ -493,7 +501,49 @@ tcTopSplice expr res_ty
-- checkNoErrs: see Note [Renamer errors] -- checkNoErrs: see Note [Renamer errors]
; exp4 <- tcMonoExpr exp3 res_ty ; exp4 <- tcMonoExpr exp3 res_ty
; return (unLoc exp4) } } ; 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 :: HsBracket Name -> SDoc
quotationCtxtDoc br_body quotationCtxtDoc br_body
= hang (ptext (sLit "In the Template Haskell quotation")) = hang (ptext (sLit "In the Template Haskell quotation"))
...@@ -822,6 +872,10 @@ runMetaE :: LHsExpr Id -- Of type (Q Exp) ...@@ -822,6 +872,10 @@ runMetaE :: LHsExpr Id -- Of type (Q Exp)
-> TcM (LHsExpr RdrName) -> TcM (LHsExpr RdrName)
runMetaE = runMetaQ exprMetaOps runMetaE = runMetaQ exprMetaOps
runMetaP :: LHsExpr Id -- Of type (Q Pat)
-> TcM (LPat RdrName)
runMetaP = runMetaQ patMetaOps
runMetaT :: LHsExpr Id -- Of type (Q Type) runMetaT :: LHsExpr Id -- Of type (Q Type)
-> TcM (LHsType RdrName) -> TcM (LHsType RdrName)
runMetaT = runMetaQ typeMetaOps runMetaT = runMetaQ typeMetaOps
......
...@@ -36,6 +36,7 @@ runQuasiQuotePat :: HsQuasiQuote RdrName -> TcM (LPat RdrName) ...@@ -36,6 +36,7 @@ runQuasiQuotePat :: HsQuasiQuote RdrName -> TcM (LPat RdrName)
runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
runMetaE :: LHsExpr Id -> TcM (LHsExpr RdrName) runMetaE :: LHsExpr Id -> TcM (LHsExpr RdrName)
runMetaP :: LHsExpr Id -> TcM (LPat RdrName)
runMetaT :: LHsExpr Id -> TcM (LHsType RdrName) runMetaT :: LHsExpr Id -> TcM (LHsType RdrName)
runMetaD :: LHsExpr Id -> TcM [LHsDecl RdrName] runMetaD :: LHsExpr Id -> TcM [LHsDecl RdrName]
\end{code} \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