Add support for pattern splices.

compiler/deSugar/Check.lhs

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

 \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

@@ -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

@@ -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

@@ -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

@@ -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}