2 % (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
4 % Author: Juan J. Quintela <quintela@krilin.dc.fi.udc.es>
5 \section{Module @Check@ in @deSugar@}
10 module Check ( check , ExhaustivePat ) where
14 import TcHsSyn ( TypecheckedPat )
15 import DsHsSyn ( outPatType )
16 import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet,
17 CanItFail(..), tidyLitPat, tidyNPat,
20 import DataCon ( DataCon, dataConTyCon, dataConArgTys,
21 dataConSourceArity, dataConFieldLabels )
22 import Name ( Name, mkLocalName, getOccName, isDataSymOcc, getName, mkVarOcc )
23 import Type ( splitAlgTyConApp, mkTyVarTys, splitTyConApp_maybe )
24 import TysPrim ( charPrimTy )
26 import PrelNames ( unboundKey )
27 import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
28 import BasicTypes ( Boxity(..) )
29 import SrcLoc ( noSrcLoc )
33 #include "HsVersions.h"
36 This module performs checks about if one list of equations are:
41 To discover that we go through the list of equations in a tree-like fashion.
43 If you like theory, a similar algorithm is described in:
45 {\em Two Techniques for Compiling Lazy Pattern Matching},
47 INRIA Rocquencourt (RR-2385, 1994)
49 The algorithm is based on the first technique, but there are some differences:
51 \item We don't generate code
52 \item We have constructors and literals (not only literals as in the
54 \item We don't use directions, we must select the columns from
57 (By the way the second technique is really similar to the one used in
58 @Match.lhs@ to generate code)
60 This function takes the equations of a pattern and returns:
62 \item The patterns that are not recognized
63 \item The equations that are not overlapped
65 It simplify the patterns and then call @check'@ (the same semantics), and it
66 needs to reconstruct the patterns again ....
68 The problem appear with things like:
73 We want to put the two patterns with the same syntax, (prefix form) and
74 then all the constructors are equal:
76 f (: x (: y [])) = ....
79 (more about that in @simplify_eqns@)
81 We would prefer to have a @WarningPat@ of type @String@, but Strings and the
82 Pretty Printer are not friends.
84 We use @InPat@ in @WarningPat@ instead of @OutPat@
85 because we need to print the
86 warning messages in the same way they are introduced, i.e. if the user
91 He don't want a warning message written:
93 f (: x (: y [])) ........
95 Then we need to use InPats.
97 Juan Quintela 5 JUL 1998\\
98 User-friendliness and compiler writers are no friends.
102 type WarningPat = InPat Name
103 type ExhaustivePat = ([WarningPat], [(Name, [HsLit])])
106 check :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
107 check qs = (untidy_warns, incomplete)
109 (warns, incomplete) = check' (simplify_eqns qs)
110 untidy_warns = map untidy_exhaustive warns
112 untidy_exhaustive :: ExhaustivePat -> ExhaustivePat
113 untidy_exhaustive ([pat], messages) =
114 ([untidy_no_pars pat], map untidy_message messages)
115 untidy_exhaustive (pats, messages) =
116 (map untidy_pars pats, map untidy_message messages)
118 untidy_message :: (Name, [HsLit]) -> (Name, [HsLit])
119 untidy_message (string, lits) = (string, map untidy_lit lits)
122 The function @untidy@ does the reverse work of the @simplify_pat@ funcion.
128 untidy_no_pars :: WarningPat -> WarningPat
129 untidy_no_pars p = untidy False p
131 untidy_pars :: WarningPat -> WarningPat
132 untidy_pars p = untidy True p
134 untidy :: NeedPars -> WarningPat -> WarningPat
135 untidy _ p@WildPatIn = p
136 untidy _ p@(VarPatIn name) = p
137 untidy _ (LitPatIn lit) = LitPatIn (untidy_lit lit)
138 untidy _ p@(ConPatIn name []) = p
139 untidy b (ConPatIn name pats) =
140 pars b (ConPatIn name (map untidy_pars pats))
141 untidy b (ConOpPatIn pat1 name fixity pat2) =
142 pars b (ConOpPatIn (untidy_pars pat1) name fixity (untidy_pars pat2))
143 untidy _ (ListPatIn pats) = ListPatIn (map untidy_no_pars pats)
144 untidy _ (TuplePatIn pats boxed) = TuplePatIn (map untidy_no_pars pats) boxed
146 untidy _ pat = pprPanic "Check.untidy: SigPatIn" (ppr pat)
148 pars :: NeedPars -> WarningPat -> WarningPat
149 pars True p = ParPatIn p
152 untidy_lit :: HsLit -> HsLit
153 untidy_lit (HsCharPrim c) = HsChar c
154 --untidy_lit (HsStringPrim s) = HsString s
158 This equation is the same that check, the only difference is that the
159 boring work is done, that work needs to be done only once, this is
160 the reason top have two functions, check is the external interface,
161 @check'@ is called recursively.
163 There are several cases:
166 \item There are no equations: Everything is OK.
167 \item There are only one equation, that can fail, and all the patterns are
168 variables. Then that equation is used and the same equation is
170 \item All the patterns are variables, and the match can fail, there are
171 more equations then the results is the result of the rest of equations
172 and this equation is used also.
174 \item The general case, if all the patterns are variables (here the match
175 can't fail) then the result is that this equation is used and this
176 equation doesn't generate non-exhaustive cases.
178 \item In the general case, there can exist literals ,constructors or only
179 vars in the first column, we actuate in consequence.
186 check' :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
187 check' [] = ([([],[])],emptyUniqSet)
189 check' [EqnInfo n ctx ps (MatchResult CanFail _)]
190 | all_vars ps = ([(take (length ps) (repeat new_wild_pat),[])], unitUniqSet n)
192 check' qs@((EqnInfo n ctx ps (MatchResult CanFail _)):rs)
193 | all_vars ps = (pats, addOneToUniqSet indexs n)
195 (pats,indexs) = check' rs
197 check' qs@((EqnInfo n ctx ps result):_)
198 | all_vars ps = ([], unitUniqSet n)
199 -- | nplusk = panic "Check.check': Work in progress: nplusk"
200 -- | npat = panic "Check.check': Work in progress: npat ?????"
201 | literals = split_by_literals qs
202 | constructors = split_by_constructor qs
203 | only_vars = first_column_only_vars qs
204 | otherwise = panic "Check.check': Not implemented :-("
206 -- Note: RecPats will have been simplified to ConPats
208 constructors = or (map is_con qs)
209 literals = or (map is_lit qs)
210 only_vars = and (map is_var qs)
211 -- npat = or (map is_npat qs)
212 -- nplusk = or (map is_nplusk qs)
215 Here begins the code to deal with literals, we need to split the matrix
216 in different matrix beginning by each literal and a last matrix with the
220 split_by_literals :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
221 split_by_literals qs = process_literals used_lits qs
223 used_lits = get_used_lits qs
226 @process_explicit_literals@ is a function that process each literal that appears
227 in the column of the matrix.
230 process_explicit_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
231 process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)
233 pats_indexs = map (\x -> construct_literal_matrix x qs) lits
234 (pats,indexs) = unzip pats_indexs
239 @process_literals@ calls @process_explicit_literals@ to deal with the literals
240 that appears in the matrix and deal also with the rest of the cases. It
241 must be one Variable to be complete.
245 process_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
246 process_literals used_lits qs
247 | length default_eqns == 0 = ([make_row_vars used_lits (head qs)]++pats,indexs)
248 | otherwise = (pats_default,indexs_default)
250 (pats,indexs) = process_explicit_literals used_lits qs
251 default_eqns = (map remove_var (filter is_var qs))
252 (pats',indexs') = check' default_eqns
253 pats_default = [(new_wild_pat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats
254 indexs_default = unionUniqSets indexs' indexs
257 Here we have selected the literal and we will select all the equations that
258 begins for that literal and create a new matrix.
261 construct_literal_matrix :: HsLit -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
262 construct_literal_matrix lit qs =
263 (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)
265 (pats,indexs) = (check' (remove_first_column_lit lit qs))
266 new_lit = LitPatIn lit
268 remove_first_column_lit :: HsLit
271 remove_first_column_lit lit qs =
272 map shift_pat (filter (is_var_lit lit) qs)
274 shift_pat (EqnInfo n ctx [] result) = panic "Check.shift_var: no patterns"
275 shift_pat (EqnInfo n ctx (_:ps) result) = EqnInfo n ctx ps result
279 This function splits the equations @qs@ in groups that deal with the
284 split_by_constructor :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
286 split_by_constructor qs | length unused_cons /= 0 = need_default_case used_cons unused_cons qs
287 | otherwise = no_need_default_case used_cons qs
289 used_cons = get_used_cons qs
290 unused_cons = get_unused_cons used_cons
294 The first column of the patterns matrix only have vars, then there is
298 first_column_only_vars :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
299 first_column_only_vars qs = (map (\ (xs,ys) -> (new_wild_pat:xs,ys)) pats,indexs)
301 (pats,indexs) = check' (map remove_var qs)
305 This equation takes a matrix of patterns and split the equations by
306 constructor, using all the constructors that appears in the first column
307 of the pattern matching.
309 We can need a default clause or not ...., it depends if we used all the
310 constructors or not explicitly. The reasoning is similar to @process_literals@,
311 the difference is that here the default case is not always needed.
314 no_need_default_case :: [TypecheckedPat] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
315 no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
317 pats_indexs = map (\x -> construct_matrix x qs) cons
318 (pats,indexs) = unzip pats_indexs
320 need_default_case :: [TypecheckedPat] -> [DataCon] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
321 need_default_case used_cons unused_cons qs
322 | length default_eqns == 0 = (pats_default_no_eqns,indexs)
323 | otherwise = (pats_default,indexs_default)
325 (pats,indexs) = no_need_default_case used_cons qs
326 default_eqns = (map remove_var (filter is_var qs))
327 (pats',indexs') = check' default_eqns
328 pats_default = [(make_whole_con c:ps,constraints) |
329 c <- unused_cons, (ps,constraints) <- pats'] ++ pats
330 new_wilds = make_row_vars_for_constructor (head qs)
331 pats_default_no_eqns = [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats
332 indexs_default = unionUniqSets indexs' indexs
334 construct_matrix :: TypecheckedPat -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
335 construct_matrix con qs =
336 (map (make_con con) pats,indexs)
338 (pats,indexs) = (check' (remove_first_column con qs))
341 Here remove first column is more difficult that with literals due to the fact
342 that constructors can have arguments.
344 For instance, the matrix
356 remove_first_column :: TypecheckedPat -- Constructor
359 remove_first_column (ConPat con _ _ _ con_pats) qs =
360 map shift_var (filter (is_var_con con) qs)
362 new_wilds = [WildPat (outPatType arg_pat) | arg_pat <- con_pats]
363 shift_var (EqnInfo n ctx (ConPat _ _ _ _ ps':ps) result) =
364 EqnInfo n ctx (ps'++ps) result
365 shift_var (EqnInfo n ctx (WildPat _ :ps) result) =
366 EqnInfo n ctx (new_wilds ++ ps) result
367 shift_var _ = panic "Check.Shift_var:No done"
369 make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat
370 make_row_vars used_lits (EqnInfo _ _ pats _ ) =
371 (VarPatIn new_var:take (length (tail pats)) (repeat new_wild_pat),[(new_var,used_lits)])
372 where new_var = hash_x
374 hash_x = mkLocalName unboundKey {- doesn't matter much -}
375 (mkVarOcc SLIT("#x"))
378 make_row_vars_for_constructor :: EquationInfo -> [WarningPat]
379 make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = take (length (tail pats)) (repeat new_wild_pat)
381 compare_cons :: TypecheckedPat -> TypecheckedPat -> Bool
382 compare_cons (ConPat id1 _ _ _ _) (ConPat id2 _ _ _ _) = id1 == id2
384 remove_dups :: [TypecheckedPat] -> [TypecheckedPat]
386 remove_dups (x:xs) | or (map (\y -> compare_cons x y) xs) = remove_dups xs
387 | otherwise = x : remove_dups xs
389 get_used_cons :: [EquationInfo] -> [TypecheckedPat]
390 get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPat _ _ _ _ _):_) _) <- qs ]
392 remove_dups' :: [HsLit] -> [HsLit]
394 remove_dups' (x:xs) | x `elem` xs = remove_dups' xs
395 | otherwise = x : remove_dups' xs
398 get_used_lits :: [EquationInfo] -> [HsLit]
399 get_used_lits qs = remove_dups' all_literals
401 all_literals = get_used_lits' qs
403 get_used_lits' :: [EquationInfo] -> [HsLit]
404 get_used_lits' [] = []
405 get_used_lits' ((EqnInfo _ _ ((LitPat lit _):_) _):qs) =
406 lit : get_used_lits qs
407 get_used_lits' ((EqnInfo _ _ ((NPat lit _ _):_) _):qs) =
408 lit : get_used_lits qs
409 get_used_lits' (q:qs) =
412 get_unused_cons :: [TypecheckedPat] -> [DataCon]
413 get_unused_cons used_cons = unused_cons
415 (ConPat _ ty _ _ _) = head used_cons
416 Just (ty_con,_) = sTyConApp_maybe used_cons ty
417 all_cons = tyConDataCons ty_con
418 used_cons_as_id = map (\ (ConPat d _ _ _ _) -> d) used_cons
419 unused_cons = uniqSetToList
420 (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
422 sTyConApp_maybe used_cons ty =
423 case splitTyConApp_maybe ty of
425 Nothing -> pprTrace "splitTyConApp_maybe" (ppr (used_cons, ty)) $ Nothing
427 all_vars :: [TypecheckedPat] -> Bool
429 all_vars (WildPat _:ps) = all_vars ps
432 remove_var :: EquationInfo -> EquationInfo
433 remove_var (EqnInfo n ctx (WildPat _:ps) result) = EqnInfo n ctx ps result
435 panic "Check.remove_var: equation does not begin with a variable"
437 is_con :: EquationInfo -> Bool
438 is_con (EqnInfo _ _ ((ConPat _ _ _ _ _):_) _) = True
441 is_lit :: EquationInfo -> Bool
442 is_lit (EqnInfo _ _ ((LitPat _ _):_) _) = True
443 is_lit (EqnInfo _ _ ((NPat _ _ _):_) _) = True
446 is_npat :: EquationInfo -> Bool
447 is_npat (EqnInfo _ _ ((NPat _ _ _):_) _) = True
450 is_nplusk :: EquationInfo -> Bool
451 is_nplusk (EqnInfo _ _ ((NPlusKPat _ _ _ _ _):_) _) = True
454 is_var :: EquationInfo -> Bool
455 is_var (EqnInfo _ _ ((WildPat _):_) _) = True
458 is_var_con :: DataCon -> EquationInfo -> Bool
459 is_var_con con (EqnInfo _ _ ((WildPat _):_) _) = True
460 is_var_con con (EqnInfo _ _ ((ConPat id _ _ _ _):_) _) | id == con = True
461 is_var_con con _ = False
463 is_var_lit :: HsLit -> EquationInfo -> Bool
464 is_var_lit lit (EqnInfo _ _ ((WildPat _):_) _) = True
465 is_var_lit lit (EqnInfo _ _ ((LitPat lit' _):_) _) | lit == lit' = True
466 is_var_lit lit (EqnInfo _ _ ((NPat lit' _ _):_) _) | lit == lit' = True
467 is_var_lit lit _ = False
470 The difference beteewn @make_con@ and @make_whole_con@ is that
471 @make_wole_con@ creates a new constructor with all their arguments, and
472 @make_con@ takes a list of argumntes, creates the contructor getting their
473 arguments from the list. See where \fbox{\ ???\ } are used for details.
475 We need to reconstruct the patterns (make the constructors infix and
476 similar) at the same time that we create the constructors.
478 You can tell tuple constructors using
482 You can see if one constructor is infix with this clearer code :-))))))))))
484 Lex.isLexConSym (Name.occNameString (Name.getOccName con))
487 Rather clumsy but it works. (Simon Peyton Jones)
490 We don't mind the @nilDataCon@ because it doesn't change the way to
491 print the messsage, we are searching only for things like: @[1,2,3]@,
494 In @reconstruct_pat@ we want to ``undo'' the work
495 that we have done in @simplify_pat@.
498 @((,) x y)@ & returns to be & @(x, y)@
499 \\ @((:) x xs)@ & returns to be & @(x:xs)@
500 \\ @(x:(...:[])@ & returns to be & @[x,...]@
503 The difficult case is the third one becouse we need to follow all the
504 contructors until the @[]@ to know that we need to use the second case,
505 not the second. \fbox{\ ???\ }
508 isInfixCon con = isDataSymOcc (getOccName con)
510 is_nil (ConPatIn con []) = con == getName nilDataCon
513 is_list (ListPatIn _) = True
516 return_list id q = id == consDataCon && (is_nil q || is_list q)
518 make_list p q | is_nil q = ListPatIn [p]
519 make_list p (ListPatIn ps) = ListPatIn (p:ps)
520 make_list _ _ = panic "Check.make_list: Invalid argument"
522 make_con :: TypecheckedPat -> ExhaustivePat -> ExhaustivePat
523 make_con (ConPat id _ _ _ _) (p:q:ps, constraints)
524 | return_list id q = (make_list p q : ps, constraints)
525 | isInfixCon id = ((ConOpPatIn p name fixity q) : ps, constraints)
526 where name = getName id
527 fixity = panic "Check.make_con: Guessing fixity"
529 make_con (ConPat id _ _ _ pats) (ps,constraints)
530 | isTupleTyCon tc = (TuplePatIn pats_con (tupleTyConBoxity tc) : rest_pats, constraints)
531 | otherwise = (ConPatIn name pats_con : rest_pats, constraints)
532 where num_args = length pats
534 pats_con = take num_args ps
535 rest_pats = drop num_args ps
539 make_whole_con :: DataCon -> WarningPat
540 make_whole_con con | isInfixCon con = ConOpPatIn new_wild_pat name fixity new_wild_pat
541 | otherwise = ConPatIn name pats
543 fixity = panic "Check.make_whole_con: Guessing fixity"
545 arity = dataConSourceArity con
546 pats = take arity (repeat new_wild_pat)
549 new_wild_pat :: WarningPat
550 new_wild_pat = WildPatIn
553 This equation makes the same thing as @tidy@ in @Match.lhs@, the
554 difference is that here we can do all the tidy in one place and in the
555 @Match@ tidy it must be done one column each time due to bookkeeping
560 simplify_eqns :: [EquationInfo] -> [EquationInfo]
561 simplify_eqns [] = []
562 simplify_eqns ((EqnInfo n ctx pats result):qs) =
563 (EqnInfo n ctx pats' result) : simplify_eqns qs
565 pats' = map simplify_pat pats
567 simplify_pat :: TypecheckedPat -> TypecheckedPat
569 simplify_pat pat@(WildPat gt) = pat
570 simplify_pat (VarPat id) = WildPat (idType id)
572 simplify_pat (LazyPat p) = simplify_pat p
573 simplify_pat (AsPat id p) = simplify_pat p
575 simplify_pat (ConPat id ty tvs dicts ps) = ConPat id ty tvs dicts (map simplify_pat ps)
577 simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y])
578 (ConPat nilDataCon list_ty [] [] [])
579 (map simplify_pat ps)
580 where list_ty = mkListTy ty
583 simplify_pat (TuplePat ps boxity)
584 = ConPat (tupleCon boxity arity)
585 (mkTupleTy boxity arity (map outPatType ps)) [] []
586 (map simplify_pat ps)
590 simplify_pat (RecPat dc ty ex_tvs dicts [])
591 = ConPat dc ty ex_tvs dicts all_wild_pats
593 all_wild_pats = map WildPat con_arg_tys
595 -- identical to machinations in Match.tidy1:
596 (_, inst_tys, _) = splitAlgTyConApp ty
597 con_arg_tys = dataConArgTys dc (inst_tys ++ mkTyVarTys ex_tvs)
599 simplify_pat (RecPat dc ty ex_tvs dicts idps)
600 = ConPat dc ty ex_tvs dicts pats
602 pats = map (simplify_pat.snd) all_pats
604 -- pad out all the missing fields with WildPats.
605 field_pats = map (\ f -> (getName f, WildPat (panic "simplify_pat(RecPat-2)")))
606 (dataConFieldLabels dc)
609 ( \ (id,p,_) acc -> insertNm (getName id) p acc)
613 insertNm nm p [] = [(nm,p)]
614 insertNm nm p (x@(n,_):xs)
615 | nm == n = (nm,p):xs
616 | otherwise = x : insertNm nm p xs
618 simplify_pat pat@(LitPat lit lit_ty) = tidyLitPat lit pat
620 -- unpack string patterns fully, so we can see when they overlap with
621 -- each other, or even explicit lists of Chars.
622 simplify_pat pat@(NPat (HsString s) _ _) =
623 foldr (\c pat -> ConPat consDataCon stringTy [] [] [mk_char_lit c,pat])
624 (ConPat nilDataCon stringTy [] [] []) (_UNPK_INT_ s)
626 mk_char_lit c = ConPat charDataCon charTy [] []
627 [LitPat (HsCharPrim c) charPrimTy]
629 simplify_pat pat@(NPat lit lit_ty hsexpr) = tidyNPat lit lit_ty pat
631 simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) =
633 where ty = panic "Check.simplify_pat: Gessing ty"
635 simplify_pat (DictPat dicts methods) =
636 case num_of_d_and_ms of
637 0 -> simplify_pat (TuplePat [] Boxed)
638 1 -> simplify_pat (head dict_and_method_pats)
639 _ -> simplify_pat (TuplePat dict_and_method_pats Boxed)
641 num_of_d_and_ms = length dicts + length methods
642 dict_and_method_pats = map VarPat (dicts ++ methods)