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 HsBasic ( HsLit, Fixity )
24 IMPORT_DELOOPER(IdLoop)
25 IMPORT_DELOOPER(HsLoop) ( HsExpr )
29 import Id --( dataConTyCon, GenId )
30 import Maybes ( maybeToBool )
31 import Outputable --( interppSP, interpp'SP, ifPprShowAll )
32 import PprStyle ( PprStyle(..), userStyle )
34 import TyCon ( maybeTyConSingleCon )
35 import PprType ( GenType )
36 #if __GLASGOW_HASKELL__ >= 202
41 Patterns come in distinct before- and after-typechecking flavo(u)rs.
44 = WildPatIn -- wild card
45 | VarPatIn name -- variable
46 | LitPatIn HsLit -- literal
47 | LazyPatIn (InPat name) -- lazy pattern
48 | AsPatIn name -- as pattern
50 | ConPatIn name -- constructed type
52 | ConOpPatIn (InPat name)
54 Fixity -- c.f. OpApp in HsExpr
57 | NPlusKPatIn name -- n+k pattern
60 -- We preserve prefix negation and parenthesis for the precedence parser.
62 | NegPatIn (InPat name) -- negated pattern
63 | ParPatIn (InPat name) -- parenthesised pattern
65 | ListPatIn [InPat name] -- syntactic list
66 -- must have >= 1 elements
67 | TuplePatIn [InPat name] -- tuple
69 | RecPatIn name -- record
70 [(name, InPat name, Bool)] -- True <=> source used punning
72 data OutPat tyvar uvar id
73 = WildPat (GenType tyvar uvar) -- wild card
75 | VarPat id -- variable (type is in the Id)
77 | LazyPat (OutPat tyvar uvar id) -- lazy pattern
79 | AsPat id -- as pattern
80 (OutPat tyvar uvar id)
82 | ConPat Id -- Constructor is always an Id
83 (GenType tyvar uvar) -- the type of the pattern
84 [OutPat tyvar uvar id]
86 | ConOpPat (OutPat tyvar uvar id) -- just a special case...
88 (OutPat tyvar uvar id)
90 | ListPat -- syntactic list
91 (GenType tyvar uvar) -- the type of the elements
92 [OutPat tyvar uvar id]
94 | TuplePat [OutPat tyvar uvar id] -- tuple
95 -- UnitPat is TuplePat []
97 | RecPat Id -- record constructor
98 (GenType tyvar uvar) -- the type of the pattern
99 [(Id, OutPat tyvar uvar id, Bool)] -- True <=> source used punning
101 | LitPat -- Used for *non-overloaded* literal patterns:
102 -- Int#, Char#, Int, Char, String, etc.
104 (GenType tyvar uvar) -- type of pattern
106 | NPat -- Used for *overloaded* literal patterns
107 HsLit -- the literal is retained so that
108 -- the desugarer can readily identify
109 -- equations with identical literal-patterns
110 (GenType tyvar uvar) -- type of pattern, t
111 (HsExpr tyvar uvar id (OutPat tyvar uvar id))
112 -- of type t -> Bool; detects match
115 HsLit -- Same reason as for LitPat
116 -- (This could be an Integer, but then
117 -- it's harder to partitionEqnsByLit
118 -- in the desugarer.)
119 (GenType tyvar uvar) -- Type of pattern, t
120 (HsExpr tyvar uvar id (OutPat tyvar uvar id)) -- Of type t -> Bool; detects match
121 (HsExpr tyvar uvar id (OutPat tyvar uvar id)) -- Of type t -> t; subtracts k
123 | DictPat -- Used when destructing Dictionaries with an explicit case
124 [id] -- superclass dicts
129 instance (Outputable name, NamedThing name) => Outputable (InPat name) where
132 pprInPat :: (Outputable name, NamedThing name) => PprStyle -> InPat name -> Doc
134 pprInPat sty (WildPatIn) = char '_'
135 pprInPat sty (VarPatIn var) = ppr sty var
136 pprInPat sty (LitPatIn s) = ppr sty s
137 pprInPat sty (LazyPatIn pat) = (<>) (char '~') (ppr sty pat)
138 pprInPat sty (AsPatIn name pat)
139 = parens (hcat [ppr sty name, char '@', ppr sty pat])
141 pprInPat sty (ConPatIn c pats)
145 hsep [ppr sty c, interppSP sty pats] -- ParPats put in the parens
147 pprInPat sty (ConOpPatIn pat1 op fixity pat2)
148 = hsep [ppr sty pat1, ppr sty op, ppr sty pat2] -- ParPats put in parens
150 -- ToDo: use pprSym to print op (but this involves fiddling various
151 -- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP)
153 pprInPat sty (NegPatIn pat)
155 pp_pat = pprInPat sty pat
163 pprInPat sty (ParPatIn pat)
164 = parens (pprInPat sty pat)
166 pprInPat sty (ListPatIn pats)
167 = brackets (interpp'SP sty pats)
168 pprInPat sty (TuplePatIn pats)
169 = parens (interpp'SP sty pats)
170 pprInPat sty (NPlusKPatIn n k)
171 = parens (hcat [ppr sty n, char '+', ppr sty k])
173 pprInPat sty (RecPatIn con rpats)
174 = hsep [ppr sty con, braces (hsep (punctuate comma (map (pp_rpat sty) rpats)))]
176 pp_rpat sty (v, _, True) | userStyle sty = ppr PprForUser v
177 pp_rpat sty (v, p, _) = hsep [ppr sty v, char '=', ppr sty p]
181 instance (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, Outputable id)
182 => Outputable (OutPat tyvar uvar id) where
187 pprOutPat sty (WildPat ty) = char '_'
188 pprOutPat sty (VarPat var) = ppr sty var
189 pprOutPat sty (LazyPat pat) = hcat [char '~', ppr sty pat]
190 pprOutPat sty (AsPat name pat)
191 = parens (hcat [ppr sty name, char '@', ppr sty pat])
193 pprOutPat sty (ConPat name ty [])
194 = (<>) (ppr sty name)
195 (ifPprShowAll sty (pprConPatTy sty ty))
197 pprOutPat sty (ConPat name ty pats)
198 = hcat [parens (hcat [ppr sty name, space, interppSP sty pats]),
199 ifPprShowAll sty (pprConPatTy sty ty) ]
201 pprOutPat sty (ConOpPat pat1 op pat2 ty)
202 = parens (hcat [ppr sty pat1, space, ppr sty op, space, ppr sty pat2])
204 pprOutPat sty (ListPat ty pats)
205 = brackets (interpp'SP sty pats)
206 pprOutPat sty (TuplePat pats)
207 = parens (interpp'SP sty pats)
209 pprOutPat sty (RecPat con ty rpats)
210 = hcat [ppr sty con, braces (hsep (punctuate comma (map (pp_rpat sty) rpats)))]
212 pp_rpat sty (v, _, True) | userStyle sty = ppr PprForUser v
213 pp_rpat sty (v, p, _) = hsep [ppr sty v, char '=', ppr sty p]
215 pprOutPat sty (LitPat l ty) = ppr sty l -- ToDo: print more
216 pprOutPat sty (NPat l ty e) = ppr sty l -- ToDo: print more
217 pprOutPat sty (NPlusKPat n k ty e1 e2) -- ToDo: print more
218 = parens (hcat [ppr sty n, char '+', ppr sty k])
220 pprOutPat sty (DictPat dicts methods)
221 = parens (sep [ptext SLIT("{-dict-}"),
222 brackets (interpp'SP sty dicts),
223 brackets (interpp'SP sty methods)])
226 = parens (ppr sty ty)
229 %************************************************************************
231 %* predicates for checking things about pattern-lists in EquationInfo *
233 %************************************************************************
234 \subsection[Pat-list-predicates]{Look for interesting things in patterns}
236 Unlike in the Wadler chapter, where patterns are either ``variables''
237 or ``constructors,'' here we distinguish between:
240 Patterns that cannot fail to match: variables, wildcards, and lazy
243 These are the irrefutable patterns; the two other categories
244 are refutable patterns.
247 A non-literal constructor pattern (see next category).
249 \item[literal patterns:]
250 At least the numeric ones may be overloaded.
253 A pattern is in {\em exactly one} of the above three categories; `as'
254 patterns are treated specially, of course.
256 The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
258 irrefutablePats :: [OutPat a b c] -> Bool
259 irrefutablePats pat_list = all irrefutablePat pat_list
261 irrefutablePat (AsPat _ pat) = irrefutablePat pat
262 irrefutablePat (WildPat _) = True
263 irrefutablePat (VarPat _) = True
264 irrefutablePat (LazyPat _) = True
265 irrefutablePat (DictPat ds ms) = (length ds + length ms) <= 1
266 irrefutablePat other = False
268 failureFreePat :: OutPat a b c -> Bool
270 failureFreePat (WildPat _) = True
271 failureFreePat (VarPat _) = True
272 failureFreePat (LazyPat _) = True
273 failureFreePat (AsPat _ pat) = failureFreePat pat
274 failureFreePat (ConPat con tys pats) = only_con con && all failureFreePat pats
275 failureFreePat (ConOpPat pat1 con pat2 _) = only_con con && failureFreePat pat1 && failureFreePat pat1
276 failureFreePat (RecPat con _ fields) = only_con con && and [ failureFreePat pat | (_,pat,_) <- fields ]
277 failureFreePat (ListPat _ _) = False
278 failureFreePat (TuplePat pats) = all failureFreePat pats
279 failureFreePat (DictPat _ _) = True
280 failureFreePat other_pat = False -- Literals, NPat
282 only_con con = maybeToBool (maybeTyConSingleCon (dataConTyCon con))
286 patsAreAllCons :: [OutPat a b c] -> Bool
287 patsAreAllCons pat_list = all isConPat pat_list
289 isConPat (AsPat _ pat) = isConPat pat
290 isConPat (ConPat _ _ _) = True
291 isConPat (ConOpPat _ _ _ _) = True
292 isConPat (ListPat _ _) = True
293 isConPat (TuplePat _) = True
294 isConPat (RecPat _ _ _) = True
295 isConPat (DictPat ds ms) = (length ds + length ms) > 1
296 isConPat other = False
298 patsAreAllLits :: [OutPat a b c] -> Bool
299 patsAreAllLits pat_list = all isLitPat pat_list
301 isLitPat (AsPat _ pat) = isLitPat pat
302 isLitPat (LitPat _ _) = True
303 isLitPat (NPat _ _ _) = True
304 isLitPat (NPlusKPat _ _ _ _ _) = True
305 isLitPat other = False
308 This function @collectPatBinders@ works with the ``collectBinders''
309 functions for @HsBinds@, etc. The order in which the binders are
310 collected is important; see @HsBinds.lhs@.
312 collectPatBinders :: InPat a -> [a]
314 collectPatBinders WildPatIn = []
315 collectPatBinders (VarPatIn var) = [var]
316 collectPatBinders (LitPatIn _) = []
317 collectPatBinders (LazyPatIn pat) = collectPatBinders pat
318 collectPatBinders (AsPatIn a pat) = a : collectPatBinders pat
319 collectPatBinders (NPlusKPatIn n _) = [n]
320 collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats)
321 collectPatBinders (ConOpPatIn p1 c f p2) = collectPatBinders p1 ++ collectPatBinders p2
322 collectPatBinders (NegPatIn pat) = collectPatBinders pat
323 collectPatBinders (ParPatIn pat) = collectPatBinders pat
324 collectPatBinders (ListPatIn pats) = concat (map collectPatBinders pats)
325 collectPatBinders (TuplePatIn pats) = concat (map collectPatBinders pats)
326 collectPatBinders (RecPatIn c fields) = concat (map (\ (f,pat,_) -> collectPatBinders pat) fields)