[project @ 1997-05-19 00:10:59 by sof]

[ghc-hetmet.git] / ghc / compiler / hsSyn / HsPat.lhs

diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs
index 5cb26fa..aff6762 100644 (file)
--- a/ghc/compiler/hsSyn/HsPat.lhs
+++ b/ghc/compiler/hsSyn/HsPat.lhs
@@ -20,7 +20,7 @@ module HsPat (
 IMP_Ubiq()
 
 -- friends:
-import HsLit           ( HsLit )
+import HsBasic                 ( HsLit, Fixity )
 IMPORT_DELOOPER(HsLoop)                ( HsExpr )
 
 -- others:
@@ -47,8 +47,12 @@ data InPat name
                    [InPat name]
   | ConOpPatIn     (InPat name)
                    name
+                   Fixity              -- c.f. OpApp in HsExpr
                    (InPat name)
 
+  | NPlusKPatIn            name                --  n+k pattern
+                   HsLit
+
   -- We preserve prefix negation and parenthesis for the precedence parser.
 
   | NegPatIn       (InPat name)        -- negated pattern
@@ -103,6 +107,15 @@ data OutPat tyvar uvar id
                    (HsExpr tyvar uvar id (OutPat tyvar uvar id))
                                                -- of type t -> Bool; detects match
 
+  | NPlusKPat      id
+                   HsLit                       -- Same reason as for LitPat
+                                               -- (This could be an Integer, but then
+                                               -- it's harder to partitionEqnsByLit
+                                               -- in the desugarer.)
+                   (GenType tyvar uvar)        -- Type of pattern, t
+                   (HsExpr tyvar uvar id (OutPat tyvar uvar id))       -- Of type t -> Bool; detects match
+                   (HsExpr tyvar uvar id (OutPat tyvar uvar id))       -- Of type t -> t; subtracts k
+
   | DictPat        -- Used when destructing Dictionaries with an explicit case
                    [id]                        -- superclass dicts
                    [id]                        -- methods
@@ -114,8 +127,8 @@ instance (Outputable name, NamedThing name) => Outputable (InPat name) where
 
 pprInPat :: (Outputable name, NamedThing name) => PprStyle -> InPat name -> Pretty
 
-pprInPat sty (WildPatIn)       = ppStr "_"
-pprInPat sty (VarPatIn var)    = pprNonSym sty var
+pprInPat sty (WildPatIn)       = ppChar '_'
+pprInPat sty (VarPatIn var)    = ppr sty var
 pprInPat sty (LitPatIn s)      = ppr sty s
 pprInPat sty (LazyPatIn pat)   = ppBeside (ppChar '~') (ppr sty pat)
 pprInPat sty (AsPatIn name pat)
@@ -127,7 +140,7 @@ pprInPat sty (ConPatIn c pats)
    else
       ppCat [ppr sty c, interppSP sty pats] -- ParPats put in the parens
 
-pprInPat sty (ConOpPatIn pat1 op pat2)
+pprInPat sty (ConOpPatIn pat1 op fixity pat2)
  = ppCat [ppr sty pat1, ppr sty op, ppr sty pat2] -- ParPats put in parens
 
        -- ToDo: use pprSym to print op (but this involves fiddling various
@@ -150,24 +163,25 @@ pprInPat sty (ListPatIn pats)
   = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack]
 pprInPat sty (TuplePatIn pats)
   = ppParens (interpp'SP sty pats)
+pprInPat sty (NPlusKPatIn n k)
+  = ppBesides [ppLparen, ppr sty n, ppChar '+', ppr sty k, ppRparen]
 
 pprInPat sty (RecPatIn con rpats)
-  = ppBesides [ppr sty con, ppSP, ppChar '{', ppInterleave ppComma (map (pp_rpat sty) rpats), ppChar '}']
+  = ppCat [ppr sty con, ppCurlies (ppIntersperse pp'SP (map (pp_rpat sty) rpats))]
   where
     pp_rpat PprForUser (v, _, True) = ppr PprForUser v
-    pp_rpat sty        (v, p, _)    = ppCat [ppr sty v, ppStr "=", ppr sty p]
+    pp_rpat sty        (v, p, _)    = ppCat [ppr sty v, ppChar '=', ppr sty p]
 \end{code}
 
 \begin{code}
-instance (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
-         NamedThing id, Outputable id)
+instance (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, Outputable id)
        => Outputable (OutPat tyvar uvar id) where
     ppr = pprOutPat
 \end{code}
 
 \begin{code}
 pprOutPat sty (WildPat ty)     = ppChar '_'
-pprOutPat sty (VarPat var)     = pprNonSym sty var
+pprOutPat sty (VarPat var)     = ppr sty var
 pprOutPat sty (LazyPat pat)    = ppBesides [ppChar '~', ppr sty pat]
 pprOutPat sty (AsPat name pat)
   = ppBesides [ppLparen, ppr sty name, ppChar '@', ppr sty pat, ppRparen]
@@ -190,13 +204,15 @@ pprOutPat sty (TuplePat pats)
   = ppParens (interpp'SP sty pats)
 
 pprOutPat sty (RecPat con ty rpats)
-  = ppBesides [ppr sty con, ppChar '{', ppInterleave ppComma (map (pp_rpat sty) rpats), ppChar '}']
+  = ppBesides [ppr sty con, ppCurlies (ppIntersperse pp'SP (map (pp_rpat sty) rpats))]
   where
     pp_rpat PprForUser (v, _, True) = ppr PprForUser v
-    pp_rpat sty (v, p, _)           = ppCat [ppr sty v, ppStr "=", ppr sty p]
+    pp_rpat sty (v, p, _)           = ppCat [ppr sty v, ppChar '=', ppr sty p]
 
 pprOutPat sty (LitPat l ty)    = ppr sty l     -- ToDo: print more
 pprOutPat sty (NPat   l ty e)  = ppr sty l     -- ToDo: print more
+pprOutPat sty (NPlusKPat n k ty e1 e2)         -- ToDo: print more
+  = ppBesides [ppLparen, ppr sty n, ppChar '+', ppr sty k, ppRparen]
 
 pprOutPat sty (DictPat dicts methods)
  = ppSep [ppBesides [ppLparen, ppPStr SLIT("{-dict-}")],
@@ -279,10 +295,11 @@ isConPat other                    = False
 patsAreAllLits :: [OutPat a b c] -> Bool
 patsAreAllLits pat_list = all isLitPat pat_list
 
-isLitPat (AsPat _ pat) = isLitPat pat
-isLitPat (LitPat _ _)  = True
-isLitPat (NPat   _ _ _)        = True
-isLitPat other         = False
+isLitPat (AsPat _ pat)        = isLitPat pat
+isLitPat (LitPat _ _)         = True
+isLitPat (NPat   _ _ _)               = True
+isLitPat (NPlusKPat _ _ _ _ _) = True
+isLitPat other                = False
 \end{code}
 
 This function @collectPatBinders@ works with the ``collectBinders''
@@ -291,16 +308,17 @@ collected is important; see @HsBinds.lhs@.
 \begin{code}
 collectPatBinders :: InPat a -> [a]
 
-collectPatBinders WildPatIn          = []
-collectPatBinders (VarPatIn var)      = [var]
-collectPatBinders (LitPatIn _)       = []
-collectPatBinders (LazyPatIn pat)     = collectPatBinders pat
-collectPatBinders (AsPatIn a pat)     = a : collectPatBinders pat
-collectPatBinders (ConPatIn c pats)   = concat (map collectPatBinders pats)
-collectPatBinders (ConOpPatIn p1 c p2)= collectPatBinders p1 ++ collectPatBinders p2
-collectPatBinders (NegPatIn  pat)     = collectPatBinders pat
-collectPatBinders (ParPatIn  pat)     = collectPatBinders pat
-collectPatBinders (ListPatIn pats)    = concat (map collectPatBinders pats)
-collectPatBinders (TuplePatIn pats)   = concat (map collectPatBinders pats)
-collectPatBinders (RecPatIn c fields) = concat (map (\ (f,pat,_) -> collectPatBinders pat) fields)
+collectPatBinders WildPatIn             = []
+collectPatBinders (VarPatIn var)        = [var]
+collectPatBinders (LitPatIn _)          = []
+collectPatBinders (LazyPatIn pat)       = collectPatBinders pat
+collectPatBinders (AsPatIn a pat)       = a : collectPatBinders pat
+collectPatBinders (NPlusKPatIn n _)      = [n]
+collectPatBinders (ConPatIn c pats)     = concat (map collectPatBinders pats)
+collectPatBinders (ConOpPatIn p1 c f p2) = collectPatBinders p1 ++ collectPatBinders p2
+collectPatBinders (NegPatIn  pat)       = collectPatBinders pat
+collectPatBinders (ParPatIn  pat)       = collectPatBinders pat
+collectPatBinders (ListPatIn pats)      = concat (map collectPatBinders pats)
+collectPatBinders (TuplePatIn pats)     = concat (map collectPatBinders pats)
+collectPatBinders (RecPatIn c fields)   = concat (map (\ (f,pat,_) -> collectPatBinders pat) fields)
 \end{code}