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 = (take num_args ps)
472 rest_pats = drop num_args ps
474 make_whole_con :: Id -> WarningPat
475 make_whole_con con | isInfixCon con = ParPatIn(ConOpPatIn new_wild_pat name fixity new_wild_pat)
476 | otherwise = ConPatIn name pats
478 fixity = panic "Check.make_whole_con: Guessing fixity"
479 name = BS (getOccString con)
480 arity = get_int_arity con
481 pats = take arity (repeat new_wild_pat)
484 new_wild_pat :: WarningPat
485 new_wild_pat = WildPatIn
487 get_int_arity :: Id -> Int
488 get_int_arity id = arity_to_int (getIdArity id)
490 arity_to_int (ArityExactly n) = n
491 arity_to_int _ = panic "getIntArity: Unknown arity"
495 This equation makes the same thing that tidy in Match.lhs, the
496 diference is that here we can do all the tidy in one place and in the
497 Match tidy it must be done one column each time due to bookeping
502 simplify_eqns :: [EquationInfo] -> [EquationInfo]
503 simplify_eqns [] = []
504 simplify_eqns ((EqnInfo n ctx pats result):qs) =
505 (EqnInfo n ctx pats' result) : simplify_eqns qs
507 pats' = map simplify_pat pats
509 simplify_pat :: TypecheckedPat -> TypecheckedPat
511 simplify_pat pat@(WildPat gt) = pat
512 simplify_pat (VarPat id) = WildPat (idType id)
514 simplify_pat (LazyPat p) = simplify_pat p
516 simplify_pat (AsPat id p) = simplify_pat p
518 simplify_pat (ConPat id ty ps) = ConPat id ty (map simplify_pat ps)
520 simplify_pat (ConOpPat p1 id p2 ty) = ConPat id ty (map simplify_pat [p1,p2])
522 simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [x, y])
523 (ConPat nilDataCon list_ty [])
524 (map simplify_pat ps)
525 where list_ty = mkListTy ty
528 simplify_pat (TuplePat ps) = ConPat (tupleCon arity)
529 (mkTupleTy arity (map outPatType ps))
530 (map simplify_pat ps)
534 simplify_pat (RecPat id ty idps) = ConPat id ty pats
536 pats = map (\ (id,p,_)-> simplify_pat p) idps
538 simplify_pat pat@(LitPat lit lit_ty)
539 | isUnboxedType lit_ty = pat
541 | lit_ty == charTy = ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy]
543 | otherwise = pprPanic "tidy1:LitPat:" (ppr pat)
545 mk_char (HsChar c) = HsCharPrim c
547 simplify_pat (NPat lit lit_ty hsexpr) = better_pat
550 | lit_ty == charTy = ConPat charDataCon lit_ty [LitPat (mk_char lit) charPrimTy]
551 | lit_ty == intTy = ConPat intDataCon lit_ty [LitPat (mk_int lit) intPrimTy]
552 | lit_ty == wordTy = ConPat wordDataCon lit_ty [LitPat (mk_word lit) wordPrimTy]
553 | lit_ty == addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy]
554 | lit_ty == floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy]
555 | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy]
557 -- Convert the literal pattern "" to the constructor pattern [].
558 | null_str_lit lit = ConPat nilDataCon lit_ty []
559 | one_str_lit lit = ConPat consDataCon list_ty
560 [ ConPat charDataCon lit_ty [LitPat (mk_head_char lit) charPrimTy]
561 , ConPat nilDataCon lit_ty []]
563 | otherwise = NPat lit lit_ty hsexpr
565 list_ty = mkListTy lit_ty
567 mk_int (HsInt i) = HsIntPrim i
568 mk_int l@(HsLitLit s) = l
570 mk_head_char (HsString s) = HsCharPrim (_HEAD_ s)
572 mk_char (HsChar c) = HsCharPrim c
573 mk_char l@(HsLitLit s) = l
575 mk_word l@(HsLitLit s) = l
577 mk_addr l@(HsLitLit s) = l
579 mk_float (HsInt i) = HsFloatPrim (fromInteger i)
580 mk_float (HsFrac f) = HsFloatPrim f
581 mk_float l@(HsLitLit s) = l
583 mk_double (HsInt i) = HsDoublePrim (fromInteger i)
584 mk_double (HsFrac f) = HsDoublePrim f
585 mk_double l@(HsLitLit s) = l
587 null_str_lit (HsString s) = _NULL_ s
588 null_str_lit other_lit = False
590 one_str_lit (HsString s) = _LENGTH_ s == (1::Int)
591 one_str_lit other_lit = False
593 simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) = --NPlusKPat id hslit ty hsexpr1 hsexpr2
595 where ty = panic "Check.simplify_pat: Never used"
597 simplify_pat (DictPat dicts methods) =
598 case num_of_d_and_ms of
599 0 -> simplify_pat (TuplePat [])
600 1 -> simplify_pat (head dict_and_method_pats)
601 _ -> simplify_pat (TuplePat dict_and_method_pats)
603 num_of_d_and_ms = length dicts + length methods
604 dict_and_method_pats = map VarPat (dicts ++ methods)