Commit 110bf0e9 authored by reinerp's avatar reinerp
Browse files

Template Haskell: add view patterns (Trac #2399)

parent b10d7d07
...@@ -1038,6 +1038,7 @@ repP (ConPatIn dc details) ...@@ -1038,6 +1038,7 @@ repP (ConPatIn dc details)
repPinfix p1' con_str p2' } repPinfix p1' con_str p2' }
} }
repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a } 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@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p) repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
-- The problem is to do with scoped type variables. -- The problem is to do with scoped type variables.
...@@ -1270,6 +1271,9 @@ repPwild = rep2 wildPName [] ...@@ -1270,6 +1271,9 @@ repPwild = rep2 wildPName []
repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ) repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
repPlist (MkC ps) = rep2 listPName [ps] 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 ----------------- --------------- Expressions -----------------
repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ) repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
...@@ -1665,7 +1669,7 @@ templateHaskellNames = [ ...@@ -1665,7 +1669,7 @@ templateHaskellNames = [
floatPrimLName, doublePrimLName, rationalLName, floatPrimLName, doublePrimLName, rationalLName,
-- Pat -- Pat
litPName, varPName, tupPName, conPName, tildePName, bangPName, infixPName, litPName, varPName, tupPName, conPName, tildePName, bangPName, infixPName,
asPName, wildPName, recPName, listPName, sigPName, asPName, wildPName, recPName, listPName, sigPName, viewPName,
-- FieldPat -- FieldPat
fieldPatName, fieldPatName,
-- Match -- Match
...@@ -1802,7 +1806,7 @@ rationalLName = libFun (fsLit "rationalL") rationalLIdKey ...@@ -1802,7 +1806,7 @@ rationalLName = libFun (fsLit "rationalL") rationalLIdKey
-- data Pat = ... -- data Pat = ...
litPName, varPName, tupPName, conPName, infixPName, tildePName, bangPName, 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 litPName = libFun (fsLit "litP") litPIdKey
varPName = libFun (fsLit "varP") varPIdKey varPName = libFun (fsLit "varP") varPIdKey
tupPName = libFun (fsLit "tupP") tupPIdKey tupPName = libFun (fsLit "tupP") tupPIdKey
...@@ -1815,6 +1819,7 @@ wildPName = libFun (fsLit "wildP") wildPIdKey ...@@ -1815,6 +1819,7 @@ wildPName = libFun (fsLit "wildP") wildPIdKey
recPName = libFun (fsLit "recP") recPIdKey recPName = libFun (fsLit "recP") recPIdKey
listPName = libFun (fsLit "listP") listPIdKey listPName = libFun (fsLit "listP") listPIdKey
sigPName = libFun (fsLit "sigP") sigPIdKey sigPName = libFun (fsLit "sigP") sigPIdKey
viewPName = libFun (fsLit "viewP") viewPIdKey
-- type FieldPat = ... -- type FieldPat = ...
fieldPatName :: Name fieldPatName :: Name
...@@ -2080,7 +2085,7 @@ liftStringIdKey = mkPreludeMiscIdUnique 218 ...@@ -2080,7 +2085,7 @@ liftStringIdKey = mkPreludeMiscIdUnique 218
-- data Pat = ... -- data Pat = ...
litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey, litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey :: Unique asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique
litPIdKey = mkPreludeMiscIdUnique 220 litPIdKey = mkPreludeMiscIdUnique 220
varPIdKey = mkPreludeMiscIdUnique 221 varPIdKey = mkPreludeMiscIdUnique 221
tupPIdKey = mkPreludeMiscIdUnique 222 tupPIdKey = mkPreludeMiscIdUnique 222
...@@ -2093,6 +2098,7 @@ wildPIdKey = mkPreludeMiscIdUnique 226 ...@@ -2093,6 +2098,7 @@ wildPIdKey = mkPreludeMiscIdUnique 226
recPIdKey = mkPreludeMiscIdUnique 227 recPIdKey = mkPreludeMiscIdUnique 227
listPIdKey = mkPreludeMiscIdUnique 228 listPIdKey = mkPreludeMiscIdUnique 228
sigPIdKey = mkPreludeMiscIdUnique 229 sigPIdKey = mkPreludeMiscIdUnique 229
viewPIdKey = mkPreludeMiscIdUnique 360
-- type FieldPat = ... -- type FieldPat = ...
fieldPatIdKey :: Unique fieldPatIdKey :: Unique
......
...@@ -637,6 +637,7 @@ cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs ...@@ -637,6 +637,7 @@ cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void } 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 (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 :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
cvtPatFld (s,p) cvtPatFld (s,p)
......
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