2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[PatSyntax]{Abstract Haskell syntax---patterns}
7 #include "HsVersions.h"
13 irrefutablePat, irrefutablePats,
15 patsAreAllCons, isConPat,
16 patsAreAllLits, isLitPat,
23 -- IMPORT_DELOOPER(IdLoop)
24 import HsBasic ( HsLit )
25 import HsExpr ( HsExpr )
26 import BasicTypes ( Fixity )
29 import Id ( SYN_IE(Id), dataConTyCon, GenId )
30 import Maybes ( maybeToBool )
31 import Outputable ( PprStyle(..), userStyle, interppSP,
32 interpp'SP, ifPprShowAll, Outputable(..)
35 import TyCon ( maybeTyConSingleCon )
36 import PprType ( GenType )
37 import CmdLineOpts ( opt_PprUserLength )
38 #if __GLASGOW_HASKELL__ >= 202
43 Patterns come in distinct before- and after-typechecking flavo(u)rs.
46 = WildPatIn -- wild card
47 | VarPatIn name -- variable
48 | LitPatIn HsLit -- literal
49 | LazyPatIn (InPat name) -- lazy pattern
50 | AsPatIn name -- as pattern
52 | ConPatIn name -- constructed type
54 | ConOpPatIn (InPat name)
56 Fixity -- c.f. OpApp in HsExpr
59 | NPlusKPatIn name -- n+k pattern
62 -- We preserve prefix negation and parenthesis for the precedence parser.
64 | NegPatIn (InPat name) -- negated pattern
65 | ParPatIn (InPat name) -- parenthesised pattern
67 | ListPatIn [InPat name] -- syntactic list
68 -- must have >= 1 elements
69 | TuplePatIn [InPat name] -- tuple
71 | RecPatIn name -- record
72 [(name, InPat name, Bool)] -- True <=> source used punning
74 data OutPat tyvar uvar id
75 = WildPat (GenType tyvar uvar) -- wild card
77 | VarPat id -- variable (type is in the Id)
79 | LazyPat (OutPat tyvar uvar id) -- lazy pattern
81 | AsPat id -- as pattern
82 (OutPat tyvar uvar id)
84 | ConPat Id -- Constructor is always an Id
85 (GenType tyvar uvar) -- the type of the pattern
86 [OutPat tyvar uvar id]
88 | ConOpPat (OutPat tyvar uvar id) -- just a special case...
90 (OutPat tyvar uvar id)
92 | ListPat -- syntactic list
93 (GenType tyvar uvar) -- the type of the elements
94 [OutPat tyvar uvar id]
96 | TuplePat [OutPat tyvar uvar id] -- tuple
97 -- UnitPat is TuplePat []
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
103 | LitPat -- Used for *non-overloaded* literal patterns:
104 -- Int#, Char#, Int, Char, String, etc.
106 (GenType tyvar uvar) -- type of pattern
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
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
125 | DictPat -- Used when destructing Dictionaries with an explicit case
126 [id] -- superclass dicts
131 instance (Outputable name, NamedThing name) => Outputable (InPat name) where
134 pprInPat :: (Outputable name, NamedThing name) => PprStyle -> InPat name -> Doc
136 pprInPat sty (WildPatIn) = char '_'
137 pprInPat sty (VarPatIn var) = ppr sty var
138 pprInPat sty (LitPatIn s) = ppr sty s
139 pprInPat sty (LazyPatIn pat) = (<>) (char '~') (ppr sty pat)
140 pprInPat sty (AsPatIn name pat)
141 = parens (hcat [ppr sty name, char '@', ppr sty pat])
143 pprInPat sty (ConPatIn c pats)
147 hsep [ppr sty c, interppSP sty pats] -- ParPats put in the parens
149 pprInPat sty (ConOpPatIn pat1 op fixity pat2)
150 = hsep [ppr sty pat1, ppr sty op, ppr sty pat2] -- ParPats put in parens
152 -- ToDo: use pprSym to print op (but this involves fiddling various
153 -- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP)
155 pprInPat sty (NegPatIn pat)
157 pp_pat = pprInPat sty pat
165 pprInPat sty (ParPatIn pat)
166 = parens (pprInPat sty pat)
168 pprInPat sty (ListPatIn pats)
169 = brackets (interpp'SP sty pats)
170 pprInPat sty (TuplePatIn pats)
171 = parens (interpp'SP sty pats)
172 pprInPat sty (NPlusKPatIn n k)
173 = parens (hcat [ppr sty n, char '+', ppr sty k])
175 pprInPat sty (RecPatIn con rpats)
176 = hsep [ppr sty con, braces (hsep (punctuate comma (map (pp_rpat sty) rpats)))]
178 pp_rpat sty (v, _, True) | userStyle sty = ppr (PprForUser opt_PprUserLength) v
179 pp_rpat sty (v, p, _) = hsep [ppr sty v, char '=', ppr sty p]
183 instance (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, Outputable id)
184 => Outputable (OutPat tyvar uvar id) where
189 pprOutPat sty (WildPat ty) = char '_'
190 pprOutPat sty (VarPat var) = ppr sty var
191 pprOutPat sty (LazyPat pat) = hcat [char '~', ppr sty pat]
192 pprOutPat sty (AsPat name pat)
193 = parens (hcat [ppr sty name, char '@', ppr sty pat])
195 pprOutPat sty (ConPat name ty [])
196 = (<>) (ppr sty name)
197 (ifPprShowAll sty (pprConPatTy sty ty))
199 pprOutPat sty (ConPat name ty pats)
200 = hcat [parens (hcat [ppr sty name, space, interppSP sty pats]),
201 ifPprShowAll sty (pprConPatTy sty ty) ]
203 pprOutPat sty (ConOpPat pat1 op pat2 ty)
204 = parens (hcat [ppr sty pat1, space, ppr sty op, space, ppr sty pat2])
206 pprOutPat sty (ListPat ty pats)
207 = brackets (interpp'SP sty pats)
208 pprOutPat sty (TuplePat pats)
209 = parens (interpp'SP sty pats)
211 pprOutPat sty (RecPat con ty rpats)
212 = hcat [ppr sty con, braces (hsep (punctuate comma (map (pp_rpat sty) rpats)))]
214 pp_rpat sty (v, _, True) | userStyle sty = ppr (PprForUser opt_PprUserLength) v
215 pp_rpat sty (v, p, _) = hsep [ppr sty v, char '=', ppr sty p]
217 pprOutPat sty (LitPat l ty) = ppr sty l -- ToDo: print more
218 pprOutPat sty (NPat l ty e) = ppr sty l -- ToDo: print more
219 pprOutPat sty (NPlusKPat n k ty e1 e2) -- ToDo: print more
220 = parens (hcat [ppr sty n, char '+', ppr sty k])
222 pprOutPat sty (DictPat dicts methods)
223 = parens (sep [ptext SLIT("{-dict-}"),
224 brackets (interpp'SP sty dicts),
225 brackets (interpp'SP sty methods)])
228 = parens (ppr sty ty)
231 %************************************************************************
233 %* predicates for checking things about pattern-lists in EquationInfo *
235 %************************************************************************
236 \subsection[Pat-list-predicates]{Look for interesting things in patterns}
238 Unlike in the Wadler chapter, where patterns are either ``variables''
239 or ``constructors,'' here we distinguish between:
242 Patterns that cannot fail to match: variables, wildcards, and lazy
245 These are the irrefutable patterns; the two other categories
246 are refutable patterns.
249 A non-literal constructor pattern (see next category).
251 \item[literal patterns:]
252 At least the numeric ones may be overloaded.
255 A pattern is in {\em exactly one} of the above three categories; `as'
256 patterns are treated specially, of course.
258 The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
260 irrefutablePats :: [OutPat a b c] -> Bool
261 irrefutablePats pat_list = all irrefutablePat pat_list
263 irrefutablePat (AsPat _ pat) = irrefutablePat pat
264 irrefutablePat (WildPat _) = True
265 irrefutablePat (VarPat _) = True
266 irrefutablePat (LazyPat _) = True
267 irrefutablePat (DictPat ds ms) = (length ds + length ms) <= 1
268 irrefutablePat other = False
270 failureFreePat :: OutPat a b c -> Bool
272 failureFreePat (WildPat _) = True
273 failureFreePat (VarPat _) = True
274 failureFreePat (LazyPat _) = True
275 failureFreePat (AsPat _ pat) = failureFreePat pat
276 failureFreePat (ConPat con tys pats) = only_con con && all failureFreePat pats
277 failureFreePat (ConOpPat pat1 con pat2 _) = only_con con && failureFreePat pat1 && failureFreePat pat1
278 failureFreePat (RecPat con _ fields) = only_con con && and [ failureFreePat pat | (_,pat,_) <- fields ]
279 failureFreePat (ListPat _ _) = False
280 failureFreePat (TuplePat pats) = all failureFreePat pats
281 failureFreePat (DictPat _ _) = True
282 failureFreePat other_pat = False -- Literals, NPat
284 only_con con = maybeToBool (maybeTyConSingleCon (dataConTyCon con))
288 patsAreAllCons :: [OutPat a b c] -> Bool
289 patsAreAllCons pat_list = all isConPat pat_list
291 isConPat (AsPat _ pat) = isConPat pat
292 isConPat (ConPat _ _ _) = True
293 isConPat (ConOpPat _ _ _ _) = True
294 isConPat (ListPat _ _) = True
295 isConPat (TuplePat _) = True
296 isConPat (RecPat _ _ _) = True
297 isConPat (DictPat ds ms) = (length ds + length ms) > 1
298 isConPat other = False
300 patsAreAllLits :: [OutPat a b c] -> Bool
301 patsAreAllLits pat_list = all isLitPat pat_list
303 isLitPat (AsPat _ pat) = isLitPat pat
304 isLitPat (LitPat _ _) = True
305 isLitPat (NPat _ _ _) = True
306 isLitPat (NPlusKPat _ _ _ _ _) = True
307 isLitPat other = False
310 This function @collectPatBinders@ works with the ``collectBinders''
311 functions for @HsBinds@, etc. The order in which the binders are
312 collected is important; see @HsBinds.lhs@.
314 collectPatBinders :: InPat a -> [a]
316 collectPatBinders WildPatIn = []
317 collectPatBinders (VarPatIn var) = [var]
318 collectPatBinders (LitPatIn _) = []
319 collectPatBinders (LazyPatIn pat) = collectPatBinders pat
320 collectPatBinders (AsPatIn a pat) = a : collectPatBinders pat
321 collectPatBinders (NPlusKPatIn n _) = [n]
322 collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats)
323 collectPatBinders (ConOpPatIn p1 c f p2) = collectPatBinders p1 ++ collectPatBinders p2
324 collectPatBinders (NegPatIn pat) = collectPatBinders pat
325 collectPatBinders (ParPatIn pat) = collectPatBinders pat
326 collectPatBinders (ListPatIn pats) = concat (map collectPatBinders pats)
327 collectPatBinders (TuplePatIn pats) = concat (map collectPatBinders pats)
328 collectPatBinders (RecPatIn c fields) = concat (map (\ (f,pat,_) -> collectPatBinders pat) fields)