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, outPatType )
15 import TcType ( tcTyConAppTyCon, tcTyConAppArgs )
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 TcType ( mkTyVarTys )
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 ty_con = tcTyConAppTyCon ty -- Newtype observable
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 all_vars :: [TypecheckedPat] -> Bool
424 all_vars (WildPat _:ps) = all_vars ps
427 remove_var :: EquationInfo -> EquationInfo
428 remove_var (EqnInfo n ctx (WildPat _:ps) result) = EqnInfo n ctx ps result
430 panic "Check.remove_var: equation does not begin with a variable"
432 is_con :: EquationInfo -> Bool
433 is_con (EqnInfo _ _ ((ConPat _ _ _ _ _):_) _) = True
436 is_lit :: EquationInfo -> Bool
437 is_lit (EqnInfo _ _ ((LitPat _ _):_) _) = True
438 is_lit (EqnInfo _ _ ((NPat _ _ _):_) _) = True
441 is_npat :: EquationInfo -> Bool
442 is_npat (EqnInfo _ _ ((NPat _ _ _):_) _) = True
445 is_nplusk :: EquationInfo -> Bool
446 is_nplusk (EqnInfo _ _ ((NPlusKPat _ _ _ _ _):_) _) = True
449 is_var :: EquationInfo -> Bool
450 is_var (EqnInfo _ _ ((WildPat _):_) _) = True
453 is_var_con :: DataCon -> EquationInfo -> Bool
454 is_var_con con (EqnInfo _ _ ((WildPat _):_) _) = True
455 is_var_con con (EqnInfo _ _ ((ConPat id _ _ _ _):_) _) | id == con = True
456 is_var_con con _ = False
458 is_var_lit :: HsLit -> EquationInfo -> Bool
459 is_var_lit lit (EqnInfo _ _ ((WildPat _):_) _) = True
460 is_var_lit lit (EqnInfo _ _ ((LitPat lit' _):_) _) | lit == lit' = True
461 is_var_lit lit (EqnInfo _ _ ((NPat lit' _ _):_) _) | lit == lit' = True
462 is_var_lit lit _ = False
465 The difference beteewn @make_con@ and @make_whole_con@ is that
466 @make_wole_con@ creates a new constructor with all their arguments, and
467 @make_con@ takes a list of argumntes, creates the contructor getting their
468 arguments from the list. See where \fbox{\ ???\ } are used for details.
470 We need to reconstruct the patterns (make the constructors infix and
471 similar) at the same time that we create the constructors.
473 You can tell tuple constructors using
477 You can see if one constructor is infix with this clearer code :-))))))))))
479 Lex.isLexConSym (Name.occNameString (Name.getOccName con))
482 Rather clumsy but it works. (Simon Peyton Jones)
485 We don't mind the @nilDataCon@ because it doesn't change the way to
486 print the messsage, we are searching only for things like: @[1,2,3]@,
489 In @reconstruct_pat@ we want to ``undo'' the work
490 that we have done in @simplify_pat@.
493 @((,) x y)@ & returns to be & @(x, y)@
494 \\ @((:) x xs)@ & returns to be & @(x:xs)@
495 \\ @(x:(...:[])@ & returns to be & @[x,...]@
498 The difficult case is the third one becouse we need to follow all the
499 contructors until the @[]@ to know that we need to use the second case,
500 not the second. \fbox{\ ???\ }
503 isInfixCon con = isDataSymOcc (getOccName con)
505 is_nil (ConPatIn con []) = con == getName nilDataCon
508 is_list (ListPatIn _) = True
511 return_list id q = id == consDataCon && (is_nil q || is_list q)
513 make_list p q | is_nil q = ListPatIn [p]
514 make_list p (ListPatIn ps) = ListPatIn (p:ps)
515 make_list _ _ = panic "Check.make_list: Invalid argument"
517 make_con :: TypecheckedPat -> ExhaustivePat -> ExhaustivePat
518 make_con (ConPat id _ _ _ _) (p:q:ps, constraints)
519 | return_list id q = (make_list p q : ps, constraints)
520 | isInfixCon id = ((ConOpPatIn p name fixity q) : ps, constraints)
521 where name = getName id
522 fixity = panic "Check.make_con: Guessing fixity"
524 make_con (ConPat id _ _ _ pats) (ps,constraints)
525 | isTupleTyCon tc = (TuplePatIn pats_con (tupleTyConBoxity tc) : rest_pats, constraints)
526 | otherwise = (ConPatIn name pats_con : rest_pats, constraints)
527 where num_args = length pats
529 pats_con = take num_args ps
530 rest_pats = drop num_args ps
534 make_whole_con :: DataCon -> WarningPat
535 make_whole_con con | isInfixCon con = ConOpPatIn new_wild_pat name fixity new_wild_pat
536 | otherwise = ConPatIn name pats
538 fixity = panic "Check.make_whole_con: Guessing fixity"
540 arity = dataConSourceArity con
541 pats = take arity (repeat new_wild_pat)
544 new_wild_pat :: WarningPat
545 new_wild_pat = WildPatIn
548 This equation makes the same thing as @tidy@ in @Match.lhs@, the
549 difference is that here we can do all the tidy in one place and in the
550 @Match@ tidy it must be done one column each time due to bookkeeping
555 simplify_eqns :: [EquationInfo] -> [EquationInfo]
556 simplify_eqns [] = []
557 simplify_eqns ((EqnInfo n ctx pats result):qs) =
558 (EqnInfo n ctx pats' result) : simplify_eqns qs
560 pats' = map simplify_pat pats
562 simplify_pat :: TypecheckedPat -> TypecheckedPat
564 simplify_pat pat@(WildPat gt) = pat
565 simplify_pat (VarPat id) = WildPat (idType id)
567 simplify_pat (LazyPat p) = simplify_pat p
568 simplify_pat (AsPat id p) = simplify_pat p
570 simplify_pat (ConPat id ty tvs dicts ps) = ConPat id ty tvs dicts (map simplify_pat ps)
572 simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y])
573 (ConPat nilDataCon list_ty [] [] [])
574 (map simplify_pat ps)
575 where list_ty = mkListTy ty
578 simplify_pat (TuplePat ps boxity)
579 = ConPat (tupleCon boxity arity)
580 (mkTupleTy boxity arity (map outPatType ps)) [] []
581 (map simplify_pat ps)
585 simplify_pat (RecPat dc ty ex_tvs dicts [])
586 = ConPat dc ty ex_tvs dicts all_wild_pats
588 all_wild_pats = map WildPat con_arg_tys
590 -- Identical to machinations in Match.tidy1:
591 inst_tys = tcTyConAppArgs ty -- Newtype is observable
592 con_arg_tys = dataConArgTys dc (inst_tys ++ mkTyVarTys ex_tvs)
594 simplify_pat (RecPat dc ty ex_tvs dicts idps)
595 = ConPat dc ty ex_tvs dicts pats
597 pats = map (simplify_pat.snd) all_pats
599 -- pad out all the missing fields with WildPats.
600 field_pats = map (\ f -> (getName f, WildPat (panic "simplify_pat(RecPat-2)")))
601 (dataConFieldLabels dc)
604 ( \ (id,p,_) acc -> insertNm (getName id) p acc)
608 insertNm nm p [] = [(nm,p)]
609 insertNm nm p (x@(n,_):xs)
610 | nm == n = (nm,p):xs
611 | otherwise = x : insertNm nm p xs
613 simplify_pat pat@(LitPat lit lit_ty) = tidyLitPat lit pat
615 -- unpack string patterns fully, so we can see when they overlap with
616 -- each other, or even explicit lists of Chars.
617 simplify_pat pat@(NPat (HsString s) _ _) =
618 foldr (\c pat -> ConPat consDataCon stringTy [] [] [mk_char_lit c,pat])
619 (ConPat nilDataCon stringTy [] [] []) (_UNPK_INT_ s)
621 mk_char_lit c = ConPat charDataCon charTy [] []
622 [LitPat (HsCharPrim c) charPrimTy]
624 simplify_pat pat@(NPat lit lit_ty hsexpr) = tidyNPat lit lit_ty pat
626 simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) =
628 where ty = panic "Check.simplify_pat: Gessing ty"
630 simplify_pat (DictPat dicts methods) =
631 case num_of_d_and_ms of
632 0 -> simplify_pat (TuplePat [] Boxed)
633 1 -> simplify_pat (head dict_and_method_pats)
634 _ -> simplify_pat (TuplePat dict_and_method_pats Boxed)
636 num_of_d_and_ms = length dicts + length methods
637 dict_and_method_pats = map VarPat (dicts ++ methods)