ghc/compiler/hsSyn/HsPat.lhs

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