ghc/compiler/hsSyn/HsPat.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[PatSyntax]{Abstract Haskell syntax---patterns}
   5
   6 \begin{code}
   7 module HsPat (
   8         InPat(..),
   9         OutPat(..),
  10
  11         irrefutablePat, irrefutablePats,
  12         failureFreePat,
  13         patsAreAllCons, isConPat,
  14         patsAreAllLits, isLitPat,
  15         collectPatBinders
  16     ) where
  17
  18 #include "HsVersions.h"
  19
  20 -- friends:
  21 import HsBasic          ( HsLit )
  22 import HsExpr           ( HsExpr )
  23 import BasicTypes       ( Fixity )
  24
  25 -- others:
  26 import Id               ( Id, dataConTyCon, GenId )
  27 import Maybes           ( maybeToBool )
  28 import Outputable
  29 import TyCon            ( maybeTyConSingleCon )
  30 import Type             ( GenType )
  31 import Name             ( NamedThing )
  32 \end{code}
  33
  34 Patterns come in distinct before- and after-typechecking flavo(u)rs.
  35 \begin{code}
  36 data InPat name
  37   = WildPatIn                           -- wild card
  38   | VarPatIn        name                -- variable
  39   | LitPatIn        HsLit               -- literal
  40   | LazyPatIn       (InPat name)        -- lazy pattern
  41   | AsPatIn         name                -- as pattern
  42                     (InPat name)
  43   | ConPatIn        name                -- constructed type
  44                     [InPat name]
  45   | ConOpPatIn      (InPat name)
  46                     name
  47                     Fixity              -- c.f. OpApp in HsExpr
  48                     (InPat name)
  49
  50   | NPlusKPatIn     name                --  n+k pattern
  51                     HsLit
  52
  53   -- We preserve prefix negation and parenthesis for the precedence parser.
  54
  55   | NegPatIn        (InPat name)        -- negated pattern
  56   | ParPatIn        (InPat name)        -- parenthesised pattern
  57
  58   | ListPatIn       [InPat name]        -- syntactic list
  59                                         -- must have >= 1 elements
  60   | TuplePatIn      [InPat name]        -- tuple
  61
  62   | RecPatIn        name                -- record
  63                     [(name, InPat name, Bool)]  -- True <=> source used punning
  64
  65 data OutPat flexi id
  66   = WildPat         (GenType flexi)     -- wild card
  67
  68   | VarPat          id                          -- variable (type is in the Id)
  69
  70   | LazyPat         (OutPat flexi id)   -- lazy pattern
  71
  72   | AsPat           id                          -- as pattern
  73                     (OutPat flexi id)
  74
  75   | ConPat          Id                          -- Constructor is always an Id
  76                     (GenType flexi)     -- the type of the pattern
  77                     [OutPat flexi id]
  78
  79   | ConOpPat        (OutPat flexi id)   -- just a special case...
  80                     Id
  81                     (OutPat flexi id)
  82                     (GenType flexi)
  83   | ListPat                                     -- syntactic list
  84                     (GenType flexi)     -- the type of the elements
  85                     [OutPat flexi id]
  86
  87   | TuplePat        [OutPat flexi id]   -- tuple
  88                                                 -- UnitPat is TuplePat []
  89
  90   | RecPat          Id                          -- record constructor
  91                     (GenType flexi)     -- the type of the pattern
  92                     [(Id, OutPat flexi id, Bool)]       -- True <=> source used punning
  93
  94   | LitPat          -- Used for *non-overloaded* literal patterns:
  95                     -- Int#, Char#, Int, Char, String, etc.
  96                     HsLit
  97                     (GenType flexi)     -- type of pattern
  98
  99   | NPat            -- Used for *overloaded* literal patterns
 100                     HsLit                       -- the literal is retained so that
 101                                                 -- the desugarer can readily identify
 102                                                 -- equations with identical literal-patterns
 103                     (GenType flexi)     -- type of pattern, t
 104                     (HsExpr flexi id (OutPat flexi id))
 105                                                 -- of type t -> Bool; detects match
 106
 107   | NPlusKPat       id
 108                     HsLit                       -- Same reason as for LitPat
 109                                                 -- (This could be an Integer, but then
 110                                                 -- it's harder to partitionEqnsByLit
 111                                                 -- in the desugarer.)
 112                     (GenType flexi)     -- Type of pattern, t
 113                     (HsExpr flexi id (OutPat flexi id))         -- Of type t -> Bool; detects match
 114                     (HsExpr flexi id (OutPat flexi id))         -- Of type t -> t; subtracts k
 115
 116   | DictPat         -- Used when destructing Dictionaries with an explicit case
 117                     [id]                        -- superclass dicts
 118                     [id]                        -- methods
 119 \end{code}
 120
 121 Now name in Inpat is not need to be in NAmedThing to be Outputable.
 122 Needed by ../deSugar/Check.lhs
 123
 124 JJQC-2-12-97
 125
 126 \begin{code}
 127 instance (Outputable name) => Outputable (InPat name) where
 128     ppr = pprInPat
 129
 130 pprInPat :: (Outputable name) => InPat name -> SDoc
 131
 132 pprInPat (WildPatIn)        = char '_'
 133 pprInPat (VarPatIn var)     = ppr var
 134 pprInPat (LitPatIn s)       = ppr s
 135 pprInPat (LazyPatIn pat)    = char '~' <> ppr pat
 136 pprInPat (AsPatIn name pat) = parens (hcat [ppr name, char '@', ppr pat])
 137
 138 pprInPat (ConPatIn c pats)
 139   | null pats = ppr c
 140   | otherwise = hsep [ppr c, interppSP pats] -- ParPats put in the parens
 141
 142 pprInPat (ConOpPatIn pat1 op fixity pat2)
 143  = hsep [ppr pat1, ppr op, ppr pat2] -- ParPats put in parens
 144
 145         -- ToDo: use pprSym to print op (but this involves fiddling various
 146         -- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP)
 147
 148 pprInPat (NegPatIn pat)
 149   = let
 150         pp_pat = pprInPat pat
 151     in
 152     char '-' <> (
 153     case pat of
 154       LitPatIn _ -> pp_pat
 155       _          -> parens pp_pat
 156     )
 157
 158 pprInPat (ParPatIn pat)
 159   = parens (pprInPat pat)
 160
 161 pprInPat (ListPatIn pats)
 162   = brackets (interpp'SP pats)
 163 pprInPat (TuplePatIn pats)
 164   = parens (interpp'SP pats)
 165 pprInPat (NPlusKPatIn n k)
 166   = parens (hcat [ppr n, char '+', ppr k])
 167
 168 pprInPat (RecPatIn con rpats)
 169   = hsep [ppr con, braces (hsep (punctuate comma (map (pp_rpat) rpats)))]
 170   where
 171     pp_rpat (v, _, True) = ppr v
 172     pp_rpat (v, p, _)    = hsep [ppr v, char '=', ppr p]
 173 \end{code}
 174
 175 \begin{code}
 176 instance (Outputable id) => Outputable (OutPat flexi id) where
 177     ppr = pprOutPat
 178 \end{code}
 179
 180 \begin{code}
 181 pprOutPat (WildPat ty)  = char '_'
 182 pprOutPat (VarPat var)  = ppr var
 183 pprOutPat (LazyPat pat) = hcat [char '~', ppr pat]
 184 pprOutPat (AsPat name pat)
 185   = parens (hcat [ppr name, char '@', ppr pat])
 186
 187 pprOutPat (ConPat name ty [])
 188   = ppr name
 189
 190 pprOutPat (ConPat name ty pats)
 191   = hcat [parens (hcat [ppr name, space, interppSP pats])]
 192
 193 pprOutPat (ConOpPat pat1 op pat2 ty)
 194   = parens (hcat [ppr pat1, space, ppr op, space, ppr pat2])
 195
 196 pprOutPat (ListPat ty pats)
 197   = brackets (interpp'SP pats)
 198 pprOutPat (TuplePat pats)
 199   = parens (interpp'SP pats)
 200
 201 pprOutPat (RecPat con ty rpats)
 202   = hcat [ppr con, braces (hsep (punctuate comma (map (pp_rpat) rpats)))]
 203   where
 204     pp_rpat (v, _, True) = ppr v
 205     pp_rpat (v, p, _)    = hsep [ppr v, char '=', ppr p]
 206
 207 pprOutPat (LitPat l ty)         = ppr l -- ToDo: print more
 208 pprOutPat (NPat   l ty e)       = ppr l -- ToDo: print more
 209 pprOutPat (NPlusKPat n k ty e1 e2)              -- ToDo: print more
 210   = parens (hcat [ppr n, char '+', ppr k])
 211
 212 pprOutPat (DictPat dicts methods)
 213  = parens (sep [ptext SLIT("{-dict-}"),
 214                   brackets (interpp'SP dicts),
 215                   brackets (interpp'SP methods)])
 216
 217 \end{code}
 218
 219 %************************************************************************
 220 %*                                                                      *
 221 %* predicates for checking things about pattern-lists in EquationInfo   *
 222 %*                                                                      *
 223 %************************************************************************
 224 \subsection[Pat-list-predicates]{Look for interesting things in patterns}
 225
 226 Unlike in the Wadler chapter, where patterns are either ``variables''
 227 or ``constructors,'' here we distinguish between:
 228 \begin{description}
 229 \item[unfailable:]
 230 Patterns that cannot fail to match: variables, wildcards, and lazy
 231 patterns.
 232
 233 These are the irrefutable patterns; the two other categories
 234 are refutable patterns.
 235
 236 \item[constructor:]
 237 A non-literal constructor pattern (see next category).
 238
 239 \item[literal patterns:]
 240 At least the numeric ones may be overloaded.
 241 \end{description}
 242
 243 A pattern is in {\em exactly one} of the above three categories; `as'
 244 patterns are treated specially, of course.
 245
 246 The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
 247 \begin{code}
 248 irrefutablePats :: [OutPat a b] -> Bool
 249 irrefutablePats pat_list = all irrefutablePat pat_list
 250
 251 irrefutablePat (AsPat   _ pat)  = irrefutablePat pat
 252 irrefutablePat (WildPat _)      = True
 253 irrefutablePat (VarPat  _)      = True
 254 irrefutablePat (LazyPat _)      = True
 255 irrefutablePat (DictPat ds ms)  = (length ds + length ms) <= 1
 256 irrefutablePat other            = False
 257
 258 failureFreePat :: OutPat a b -> Bool
 259
 260 failureFreePat (WildPat _)                = True
 261 failureFreePat (VarPat _)                 = True
 262 failureFreePat (LazyPat _)                = True
 263 failureFreePat (AsPat _ pat)              = failureFreePat pat
 264 failureFreePat (ConPat con tys pats)      = only_con con && all failureFreePat pats
 265 failureFreePat (ConOpPat pat1 con pat2 _) = only_con con && failureFreePat pat1 && failureFreePat pat1
 266 failureFreePat (RecPat con _ fields)      = only_con con && and [ failureFreePat pat | (_,pat,_) <- fields ]
 267 failureFreePat (ListPat _ _)              = False
 268 failureFreePat (TuplePat pats)            = all failureFreePat pats
 269 failureFreePat (DictPat _ _)              = True
 270 failureFreePat other_pat                  = False   -- Literals, NPat
 271
 272 only_con con = maybeToBool (maybeTyConSingleCon (dataConTyCon con))
 273 \end{code}
 274
 275 \begin{code}
 276 patsAreAllCons :: [OutPat a b] -> Bool
 277 patsAreAllCons pat_list = all isConPat pat_list
 278
 279 isConPat (AsPat _ pat)          = isConPat pat
 280 isConPat (ConPat _ _ _)         = True
 281 isConPat (ConOpPat _ _ _ _)     = True
 282 isConPat (ListPat _ _)          = True
 283 isConPat (TuplePat _)           = True
 284 isConPat (RecPat _ _ _)         = True
 285 isConPat (DictPat ds ms)        = (length ds + length ms) > 1
 286 isConPat other                  = False
 287
 288 patsAreAllLits :: [OutPat a b] -> Bool
 289 patsAreAllLits pat_list = all isLitPat pat_list
 290
 291 isLitPat (AsPat _ pat)         = isLitPat pat
 292 isLitPat (LitPat _ _)          = True
 293 isLitPat (NPat   _ _ _)        = True
 294 isLitPat (NPlusKPat _ _ _ _ _) = True
 295 isLitPat other                 = False
 296 \end{code}
 297
 298 This function @collectPatBinders@ works with the ``collectBinders''
 299 functions for @HsBinds@, etc.  The order in which the binders are
 300 collected is important; see @HsBinds.lhs@.
 301 \begin{code}
 302 collectPatBinders :: InPat a -> [a]
 303
 304 collectPatBinders WildPatIn              = []
 305 collectPatBinders (VarPatIn var)         = [var]
 306 collectPatBinders (LitPatIn _)           = []
 307 collectPatBinders (LazyPatIn pat)        = collectPatBinders pat
 308 collectPatBinders (AsPatIn a pat)        = a : collectPatBinders pat
 309 collectPatBinders (NPlusKPatIn n _)      = [n]
 310 collectPatBinders (ConPatIn c pats)      = concat (map collectPatBinders pats)
 311 collectPatBinders (ConOpPatIn p1 c f p2) = collectPatBinders p1 ++ collectPatBinders p2
 312 collectPatBinders (NegPatIn  pat)        = collectPatBinders pat
 313 collectPatBinders (ParPatIn  pat)        = collectPatBinders pat
 314 collectPatBinders (ListPatIn pats)       = concat (map collectPatBinders pats)
 315 collectPatBinders (TuplePatIn pats)      = concat (map collectPatBinders pats)
 316 collectPatBinders (RecPatIn c fields)    = concat (map (\ (f,pat,_) -> collectPatBinders pat) fields)
 317 \end{code}