Add a class HasDynFlags(getDynFlags)
[ghc.git] / compiler / deSugar / Check.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
4 %
5 % Author: Juan J. Quintela    <quintela@krilin.dc.fi.udc.es>
6
7 \begin{code}
8 module Check ( check , ExhaustivePat ) where
9
10 #include "HsVersions.h"
11
12 import HsSyn
13 import TcHsSyn
14 import DsUtils
15 import MatchLit
16 import Id
17 import DataCon
18 import Name
19 import TysWiredIn
20 import PrelNames
21 import TyCon
22 import Type
23 import SrcLoc
24 import UniqSet
25 import Util
26 import BasicTypes
27 import Outputable
28 import FastString
29 \end{code}
30
31 This module performs checks about if one list of equations are:
32 \begin{itemize}
33 \item Overlapped
34 \item Non exhaustive
35 \end{itemize}
36 To discover that we go through the list of equations in a tree-like fashion.
37
38 If you like theory, a similar algorithm is described in:
39 \begin{quotation}
40         {\em Two Techniques for Compiling Lazy Pattern Matching},
41         Luc Maranguet,
42         INRIA Rocquencourt (RR-2385, 1994)
43 \end{quotation}
44 The algorithm is based on the first technique, but there are some differences:
45 \begin{itemize}
46 \item We don't generate code
47 \item We have constructors and literals (not only literals as in the
48           article)
49 \item We don't use directions, we must select the columns from
50           left-to-right
51 \end{itemize}
52 (By the way the second technique is really similar to the one used in
53  @Match.lhs@ to generate code)
54
55 This function takes the equations of a pattern and returns:
56 \begin{itemize}
57 \item The patterns that are not recognized
58 \item The equations that are not overlapped
59 \end{itemize}
60 It simplify the patterns and then call @check'@ (the same semantics), and it
61 needs to reconstruct the patterns again ....
62
63 The problem appear with things like:
64 \begin{verbatim}
65   f [x,y]   = ....
66   f (x:xs)  = .....
67 \end{verbatim}
68 We want to put the two patterns with the same syntax, (prefix form) and
69 then all the constructors are equal:
70 \begin{verbatim}
71   f (: x (: y []))   = ....
72   f (: x xs)         = .....
73 \end{verbatim}
74 (more about that in @tidy_eqns@)
75
76 We would prefer to have a @WarningPat@ of type @String@, but Strings and the
77 Pretty Printer are not friends.
78
79 We use @InPat@ in @WarningPat@ instead of @OutPat@
80 because we need to print the
81 warning messages in the same way they are introduced, i.e. if the user
82 wrote:
83 \begin{verbatim}
84         f [x,y] = ..
85 \end{verbatim}
86 He don't want a warning message written:
87 \begin{verbatim}
88         f (: x (: y [])) ........
89 \end{verbatim}
90 Then we need to use InPats.
91 \begin{quotation}
92      Juan Quintela 5 JUL 1998\\
93           User-friendliness and compiler writers are no friends.
94 \end{quotation}
95
96 \begin{code}
97 type WarningPat = InPat Name
98 type ExhaustivePat = ([WarningPat], [(Name, [HsLit])])
99 type EqnNo  = Int
100 type EqnSet = UniqSet EqnNo
101
102
103 check :: [EquationInfo] -> ([ExhaustivePat], [EquationInfo])
104   -- Second result is the shadowed equations
105   -- if there are view patterns, just give up - don't know what the function is
106 check qs = (untidy_warns, shadowed_eqns)
107       where
108         tidy_qs = map tidy_eqn qs
109         (warns, used_nos) = check' ([1..] `zip` tidy_qs)
110         untidy_warns = map untidy_exhaustive warns
111         shadowed_eqns = [eqn | (eqn,i) <- qs `zip` [1..],
112                                 not (i `elementOfUniqSet` used_nos)]
113
114 untidy_exhaustive :: ExhaustivePat -> ExhaustivePat
115 untidy_exhaustive ([pat], messages) =
116                   ([untidy_no_pars pat], map untidy_message messages)
117 untidy_exhaustive (pats, messages) =
118                   (map untidy_pars pats, map untidy_message messages)
119
120 untidy_message :: (Name, [HsLit]) -> (Name, [HsLit])
121 untidy_message (string, lits) = (string, map untidy_lit lits)
122 \end{code}
123
124 The function @untidy@ does the reverse work of the @tidy_pat@ funcion.
125
126 \begin{code}
127
128 type NeedPars = Bool
129
130 untidy_no_pars :: WarningPat -> WarningPat
131 untidy_no_pars p = untidy False p
132
133 untidy_pars :: WarningPat -> WarningPat
134 untidy_pars p = untidy True p
135
136 untidy :: NeedPars -> WarningPat -> WarningPat
137 untidy b (L loc p) = L loc (untidy' b p)
138   where
139     untidy' _ p@(WildPat _)          = p
140     untidy' _ p@(VarPat _)           = p
141     untidy' _ (LitPat lit)           = LitPat (untidy_lit lit)
142     untidy' _ p@(ConPatIn _ (PrefixCon [])) = p
143     untidy' b (ConPatIn name ps)     = pars b (L loc (ConPatIn name (untidy_con ps)))
144     untidy' _ (ListPat pats ty)      = ListPat (map untidy_no_pars pats) ty
145     untidy' _ (TuplePat pats box ty) = TuplePat (map untidy_no_pars pats) box ty
146     untidy' _ (PArrPat _ _)          = panic "Check.untidy: Shouldn't get a parallel array here!"
147     untidy' _ (SigPatIn _ _)         = panic "Check.untidy: SigPat"
148     untidy' _ (LazyPat {})           = panic "Check.untidy: LazyPat"
149     untidy' _ (AsPat {})             = panic "Check.untidy: AsPat"
150     untidy' _ (ParPat {})            = panic "Check.untidy: ParPat"
151     untidy' _ (BangPat {})           = panic "Check.untidy: BangPat"
152     untidy' _ (ConPatOut {})         = panic "Check.untidy: ConPatOut"
153     untidy' _ (ViewPat {})           = panic "Check.untidy: ViewPat"
154     untidy' _ (QuasiQuotePat {})     = panic "Check.untidy: QuasiQuotePat"
155     untidy' _ (NPat {})              = panic "Check.untidy: NPat"
156     untidy' _ (NPlusKPat {})         = panic "Check.untidy: NPlusKPat"
157     untidy' _ (SigPatOut {})         = panic "Check.untidy: SigPatOut"
158     untidy' _ (CoPat {})             = panic "Check.untidy: CoPat"
159
160 untidy_con :: HsConPatDetails Name -> HsConPatDetails Name
161 untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats)
162 untidy_con (InfixCon p1 p2) = InfixCon  (untidy_pars p1) (untidy_pars p2)
163 untidy_con (RecCon (HsRecFields flds dd))
164   = RecCon (HsRecFields [ fld { hsRecFieldArg = untidy_pars (hsRecFieldArg fld) }
165                         | fld <- flds ] dd)
166
167 pars :: NeedPars -> WarningPat -> Pat Name
168 pars True p = ParPat p
169 pars _    p = unLoc p
170
171 untidy_lit :: HsLit -> HsLit
172 untidy_lit (HsCharPrim c) = HsChar c
173 untidy_lit lit            = lit
174 \end{code}
175
176 This equation is the same that check, the only difference is that the
177 boring work is done, that work needs to be done only once, this is
178 the reason top have two functions, check is the external interface,
179 @check'@ is called recursively.
180
181 There are several cases:
182
183 \begin{itemize}
184 \item There are no equations: Everything is OK.
185 \item There are only one equation, that can fail, and all the patterns are
186       variables. Then that equation is used and the same equation is
187       non-exhaustive.
188 \item All the patterns are variables, and the match can fail, there are
189       more equations then the results is the result of the rest of equations
190       and this equation is used also.
191
192 \item The general case, if all the patterns are variables (here the match
193       can't fail) then the result is that this equation is used and this
194       equation doesn't generate non-exhaustive cases.
195
196 \item In the general case, there can exist literals ,constructors or only
197       vars in the first column, we actuate in consequence.
198
199 \end{itemize}
200
201
202 \begin{code}
203
204 check' :: [(EqnNo, EquationInfo)]
205         -> ([ExhaustivePat],    -- Pattern scheme that might not be matched at all
206             EqnSet)             -- Eqns that are used (others are overlapped)
207
208 check' [] = ([([],[])],emptyUniqSet)
209
210 check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult can_fail _ }) : rs)
211    | first_eqn_all_vars && case can_fail of { CantFail -> True; CanFail -> False }
212    = ([], unitUniqSet n)        -- One eqn, which can't fail
213
214    | first_eqn_all_vars && null rs      -- One eqn, but it can fail
215    = ([(takeList ps (repeat nlWildPat),[])], unitUniqSet n)
216
217    | first_eqn_all_vars         -- Several eqns, first can fail
218    = (pats, addOneToUniqSet indexs n)
219   where
220     first_eqn_all_vars = all_vars ps
221     (pats,indexs) = check' rs
222
223 check' qs
224    | some_literals     = split_by_literals qs
225    | some_constructors = split_by_constructor qs
226    | only_vars         = first_column_only_vars qs
227    | otherwise = pprPanic "Check.check': Not implemented :-(" (ppr first_pats)
228                  -- Shouldn't happen
229   where
230      -- Note: RecPats will have been simplified to ConPats
231      --       at this stage.
232     first_pats        = ASSERT2( okGroup qs, pprGroup qs ) map firstPatN qs
233     some_constructors = any is_con first_pats
234     some_literals     = any is_lit first_pats
235     only_vars         = all is_var first_pats
236 \end{code}
237
238 Here begins the code to deal with literals, we need to split the matrix
239 in different matrix beginning by each literal and a last matrix with the
240 rest of values.
241
242 \begin{code}
243 split_by_literals :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
244 split_by_literals qs = process_literals used_lits qs
245            where
246              used_lits = get_used_lits qs
247 \end{code}
248
249 @process_explicit_literals@ is a function that process each literal that appears
250 in the column of the matrix.
251
252 \begin{code}
253 process_explicit_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
254 process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)
255     where
256       pats_indexs   = map (\x -> construct_literal_matrix x qs) lits
257       (pats,indexs) = unzip pats_indexs
258 \end{code}
259
260
261 @process_literals@ calls @process_explicit_literals@ to deal with the literals
262 that appears in the matrix and deal also with the rest of the cases. It
263 must be one Variable to be complete.
264
265 \begin{code}
266
267 process_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
268 process_literals used_lits qs
269   | null default_eqns  = ASSERT( not (null qs) ) ([make_row_vars used_lits (head qs)] ++ pats,indexs)
270   | otherwise          = (pats_default,indexs_default)
271      where
272        (pats,indexs)   = process_explicit_literals used_lits qs
273        default_eqns    = ASSERT2( okGroup qs, pprGroup qs )
274                          [remove_var q | q <- qs, is_var (firstPatN q)]
275        (pats',indexs') = check' default_eqns
276        pats_default    = [(nlWildPat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats
277        indexs_default  = unionUniqSets indexs' indexs
278 \end{code}
279
280 Here we have selected the literal and we will select all the equations that
281 begins for that literal and create a new matrix.
282
283 \begin{code}
284 construct_literal_matrix :: HsLit -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
285 construct_literal_matrix lit qs =
286     (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)
287   where
288     (pats,indexs) = (check' (remove_first_column_lit lit qs))
289     new_lit = nlLitPat lit
290
291 remove_first_column_lit :: HsLit
292                         -> [(EqnNo, EquationInfo)]
293                         -> [(EqnNo, EquationInfo)]
294 remove_first_column_lit lit qs
295   = ASSERT2( okGroup qs, pprGroup qs )
296     [(n, shift_pat eqn) | q@(n,eqn) <- qs, is_var_lit lit (firstPatN q)]
297   where
298      shift_pat eqn@(EqnInfo { eqn_pats = _:ps}) = eqn { eqn_pats = ps }
299      shift_pat _                                = panic "Check.shift_var: no patterns"
300 \end{code}
301
302 This function splits the equations @qs@ in groups that deal with the
303 same constructor.
304
305 \begin{code}
306 split_by_constructor :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
307 split_by_constructor qs
308   | notNull unused_cons = need_default_case used_cons unused_cons qs
309   | otherwise           = no_need_default_case used_cons qs
310                        where
311                           used_cons   = get_used_cons qs
312                           unused_cons = get_unused_cons used_cons
313 \end{code}
314
315 The first column of the patterns matrix only have vars, then there is
316 nothing to do.
317
318 \begin{code}
319 first_column_only_vars :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
320 first_column_only_vars qs = (map (\ (xs,ys) -> (nlWildPat:xs,ys)) pats,indexs)
321                           where
322                             (pats, indexs) = check' (map remove_var qs)
323 \end{code}
324
325 This equation takes a matrix of patterns and split the equations by
326 constructor, using all the constructors that appears in the first column
327 of the pattern matching.
328
329 We can need a default clause or not ...., it depends if we used all the
330 constructors or not explicitly. The reasoning is similar to @process_literals@,
331 the difference is that here the default case is not always needed.
332
333 \begin{code}
334 no_need_default_case :: [Pat Id] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
335 no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
336     where
337       pats_indexs   = map (\x -> construct_matrix x qs) cons
338       (pats,indexs) = unzip pats_indexs
339
340 need_default_case :: [Pat Id] -> [DataCon] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
341 need_default_case used_cons unused_cons qs
342   | null default_eqns  = (pats_default_no_eqns,indexs)
343   | otherwise          = (pats_default,indexs_default)
344      where
345        (pats,indexs)   = no_need_default_case used_cons qs
346        default_eqns    = ASSERT2( okGroup qs, pprGroup qs )
347                          [remove_var q | q <- qs, is_var (firstPatN q)]
348        (pats',indexs') = check' default_eqns
349        pats_default    = [(make_whole_con c:ps,constraints) |
350                           c <- unused_cons, (ps,constraints) <- pats'] ++ pats
351        new_wilds       = ASSERT( not (null qs) ) make_row_vars_for_constructor (head qs)
352        pats_default_no_eqns =  [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats
353        indexs_default  = unionUniqSets indexs' indexs
354
355 construct_matrix :: Pat Id -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
356 construct_matrix con qs =
357     (map (make_con con) pats,indexs)
358   where
359     (pats,indexs) = (check' (remove_first_column con qs))
360 \end{code}
361
362 Here remove first column is more difficult that with literals due to the fact
363 that constructors can have arguments.
364
365 For instance, the matrix
366 \begin{verbatim}
367  (: x xs) y
368  z        y
369 \end{verbatim}
370 is transformed in:
371 \begin{verbatim}
372  x xs y
373  _ _  y
374 \end{verbatim}
375
376 \begin{code}
377 remove_first_column :: Pat Id                -- Constructor
378                     -> [(EqnNo, EquationInfo)]
379                     -> [(EqnNo, EquationInfo)]
380 remove_first_column (ConPatOut{ pat_con = L _ con, pat_args = PrefixCon con_pats }) qs
381   = ASSERT2( okGroup qs, pprGroup qs )
382     [(n, shift_var eqn) | q@(n, eqn) <- qs, is_var_con con (firstPatN q)]
383   where
384      new_wilds = [WildPat (hsLPatType arg_pat) | arg_pat <- con_pats]
385      shift_var eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_args = PrefixCon ps' } : ps})
386         = eqn { eqn_pats = map unLoc ps' ++ ps }
387      shift_var eqn@(EqnInfo { eqn_pats = WildPat _ : ps })
388         = eqn { eqn_pats = new_wilds ++ ps }
389      shift_var _ = panic "Check.Shift_var:No done"
390 remove_first_column _ _ = panic "Check.remove_first_column: Not ConPatOut"
391
392 make_row_vars :: [HsLit] -> (EqnNo, EquationInfo) -> ExhaustivePat
393 make_row_vars used_lits (_, EqnInfo { eqn_pats = pats})
394    = (nlVarPat new_var:takeList (tail pats) (repeat nlWildPat),[(new_var,used_lits)])
395   where
396      new_var = hash_x
397
398 hash_x :: Name
399 hash_x = mkInternalName unboundKey {- doesn't matter much -}
400                      (mkVarOccFS (fsLit "#x"))
401                      noSrcSpan
402
403 make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat]
404 make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats})
405   = takeList (tail pats) (repeat nlWildPat)
406
407 compare_cons :: Pat Id -> Pat Id -> Bool
408 compare_cons (ConPatOut{ pat_con = L _ id1 }) (ConPatOut { pat_con = L _ id2 }) = id1 == id2
409 compare_cons _ _ = panic "Check.compare_cons: Not ConPatOut"
410
411 remove_dups :: [Pat Id] -> [Pat Id]
412 remove_dups []     = []
413 remove_dups (x:xs) | or (map (\y -> compare_cons x y) xs) = remove_dups  xs
414                    | otherwise                            = x : remove_dups xs
415
416 get_used_cons :: [(EqnNo, EquationInfo)] -> [Pat Id]
417 get_used_cons qs = remove_dups [pat | q <- qs, let pat = firstPatN q,
418                                       isConPatOut pat]
419
420 isConPatOut :: Pat Id -> Bool
421 isConPatOut (ConPatOut {}) = True
422 isConPatOut _              = False
423
424 remove_dups' :: [HsLit] -> [HsLit]
425 remove_dups' []                   = []
426 remove_dups' (x:xs) | x `elem` xs = remove_dups' xs
427                     | otherwise   = x : remove_dups' xs
428
429
430 get_used_lits :: [(EqnNo, EquationInfo)] -> [HsLit]
431 get_used_lits qs = remove_dups' all_literals
432                  where
433                    all_literals = get_used_lits' qs
434
435 get_used_lits' :: [(EqnNo, EquationInfo)] -> [HsLit]
436 get_used_lits' [] = []
437 get_used_lits' (q:qs)
438   | Just lit <- get_lit (firstPatN q) = lit : get_used_lits' qs
439   | otherwise                         = get_used_lits qs
440
441 get_lit :: Pat id -> Maybe HsLit
442 -- Get a representative HsLit to stand for the OverLit
443 -- It doesn't matter which one, because they will only be compared
444 -- with other HsLits gotten in the same way
445 get_lit (LitPat lit)                                      = Just lit
446 get_lit (NPat (OverLit { ol_val = HsIntegral i})    mb _) = Just (HsIntPrim   (mb_neg negate              mb i))
447 get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg negateFractionalLit mb f))
448 get_lit (NPat (OverLit { ol_val = HsIsString s })   _  _) = Just (HsStringPrim s)
449 get_lit _                                                 = Nothing
450
451 mb_neg :: (a -> a) -> Maybe b -> a -> a
452 mb_neg _      Nothing  v = v
453 mb_neg negate (Just _) v = negate v
454
455 get_unused_cons :: [Pat Id] -> [DataCon]
456 get_unused_cons used_cons = ASSERT( not (null used_cons) ) unused_cons
457      where
458        used_set :: UniqSet DataCon
459        used_set = mkUniqSet [d | ConPatOut{ pat_con = L _ d} <- used_cons]
460        (ConPatOut { pat_ty = ty }) = head used_cons
461        Just (ty_con, inst_tys) = splitTyConApp_maybe ty
462        unused_cons = filterOut is_used (tyConDataCons ty_con)
463        is_used con = con `elementOfUniqSet` used_set
464                      || dataConCannotMatch inst_tys con
465
466 all_vars :: [Pat Id] -> Bool
467 all_vars []             = True
468 all_vars (WildPat _:ps) = all_vars ps
469 all_vars _              = False
470
471 remove_var :: (EqnNo, EquationInfo) -> (EqnNo, EquationInfo)
472 remove_var (n, eqn@(EqnInfo { eqn_pats = WildPat _ : ps})) = (n, eqn { eqn_pats = ps })
473 remove_var _  = panic "Check.remove_var: equation does not begin with a variable"
474
475 -----------------------
476 eqnPats :: (EqnNo, EquationInfo) -> [Pat Id]
477 eqnPats (_, eqn) = eqn_pats eqn
478
479 okGroup :: [(EqnNo, EquationInfo)] -> Bool
480 -- True if all equations have at least one pattern, and
481 -- all have the same number of patterns
482 okGroup [] = True
483 okGroup (e:es) = n_pats > 0 && and [length (eqnPats e) == n_pats | e <- es]
484                where
485                  n_pats = length (eqnPats e)
486
487 -- Half-baked print
488 pprGroup :: [(EqnNo, EquationInfo)] -> SDoc
489 pprEqnInfo :: (EqnNo, EquationInfo) -> SDoc
490 pprGroup es = vcat (map pprEqnInfo es)
491 pprEqnInfo e = ppr (eqnPats e)
492
493
494 firstPatN :: (EqnNo, EquationInfo) -> Pat Id
495 firstPatN (_, eqn) = firstPat eqn
496
497 is_con :: Pat Id -> Bool
498 is_con (ConPatOut {}) = True
499 is_con _              = False
500
501 is_lit :: Pat Id -> Bool
502 is_lit (LitPat _)      = True
503 is_lit (NPat _ _ _)  = True
504 is_lit _               = False
505
506 is_var :: Pat Id -> Bool
507 is_var (WildPat _) = True
508 is_var _           = False
509
510 is_var_con :: DataCon -> Pat Id -> Bool
511 is_var_con _   (WildPat _)                                 = True
512 is_var_con con (ConPatOut{ pat_con = L _ id }) | id == con = True
513 is_var_con _   _                                           = False
514
515 is_var_lit :: HsLit -> Pat Id -> Bool
516 is_var_lit _   (WildPat _)   = True
517 is_var_lit lit pat
518   | Just lit' <- get_lit pat = lit == lit'
519   | otherwise                = False
520 \end{code}
521
522 The difference beteewn @make_con@ and @make_whole_con@ is that
523 @make_wole_con@ creates a new constructor with all their arguments, and
524 @make_con@ takes a list of argumntes, creates the contructor getting their
525 arguments from the list. See where \fbox{\ ???\ } are used for details.
526
527 We need to reconstruct the patterns (make the constructors infix and
528 similar) at the same time that we create the constructors.
529
530 You can tell tuple constructors using
531 \begin{verbatim}
532         Id.isTupleCon
533 \end{verbatim}
534 You can see if one constructor is infix with this clearer code :-))))))))))
535 \begin{verbatim}
536         Lex.isLexConSym (Name.occNameString (Name.getOccName con))
537 \end{verbatim}
538
539        Rather clumsy but it works. (Simon Peyton Jones)
540
541
542 We don't mind the @nilDataCon@ because it doesn't change the way to
543 print the messsage, we are searching only for things like: @[1,2,3]@,
544 not @x:xs@ ....
545
546 In @reconstruct_pat@ we want to ``undo'' the work
547 that we have done in @tidy_pat@.
548 In particular:
549 \begin{tabular}{lll}
550         @((,) x y)@   & returns to be & @(x, y)@
551 \\      @((:) x xs)@  & returns to be & @(x:xs)@
552 \\      @(x:(...:[])@ & returns to be & @[x,...]@
553 \end{tabular}
554 %
555 The difficult case is the third one becouse we need to follow all the
556 contructors until the @[]@ to know that we need to use the second case,
557 not the second. \fbox{\ ???\ }
558 %
559 \begin{code}
560 isInfixCon :: DataCon -> Bool
561 isInfixCon con = isDataSymOcc (getOccName con)
562
563 is_nil :: Pat Name -> Bool
564 is_nil (ConPatIn con (PrefixCon [])) = unLoc con == getName nilDataCon
565 is_nil _                             = False
566
567 is_list :: Pat Name -> Bool
568 is_list (ListPat _ _) = True
569 is_list _             = False
570
571 return_list :: DataCon -> Pat Name -> Bool
572 return_list id q = id == consDataCon && (is_nil q || is_list q)
573
574 make_list :: LPat Name -> Pat Name -> Pat Name
575 make_list p q | is_nil q    = ListPat [p] placeHolderType
576 make_list p (ListPat ps ty) = ListPat (p:ps) ty
577 make_list _ _               = panic "Check.make_list: Invalid argument"
578
579 make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat
580 make_con (ConPatOut{ pat_con = L _ id }) (lp:lq:ps, constraints)
581      | return_list id q = (noLoc (make_list lp q) : ps, constraints)
582      | isInfixCon id    = (nlInfixConPat (getName id) lp lq : ps, constraints)
583    where q  = unLoc lq
584
585 make_con (ConPatOut{ pat_con = L _ id, pat_args = PrefixCon pats, pat_ty = ty }) (ps, constraints)
586       | isTupleTyCon tc  = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) ty) : rest_pats, constraints)
587       | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType)           : rest_pats, constraints)
588       | otherwise        = (nlConPat name pats_con      : rest_pats, constraints)
589     where
590         name                  = getName id
591         (pats_con, rest_pats) = splitAtList pats ps
592         tc                    = dataConTyCon id
593
594 make_con _ _ = panic "Check.make_con: Not ConPatOut"
595
596 -- reconstruct parallel array pattern
597 --
598 --  * don't check for the type only; we need to make sure that we are really
599 --   dealing with one of the fake constructors and not with the real
600 --   representation
601
602 make_whole_con :: DataCon -> WarningPat
603 make_whole_con con | isInfixCon con = nlInfixConPat name nlWildPat nlWildPat
604                    | otherwise      = nlConPat name pats
605                 where
606                   name   = getName con
607                   pats   = [nlWildPat | _ <- dataConOrigArgTys con]
608 \end{code}
609
610 ------------------------------------------------------------------------
611                    Tidying equations
612 ------------------------------------------------------------------------
613
614 tidy_eqn does more or less the same thing as @tidy@ in @Match.lhs@;
615 that is, it removes syntactic sugar, reducing the number of cases that
616 must be handled by the main checking algorithm.  One difference is
617 that here we can do *all* the tidying at once (recursively), rather
618 than doing it incrementally.
619
620 \begin{code}
621 tidy_eqn :: EquationInfo -> EquationInfo
622 tidy_eqn eqn = eqn { eqn_pats = map tidy_pat (eqn_pats eqn),
623                      eqn_rhs  = tidy_rhs (eqn_rhs eqn) }
624   where
625         -- Horrible hack.  The tidy_pat stuff converts "might-fail" patterns to
626         -- WildPats which of course loses the info that they can fail to match.
627         -- So we stick in a CanFail as if it were a guard.
628     tidy_rhs (MatchResult can_fail body)
629         | any might_fail_pat (eqn_pats eqn) = MatchResult CanFail body
630         | otherwise                         = MatchResult can_fail body
631
632 --------------
633 might_fail_pat :: Pat Id -> Bool
634 -- Returns True of patterns that might fail (i.e. fall through) in a way
635 -- that is not covered by the checking algorithm.  Specifically:
636 --         NPlusKPat
637 --         ViewPat (if refutable)
638
639 -- First the two special cases
640 might_fail_pat (NPlusKPat {})                = True
641 might_fail_pat (ViewPat _ p _)               = not (isIrrefutableHsPat p)
642
643 -- Now the recursive stuff
644 might_fail_pat (ParPat p)                    = might_fail_lpat p
645 might_fail_pat (AsPat _ p)                   = might_fail_lpat p
646 might_fail_pat (SigPatOut p _ )              = might_fail_lpat p
647 might_fail_pat (ListPat ps _)                = any might_fail_lpat ps
648 might_fail_pat (TuplePat ps _ _)             = any might_fail_lpat ps
649 might_fail_pat (PArrPat ps _)                = any might_fail_lpat ps
650 might_fail_pat (BangPat p)                   = might_fail_lpat p
651 might_fail_pat (ConPatOut { pat_args = ps }) = any might_fail_lpat (hsConPatArgs ps)
652
653 -- Finally the ones that are sure to succeed, or which are covered by the checking algorithm
654 might_fail_pat (LazyPat _)                   = False -- Always succeeds
655 might_fail_pat _                             = False -- VarPat, WildPat, LitPat, NPat
656
657 --------------
658 might_fail_lpat :: LPat Id -> Bool
659 might_fail_lpat (L _ p) = might_fail_pat p
660
661 --------------
662 tidy_lpat :: LPat Id -> LPat Id
663 tidy_lpat p = fmap tidy_pat p
664
665 --------------
666 tidy_pat :: Pat Id -> Pat Id
667 tidy_pat pat@(WildPat _)  = pat
668 tidy_pat (VarPat id)      = WildPat (idType id)
669 tidy_pat (ParPat p)       = tidy_pat (unLoc p)
670 tidy_pat (LazyPat p)      = WildPat (hsLPatType p)      -- For overlap and exhaustiveness checking
671                                                         -- purposes, a ~pat is like a wildcard
672 tidy_pat (BangPat p)      = tidy_pat (unLoc p)
673 tidy_pat (AsPat _ p)      = tidy_pat (unLoc p)
674 tidy_pat (SigPatOut p _)  = tidy_pat (unLoc p)
675 tidy_pat (CoPat _ pat _)  = tidy_pat pat
676
677 -- These two are might_fail patterns, so we map them to
678 -- WildPats.  The might_fail_pat stuff arranges that the
679 -- guard says "this equation might fall through".
680 tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id))
681 tidy_pat (ViewPat _ _ ty)     = WildPat ty
682
683 tidy_pat pat@(ConPatOut { pat_con = L _ id, pat_args = ps })
684   = pat { pat_args = tidy_con id ps }
685
686 tidy_pat (ListPat ps ty)
687   = unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty)
688                                   (mkNilPat list_ty)
689                                   (map tidy_lpat ps)
690   where list_ty = mkListTy ty
691
692 -- introduce fake parallel array constructors to be able to handle parallel
693 -- arrays with the existing machinery for constructor pattern
694 --
695 tidy_pat (PArrPat ps ty)
696   = unLoc $ mkPrefixConPat (parrFakeCon (length ps))
697                            (map tidy_lpat ps)
698                            (mkPArrTy ty)
699
700 tidy_pat (TuplePat ps boxity ty)
701   = unLoc $ mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity)
702                            (map tidy_lpat ps) ty
703   where
704     arity = length ps
705
706 tidy_pat (NPat lit mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq
707 tidy_pat (LitPat lit)         = tidy_lit_pat lit
708
709 tidy_pat (ConPatIn {})        = panic "Check.tidy_pat: ConPatIn"
710 tidy_pat (QuasiQuotePat {})   = panic "Check.tidy_pat: QuasiQuotePat"
711 tidy_pat (SigPatIn {})        = panic "Check.tidy_pat: SigPatIn"
712
713 tidy_lit_pat :: HsLit -> Pat Id
714 -- Unpack string patterns fully, so we can see when they
715 -- overlap with each other, or even explicit lists of Chars.
716 tidy_lit_pat lit
717   | HsString s <- lit
718   = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
719                   (mkPrefixConPat nilDataCon [] stringTy) (unpackFS s)
720   | otherwise
721   = tidyLitPat lit
722
723 -----------------
724 tidy_con :: DataCon -> HsConPatDetails Id -> HsConPatDetails Id
725 tidy_con _   (PrefixCon ps)   = PrefixCon (map tidy_lpat ps)
726 tidy_con _   (InfixCon p1 p2) = PrefixCon [tidy_lpat p1, tidy_lpat p2]
727 tidy_con con (RecCon (HsRecFields fs _))
728   | null fs   = PrefixCon [nlWildPat | _ <- dataConOrigArgTys con]
729                 -- Special case for null patterns; maybe not a record at all
730   | otherwise = PrefixCon (map (tidy_lpat.snd) all_pats)
731   where
732      -- pad out all the missing fields with WildPats.
733     field_pats = map (\ f -> (f, nlWildPat)) (dataConFieldLabels con)
734     all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc)
735                      field_pats fs
736
737     insertNm nm p [] = [(nm,p)]
738     insertNm nm p (x@(n,_):xs)
739       | nm == n    = (nm,p):xs
740       | otherwise  = x : insertNm nm p xs
741 \end{code}