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>
7 \begin{code}
8 module Check ( check , ExhaustivePat ) where
10 #include "HsVersions.h"
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}
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.
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)
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 ....
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@)
76 We would prefer to have a @WarningPat@ of type @String@, but Strings and the
77 Pretty Printer are not friends.
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}
96 \begin{code}
97 type WarningPat = InPat Name
98 type ExhaustivePat = ([WarningPat], [(Name, [HsLit])])
99 type EqnNo  = Int
100 type EqnSet = UniqSet EqnNo
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)]
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)
120 untidy_message :: (Name, [HsLit]) -> (Name, [HsLit])
121 untidy_message (string, lits) = (string, map untidy_lit lits)
122 \end{code}
124 The function @untidy@ does the reverse work of the @tidy_pat@ funcion.
126 \begin{code}
128 type NeedPars = Bool
130 untidy_no_pars :: WarningPat -> WarningPat
131 untidy_no_pars p = untidy False p
133 untidy_pars :: WarningPat -> WarningPat
134 untidy_pars p = untidy True p
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 Nothing)     = ListPat (map untidy_no_pars pats) ty Nothing
145     untidy' _ (TuplePat pats box ty) = TuplePat (map untidy_no_pars pats) box ty
146     untidy' _ (ListPat _ _ (Just _)) = panic "Check.untidy: Overloaded ListPat"
147     untidy' _ (PArrPat _ _)          = panic "Check.untidy: Shouldn't get a parallel array here!"
148     untidy' _ (SigPatIn _ _)         = panic "Check.untidy: SigPat"
149     untidy' _ (LazyPat {})           = panic "Check.untidy: LazyPat"
150     untidy' _ (AsPat {})             = panic "Check.untidy: AsPat"
151     untidy' _ (ParPat {})            = panic "Check.untidy: ParPat"
152     untidy' _ (BangPat {})           = panic "Check.untidy: BangPat"
153     untidy' _ (ConPatOut {})         = panic "Check.untidy: ConPatOut"
154     untidy' _ (ViewPat {})           = panic "Check.untidy: ViewPat"
155     untidy' _ (QuasiQuotePat {})     = panic "Check.untidy: QuasiQuotePat"
156     untidy' _ (NPat {})              = panic "Check.untidy: NPat"
157     untidy' _ (NPlusKPat {})         = panic "Check.untidy: NPlusKPat"
158     untidy' _ (SigPatOut {})         = panic "Check.untidy: SigPatOut"
159     untidy' _ (CoPat {})             = panic "Check.untidy: CoPat"
161 untidy_con :: HsConPatDetails Name -> HsConPatDetails Name
162 untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats)
163 untidy_con (InfixCon p1 p2) = InfixCon  (untidy_pars p1) (untidy_pars p2)
164 untidy_con (RecCon (HsRecFields flds dd))
165   = RecCon (HsRecFields [ fld { hsRecFieldArg = untidy_pars (hsRecFieldArg fld) }
166                         | fld <- flds ] dd)
168 pars :: NeedPars -> WarningPat -> Pat Name
169 pars True p = ParPat p
170 pars _    p = unLoc p
172 untidy_lit :: HsLit -> HsLit
173 untidy_lit (HsCharPrim c) = HsChar c
174 untidy_lit lit            = lit
175 \end{code}
177 This equation is the same that check, the only difference is that the
178 boring work is done, that work needs to be done only once, this is
179 the reason top have two functions, check is the external interface,
180 @check'@ is called recursively.
182 There are several cases:
184 \begin{itemize}
185 \item There are no equations: Everything is OK.
186 \item There are only one equation, that can fail, and all the patterns are
187       variables. Then that equation is used and the same equation is
188       non-exhaustive.
189 \item All the patterns are variables, and the match can fail, there are
190       more equations then the results is the result of the rest of equations
191       and this equation is used also.
193 \item The general case, if all the patterns are variables (here the match
194       can't fail) then the result is that this equation is used and this
195       equation doesn't generate non-exhaustive cases.
197 \item In the general case, there can exist literals ,constructors or only
198       vars in the first column, we actuate in consequence.
200 \end{itemize}
203 \begin{code}
205 check' :: [(EqnNo, EquationInfo)]
206         -> ([ExhaustivePat],    -- Pattern scheme that might not be matched at all
207             EqnSet)             -- Eqns that are used (others are overlapped)
209 check' [] = ([],emptyUniqSet)
210   -- Was    ([([],[])], emptyUniqSet)
211   -- But that (a) seems weird, and (b) triggered Trac #7669
212   -- So now I'm just doing the simple obvious thing
214 check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult can_fail _ }) : rs)
215    | first_eqn_all_vars && case can_fail of { CantFail -> True; CanFail -> False }
216    = ([], unitUniqSet n)        -- One eqn, which can't fail
218    | first_eqn_all_vars && null rs      -- One eqn, but it can fail
219    = ([(takeList ps (repeat nlWildPat),[])], unitUniqSet n)
221    | first_eqn_all_vars         -- Several eqns, first can fail
222    = (pats, addOneToUniqSet indexs n)
223   where
224     first_eqn_all_vars = all_vars ps
225     (pats,indexs) = check' rs
227 check' qs
228    | some_literals     = split_by_literals qs
229    | some_constructors = split_by_constructor qs
230    | only_vars         = first_column_only_vars qs
231    | otherwise = pprPanic "Check.check': Not implemented :-(" (ppr first_pats)
232                  -- Shouldn't happen
233   where
234      -- Note: RecPats will have been simplified to ConPats
235      --       at this stage.
236     first_pats        = ASSERT2( okGroup qs, pprGroup qs ) map firstPatN qs
237     some_constructors = any is_con first_pats
238     some_literals     = any is_lit first_pats
239     only_vars         = all is_var first_pats
240 \end{code}
242 Here begins the code to deal with literals, we need to split the matrix
243 in different matrix beginning by each literal and a last matrix with the
244 rest of values.
246 \begin{code}
247 split_by_literals :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
248 split_by_literals qs = process_literals used_lits qs
249            where
250              used_lits = get_used_lits qs
251 \end{code}
253 @process_explicit_literals@ is a function that process each literal that appears
254 in the column of the matrix.
256 \begin{code}
257 process_explicit_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
258 process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)
259     where
260       pats_indexs   = map (\x -> construct_literal_matrix x qs) lits
261       (pats,indexs) = unzip pats_indexs
262 \end{code}
265 @process_literals@ calls @process_explicit_literals@ to deal with the literals
266 that appears in the matrix and deal also with the rest of the cases. It
267 must be one Variable to be complete.
269 \begin{code}
271 process_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
272 process_literals used_lits qs
273   | null default_eqns  = ASSERT( not (null qs) ) ([make_row_vars used_lits (head qs)] ++ pats,indexs)
274   | otherwise          = (pats_default,indexs_default)
275      where
276        (pats,indexs)   = process_explicit_literals used_lits qs
277        default_eqns    = ASSERT2( okGroup qs, pprGroup qs )
278                          [remove_var q | q <- qs, is_var (firstPatN q)]
279        (pats',indexs') = check' default_eqns
280        pats_default    = [(nlWildPat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats
281        indexs_default  = unionUniqSets indexs' indexs
282 \end{code}
284 Here we have selected the literal and we will select all the equations that
285 begins for that literal and create a new matrix.
287 \begin{code}
288 construct_literal_matrix :: HsLit -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
289 construct_literal_matrix lit qs =
290     (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)
291   where
292     (pats,indexs) = (check' (remove_first_column_lit lit qs))
293     new_lit = nlLitPat lit
295 remove_first_column_lit :: HsLit
296                         -> [(EqnNo, EquationInfo)]
297                         -> [(EqnNo, EquationInfo)]
298 remove_first_column_lit lit qs
299   = ASSERT2( okGroup qs, pprGroup qs )
300     [(n, shift_pat eqn) | q@(n,eqn) <- qs, is_var_lit lit (firstPatN q)]
301   where
302      shift_pat eqn@(EqnInfo { eqn_pats = _:ps}) = eqn { eqn_pats = ps }
303      shift_pat _                                = panic "Check.shift_var: no patterns"
304 \end{code}
306 This function splits the equations @qs@ in groups that deal with the
307 same constructor.
309 \begin{code}
310 split_by_constructor :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
311 split_by_constructor qs
312   | notNull unused_cons = need_default_case used_cons unused_cons qs
313   | otherwise           = no_need_default_case used_cons qs
314                        where
315                           used_cons   = get_used_cons qs
316                           unused_cons = get_unused_cons used_cons
317 \end{code}
319 The first column of the patterns matrix only have vars, then there is
320 nothing to do.
322 \begin{code}
323 first_column_only_vars :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
324 first_column_only_vars qs = (map (\ (xs,ys) -> (nlWildPat:xs,ys)) pats,indexs)
325                           where
326                             (pats, indexs) = check' (map remove_var qs)
327 \end{code}
329 This equation takes a matrix of patterns and split the equations by
330 constructor, using all the constructors that appears in the first column
331 of the pattern matching.
333 We can need a default clause or not ...., it depends if we used all the
334 constructors or not explicitly. The reasoning is similar to @process_literals@,
335 the difference is that here the default case is not always needed.
337 \begin{code}
338 no_need_default_case :: [Pat Id] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
339 no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
340     where
341       pats_indexs   = map (\x -> construct_matrix x qs) cons
342       (pats,indexs) = unzip pats_indexs
344 need_default_case :: [Pat Id] -> [DataCon] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
345 need_default_case used_cons unused_cons qs
346   | null default_eqns  = (pats_default_no_eqns,indexs)
347   | otherwise          = (pats_default,indexs_default)
348      where
349        (pats,indexs)   = no_need_default_case used_cons qs
350        default_eqns    = ASSERT2( okGroup qs, pprGroup qs )
351                          [remove_var q | q <- qs, is_var (firstPatN q)]
352        (pats',indexs') = check' default_eqns
353        pats_default    = [(make_whole_con c:ps,constraints) |
354                           c <- unused_cons, (ps,constraints) <- pats'] ++ pats
355        new_wilds       = ASSERT( not (null qs) ) make_row_vars_for_constructor (head qs)
356        pats_default_no_eqns =  [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats
357        indexs_default  = unionUniqSets indexs' indexs
359 construct_matrix :: Pat Id -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
360 construct_matrix con qs =
361     (map (make_con con) pats,indexs)
362   where
363     (pats,indexs) = (check' (remove_first_column con qs))
364 \end{code}
366 Here remove first column is more difficult that with literals due to the fact
367 that constructors can have arguments.
369 For instance, the matrix
370 \begin{verbatim}
371  (: x xs) y
372  z        y
373 \end{verbatim}
374 is transformed in:
375 \begin{verbatim}
376  x xs y
377  _ _  y
378 \end{verbatim}
380 \begin{code}
381 remove_first_column :: Pat Id                -- Constructor
382                     -> [(EqnNo, EquationInfo)]
383                     -> [(EqnNo, EquationInfo)]
384 remove_first_column (ConPatOut{ pat_con = L _ con, pat_args = PrefixCon con_pats }) qs
385   = ASSERT2( okGroup qs, pprGroup qs )
386     [(n, shift_var eqn) | q@(n, eqn) <- qs, is_var_con con (firstPatN q)]
387   where
388      new_wilds = [WildPat (hsLPatType arg_pat) | arg_pat <- con_pats]
389      shift_var eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_args = PrefixCon ps' } : ps})
390         = eqn { eqn_pats = map unLoc ps' ++ ps }
391      shift_var eqn@(EqnInfo { eqn_pats = WildPat _ : ps })
392         = eqn { eqn_pats = new_wilds ++ ps }
393      shift_var _ = panic "Check.Shift_var:No done"
394 remove_first_column _ _ = panic "Check.remove_first_column: Not ConPatOut"
396 make_row_vars :: [HsLit] -> (EqnNo, EquationInfo) -> ExhaustivePat
397 make_row_vars used_lits (_, EqnInfo { eqn_pats = pats})
398    = (nlVarPat new_var:takeList (tail pats) (repeat nlWildPat),[(new_var,used_lits)])
399   where
400      new_var = hash_x
402 hash_x :: Name
403 hash_x = mkInternalName unboundKey {- doesn't matter much -}
404                      (mkVarOccFS (fsLit "#x"))
405                      noSrcSpan
407 make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat]
408 make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats})
409   = takeList (tail pats) (repeat nlWildPat)
411 compare_cons :: Pat Id -> Pat Id -> Bool
412 compare_cons (ConPatOut{ pat_con = L _ id1 }) (ConPatOut { pat_con = L _ id2 }) = id1 == id2
413 compare_cons _ _ = panic "Check.compare_cons: Not ConPatOut"
415 remove_dups :: [Pat Id] -> [Pat Id]
416 remove_dups []     = []
417 remove_dups (x:xs) | or (map (\y -> compare_cons x y) xs) = remove_dups  xs
418                    | otherwise                            = x : remove_dups xs
420 get_used_cons :: [(EqnNo, EquationInfo)] -> [Pat Id]
421 get_used_cons qs = remove_dups [pat | q <- qs, let pat = firstPatN q,
422                                       isConPatOut pat]
424 isConPatOut :: Pat Id -> Bool
425 isConPatOut (ConPatOut {}) = True
426 isConPatOut _              = False
428 remove_dups' :: [HsLit] -> [HsLit]
429 remove_dups' []                   = []
430 remove_dups' (x:xs) | x elem xs = remove_dups' xs
431                     | otherwise   = x : remove_dups' xs
434 get_used_lits :: [(EqnNo, EquationInfo)] -> [HsLit]
435 get_used_lits qs = remove_dups' all_literals
436                  where
437                    all_literals = get_used_lits' qs
439 get_used_lits' :: [(EqnNo, EquationInfo)] -> [HsLit]
440 get_used_lits' [] = []
441 get_used_lits' (q:qs)
442   | Just lit <- get_lit (firstPatN q) = lit : get_used_lits' qs
443   | otherwise                         = get_used_lits qs
445 get_lit :: Pat id -> Maybe HsLit
446 -- Get a representative HsLit to stand for the OverLit
447 -- It doesn't matter which one, because they will only be compared
448 -- with other HsLits gotten in the same way
449 get_lit (LitPat lit)                                      = Just lit
450 get_lit (NPat (OverLit { ol_val = HsIntegral i})    mb _) = Just (HsIntPrim   (mb_neg negate              mb i))
451 get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg negateFractionalLit mb f))
452 get_lit (NPat (OverLit { ol_val = HsIsString s })   _  _) = Just (HsStringPrim (fastStringToByteString s))
453 get_lit _                                                 = Nothing
455 mb_neg :: (a -> a) -> Maybe b -> a -> a
456 mb_neg _      Nothing  v = v
457 mb_neg negate (Just _) v = negate v
459 get_unused_cons :: [Pat Id] -> [DataCon]
460 get_unused_cons used_cons = ASSERT( not (null used_cons) ) unused_cons
461      where
462        used_set :: UniqSet DataCon
463        used_set = mkUniqSet [d | ConPatOut{ pat_con = L _ d} <- used_cons]
464        (ConPatOut { pat_ty = ty }) = head used_cons
465        Just (ty_con, inst_tys) = splitTyConApp_maybe ty
466        unused_cons = filterOut is_used (tyConDataCons ty_con)
467        is_used con = con elementOfUniqSet used_set
468                      || dataConCannotMatch inst_tys con
470 all_vars :: [Pat Id] -> Bool
471 all_vars []             = True
472 all_vars (WildPat _:ps) = all_vars ps
473 all_vars _              = False
475 remove_var :: (EqnNo, EquationInfo) -> (EqnNo, EquationInfo)
476 remove_var (n, eqn@(EqnInfo { eqn_pats = WildPat _ : ps})) = (n, eqn { eqn_pats = ps })
477 remove_var _  = panic "Check.remove_var: equation does not begin with a variable"
479 -----------------------
480 eqnPats :: (EqnNo, EquationInfo) -> [Pat Id]
481 eqnPats (_, eqn) = eqn_pats eqn
483 okGroup :: [(EqnNo, EquationInfo)] -> Bool
484 -- True if all equations have at least one pattern, and
485 -- all have the same number of patterns
486 okGroup [] = True
487 okGroup (e:es) = n_pats > 0 && and [length (eqnPats e) == n_pats | e <- es]
488                where
489                  n_pats = length (eqnPats e)
491 -- Half-baked print
492 pprGroup :: [(EqnNo, EquationInfo)] -> SDoc
493 pprEqnInfo :: (EqnNo, EquationInfo) -> SDoc
494 pprGroup es = vcat (map pprEqnInfo es)
495 pprEqnInfo e = ppr (eqnPats e)
498 firstPatN :: (EqnNo, EquationInfo) -> Pat Id
499 firstPatN (_, eqn) = firstPat eqn
501 is_con :: Pat Id -> Bool
502 is_con (ConPatOut {}) = True
503 is_con _              = False
505 is_lit :: Pat Id -> Bool
506 is_lit (LitPat _)      = True
507 is_lit (NPat _ _ _)  = True
508 is_lit _               = False
510 is_var :: Pat Id -> Bool
511 is_var (WildPat _) = True
512 is_var _           = False
514 is_var_con :: DataCon -> Pat Id -> Bool
515 is_var_con _   (WildPat _)                                 = True
516 is_var_con con (ConPatOut{ pat_con = L _ id }) | id == con = True
517 is_var_con _   _                                           = False
519 is_var_lit :: HsLit -> Pat Id -> Bool
520 is_var_lit _   (WildPat _)   = True
521 is_var_lit lit pat
522   | Just lit' <- get_lit pat = lit == lit'
523   | otherwise                = False
524 \end{code}
526 The difference beteewn @make_con@ and @make_whole_con@ is that
527 @make_wole_con@ creates a new constructor with all their arguments, and
528 @make_con@ takes a list of argumntes, creates the contructor getting their
529 arguments from the list. See where \fbox{\ ???\ } are used for details.
531 We need to reconstruct the patterns (make the constructors infix and
532 similar) at the same time that we create the constructors.
534 You can tell tuple constructors using
535 \begin{verbatim}
536         Id.isTupleDataCon
537 \end{verbatim}
538 You can see if one constructor is infix with this clearer code :-))))))))))
539 \begin{verbatim}
540         Lex.isLexConSym (Name.occNameString (Name.getOccName con))
541 \end{verbatim}
543        Rather clumsy but it works. (Simon Peyton Jones)
546 We don't mind the @nilDataCon@ because it doesn't change the way to
547 print the messsage, we are searching only for things like: @[1,2,3]@,
548 not @x:xs@ ....
550 In @reconstruct_pat@ we want to undo'' the work
551 that we have done in @tidy_pat@.
552 In particular:
553 \begin{tabular}{lll}
554         @((,) x y)@   & returns to be & @(x, y)@
555 \\      @((:) x xs)@  & returns to be & @(x:xs)@
556 \\      @(x:(...:[])@ & returns to be & @[x,...]@
557 \end{tabular}
558 %
559 The difficult case is the third one becouse we need to follow all the
560 contructors until the @[]@ to know that we need to use the second case,
561 not the second. \fbox{\ ???\ }
562 %
563 \begin{code}
564 isInfixCon :: DataCon -> Bool
565 isInfixCon con = isDataSymOcc (getOccName con)
567 is_nil :: Pat Name -> Bool
568 is_nil (ConPatIn con (PrefixCon [])) = unLoc con == getName nilDataCon
569 is_nil _                             = False
571 is_list :: Pat Name -> Bool
572 is_list (ListPat _ _ Nothing) = True
573 is_list _             = False
575 return_list :: DataCon -> Pat Name -> Bool
576 return_list id q = id == consDataCon && (is_nil q || is_list q)
578 make_list :: LPat Name -> Pat Name -> Pat Name
579 make_list p q | is_nil q    = ListPat [p] placeHolderType Nothing
580 make_list p (ListPat ps ty Nothing) = ListPat (p:ps) ty Nothing
581 make_list _ _               = panic "Check.make_list: Invalid argument"
583 make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat
584 make_con (ConPatOut{ pat_con = L _ id }) (lp:lq:ps, constraints)
585      | return_list id q = (noLoc (make_list lp q) : ps, constraints)
586      | isInfixCon id    = (nlInfixConPat (getName id) lp lq : ps, constraints)
587    where q  = unLoc lq
589 make_con (ConPatOut{ pat_con = L _ id, pat_args = PrefixCon pats, pat_ty = ty }) (ps, constraints)
590       | isTupleTyCon tc  = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) ty) : rest_pats, constraints)
591       | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType)           : rest_pats, constraints)
592       | otherwise        = (nlConPat name pats_con      : rest_pats, constraints)
593     where
594         name                  = getName id
595         (pats_con, rest_pats) = splitAtList pats ps
596         tc                    = dataConTyCon id
598 make_con _ _ = panic "Check.make_con: Not ConPatOut"
600 -- reconstruct parallel array pattern
601 --
602 --  * don't check for the type only; we need to make sure that we are really
603 --   dealing with one of the fake constructors and not with the real
604 --   representation
606 make_whole_con :: DataCon -> WarningPat
607 make_whole_con con | isInfixCon con = nlInfixConPat name nlWildPat nlWildPat
608                    | otherwise      = nlConPat name pats
609                 where
610                   name   = getName con
611                   pats   = [nlWildPat | _ <- dataConOrigArgTys con]
612 \end{code}
614 ------------------------------------------------------------------------
615                    Tidying equations
616 ------------------------------------------------------------------------
618 tidy_eqn does more or less the same thing as @tidy@ in @Match.lhs@;
619 that is, it removes syntactic sugar, reducing the number of cases that
620 must be handled by the main checking algorithm.  One difference is
621 that here we can do *all* the tidying at once (recursively), rather
622 than doing it incrementally.
624 \begin{code}
625 tidy_eqn :: EquationInfo -> EquationInfo
626 tidy_eqn eqn = eqn { eqn_pats = map tidy_pat (eqn_pats eqn),
627                      eqn_rhs  = tidy_rhs (eqn_rhs eqn) }
628   where
629         -- Horrible hack.  The tidy_pat stuff converts "might-fail" patterns to
630         -- WildPats which of course loses the info that they can fail to match.
631         -- So we stick in a CanFail as if it were a guard.
632     tidy_rhs (MatchResult can_fail body)
633         | any might_fail_pat (eqn_pats eqn) = MatchResult CanFail body
634         | otherwise                         = MatchResult can_fail body
636 --------------
637 might_fail_pat :: Pat Id -> Bool
638 -- Returns True of patterns that might fail (i.e. fall through) in a way
639 -- that is not covered by the checking algorithm.  Specifically:
640 --         NPlusKPat
641 --         ViewPat (if refutable)
643 -- First the two special cases
644 might_fail_pat (NPlusKPat {})                = True
645 might_fail_pat (ViewPat _ p _)               = not (isIrrefutableHsPat p)
647 -- Now the recursive stuff
648 might_fail_pat (ParPat p)                    = might_fail_lpat p
649 might_fail_pat (AsPat _ p)                   = might_fail_lpat p
650 might_fail_pat (SigPatOut p _ )              = might_fail_lpat p
651 might_fail_pat (ListPat ps _ Nothing)        = any might_fail_lpat ps
652 might_fail_pat (ListPat _ _ (Just _))      = True
653 might_fail_pat (TuplePat ps _ _)             = any might_fail_lpat ps
654 might_fail_pat (PArrPat ps _)                = any might_fail_lpat ps
655 might_fail_pat (BangPat p)                   = might_fail_lpat p
656 might_fail_pat (ConPatOut { pat_args = ps }) = any might_fail_lpat (hsConPatArgs ps)
658 -- Finally the ones that are sure to succeed, or which are covered by the checking algorithm
659 might_fail_pat (LazyPat _)                   = False -- Always succeeds
660 might_fail_pat _                             = False -- VarPat, WildPat, LitPat, NPat
662 --------------
663 might_fail_lpat :: LPat Id -> Bool
664 might_fail_lpat (L _ p) = might_fail_pat p
666 --------------
667 tidy_lpat :: LPat Id -> LPat Id
668 tidy_lpat p = fmap tidy_pat p
670 --------------
671 tidy_pat :: Pat Id -> Pat Id
672 tidy_pat pat@(WildPat _)  = pat
673 tidy_pat (VarPat id)      = WildPat (idType id)
674 tidy_pat (ParPat p)       = tidy_pat (unLoc p)
675 tidy_pat (LazyPat p)      = WildPat (hsLPatType p)      -- For overlap and exhaustiveness checking
676                                                         -- purposes, a ~pat is like a wildcard
677 tidy_pat (BangPat p)      = tidy_pat (unLoc p)
678 tidy_pat (AsPat _ p)      = tidy_pat (unLoc p)
679 tidy_pat (SigPatOut p _)  = tidy_pat (unLoc p)
680 tidy_pat (CoPat _ pat _)  = tidy_pat pat
682 -- These two are might_fail patterns, so we map them to
683 -- WildPats.  The might_fail_pat stuff arranges that the
684 -- guard says "this equation might fall through".
685 tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id))
686 tidy_pat (ViewPat _ _ ty)     = WildPat ty
687 tidy_pat (ListPat _ _ (Just (ty,_))) = WildPat ty
689 tidy_pat pat@(ConPatOut { pat_con = L _ id, pat_args = ps })
690   = pat { pat_args = tidy_con id ps }
692 tidy_pat (ListPat ps ty Nothing)
693   = unLoc $foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty) 694 (mkNilPat list_ty) 695 (map tidy_lpat ps) 696 where list_ty = mkListTy ty 698 -- introduce fake parallel array constructors to be able to handle parallel 699 -- arrays with the existing machinery for constructor pattern 700 -- 701 tidy_pat (PArrPat ps ty) 702 = unLoc$ mkPrefixConPat (parrFakeCon (length ps))
703                            (map tidy_lpat ps)
704                            (mkPArrTy ty)
706 tidy_pat (TuplePat ps boxity ty)
707   = unLoc $mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) 708 (map tidy_lpat ps) ty 709 where 710 arity = length ps 712 tidy_pat (NPat lit mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq 713 tidy_pat (LitPat lit) = tidy_lit_pat lit 715 tidy_pat (ConPatIn {}) = panic "Check.tidy_pat: ConPatIn" 716 tidy_pat (QuasiQuotePat {}) = panic "Check.tidy_pat: QuasiQuotePat" 717 tidy_pat (SigPatIn {}) = panic "Check.tidy_pat: SigPatIn" 719 tidy_lit_pat :: HsLit -> Pat Id 720 -- Unpack string patterns fully, so we can see when they 721 -- overlap with each other, or even explicit lists of Chars. 722 tidy_lit_pat lit 723 | HsString s <- lit 724 = unLoc$ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
725                   (mkPrefixConPat nilDataCon [] stringTy) (unpackFS s)
726   | otherwise
727   = tidyLitPat lit
729 -----------------
730 tidy_con :: DataCon -> HsConPatDetails Id -> HsConPatDetails Id
731 tidy_con _   (PrefixCon ps)   = PrefixCon (map tidy_lpat ps)
732 tidy_con _   (InfixCon p1 p2) = PrefixCon [tidy_lpat p1, tidy_lpat p2]
733 tidy_con con (RecCon (HsRecFields fs _))
734   | null fs   = PrefixCon [nlWildPat | _ <- dataConOrigArgTys con]
735                 -- Special case for null patterns; maybe not a record at all
736   | otherwise = PrefixCon (map (tidy_lpat.snd) all_pats)
737   where
738      -- pad out all the missing fields with WildPats.
739     field_pats = map (\ f -> (f, nlWildPat)) (dataConFieldLabels con)
740     all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc)
741                      field_pats fs
743     insertNm nm p [] = [(nm,p)]
744     insertNm nm p (x@(n,_):xs)
745       | nm == n    = (nm,p):xs
746       | otherwise  = x : insertNm nm p xs
747 \end{code}