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
12 import {-# SOURCE #-} DsExpr ( dsExpr )
13 import {-# SOURCE #-} DsBinds ( dsBinds )
16 import TcHsSyn ( TypecheckedPat,
21 import DsHsSyn ( outPatType )
24 import DsMonad ( DsM, DsMatchContext(..),
27 import DsUtils ( EquationInfo(..),
39 import IdInfo ( ArityInfo(..) )
40 import Lex ( isLexConSym )
41 import Name ( occNameString,
52 import TyVar ( TyVar )
53 import TysPrim ( intPrimTy,
60 import TysWiredIn ( nilDataCon, consDataCon,
65 floatTy, floatDataCon,
66 doubleTy, doubleDataCon,
70 import TyCon ( tyConDataCons )
72 import Unique ( Unique )
75 #include "HsVersions.h"
78 This module perfoms checks about if one list of equations are:
82 To discover that we go through the list of equations in a tree-like fashion.
84 If you like theory, a similar algoritm is described in:
85 Two Tecniques for Compiling Lazy Pattern Matching
87 INRIA Rocquencourt (RR-2385, 1994)
89 The algorithm is based in the first Technique, but there are somo diferences:
90 - We don't generate code
91 - We have constructors and literals (not only literals as in the article)
92 - We don't use directions, we must select the columns from left-to-right
94 (By the wat the second technique is really similar to the one used in MAtch.lhs to generate code)
97 This function takes the equations of a pattern and returns:
98 - The patterns that are not recognized
99 - The equations that are not overlapped
101 It symplify the patterns and then call check' (the same semantics),and it needs to
102 reconstruct the patterns again ....
104 The problem appear with things like:
108 We want to put the two patterns with the same syntax, (prefix form) and then all the
109 constructors are equal:
110 f (: x (: y [])) = ....
113 (more about that in symplify_eqns)
115 We would preffer to have a WarningPat of type String, but Strings and the
116 Pretty Printer are not friends.
120 newtype BoxedString = BS String
122 type WarningPat = InPat BoxedString --Name --String
123 type ExhaustivePat = ([WarningPat], [(BoxedString, [HsLit])])
126 instance Outputable BoxedString where
130 check :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
131 check qs = check' (simplify_eqns qs)
135 This equation is the same that check, the only difference is that the
136 boring work is done, that woprk needs to be done only once, this is
137 the reason top have two funtions, check is the external interface,
138 check' is called recursively.
140 There are several cases:
143 \item There are no equations: Everything is okey.
144 \item There are only one equation, that can fail, and all the patterns are
145 variables. Then that equation is used and the same equation is
147 \item All the patterns are variables, and the match can fail,therr are more equations
148 then the results is the result of the rest of equations and this equation is used also.
150 \item The general case, if all the patterns are variables (here the match can't fail)
151 then the result is that this equation is used and this equation doesn't generate
154 \item In the general case, there can exist literals ,constructors or only vars in the
155 first column, we actuate in consecuence.
162 check' :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
163 check' [] = ([([],[])],emptyUniqSet)
165 check' [EqnInfo n ctx ps (MatchResult CanFail _ _)]
166 | all_vars ps = ([(take (length ps) (repeat new_wild_pat),[])], unitUniqSet n)
168 check' qs@((EqnInfo n ctx ps (MatchResult CanFail _ _)):_)
169 | all_vars ps = (pats, addOneToUniqSet indexs n)
171 (pats,indexs) = check' (tail qs)
173 check' qs@((EqnInfo n ctx ps result):_)
174 | all_vars ps = ([], unitUniqSet n)
175 -- | nplusk = panic "Check.check': Work in progress: nplusk"
176 -- | npat = panic "Check.check': Work in progress: npat ?????"
177 | literals = split_by_literals qs
178 | constructors = split_by_constructor qs
179 | only_vars = first_column_only_vars qs
180 | otherwise = panic "Check.check': Not implemented :-("
182 constructors = or (map is_con qs)
183 literals = or (map is_lit qs)
184 -- npat = or (map is_npat qs)
185 -- nplusk = or (map is_nplusk qs)
186 only_vars = and (map is_var qs)
189 Here begins the code to deal with literals, we need to split the matrix in diferent matrix
190 begining by each literal and a last matrix with the rest of values.
193 split_by_literals :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
194 split_by_literals qs = process_literals used_lits qs
196 used_lits = get_used_lits qs
199 process_explicit_literals is a funtion taht process each literal that appears in
200 the column of the matrix.
203 process_explicit_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
204 process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)
206 pats_indexs = map (\x -> construct_literal_matrix x qs) lits
207 (pats,indexs) = unzip pats_indexs
212 Process_literals calls process_explicit_literals to deal with the literals taht apears in
213 the matrix and deal also sith ther rest of the cases. It must be one Variable to be complete.
217 process_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
218 process_literals used_lits qs
219 | length default_eqns == 0 = ([make_row_vars used_lits (head qs)]++pats,indexs)
220 | otherwise = (pats_default,indexs_default)
222 (pats,indexs) = process_explicit_literals used_lits qs
223 default_eqns = (map remove_var (filter is_var qs))
224 (pats',indexs') = check' default_eqns
225 pats_default = [(new_wild_pat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats
226 indexs_default = unionUniqSets indexs' indexs
229 Here we have selected the literal and we will select all the equations that begins for that
230 literal and create a new matrix.
233 construct_literal_matrix :: HsLit -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
234 construct_literal_matrix lit qs =
235 (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)
237 (pats,indexs) = (check' (remove_first_column_lit lit qs))
238 new_lit = LitPatIn lit
240 remove_first_column_lit :: HsLit
243 remove_first_column_lit lit qs =
244 map shift_pat (filter (is_var_lit lit) qs)
246 shift_pat (EqnInfo n ctx [] result) = panic "Check.shift_var: no patterns"
247 shift_pat (EqnInfo n ctx (_:ps) result) = EqnInfo n ctx ps result
251 This function splits the equations @qs@ in groups that deal with the same constructor
255 split_by_constructor :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
257 split_by_constructor qs | length unused_cons /= 0 = need_default_case used_cons unused_cons qs
258 | otherwise = no_need_default_case used_cons qs
260 used_cons = get_used_cons qs
261 unused_cons = get_unused_cons used_cons
265 The first column of the patterns matrix only have vars, then there is nothing to do.
268 first_column_only_vars :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
269 first_column_only_vars qs = (map (\ (xs,ys) -> (WildPatIn:xs,ys)) pats,indexs)
271 (pats,indexs) = check' (map remove_var qs)
275 This equation takes a matrix of patterns and split the equations by constructor, using all
276 the constructors that appears in the first column of the pattern matching.
278 We can need a default clause or not ...., it depends if we used all the constructors or not
279 explicitily. The reasoning is similar to process_literals, the difference is that here
280 the default case is not allways needed.
283 no_need_default_case :: [TypecheckedPat] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
284 no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
286 pats_indexs = map (\x -> construct_matrix x qs) cons
287 (pats,indexs) = unzip pats_indexs
289 need_default_case :: [TypecheckedPat] -> [Id] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
290 need_default_case used_cons unused_cons qs
291 | length default_eqns == 0 = (pats_default_no_eqns,indexs)
292 | otherwise = (pats_default,indexs_default)
294 (pats,indexs) = no_need_default_case used_cons qs
295 default_eqns = (map remove_var (filter is_var qs))
296 (pats',indexs') = check' default_eqns
297 pats_default = [(make_whole_con c:ps,constraints) |
298 c <- unused_cons, (ps,constraints) <- pats'] ++ pats
299 new_wilds = make_row_vars_for_constructor (head qs)
300 pats_default_no_eqns = [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats
301 indexs_default = unionUniqSets indexs' indexs
303 construct_matrix :: TypecheckedPat -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
304 construct_matrix con qs =
306 (map (make_con con) pats,indexs)
308 (pats,indexs) = (check' (remove_first_column con qs))
311 Here remove first column is more difficult that with literals due to the fact that
312 constructors can have arguments.
314 for instance, the matrix
326 remove_first_column :: TypecheckedPat -- Constructor
329 remove_first_column (ConPat con _ con_pats) qs =
330 map shift_var (filter (is_var_con con) qs)
332 new_wilds = [WildPat (outPatType arg_pat) | arg_pat <- con_pats]
333 shift_var (EqnInfo n ctx (ConPat _ _ ps':ps) result) =
334 EqnInfo n ctx (ps'++ps) result
335 shift_var (EqnInfo n ctx (WildPat _ :ps) result) =
336 EqnInfo n ctx (new_wilds ++ ps) result
337 shift_var _ = panic "Check.Shift_var:No done"
339 make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat
340 make_row_vars used_lits (EqnInfo _ _ pats _ ) =
341 (VarPatIn new_var:take (length (tail pats)) (repeat WildPatIn),[(new_var,used_lits)])
342 where new_var = BS "#x"
344 make_row_vars_for_constructor :: EquationInfo -> [WarningPat]
345 make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = take (length (tail pats)) (repeat WildPatIn)
347 compare_cons :: TypecheckedPat -> TypecheckedPat -> Bool
348 compare_cons (ConPat id1 _ _) (ConPat id2 _ _) = id1 == id2
350 remove_dups :: [TypecheckedPat] -> [TypecheckedPat]
352 remove_dups (x:xs) | or (map (\y -> compare_cons x y) xs) = remove_dups xs
353 | otherwise = x : remove_dups xs
355 get_used_cons :: [EquationInfo] -> [TypecheckedPat]
356 get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPat _ _ _):_) _) <- qs]
358 remove_dups' :: [HsLit] -> [HsLit]
360 remove_dups' (x:xs) | x `elem` xs = remove_dups' xs
361 | otherwise = x : remove_dups' xs
364 get_used_lits :: [EquationInfo] -> [HsLit]
365 get_used_lits qs = remove_dups' (get_used_lits' qs)
367 get_used_lits' :: [EquationInfo] -> [HsLit]
368 get_used_lits' [] = []
369 get_used_lits' ((EqnInfo _ _ ((LitPat lit _):_) _):qs) = lit : get_used_lits qs
370 get_used_lits' ((EqnInfo _ _ ((NPat lit _ _):_) _):qs) = lit : get_used_lits qs
371 get_used_lits' (q:qs) = get_used_lits qs
373 get_unused_cons :: [TypecheckedPat] -> [Id]
374 get_unused_cons used_cons = unused_cons
376 (ConPat _ ty _) = head used_cons
377 Just (ty_con,_) = splitTyConApp_maybe ty
378 all_cons = tyConDataCons ty_con
379 used_cons_as_id = map (\ (ConPat id _ _) -> id) used_cons
380 unused_cons = uniqSetToList (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
382 all_vars :: [TypecheckedPat] -> Bool
384 all_vars (WildPat _:ps) = all_vars ps
387 remove_var :: EquationInfo -> EquationInfo
388 remove_var (EqnInfo n ctx (WildPat _:ps) result) = EqnInfo n ctx ps result
389 remove_var _ = panic "Check:remove_var: equation not begin with a variable"
391 is_con :: EquationInfo -> Bool
392 is_con (EqnInfo _ _ ((ConPat _ _ _):_) _) = True
395 is_lit :: EquationInfo -> Bool
396 is_lit (EqnInfo _ _ ((LitPat _ _):_) _) = True
397 is_lit (EqnInfo _ _ ((NPat _ _ _):_) _) = True
400 is_npat :: EquationInfo -> Bool
401 is_npat (EqnInfo _ _ ((NPat _ _ _):_) _) = True
404 is_nplusk :: EquationInfo -> Bool
405 is_nplusk (EqnInfo _ _ ((NPlusKPat _ _ _ _ _):_) _) = True
408 is_var :: EquationInfo -> Bool
409 is_var (EqnInfo _ _ ((WildPat _):_) _) = True
412 is_var_con :: Id -> EquationInfo -> Bool
413 is_var_con con (EqnInfo _ _ ((WildPat _):_) _) = True
414 is_var_con con (EqnInfo _ _ ((ConPat id _ _):_) _) | id == con = True
415 is_var_con con _ = False
417 is_var_lit :: HsLit -> EquationInfo -> Bool
418 is_var_lit lit (EqnInfo _ _ ((WildPat _):_) _) = True
419 is_var_lit lit (EqnInfo _ _ ((LitPat lit' _):_) _) | lit == lit' = True
420 is_var_lit lit (EqnInfo _ _ ((NPat lit' _ _):_) _) | lit == lit' = True
421 is_var_lit lit _ = False
424 The difference beteewn make_con and make_whole_con is that make_wole_con creates a new
425 constructor with all their arguments, and make_Con takes a list of argumntes, creates
426 the contructor geting thir argumnts from the list. See where are used for details.
428 We need to reconstruct the patterns (make the constructors infix and similar) at the
429 same time that we create the constructors.
431 You can tell tuple constructors using
435 You can see if one contructur is infix with this clearer code :-))))))))))
437 Lex.isLexConSym (Name.occNameString (Name.getOccName con))
439 Rather clumsy but it works. (Simon Peyton Jones)
442 We con't mind the nilDataCon because it doesn't change the way to print the messsage,
443 we are searching only for things like: [1,2,3], not x:xs ....
446 In recontruct_pat we want to "undo" the work taht we have done in simplify_pat
448 ((,) x y) returns to be (x, y)
449 ((:) x xs) returns to be (x:xs)
450 (x:(...:[]) returns to be [x,...]
452 The dificult case is the third one becouse we need to follow all the contructors until the []
453 to know taht we need to use the second case, not the second.
457 isInfixCon con = isLexConSym (occNameString (getOccName con))
459 is_nil (ConPatIn (BS con) []) = con == getOccString nilDataCon
462 is_list (ListPatIn _) = True
465 return_list id q = id == consDataCon && (is_nil q || is_list q)
467 make_list p q | is_nil q = ListPatIn [p]
468 make_list p (ListPatIn ps) = ListPatIn (p:ps)
469 make_list _ _ = panic "Check.make_list: Invalid argument"
471 make_con :: TypecheckedPat -> ExhaustivePat -> ExhaustivePat
472 make_con (ConPat id ty pats) (p:q:ps, constraints)
473 | return_list id q = (make_list p q : ps, constraints)
474 | isInfixCon id = (ParPatIn (ConOpPatIn p name fixity q) : ps, constraints)
475 where name = BS (getOccString id)
476 fixity = panic "Check.make_con: Guessing fixity"
477 make_con (ConPat id ty pats) (ps,constraints)
478 | isTupleCon id = (TuplePatIn pats_con : rest_pats, constraints)
479 | otherwise = (ConPatIn name pats_con : rest_pats, constraints)
480 where num_args = length pats
481 name = BS (getOccString id)
482 pats_con = (take num_args ps)
483 rest_pats = drop num_args ps
485 make_whole_con :: Id -> WarningPat
486 make_whole_con con | isInfixCon con = ParPatIn(ConOpPatIn new_wild_pat name fixity new_wild_pat)
487 | otherwise = ConPatIn name pats
489 fixity = panic "Check.make_whole_con: Guessing fixity"
490 name = BS (getOccString con)
491 arity = get_int_arity con
492 pats = take arity (repeat new_wild_pat)
495 new_wild_pat :: WarningPat
496 new_wild_pat = WildPatIn
498 get_int_arity :: Id -> Int
499 get_int_arity id = arity_to_int (getIdArity id)
501 arity_to_int (ArityExactly n) = n
502 arity_to_int _ = panic "getIntArity: Unknown arity"
506 This equation makes the same thing that tidy in Match.lhs, the
507 diference is that here we can do all the tidy in one place and in the
508 Match tidy it must be done one column each time due to bookeping
513 simplify_eqns :: [EquationInfo] -> [EquationInfo]
514 simplify_eqns [] = []
515 simplify_eqns ((EqnInfo n ctx pats result):qs) =
516 (EqnInfo n ctx(map simplify_pat pats) result) :
519 simplify_pat :: TypecheckedPat -> TypecheckedPat
520 simplify_pat (WildPat gt ) = WildPat gt
522 simplify_pat (VarPat id) = WildPat (idType id)
524 simplify_pat (LazyPat p) = simplify_pat p
526 simplify_pat (AsPat id p) = simplify_pat p
528 simplify_pat (ConPat id ty ps) = ConPat id ty (map simplify_pat ps)
530 simplify_pat (ConOpPat p1 id p2 ty) = ConPat id ty (map simplify_pat [p1,p2])
532 simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [x, y])
533 (ConPat nilDataCon list_ty [])
534 (map simplify_pat ps)
535 where list_ty = mkListTy ty
538 simplify_pat (TuplePat ps) = ConPat (tupleCon arity)
539 (mkTupleTy arity (map outPatType ps))
540 (map simplify_pat ps)
544 simplify_pat (RecPat id ty idps) = ConPat id ty pats
546 pats = map (\ (id,p,_)-> simplify_pat p) idps
548 simplify_pat pat@(LitPat lit lit_ty)
549 | isUnboxedType lit_ty = LitPat lit lit_ty
551 | lit_ty == charTy = ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy]
553 | otherwise = pprPanic "tidy1:LitPat:" (ppr pat)
555 mk_char (HsChar c) = HsCharPrim c
557 simplify_pat (NPat lit lit_ty hsexpr) = better_pat
560 | lit_ty == charTy = ConPat charDataCon lit_ty [LitPat (mk_char lit) charPrimTy]
561 | lit_ty == intTy = ConPat intDataCon lit_ty [LitPat (mk_int lit) intPrimTy]
562 | lit_ty == wordTy = ConPat wordDataCon lit_ty [LitPat (mk_word lit) wordPrimTy]
563 | lit_ty == addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy]
564 | lit_ty == floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy]
565 | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy]
567 -- Convert the literal pattern "" to the constructor pattern [].
568 | null_str_lit lit = ConPat nilDataCon lit_ty []
570 | otherwise = NPat lit lit_ty hsexpr
572 mk_int (HsInt i) = HsIntPrim i
573 mk_int l@(HsLitLit s) = l
575 mk_char (HsChar c) = HsCharPrim c
576 mk_char l@(HsLitLit s) = l
578 mk_word l@(HsLitLit s) = l
580 mk_addr l@(HsLitLit s) = l
582 mk_float (HsInt i) = HsFloatPrim (fromInteger i)
583 mk_float (HsFrac f) = HsFloatPrim f
584 mk_float l@(HsLitLit s) = l
586 mk_double (HsInt i) = HsDoublePrim (fromInteger i)
587 mk_double (HsFrac f) = HsDoublePrim f
588 mk_double l@(HsLitLit s) = l
590 null_str_lit (HsString s) = _NULL_ s
591 null_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)