2 % (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
4 % Author: Juan J. Quintela <quintela@krilin.dc.fi.udc.es>
9 module Check ( check , ExhaustivePat ) where
13 import TcHsSyn ( TypecheckedPat )
14 import DsHsSyn ( outPatType )
17 import DsUtils ( EquationInfo(..),
23 import DataCon ( DataCon, isTupleCon, isUnboxedTupleCon,
25 import Name ( Name, mkLocalName, getOccName, isConSymOcc, getName, varOcc )
30 import TysPrim ( intPrimTy,
37 import TysWiredIn ( nilDataCon, consDataCon,
39 mkUnboxedTupleTy, unboxedTupleCon,
43 floatTy, floatDataCon,
44 doubleTy, doubleDataCon,
49 import Unique ( unboundKey )
50 import TyCon ( tyConDataCons )
54 #include "HsVersions.h"
57 This module performs checks about if one list of equations are:
61 To discover that we go through the list of equations in a tree-like fashion.
63 If you like theory, a similar algorithm is described in:
64 Two Techniques for Compiling Lazy Pattern Matching
66 INRIA Rocquencourt (RR-2385, 1994)
68 The algorithm is based in the first Technique, but there are some differences:
69 - We don't generate code
70 - We have constructors and literals (not only literals as in the
72 - We don't use directions, we must select the columns from
75 (By the way the second technique is really similar to the one used in
76 Match.lhs to generate code)
78 This function takes the equations of a pattern and returns:
79 - The patterns that are not recognized
80 - The equations that are not overlapped
82 It simplify the patterns and then call check' (the same semantics),and it
83 needs to reconstruct the patterns again ....
85 The problem appear with things like:
89 We want to put the two patterns with the same syntax, (prefix form) and
90 then all the constructors are equal:
91 f (: x (: y [])) = ....
94 (more about that in simplify_eqns)
96 We would prefer to have a WarningPat of type String, but Strings and the
97 Pretty Printer are not friends.
99 We use InPat in WarningPat instead of OutPat because we need to print the
100 warning messages in the same way they are introduced, i.e. if the user
104 He don't want a warning message written:
106 f (: x (: y [])) ........
108 Then we need to use InPats.
110 Juan Quintela 5 JUL 1998
111 User-friendliness and compiler writers are no friends.
115 type WarningPat = InPat Name
116 type ExhaustivePat = ([WarningPat], [(Name, [HsLit])])
119 check :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
120 check qs = (untidy_warns, incomplete)
122 (warns, incomplete) = check' (simplify_eqns qs)
123 untidy_warns = map untidy_exhaustive warns
125 untidy_exhaustive :: ExhaustivePat -> ExhaustivePat
126 untidy_exhaustive ([pat], messages) =
127 ([untidy_no_pars pat], map untidy_message messages)
128 untidy_exhaustive (pats, messages) =
129 (map untidy_pars pats, map untidy_message messages)
131 untidy_message :: (Name, [HsLit]) -> (Name, [HsLit])
132 untidy_message (string, lits) = (string, map untidy_lit lits)
135 The function @untidy@ does the reverse work of the @simplify_pat@ funcion.
141 untidy_no_pars :: WarningPat -> WarningPat
142 untidy_no_pars p = untidy False p
144 untidy_pars :: WarningPat -> WarningPat
145 untidy_pars p = untidy True p
147 untidy :: NeedPars -> WarningPat -> WarningPat
148 untidy _ p@WildPatIn = p
149 untidy _ p@(VarPatIn name) = p
150 untidy _ (LitPatIn lit) = LitPatIn (untidy_lit lit)
151 untidy _ p@(ConPatIn name []) = p
152 untidy b (ConPatIn name pats) =
153 pars b (ConPatIn name (map untidy_pars pats))
154 untidy b (ConOpPatIn pat1 name fixity pat2) =
155 pars b (ConOpPatIn (untidy_pars pat1) name fixity (untidy_pars pat2))
156 untidy _ (ListPatIn pats) = ListPatIn (map untidy_no_pars pats)
157 untidy _ (TuplePatIn pats boxed) = TuplePatIn (map untidy_no_pars pats) boxed
159 untidy _ (SigPatIn pat ty) = panic "Check.untidy: SigPatIn"
160 untidy _ (LazyPatIn pat) = panic "Check.untidy: LazyPatIn"
161 untidy _ (AsPatIn name pat) = panic "Check.untidy: AsPatIn"
162 untidy _ (NPlusKPatIn name lit) = panic "Check.untidy: NPlusKPatIn"
163 untidy _ (NegPatIn ipat) = panic "Check.untidy: NegPatIn"
164 untidy _ (ParPatIn pat) = panic "Check.untidy: ParPatIn"
165 untidy _ (RecPatIn name fields) = panic "Check.untidy: RecPatIn"
166 -- [(name, InPat name, Bool)] -- True <=> source used punning
168 pars :: NeedPars -> WarningPat -> WarningPat
169 pars True p = ParPatIn p
172 untidy_lit :: HsLit -> HsLit
173 untidy_lit (HsCharPrim c) = HsChar c
174 --untidy_lit (HsStringPrim s) = HsString s
178 This equation is the same that check, the only difference is that the
179 boring work is done, that work needs to be done only once, this is
180 the reason top have two functions, check is the external interface,
181 check' is called recursively.
183 There are several cases:
186 \item There are no equations: Everything is OK.
187 \item There are only one equation, that can fail, and all the patterns are
188 variables. Then that equation is used and the same equation is
190 \item All the patterns are variables, and the match can fail, there are
191 more equations then the results is the result of the rest of equations
192 and this equation is used also.
194 \item The general case, if all the patterns are variables (here the match
195 can't fail) then the result is that this equation is used and this
196 equation doesn't generate non-exhaustive cases.
198 \item In the general case, there can exist literals ,constructors or only
199 vars in the first column, we actuate in consequence.
206 check' :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
207 check' [] = ([([],[])],emptyUniqSet)
209 check' [EqnInfo n ctx ps (MatchResult CanFail _)]
210 | all_vars ps = ([(take (length ps) (repeat new_wild_pat),[])], unitUniqSet n)
212 check' qs@((EqnInfo n ctx ps (MatchResult CanFail _)):_)
213 | all_vars ps = (pats, addOneToUniqSet indexs n)
215 (pats,indexs) = check' (tail qs)
217 check' qs@((EqnInfo n ctx ps result):_)
218 | all_vars ps = ([], unitUniqSet n)
219 -- | nplusk = panic "Check.check': Work in progress: nplusk"
220 -- | npat = panic "Check.check': Work in progress: npat ?????"
221 | literals = split_by_literals qs
222 | constructors = split_by_constructor qs
223 | only_vars = first_column_only_vars qs
224 | otherwise = panic "Check.check': Not implemented :-("
226 constructors = or (map is_con qs)
227 literals = or (map is_lit qs)
228 -- npat = or (map is_npat qs)
229 -- nplusk = or (map is_nplusk qs)
230 only_vars = and (map is_var qs)
233 Here begins the code to deal with literals, we need to split the matrix
234 in different matrix beginning by each literal and a last matrix with the
238 split_by_literals :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
239 split_by_literals qs = process_literals used_lits qs
241 used_lits = get_used_lits qs
244 process_explicit_literals is a function that process each literal that appears
245 in the column of the matrix.
248 process_explicit_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
249 process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)
251 pats_indexs = map (\x -> construct_literal_matrix x qs) lits
252 (pats,indexs) = unzip pats_indexs
257 Process_literals calls process_explicit_literals to deal with the literals
258 that appears in the matrix and deal also with the rest of the cases. It
259 must be one Variable to be complete.
263 process_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
264 process_literals used_lits qs
265 | length default_eqns == 0 = ([make_row_vars used_lits (head qs)]++pats,indexs)
266 | otherwise = (pats_default,indexs_default)
268 (pats,indexs) = process_explicit_literals used_lits qs
269 default_eqns = (map remove_var (filter is_var qs))
270 (pats',indexs') = check' default_eqns
271 pats_default = [(new_wild_pat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats
272 indexs_default = unionUniqSets indexs' indexs
275 Here we have selected the literal and we will select all the equations that
276 begins for that literal and create a new matrix.
279 construct_literal_matrix :: HsLit -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
280 construct_literal_matrix lit qs =
281 (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)
283 (pats,indexs) = (check' (remove_first_column_lit lit qs))
284 new_lit = LitPatIn lit
286 remove_first_column_lit :: HsLit
289 remove_first_column_lit lit qs =
290 map shift_pat (filter (is_var_lit lit) qs)
292 shift_pat (EqnInfo n ctx [] result) = panic "Check.shift_var: no patterns"
293 shift_pat (EqnInfo n ctx (_:ps) result) = EqnInfo n ctx ps result
297 This function splits the equations @qs@ in groups that deal with the
302 split_by_constructor :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
304 split_by_constructor qs | length unused_cons /= 0 = need_default_case used_cons unused_cons qs
305 | otherwise = no_need_default_case used_cons qs
307 used_cons = get_used_cons qs
308 unused_cons = get_unused_cons used_cons
312 The first column of the patterns matrix only have vars, then there is
316 first_column_only_vars :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
317 first_column_only_vars qs = (map (\ (xs,ys) -> (new_wild_pat:xs,ys)) pats,indexs)
319 (pats,indexs) = check' (map remove_var qs)
323 This equation takes a matrix of patterns and split the equations by
324 constructor, using all the constructors that appears in the first column
325 of the pattern matching.
327 We can need a default clause or not ...., it depends if we used all the
328 constructors or not explicitly. The reasoning is similar to process_literals,
329 the difference is that here the default case is not always needed.
332 no_need_default_case :: [TypecheckedPat] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
333 no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
335 pats_indexs = map (\x -> construct_matrix x qs) cons
336 (pats,indexs) = unzip pats_indexs
338 need_default_case :: [TypecheckedPat] -> [DataCon] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
339 need_default_case used_cons unused_cons qs
340 | length default_eqns == 0 = (pats_default_no_eqns,indexs)
341 | otherwise = (pats_default,indexs_default)
343 (pats,indexs) = no_need_default_case used_cons qs
344 default_eqns = (map remove_var (filter is_var qs))
345 (pats',indexs') = check' default_eqns
346 pats_default = [(make_whole_con c:ps,constraints) |
347 c <- unused_cons, (ps,constraints) <- pats'] ++ pats
348 new_wilds = make_row_vars_for_constructor (head qs)
349 pats_default_no_eqns = [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats
350 indexs_default = unionUniqSets indexs' indexs
352 construct_matrix :: TypecheckedPat -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
353 construct_matrix con qs =
354 (map (make_con con) pats,indexs)
356 (pats,indexs) = (check' (remove_first_column con qs))
359 Here remove first column is more difficult that with literals due to the fact
360 that constructors can have arguments.
362 For instance, the matrix
374 remove_first_column :: TypecheckedPat -- Constructor
377 remove_first_column (ConPat con _ _ _ con_pats) qs =
378 map shift_var (filter (is_var_con con) qs)
380 new_wilds = [WildPat (outPatType arg_pat) | arg_pat <- con_pats]
381 shift_var (EqnInfo n ctx (ConPat _ _ _ _ ps':ps) result) =
382 EqnInfo n ctx (ps'++ps) result
383 shift_var (EqnInfo n ctx (WildPat _ :ps) result) =
384 EqnInfo n ctx (new_wilds ++ ps) result
385 shift_var _ = panic "Check.Shift_var:No done"
387 make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat
388 make_row_vars used_lits (EqnInfo _ _ pats _ ) =
389 (VarPatIn new_var:take (length (tail pats)) (repeat new_wild_pat),[(new_var,used_lits)])
390 where new_var = hash_x
392 hash_x = mkLocalName unboundKey {- doesn't matter much -}
395 make_row_vars_for_constructor :: EquationInfo -> [WarningPat]
396 make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = take (length (tail pats)) (repeat new_wild_pat)
398 compare_cons :: TypecheckedPat -> TypecheckedPat -> Bool
399 compare_cons (ConPat id1 _ _ _ _) (ConPat id2 _ _ _ _) = id1 == id2
401 remove_dups :: [TypecheckedPat] -> [TypecheckedPat]
403 remove_dups (x:xs) | or (map (\y -> compare_cons x y) xs) = remove_dups xs
404 | otherwise = x : remove_dups xs
406 get_used_cons :: [EquationInfo] -> [TypecheckedPat]
407 get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPat _ _ _ _ _):_) _) <- qs]
409 remove_dups' :: [HsLit] -> [HsLit]
411 remove_dups' (x:xs) | x `elem` xs = remove_dups' xs
412 | otherwise = x : remove_dups' xs
415 get_used_lits :: [EquationInfo] -> [HsLit]
416 get_used_lits qs = remove_dups' all_literals
418 all_literals = get_used_lits' qs
420 get_used_lits' :: [EquationInfo] -> [HsLit]
421 get_used_lits' [] = []
422 get_used_lits' ((EqnInfo _ _ ((LitPat lit _):_) _):qs) =
423 lit : get_used_lits qs
424 get_used_lits' ((EqnInfo _ _ ((NPat lit _ _):_) _):qs) =
425 lit : get_used_lits qs
426 get_used_lits' (q:qs) =
429 get_unused_cons :: [TypecheckedPat] -> [DataCon]
430 get_unused_cons used_cons = unused_cons
432 (ConPat _ ty _ _ _) = head used_cons
433 Just (ty_con,_) = splitTyConApp_maybe ty
434 all_cons = tyConDataCons ty_con
435 used_cons_as_id = map (\ (ConPat id _ _ _ _) -> id) used_cons
436 unused_cons = uniqSetToList (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
438 all_vars :: [TypecheckedPat] -> Bool
440 all_vars (WildPat _:ps) = all_vars ps
443 remove_var :: EquationInfo -> EquationInfo
444 remove_var (EqnInfo n ctx (WildPat _:ps) result) = EqnInfo n ctx ps result
445 remove_var _ = panic "Check:remove_var: equation not begin with a variable"
447 is_con :: EquationInfo -> Bool
448 is_con (EqnInfo _ _ ((ConPat _ _ _ _ _):_) _) = True
451 is_lit :: EquationInfo -> Bool
452 is_lit (EqnInfo _ _ ((LitPat _ _):_) _) = True
453 is_lit (EqnInfo _ _ ((NPat _ _ _):_) _) = True
456 is_npat :: EquationInfo -> Bool
457 is_npat (EqnInfo _ _ ((NPat _ _ _):_) _) = True
460 is_nplusk :: EquationInfo -> Bool
461 is_nplusk (EqnInfo _ _ ((NPlusKPat _ _ _ _ _):_) _) = True
464 is_var :: EquationInfo -> Bool
465 is_var (EqnInfo _ _ ((WildPat _):_) _) = True
468 is_var_con :: DataCon -> EquationInfo -> Bool
469 is_var_con con (EqnInfo _ _ ((WildPat _):_) _) = True
470 is_var_con con (EqnInfo _ _ ((ConPat id _ _ _ _):_) _) | id == con = True
471 is_var_con con _ = False
473 is_var_lit :: HsLit -> EquationInfo -> Bool
474 is_var_lit lit (EqnInfo _ _ ((WildPat _):_) _) = True
475 is_var_lit lit (EqnInfo _ _ ((LitPat lit' _):_) _) | lit == lit' = True
476 is_var_lit lit (EqnInfo _ _ ((NPat lit' _ _):_) _) | lit == lit' = True
477 is_var_lit lit _ = False
480 The difference beteewn make_con and make_whole_con is that
481 make_wole_con creates a new constructor with all their arguments, and
482 make_Con takes a list of argumntes, creates the contructor geting thir
483 argumnts from the list. See where are used for details.
485 We need to reconstruct the patterns (make the constructors infix and
486 similar) at the same time that we create the constructors.
488 You can tell tuple constructors using
492 You can see if one constructor is infix with this clearer code :-))))))))))
494 Lex.isLexConSym (Name.occNameString (Name.getOccName con))
496 Rather clumsy but it works. (Simon Peyton Jones)
499 We con't mind the nilDataCon because it doesn't change the way to
500 print the messsage, we are searching only for things like: [1,2,3],
503 In reconstruct_pat we want to "undo" the work that we have done in simplify_pat
505 ((,) x y) returns to be (x, y)
506 ((:) x xs) returns to be (x:xs)
507 (x:(...:[]) returns to be [x,...]
509 The difficult case is the third one becouse we need to follow all the
510 contructors until the [] to know taht we need to use the second case,
515 isInfixCon con = isConSymOcc (getOccName con)
517 is_nil (ConPatIn con []) = con == getName nilDataCon
520 is_list (ListPatIn _) = True
523 return_list id q = id == consDataCon && (is_nil q || is_list q)
525 make_list p q | is_nil q = ListPatIn [p]
526 make_list p (ListPatIn ps) = ListPatIn (p:ps)
527 make_list _ _ = panic "Check.make_list: Invalid argument"
529 make_con :: TypecheckedPat -> ExhaustivePat -> ExhaustivePat
530 make_con (ConPat id _ _ _ _) (p:q:ps, constraints)
531 | return_list id q = (make_list p q : ps, constraints)
532 | isInfixCon id = ((ConOpPatIn p name fixity q) : ps, constraints)
533 where name = getName id
534 fixity = panic "Check.make_con: Guessing fixity"
536 make_con (ConPat id _ _ _ pats) (ps,constraints)
537 | isTupleCon id = (TuplePatIn pats_con True : rest_pats, constraints)
538 | isUnboxedTupleCon id = (TuplePatIn pats_con False : rest_pats, constraints)
539 | otherwise = (ConPatIn name pats_con : rest_pats, constraints)
540 where num_args = length pats
542 pats_con = take num_args ps
543 rest_pats = drop num_args ps
546 make_whole_con :: DataCon -> WarningPat
547 make_whole_con con | isInfixCon con = ConOpPatIn new_wild_pat name fixity new_wild_pat
548 | otherwise = ConPatIn name pats
550 fixity = panic "Check.make_whole_con: Guessing fixity"
552 arity = dataConSourceArity con
553 pats = take arity (repeat new_wild_pat)
556 new_wild_pat :: WarningPat
557 new_wild_pat = WildPatIn
560 This equation makes the same thing that tidy in Match.lhs, the
561 difference is that here we can do all the tidy in one place and in the
562 Match tidy it must be done one column each time due to bookkeeping
567 simplify_eqns :: [EquationInfo] -> [EquationInfo]
568 simplify_eqns [] = []
569 simplify_eqns ((EqnInfo n ctx pats result):qs) =
570 (EqnInfo n ctx pats' result) : simplify_eqns qs
572 pats' = map simplify_pat pats
574 simplify_pat :: TypecheckedPat -> TypecheckedPat
576 simplify_pat pat@(WildPat gt) = pat
577 simplify_pat (VarPat id) = WildPat (idType id)
579 simplify_pat (LazyPat p) = simplify_pat p
580 simplify_pat (AsPat id p) = simplify_pat p
582 simplify_pat (ConPat id ty tvs dicts ps) = ConPat id ty tvs dicts (map simplify_pat ps)
584 simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y])
585 (ConPat nilDataCon list_ty [] [] [])
586 (map simplify_pat ps)
587 where list_ty = mkListTy ty
590 simplify_pat (TuplePat ps True) = ConPat (tupleCon arity)
591 (mkTupleTy arity (map outPatType ps)) [] []
592 (map simplify_pat ps)
596 simplify_pat (TuplePat ps False)
597 = ConPat (unboxedTupleCon arity)
598 (mkUnboxedTupleTy arity (map outPatType ps)) [] []
599 (map simplify_pat ps)
603 simplify_pat (RecPat id ty tvs dicts [])
604 = ConPat id ty tvs dicts [wild_pat]
606 wild_pat = WildPat gt
607 gt = panic "Check.symplify_pat: gessing gt"
609 simplify_pat (RecPat id ty tvs dicts idps)
610 = ConPat id ty tvs dicts pats
612 pats = map (\ (id,p,_)-> simplify_pat p) idps
614 simplify_pat pat@(LitPat lit lit_ty)
615 | isUnboxedType lit_ty = pat
617 | lit_ty == charTy = ConPat charDataCon charTy [] [] [LitPat (mk_char lit) charPrimTy]
619 | otherwise = pprPanic "Check.simplify_pat: LitPat:" (ppr pat)
621 mk_char (HsChar c) = HsCharPrim c
623 simplify_pat (NPat lit lit_ty hsexpr) = better_pat
626 | lit_ty == charTy = ConPat charDataCon lit_ty [] [] [LitPat (mk_char lit) charPrimTy]
627 | lit_ty == intTy = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy]
628 | lit_ty == wordTy = ConPat wordDataCon lit_ty [] [] [LitPat (mk_word lit) wordPrimTy]
629 | lit_ty == addrTy = ConPat addrDataCon lit_ty [] [] [LitPat (mk_addr lit) addrPrimTy]
630 | lit_ty == floatTy = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy]
631 | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
633 -- Convert the literal pattern "" to the constructor pattern [].
634 | null_str_lit lit = ConPat nilDataCon lit_ty [] [] []
635 | lit_ty == stringTy =
636 foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y])
637 (ConPat nilDataCon list_ty [] [] [])
639 | otherwise = NPat lit lit_ty hsexpr
641 list_ty = mkListTy lit_ty
643 mk_int (HsInt i) = HsIntPrim i
644 mk_int l@(HsLitLit s) = l
646 mk_head_char (HsString s) = HsCharPrim (_HEAD_ s)
647 mk_string (HsString s) =
648 map (\ c -> ConPat charDataCon charTy [] []
649 [LitPat (HsCharPrim c) charPrimTy])
652 mk_char (HsChar c) = HsCharPrim c
653 mk_char l@(HsLitLit s) = l
655 mk_word l@(HsLitLit s) = l
657 mk_addr l@(HsLitLit s) = l
659 mk_float (HsInt i) = HsFloatPrim (fromInteger i)
660 mk_float (HsFrac f) = HsFloatPrim f
661 mk_float l@(HsLitLit s) = l
663 mk_double (HsInt i) = HsDoublePrim (fromInteger i)
664 mk_double (HsFrac f) = HsDoublePrim f
665 mk_double l@(HsLitLit s) = l
667 null_str_lit (HsString s) = _NULL_ s
668 null_str_lit other_lit = False
670 one_str_lit (HsString s) = _LENGTH_ s == (1::Int)
671 one_str_lit other_lit = False
673 simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) =
675 where ty = panic "Check.simplify_pat: Gessing ty"
677 simplify_pat (DictPat dicts methods) =
678 case num_of_d_and_ms of
679 0 -> simplify_pat (TuplePat [] True)
680 1 -> simplify_pat (head dict_and_method_pats)
681 _ -> simplify_pat (TuplePat dict_and_method_pats True)
683 num_of_d_and_ms = length dicts + length methods
684 dict_and_method_pats = map VarPat (dicts ++ methods)