From 110bf0e93196b88606503a06552c95d2014e6267 Mon Sep 17 00:00:00 2001 From: Reiner Pope Date: Sun, 10 Oct 2010 13:17:20 +0000 Subject: [PATCH] Template Haskell: add view patterns (Trac #2399) --- compiler/deSugar/DsMeta.hs | 12 +++++++++--- compiler/hsSyn/Convert.lhs | 1 + 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index b809795..27f816d 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1038,6 +1038,7 @@ repP (ConPatIn dc details) repPinfix p1' con_str p2' } } repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a } +repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p) -- The problem is to do with scoped type variables. @@ -1270,6 +1271,9 @@ repPwild = rep2 wildPName [] repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ) repPlist (MkC ps) = rep2 listPName [ps] +repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ) +repPview (MkC e) (MkC p) = rep2 viewPName [e,p] + --------------- Expressions ----------------- repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ) repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str @@ -1665,7 +1669,7 @@ templateHaskellNames = [ floatPrimLName, doublePrimLName, rationalLName, -- Pat litPName, varPName, tupPName, conPName, tildePName, bangPName, infixPName, - asPName, wildPName, recPName, listPName, sigPName, + asPName, wildPName, recPName, listPName, sigPName, viewPName, -- FieldPat fieldPatName, -- Match @@ -1802,7 +1806,7 @@ rationalLName = libFun (fsLit "rationalL") rationalLIdKey -- data Pat = ... litPName, varPName, tupPName, conPName, infixPName, tildePName, bangPName, - asPName, wildPName, recPName, listPName, sigPName :: Name + asPName, wildPName, recPName, listPName, sigPName, viewPName :: Name litPName = libFun (fsLit "litP") litPIdKey varPName = libFun (fsLit "varP") varPIdKey tupPName = libFun (fsLit "tupP") tupPIdKey @@ -1815,6 +1819,7 @@ wildPName = libFun (fsLit "wildP") wildPIdKey recPName = libFun (fsLit "recP") recPIdKey listPName = libFun (fsLit "listP") listPIdKey sigPName = libFun (fsLit "sigP") sigPIdKey +viewPName = libFun (fsLit "viewP") viewPIdKey -- type FieldPat = ... fieldPatName :: Name @@ -2080,7 +2085,7 @@ liftStringIdKey = mkPreludeMiscIdUnique 218 -- data Pat = ... litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey, - asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey :: Unique + asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique litPIdKey = mkPreludeMiscIdUnique 220 varPIdKey = mkPreludeMiscIdUnique 221 tupPIdKey = mkPreludeMiscIdUnique 222 @@ -2093,6 +2098,7 @@ wildPIdKey = mkPreludeMiscIdUnique 226 recPIdKey = mkPreludeMiscIdUnique 227 listPIdKey = mkPreludeMiscIdUnique 228 sigPIdKey = mkPreludeMiscIdUnique 229 +viewPIdKey = mkPreludeMiscIdUnique 360 -- type FieldPat = ... fieldPatIdKey :: Unique diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index fc5f897..b5a185c 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -637,6 +637,7 @@ cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void } cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' } +cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void } cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName)) cvtPatFld (s,p) -- 1.7.10.4