2 % (c) The GRASP/AQUA Project, Glasgow University, 1997
4 % Author: Juan J. Quintela <quintela@dc.fi.udc.es>
9 module Check ( check , ExhaustivePat, WarningPat, BoxedString(..) ) where
13 import TcHsSyn ( TypecheckedPat )
14 import DsHsSyn ( outPatType )
17 import DsUtils ( EquationInfo(..),
28 import IdInfo ( ArityInfo(..) )
29 import Lex ( isLexConSym )
30 import Name ( occNameString,
41 import TyVar ( TyVar )
42 import TysPrim ( intPrimTy,
49 import TysWiredIn ( nilDataCon, consDataCon,
54 floatTy, floatDataCon,
55 doubleTy, doubleDataCon,
59 import TyCon ( tyConDataCons )
61 import Unique ( Unique )
64 #include "HsVersions.h"
67 This module perfoms checks about if one list of equations are:
71 To discover that we go through the list of equations in a tree-like fashion.
73 If you like theory, a similar algoritm is described in:
74 Two Tecniques for Compiling Lazy Pattern Matching
76 INRIA Rocquencourt (RR-2385, 1994)
78 The algorithm is based in the first Technique, but there are somo diferences:
79 - We don't generate code
80 - We have constructors and literals (not only literals as in the article)
81 - We don't use directions, we must select the columns from left-to-right
83 (By the wat the second technique is really similar to the one used in MAtch.lhs to generate code)
86 This function takes the equations of a pattern and returns:
87 - The patterns that are not recognized
88 - The equations that are not overlapped
90 It symplify the patterns and then call check' (the same semantics),and it needs to
91 reconstruct the patterns again ....
93 The problem appear with things like:
97 We want to put the two patterns with the same syntax, (prefix form) and then all the
98 constructors are equal:
99 f (: x (: y [])) = ....
102 (more about that in symplify_eqns)
104 We would preffer to have a WarningPat of type String, but Strings and the
105 Pretty Printer are not friends.
109 newtype BoxedString = BS String
111 type WarningPat = InPat BoxedString --Name --String
112 type ExhaustivePat = ([WarningPat], [(BoxedString, [HsLit])])
115 instance Outputable BoxedString where
119 check :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
120 check qs = check' (simplify_eqns qs)
124 This equation is the same that check, the only difference is that the
125 boring work is done, that woprk needs to be done only once, this is
126 the reason top have two funtions, check is the external interface,
127 check' is called recursively.
129 There are several cases:
132 \item There are no equations: Everything is okey.
133 \item There are only one equation, that can fail, and all the patterns are
134 variables. Then that equation is used and the same equation is
136 \item All the patterns are variables, and the match can fail,therr are more equations
137 then the results is the result of the rest of equations and this equation is used also.
139 \item The general case, if all the patterns are variables (here the match can't fail)
140 then the result is that this equation is used and this equation doesn't generate
143 \item In the general case, there can exist literals ,constructors or only vars in the
144 first column, we actuate in consecuence.
151 check' :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
152 check' [] = ([([],[])],emptyUniqSet)
154 check' [EqnInfo n ctx ps (MatchResult CanFail _ _)]
155 | all_vars ps = ([(take (length ps) (repeat new_wild_pat),[])], unitUniqSet n)
157 check' qs@((EqnInfo n ctx ps (MatchResult CanFail _ _)):_)
158 | all_vars ps = (pats, addOneToUniqSet indexs n)
160 (pats,indexs) = check' (tail qs)
162 check' qs@((EqnInfo n ctx ps result):_)
163 | all_vars ps = ([], unitUniqSet n)
164 -- | nplusk = panic "Check.check': Work in progress: nplusk"
165 -- | npat = panic "Check.check': Work in progress: npat ?????"
166 | literals = split_by_literals qs
167 | constructors = split_by_constructor qs
168 | only_vars = first_column_only_vars qs
169 | otherwise = panic "Check.check': Not implemented :-("
171 constructors = or (map is_con qs)
172 literals = or (map is_lit qs)
173 -- npat = or (map is_npat qs)
174 -- nplusk = or (map is_nplusk qs)
175 only_vars = and (map is_var qs)
178 Here begins the code to deal with literals, we need to split the matrix in diferent matrix
179 begining by each literal and a last matrix with the rest of values.
182 split_by_literals :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
183 split_by_literals qs = process_literals used_lits qs
185 used_lits = get_used_lits qs
188 process_explicit_literals is a funtion taht process each literal that appears in
189 the column of the matrix.
192 process_explicit_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
193 process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)
195 pats_indexs = map (\x -> construct_literal_matrix x qs) lits
196 (pats,indexs) = unzip pats_indexs
201 Process_literals calls process_explicit_literals to deal with the literals taht apears in
202 the matrix and deal also sith ther rest of the cases. It must be one Variable to be complete.
206 process_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
207 process_literals used_lits qs
208 | length default_eqns == 0 = ([make_row_vars used_lits (head qs)]++pats,indexs)
209 | otherwise = (pats_default,indexs_default)
211 (pats,indexs) = process_explicit_literals used_lits qs
212 default_eqns = (map remove_var (filter is_var qs))
213 (pats',indexs') = check' default_eqns
214 pats_default = [(new_wild_pat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats
215 indexs_default = unionUniqSets indexs' indexs
218 Here we have selected the literal and we will select all the equations that begins for that
219 literal and create a new matrix.
222 construct_literal_matrix :: HsLit -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
223 construct_literal_matrix lit qs =
224 (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)
226 (pats,indexs) = (check' (remove_first_column_lit lit qs))
227 new_lit = LitPatIn lit
229 remove_first_column_lit :: HsLit
232 remove_first_column_lit lit qs =
233 map shift_pat (filter (is_var_lit lit) qs)
235 shift_pat (EqnInfo n ctx [] result) = panic "Check.shift_var: no patterns"
236 shift_pat (EqnInfo n ctx (_:ps) result) = EqnInfo n ctx ps result
240 This function splits the equations @qs@ in groups that deal with the same constructor
244 split_by_constructor :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
246 split_by_constructor qs | length unused_cons /= 0 = need_default_case used_cons unused_cons qs
247 | otherwise = no_need_default_case used_cons qs
249 used_cons = get_used_cons qs
250 unused_cons = get_unused_cons used_cons
254 The first column of the patterns matrix only have vars, then there is nothing to do.
257 first_column_only_vars :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
258 first_column_only_vars qs = (map (\ (xs,ys) -> (WildPatIn:xs,ys)) pats,indexs)
260 (pats,indexs) = check' (map remove_var qs)
264 This equation takes a matrix of patterns and split the equations by constructor, using all
265 the constructors that appears in the first column of the pattern matching.
267 We can need a default clause or not ...., it depends if we used all the constructors or not
268 explicitily. The reasoning is similar to process_literals, the difference is that here
269 the default case is not allways needed.
272 no_need_default_case :: [TypecheckedPat] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
273 no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
275 pats_indexs = map (\x -> construct_matrix x qs) cons
276 (pats,indexs) = unzip pats_indexs
278 need_default_case :: [TypecheckedPat] -> [Id] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
279 need_default_case used_cons unused_cons qs
280 | length default_eqns == 0 = (pats_default_no_eqns,indexs)
281 | otherwise = (pats_default,indexs_default)
283 (pats,indexs) = no_need_default_case used_cons qs
284 default_eqns = (map remove_var (filter is_var qs))
285 (pats',indexs') = check' default_eqns
286 pats_default = [(make_whole_con c:ps,constraints) |
287 c <- unused_cons, (ps,constraints) <- pats'] ++ pats
288 new_wilds = make_row_vars_for_constructor (head qs)
289 pats_default_no_eqns = [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats
290 indexs_default = unionUniqSets indexs' indexs
292 construct_matrix :: TypecheckedPat -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
293 construct_matrix con qs =
295 (map (make_con con) pats,indexs)
297 (pats,indexs) = (check' (remove_first_column con qs))
300 Here remove first column is more difficult that with literals due to the fact that
301 constructors can have arguments.
303 for instance, the matrix
315 remove_first_column :: TypecheckedPat -- Constructor
318 remove_first_column (ConPat con _ con_pats) qs =
319 map shift_var (filter (is_var_con con) qs)
321 new_wilds = [WildPat (outPatType arg_pat) | arg_pat <- con_pats]
322 shift_var (EqnInfo n ctx (ConPat _ _ ps':ps) result) =
323 EqnInfo n ctx (ps'++ps) result
324 shift_var (EqnInfo n ctx (WildPat _ :ps) result) =
325 EqnInfo n ctx (new_wilds ++ ps) result
326 shift_var _ = panic "Check.Shift_var:No done"
328 make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat
329 make_row_vars used_lits (EqnInfo _ _ pats _ ) =
330 (VarPatIn new_var:take (length (tail pats)) (repeat WildPatIn),[(new_var,used_lits)])
331 where new_var = BS "#x"
333 make_row_vars_for_constructor :: EquationInfo -> [WarningPat]
334 make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = take (length (tail pats)) (repeat WildPatIn)
336 compare_cons :: TypecheckedPat -> TypecheckedPat -> Bool
337 compare_cons (ConPat id1 _ _) (ConPat id2 _ _) = id1 == id2
339 remove_dups :: [TypecheckedPat] -> [TypecheckedPat]
341 remove_dups (x:xs) | or (map (\y -> compare_cons x y) xs) = remove_dups xs
342 | otherwise = x : remove_dups xs
344 get_used_cons :: [EquationInfo] -> [TypecheckedPat]
345 get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPat _ _ _):_) _) <- qs]
347 remove_dups' :: [HsLit] -> [HsLit]
349 remove_dups' (x:xs) | x `elem` xs = remove_dups' xs
350 | otherwise = x : remove_dups' xs
353 get_used_lits :: [EquationInfo] -> [HsLit]
354 get_used_lits qs = remove_dups' (get_used_lits' qs)
356 get_used_lits' :: [EquationInfo] -> [HsLit]
357 get_used_lits' [] = []
358 get_used_lits' ((EqnInfo _ _ ((LitPat lit _):_) _):qs) = lit : get_used_lits qs
359 get_used_lits' ((EqnInfo _ _ ((NPat lit _ _):_) _):qs) = lit : get_used_lits qs
360 get_used_lits' (q:qs) = get_used_lits qs
362 get_unused_cons :: [TypecheckedPat] -> [Id]
363 get_unused_cons used_cons = unused_cons
365 (ConPat _ ty _) = head used_cons
366 Just (ty_con,_) = splitTyConApp_maybe ty
367 all_cons = tyConDataCons ty_con
368 used_cons_as_id = map (\ (ConPat id _ _) -> id) used_cons
369 unused_cons = uniqSetToList (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
371 all_vars :: [TypecheckedPat] -> Bool
373 all_vars (WildPat _:ps) = all_vars ps
376 remove_var :: EquationInfo -> EquationInfo
377 remove_var (EqnInfo n ctx (WildPat _:ps) result) = EqnInfo n ctx ps result
378 remove_var _ = panic "Check:remove_var: equation not begin with a variable"
380 is_con :: EquationInfo -> Bool
381 is_con (EqnInfo _ _ ((ConPat _ _ _):_) _) = True
384 is_lit :: EquationInfo -> Bool
385 is_lit (EqnInfo _ _ ((LitPat _ _):_) _) = True
386 is_lit (EqnInfo _ _ ((NPat _ _ _):_) _) = True
389 is_npat :: EquationInfo -> Bool
390 is_npat (EqnInfo _ _ ((NPat _ _ _):_) _) = True
393 is_nplusk :: EquationInfo -> Bool
394 is_nplusk (EqnInfo _ _ ((NPlusKPat _ _ _ _ _):_) _) = True
397 is_var :: EquationInfo -> Bool
398 is_var (EqnInfo _ _ ((WildPat _):_) _) = True
401 is_var_con :: Id -> EquationInfo -> Bool
402 is_var_con con (EqnInfo _ _ ((WildPat _):_) _) = True
403 is_var_con con (EqnInfo _ _ ((ConPat id _ _):_) _) | id == con = True
404 is_var_con con _ = False
406 is_var_lit :: HsLit -> EquationInfo -> Bool
407 is_var_lit lit (EqnInfo _ _ ((WildPat _):_) _) = True
408 is_var_lit lit (EqnInfo _ _ ((LitPat lit' _):_) _) | lit == lit' = True
409 is_var_lit lit (EqnInfo _ _ ((NPat lit' _ _):_) _) | lit == lit' = True
410 is_var_lit lit _ = False
413 The difference beteewn make_con and make_whole_con is that make_wole_con creates a new
414 constructor with all their arguments, and make_Con takes a list of argumntes, creates
415 the contructor geting thir argumnts from the list. See where are used for details.
417 We need to reconstruct the patterns (make the constructors infix and similar) at the
418 same time that we create the constructors.
420 You can tell tuple constructors using
424 You can see if one contructur is infix with this clearer code :-))))))))))
426 Lex.isLexConSym (Name.occNameString (Name.getOccName con))
428 Rather clumsy but it works. (Simon Peyton Jones)
431 We con't mind the nilDataCon because it doesn't change the way to print the messsage,
432 we are searching only for things like: [1,2,3], not x:xs ....
435 In recontruct_pat we want to "undo" the work taht we have done in simplify_pat
437 ((,) x y) returns to be (x, y)
438 ((:) x xs) returns to be (x:xs)
439 (x:(...:[]) returns to be [x,...]
441 The dificult case is the third one becouse we need to follow all the contructors until the []
442 to know taht we need to use the second case, not the second.
446 isInfixCon con = isLexConSym (occNameString (getOccName con))
448 is_nil (ConPatIn (BS con) []) = con == getOccString nilDataCon
451 is_list (ListPatIn _) = True
454 return_list id q = id == consDataCon && (is_nil q || is_list q)
456 make_list p q | is_nil q = ListPatIn [p]
457 make_list p (ListPatIn ps) = ListPatIn (p:ps)
458 make_list _ _ = panic "Check.make_list: Invalid argument"
460 make_con :: TypecheckedPat -> ExhaustivePat -> ExhaustivePat
461 make_con (ConPat id ty pats) (p:q:ps, constraints)
462 | return_list id q = (make_list p q : ps, constraints)
463 | isInfixCon id = (ParPatIn (ConOpPatIn p name fixity q) : ps, constraints)
464 where name = BS (getOccString id)
465 fixity = panic "Check.make_con: Guessing fixity"
466 make_con (ConPat id ty pats) (ps,constraints)
467 | isTupleCon id = (TuplePatIn pats_con : rest_pats, constraints)
468 | otherwise = (ConPatIn name pats_con : rest_pats, constraints)
469 where num_args = length pats
470 name = BS (getOccString id)
471 pats_con = map paren_conpat_arg (take num_args ps)
472 rest_pats = drop num_args ps
474 -- if needed, wrap a ParPatIn around a ConPatIn arg
475 -- (for prettier printing.)
476 paren_conpat_arg p@(ConPatIn _ []) = p
477 paren_conpat_arg p@(ConPatIn _ _) = ParPatIn p
478 paren_conpat_arg p@(ConOpPatIn _ _ _ _) = ParPatIn p
479 paren_conpat_arg p = p
482 make_whole_con :: Id -> WarningPat
483 make_whole_con con | isInfixCon con = ParPatIn(ConOpPatIn new_wild_pat name fixity new_wild_pat)
484 | otherwise = ConPatIn name pats
486 fixity = panic "Check.make_whole_con: Guessing fixity"
487 name = BS (getOccString con)
488 arity = get_int_arity con
489 pats = map paren_conpat_arg (take arity (repeat new_wild_pat))
492 new_wild_pat :: WarningPat
493 new_wild_pat = WildPatIn
495 get_int_arity :: Id -> Int
496 get_int_arity id = arity_to_int (getIdArity id)
498 arity_to_int (ArityExactly n) = n
499 arity_to_int _ = panic "getIntArity: Unknown arity"
503 This equation makes the same thing that tidy in Match.lhs, the
504 diference is that here we can do all the tidy in one place and in the
505 Match tidy it must be done one column each time due to bookeping
510 simplify_eqns :: [EquationInfo] -> [EquationInfo]
511 simplify_eqns [] = []
512 simplify_eqns ((EqnInfo n ctx pats result):qs) =
513 (EqnInfo n ctx pats' result) : simplify_eqns qs
515 pats' = map simplify_pat pats
517 simplify_pat :: TypecheckedPat -> TypecheckedPat
519 simplify_pat pat@(WildPat gt) = pat
520 simplify_pat (VarPat id) = WildPat (idType id)
522 simplify_pat (LazyPat p) = simplify_pat p
524 simplify_pat (AsPat id p) = simplify_pat p
526 simplify_pat (ConPat id ty ps) = ConPat id ty (map simplify_pat ps)
528 simplify_pat (ConOpPat p1 id p2 ty) = ConPat id ty (map simplify_pat [p1,p2])
530 simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [x, y])
531 (ConPat nilDataCon list_ty [])
532 (map simplify_pat ps)
533 where list_ty = mkListTy ty
536 simplify_pat (TuplePat ps) = ConPat (tupleCon arity)
537 (mkTupleTy arity (map outPatType ps))
538 (map simplify_pat ps)
542 simplify_pat (RecPat id ty idps) = ConPat id ty pats
544 pats = map (\ (id,p,_)-> simplify_pat p) idps
546 simplify_pat pat@(LitPat lit lit_ty)
547 | isUnboxedType lit_ty = pat
549 | lit_ty == charTy = ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy]
551 | otherwise = pprPanic "tidy1:LitPat:" (ppr pat)
553 mk_char (HsChar c) = HsCharPrim c
555 simplify_pat (NPat lit lit_ty hsexpr) = better_pat
558 | lit_ty == charTy = ConPat charDataCon lit_ty [LitPat (mk_char lit) charPrimTy]
559 | lit_ty == intTy = ConPat intDataCon lit_ty [LitPat (mk_int lit) intPrimTy]
560 | lit_ty == wordTy = ConPat wordDataCon lit_ty [LitPat (mk_word lit) wordPrimTy]
561 | lit_ty == addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy]
562 | lit_ty == floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy]
563 | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy]
565 -- Convert the literal pattern "" to the constructor pattern [].
566 | null_str_lit lit = ConPat nilDataCon lit_ty []
567 | one_str_lit lit = ConPat consDataCon list_ty
568 [ ConPat charDataCon lit_ty [LitPat (mk_head_char lit) charPrimTy]
569 , ConPat nilDataCon lit_ty []]
571 | otherwise = NPat lit lit_ty hsexpr
573 list_ty = mkListTy lit_ty
575 mk_int (HsInt i) = HsIntPrim i
576 mk_int l@(HsLitLit s) = l
578 mk_head_char (HsString s) = HsCharPrim (_HEAD_ s)
580 mk_char (HsChar c) = HsCharPrim c
581 mk_char l@(HsLitLit s) = l
583 mk_word l@(HsLitLit s) = l
585 mk_addr l@(HsLitLit s) = l
587 mk_float (HsInt i) = HsFloatPrim (fromInteger i)
588 mk_float (HsFrac f) = HsFloatPrim f
589 mk_float l@(HsLitLit s) = l
591 mk_double (HsInt i) = HsDoublePrim (fromInteger i)
592 mk_double (HsFrac f) = HsDoublePrim f
593 mk_double l@(HsLitLit s) = l
595 null_str_lit (HsString s) = _NULL_ s
596 null_str_lit other_lit = False
598 one_str_lit (HsString s) = _LENGTH_ s == (1::Int)
599 one_str_lit other_lit = False
601 simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) = --NPlusKPat id hslit ty hsexpr1 hsexpr2
603 where ty = panic "Check.simplify_pat: Never used"
605 simplify_pat (DictPat dicts methods) =
606 case num_of_d_and_ms of
607 0 -> simplify_pat (TuplePat [])
608 1 -> simplify_pat (head dict_and_method_pats)
609 _ -> simplify_pat (TuplePat dict_and_method_pats)
611 num_of_d_and_ms = length dicts + length methods
612 dict_and_method_pats = map VarPat (dicts ++ methods)