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