Add support for pattern splices.

compiler/deSugar/Check.lhs

@@ -151,6 +151,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"
@@ -707,6 +708,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

@@ -1102,6 +1102,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

@@ -1246,6 +1246,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

@@ -96,6 +96,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

@@ -318,6 +318,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)
@@ -337,6 +338,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)|]
@@ -1288,6 +1293,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)
@@ -1347,7 +1353,8 @@ data HsMatchContext id  -- Context of a Match
   | StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt, list comprehension, 
     	     		    	-- pattern guard, etc
 
-  | ThPatQuote			-- A Template Haskell pattern quotation [p| (a,b) |]
+  | ThPatSplice                 -- A Template Haskell pattern splice
+  | ThPatQuote                  -- A Template Haskell pattern quotation [p| (a,b) |]
   deriving (Data, Typeable)
 
 data HsStmtContext id
@@ -1393,6 +1400,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}
 
@@ -1412,6 +1420,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")
@@ -1464,6 +1473,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

@@ -3,7 +3,7 @@
 module HsExpr where
 
 import SrcLoc     ( Located )
-import Outputable ( SDoc, OutputableBndr )
+import Outputable ( SDoc, OutputableBndr, Outputable )
 import {-# SOURCE #-} HsPat  ( LPat )
 
 import Data.Data
@@ -23,6 +23,9 @@ instance Data i => Data (MatchGroup i)
 instance Typeable1 GRHSs
 instance Data i => Data (GRHSs i)
 
+instance OutputableBndr id => Outputable (HsSplice id)
+instance OutputableBndr id => Outputable (HsExpr id)
+
 type LHsExpr a = Located (HsExpr a)
 type SyntaxExpr a = HsExpr a
 

compiler/hsSyn/HsPat.lhs

@@ -23,7 +23,7 @@ module HsPat (
         pprParendLPat
     ) where
 
-import {-# SOURCE #-} HsExpr            (SyntaxExpr, LHsExpr, pprLExpr)
+import {-# SOURCE #-} HsExpr            (SyntaxExpr, LHsExpr, HsSplice, pprLExpr)
 
 -- friends:
 import HsBinds
@@ -110,6 +110,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)
@@ -264,6 +267,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
@@ -415,13 +419,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

@@ -581,6 +581,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

@@ -611,6 +611,7 @@ checkAPat dynflags loc e0 = case e0 of
    RecordCon c _ (HsRecFields fs dd)
                       -> do fs <- mapM checkPatField fs
                             return (ConPatIn c (RecCon (HsRecFields fs dd)))
+   HsSpliceE s        -> return (SplicePat s)
    HsQuasiQuoteE q    -> return (QuasiQuotePat q)
    _                  -> patFail loc e0
 

compiler/rename/RnPat.lhs

@@ -19,14 +19,17 @@ 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,
                                              --   sometimes we want to make top (qualified) names.
 
               rnHsRecFields1, HsRecFieldContext(..),
 
+              -- CpsRn monad
+              CpsRn, liftCps,
+
 	      -- Literals
 	      rnLit, rnOverLit,     
 
@@ -38,6 +41,7 @@ module RnPat (-- main entry points
 
 import {-# SOURCE #-} RnExpr ( rnLExpr )
 #ifdef GHCI
+import {-# SOURCE #-} RnSplice ( rnSplicePat )
 import {-# SOURCE #-} TcSplice ( runQuasiQuotePat )
 #endif 	/* GHCI */
 
@@ -375,9 +379,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
        ; L _ pat' <- rnLPatAndThen mk pat

compiler/rename/RnSplice.lhs

@@ -1,6 +1,6 @@
 \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 RnEnv
 import RnPat
@@ -27,7 +27,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}
 
@@ -42,6 +42,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 <+>
@@ -208,6 +211,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

@@ -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/TcExpr.lhs

@@ -807,8 +807,7 @@ tcExpr (PArrSeq _ _) _
 #ifdef GHCI     /* Only if bootstrapped */
         -- Rename excludes these cases otherwise
 tcExpr (HsSpliceE splice) res_ty        = tcSpliceExpr splice res_ty
-tcExpr (HsRnBracketOut brack ps) res_ty = do   { e <- tcBracket brack ps res_ty
-                                               ; return (unLoc e) }
+tcExpr (HsRnBracketOut brack ps) res_ty = tcBracket brack ps res_ty
 tcExpr e@(HsBracketOut _ _) _ =
     pprPanic "Should never see HsBracketOut in type checker" (ppr e)
 tcExpr e@(HsQuasiQuoteE _) _ =

compiler/typecheck/TcHsSyn.lhs

@@ -577,6 +577,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)