2 % (c) The GRASP/AQUA Project, Glasgow University, 1997
4 % Author: Juan J. Quintela <quintela@dc.fi.udc.es>
8 #include "HsVersions.h"
10 module Check ( check , SYN_IE(ExhaustivePat), SYN_IE(WarningPat), BoxedString(..) ) where
13 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
14 IMPORT_DELOOPER(DsLoop) -- here for paranoia-checking reasons
15 -- and to break dsExpr/dsBinds-ish loop
17 import {-# SOURCE #-} DsExpr ( dsExpr )
18 import {-# SOURCE #-} DsBinds ( dsBinds )
22 import TcHsSyn ( SYN_IE(TypecheckedPat),
23 SYN_IE(TypecheckedMatch),
24 SYN_IE(TypecheckedHsBinds),
25 SYN_IE(TypecheckedHsExpr)
27 import DsHsSyn ( outPatType )
30 import DsMonad ( SYN_IE(DsM), DsMatchContext(..),
33 import DsUtils ( EquationInfo(..),
46 import IdInfo ( ArityInfo(..) )
47 import Lex ( isLexConSym )
48 import Name ( occNameString,
55 import Outputable ( PprStyle(..),
58 import PprType ( GenType{-instance-},
62 import Type ( isPrimType,
67 import TyVar ( GenTyVar{-instance Eq-}, SYN_IE(TyVar) )
68 import TysPrim ( intPrimTy,
75 import TysWiredIn ( nilDataCon, consDataCon,
80 floatTy, floatDataCon,
81 doubleTy, doubleDataCon,
85 import TyCon ( tyConDataCons )
87 import Unique ( Unique{-instance Eq-} )
88 import Util ( pprTrace,
94 This module perfoms checks about if one list of equations are:
98 To discover that we go through the list of equations in a tree-like fashion.
100 If you like theory, a similar algoritm is described in:
101 Two Tecniques for Compiling Lazy Pattern Matching
103 INRIA Rocquencourt (RR-2385, 1994)
105 The algorithm is based in the first Technique, but there are somo diferences:
106 - We don't generate code
107 - We have constructors and literals (not only literals as in the article)
108 - We don't use directions, we must select the columns from left-to-right
110 (By the wat the second technique is really similar to the one used in MAtch.lhs to generate code)
113 This function takes the equations of a pattern and returns:
114 - The patterns that are not recognized
115 - The equations that are not overlapped
117 It symplify the patterns and then call check' (the same semantics),and it needs to
118 reconstruct the patterns again ....
120 The problem appear with things like:
124 We want to put the two patterns with the same syntax, (prefix form) and then all the
125 constructors are equal:
126 f (: x (: y [])) = ....
129 (more about that in symplify_eqns)
131 We would preffer to have a WarningPat of type String, but Strings and the
132 Pretty Printer are not friends.
136 data BoxedString = BS String
138 type WarningPat = InPat BoxedString --Name --String
139 type ExhaustivePat = ([WarningPat], [(BoxedString, [HsLit])])
142 instance Outputable BoxedString where
143 ppr sty (BS s) = text s
146 check :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
147 check qs = check' (simplify_eqns qs)
151 This equation is the same that check, the only difference is that the
152 boring work is done, that woprk needs to be done only once, this is
153 the reason top have two funtions, check is the external interface,
154 check' is called recursively.
156 There are several cases:
159 \item There are no equations: Everything is okey.
160 \item There are only one equation, that can fail, and all the patterns are
161 variables. Then that equation is used and the same equation is
163 \item All the patterns are variables, and the match can fail,therr are more equations
164 then the results is the result of the rest of equations and this equation is used also.
166 \item The general case, if all the patterns are variables (here the match can't fail)
167 then the result is that this equation is used and this equation doesn't generate
170 \item In the general case, there can exist literals ,constructors or only vars in the
171 first column, we actuate in consecuence.
178 check' :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
179 check' [] = ([([],[])],emptyUniqSet)
181 check' [EqnInfo n ctx ps (MatchResult CanFail _ _)]
182 | all_vars ps = ([(take (length ps) (repeat new_wild_pat),[])], unitUniqSet n)
184 check' qs@((EqnInfo n ctx ps (MatchResult CanFail _ _)):_)
185 | all_vars ps = (pats, addOneToUniqSet indexs n)
187 (pats,indexs) = check' (tail qs)
189 check' qs@((EqnInfo n ctx ps result):_)
190 | all_vars ps = ([], unitUniqSet n)
191 -- | nplusk = panic "Check.check': Work in progress: nplusk"
192 -- | npat = panic "Check.check': Work in progress: npat ?????"
193 | literals = split_by_literals qs
194 | constructors = split_by_constructor qs
195 | only_vars = first_column_only_vars qs
196 | otherwise = panic "Check.check': Not implemented :-("
198 constructors = or (map is_con qs)
199 literals = or (map is_lit qs)
200 -- npat = or (map is_npat qs)
201 -- nplusk = or (map is_nplusk qs)
202 only_vars = and (map is_var qs)
205 Here begins the code to deal with literals, we need to split the matrix in diferent matrix
206 begining by each literal and a last matrix with the rest of values.
209 split_by_literals :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
210 split_by_literals qs = process_literals used_lits qs
212 used_lits = get_used_lits qs
215 process_explicit_literals is a funtion taht process each literal that appears in
216 the column of the matrix.
219 process_explicit_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
220 process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)
222 pats_indexs = map (\x -> construct_literal_matrix x qs) lits
223 (pats,indexs) = unzip pats_indexs
228 Process_literals calls process_explicit_literals to deal with the literals taht apears in
229 the matrix and deal also sith ther rest of the cases. It must be one Variable to be complete.
233 process_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
234 process_literals used_lits qs
235 | length default_eqns == 0 = ([make_row_vars used_lits (head qs)]++pats,indexs)
236 | otherwise = (pats_default,indexs_default)
238 (pats,indexs) = process_explicit_literals used_lits qs
239 default_eqns = (map remove_var (filter is_var qs))
240 (pats',indexs') = check' default_eqns
241 pats_default = [(new_wild_pat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats
242 indexs_default = unionUniqSets indexs' indexs
245 Here we have selected the literal and we will select all the equations that begins for that
246 literal and create a new matrix.
249 construct_literal_matrix :: HsLit -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
250 construct_literal_matrix lit qs =
251 (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)
253 (pats,indexs) = (check' (remove_first_column_lit lit qs))
254 new_lit = LitPatIn lit
256 remove_first_column_lit :: HsLit
259 remove_first_column_lit lit qs =
260 map shift_pat (filter (is_var_lit lit) qs)
262 shift_pat (EqnInfo n ctx [] result) = panic "Check.shift_var: no patterns"
263 shift_pat (EqnInfo n ctx (_:ps) result) = EqnInfo n ctx ps result
267 This function splits the equations @qs@ in groups that deal with the same constructor
271 split_by_constructor :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
273 split_by_constructor qs | length unused_cons /= 0 = need_default_case used_cons unused_cons qs
274 | otherwise = no_need_default_case used_cons qs
276 used_cons = get_used_cons qs
277 unused_cons = get_unused_cons used_cons
281 The first column of the patterns matrix only have vars, then there is nothing to do.
284 first_column_only_vars :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
285 first_column_only_vars qs = (map (\ (xs,ys) -> (WildPatIn:xs,ys)) pats,indexs)
287 (pats,indexs) = check' (map remove_var qs)
291 This equation takes a matrix of patterns and split the equations by constructor, using all
292 the constructors that appears in the first column of the pattern matching.
294 We can need a default clause or not ...., it depends if we used all the constructors or not
295 explicitily. The reasoning is similar to process_literals, the difference is that here
296 the default case is not allways needed.
299 no_need_default_case :: [TypecheckedPat] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
300 no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
302 pats_indexs = map (\x -> construct_matrix x qs) cons
303 (pats,indexs) = unzip pats_indexs
305 need_default_case :: [TypecheckedPat] -> [Id] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
306 need_default_case used_cons unused_cons qs
307 | length default_eqns == 0 = (pats_default_no_eqns,indexs)
308 | otherwise = (pats_default,indexs_default)
310 (pats,indexs) = no_need_default_case used_cons qs
311 default_eqns = (map remove_var (filter is_var qs))
312 (pats',indexs') = check' default_eqns
313 pats_default = [(make_whole_con c:ps,constraints) |
314 c <- unused_cons, (ps,constraints) <- pats'] ++ pats
315 new_wilds = make_row_vars_for_constructor (head qs)
316 pats_default_no_eqns = [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats
317 indexs_default = unionUniqSets indexs' indexs
319 construct_matrix :: TypecheckedPat -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
320 construct_matrix con qs =
322 (map (make_con con) pats,indexs)
324 (pats,indexs) = (check' (remove_first_column con qs))
327 Here remove first column is more difficult that with literals due to the fact that
328 constructors can have arguments.
330 for instance, the matrix
342 remove_first_column :: TypecheckedPat -- Constructor
345 remove_first_column (ConPat con _ con_pats) qs =
346 map shift_var (filter (is_var_con con) qs)
348 new_wilds = [WildPat (outPatType arg_pat) | arg_pat <- con_pats]
349 shift_var (EqnInfo n ctx (ConPat _ _ ps':ps) result) =
350 EqnInfo n ctx (ps'++ps) result
351 shift_var (EqnInfo n ctx (WildPat _ :ps) result) =
352 EqnInfo n ctx (new_wilds ++ ps) result
353 shift_var _ = panic "Check.Shift_var:No done"
355 make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat
356 make_row_vars used_lits (EqnInfo _ _ pats _ ) =
357 (VarPatIn new_var:take (length (tail pats)) (repeat WildPatIn),[(new_var,used_lits)])
358 where new_var = BS "#x"
360 make_row_vars_for_constructor :: EquationInfo -> [WarningPat]
361 make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = take (length (tail pats)) (repeat WildPatIn)
363 compare_cons :: TypecheckedPat -> TypecheckedPat -> Bool
364 compare_cons (ConPat id1 _ _) (ConPat id2 _ _) = id1 == id2
366 remove_dups :: [TypecheckedPat] -> [TypecheckedPat]
368 remove_dups (x:xs) | or (map (\y -> compare_cons x y) xs) = remove_dups xs
369 | otherwise = x : remove_dups xs
371 get_used_cons :: [EquationInfo] -> [TypecheckedPat]
372 get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPat _ _ _):_) _) <- qs]
374 remove_dups' :: [HsLit] -> [HsLit]
376 remove_dups' (x:xs) | x `elem` xs = remove_dups' xs
377 | otherwise = x : remove_dups' xs
380 get_used_lits :: [EquationInfo] -> [HsLit]
381 get_used_lits qs = remove_dups' (get_used_lits' qs)
383 get_used_lits' :: [EquationInfo] -> [HsLit]
384 get_used_lits' [] = []
385 get_used_lits' ((EqnInfo _ _ ((LitPat lit _):_) _):qs) = lit : get_used_lits qs
386 get_used_lits' ((EqnInfo _ _ ((NPat lit _ _):_) _):qs) = lit : get_used_lits qs
387 get_used_lits' (q:qs) = get_used_lits qs
389 get_unused_cons :: [TypecheckedPat] -> [Id]
390 get_unused_cons used_cons = unused_cons
392 (ConPat _ ty _) = head used_cons
393 (ty_con,_) = getAppTyCon ty
394 all_cons = tyConDataCons ty_con
395 used_cons_as_id = map (\ (ConPat id _ _) -> id) used_cons
396 unused_cons = uniqSetToList (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
398 all_vars :: [TypecheckedPat] -> Bool
400 all_vars (WildPat _:ps) = all_vars ps
403 remove_var :: EquationInfo -> EquationInfo
404 remove_var (EqnInfo n ctx (WildPat _:ps) result) = EqnInfo n ctx ps result
405 remove_var _ = panic "Check:remove_var: equation not begin with a variable"
407 is_con :: EquationInfo -> Bool
408 is_con (EqnInfo _ _ ((ConPat _ _ _):_) _) = True
411 is_lit :: EquationInfo -> Bool
412 is_lit (EqnInfo _ _ ((LitPat _ _):_) _) = True
413 is_lit (EqnInfo _ _ ((NPat _ _ _):_) _) = True
416 is_npat :: EquationInfo -> Bool
417 is_npat (EqnInfo _ _ ((NPat _ _ _):_) _) = True
420 is_nplusk :: EquationInfo -> Bool
421 is_nplusk (EqnInfo _ _ ((NPlusKPat _ _ _ _ _):_) _) = True
424 is_var :: EquationInfo -> Bool
425 is_var (EqnInfo _ _ ((WildPat _):_) _) = True
428 is_var_con :: Id -> EquationInfo -> Bool
429 is_var_con con (EqnInfo _ _ ((WildPat _):_) _) = True
430 is_var_con con (EqnInfo _ _ ((ConPat id _ _):_) _) | id == con = True
431 is_var_con con _ = False
433 is_var_lit :: HsLit -> EquationInfo -> Bool
434 is_var_lit lit (EqnInfo _ _ ((WildPat _):_) _) = True
435 is_var_lit lit (EqnInfo _ _ ((LitPat lit' _):_) _) | lit == lit' = True
436 is_var_lit lit (EqnInfo _ _ ((NPat lit' _ _):_) _) | lit == lit' = True
437 is_var_lit lit _ = False
440 The difference beteewn make_con and make_whole_con is that make_wole_con creates a new
441 constructor with all their arguments, and make_Con takes a list of argumntes, creates
442 the contructor geting thir argumnts from the list. See where are used for details.
444 We need to reconstruct the patterns (make the constructors infix and similar) at the
445 same time that we create the constructors.
447 You can tell tuple constructors using
451 You can see if one contructur is infix with this clearer code :-))))))))))
453 Lex.isLexConSym (Name.occNameString (Name.getOccName con))
455 Rather clumsy but it works. (Simon Peyton Jones)
458 We con't mind the nilDataCon because it doesn't change the way to print the messsage,
459 we are searching only for things like: [1,2,3], not x:xs ....
462 In recontruct_pat we want to "undo" the work taht we have done in simplify_pat
464 ((,) x y) returns to be (x, y)
465 ((:) x xs) returns to be (x:xs)
466 (x:(...:[]) returns to be [x,...]
468 The dificult case is the third one becouse we need to follow all the contructors until the []
469 to know taht we need to use the second case, not the second.
473 isInfixCon con = isLexConSym (occNameString (getOccName con))
475 is_nil (ConPatIn (BS con) []) = con == getOccString nilDataCon
478 is_list (ListPatIn _) = True
481 return_list id q = id == consDataCon && (is_nil q || is_list q)
483 make_list p q | is_nil q = ListPatIn [p]
484 make_list p (ListPatIn ps) = ListPatIn (p:ps)
485 make_list _ _ = panic "Check.make_list: Invalid argument"
487 make_con :: TypecheckedPat -> ExhaustivePat -> ExhaustivePat
488 make_con (ConPat id ty pats) (p:q:ps, constraints)
489 | return_list id q = (make_list p q : ps, constraints)
490 | isInfixCon id = (ParPatIn (ConOpPatIn p name fixity q) : ps, constraints)
491 where name = BS (getOccString id)
492 fixity = panic "Check.make_con: Guessing fixity"
493 make_con (ConPat id ty pats) (ps,constraints)
494 | isTupleCon id = (TuplePatIn pats_con : rest_pats, constraints)
495 | otherwise = (ConPatIn name pats_con : rest_pats, constraints)
496 where num_args = length pats
497 name = BS (getOccString id)
498 pats_con = (take num_args ps)
499 rest_pats = drop num_args ps
501 make_whole_con :: Id -> WarningPat
502 make_whole_con con | isInfixCon con = ParPatIn(ConOpPatIn new_wild_pat name fixity new_wild_pat)
503 | otherwise = ConPatIn name pats
505 fixity = panic "Check.make_whole_con: Guessing fixity"
506 name = BS (getOccString con)
507 arity = get_int_arity con
508 pats = take arity (repeat new_wild_pat)
511 new_wild_pat :: WarningPat
512 new_wild_pat = WildPatIn
514 get_int_arity :: Id -> Int
515 get_int_arity id = arity_to_int (getIdArity id)
517 arity_to_int (ArityExactly n) = n
518 arity_to_int _ = panic "getIntArity: Unknown arity"
522 This equation makes the same thing that tidy in Match.lhs, the
523 diference is that here we can do all the tidy in one place and in the
524 Match tidy it must be done one column each time due to bookeping
529 simplify_eqns :: [EquationInfo] -> [EquationInfo]
530 simplify_eqns [] = []
531 simplify_eqns ((EqnInfo n ctx pats result):qs) =
532 (EqnInfo n ctx(map simplify_pat pats) result) :
535 simplify_pat :: TypecheckedPat -> TypecheckedPat
536 simplify_pat (WildPat gt ) = WildPat gt
538 simplify_pat (VarPat id) = WildPat (idType id)
540 simplify_pat (LazyPat p) = simplify_pat p
542 simplify_pat (AsPat id p) = simplify_pat p
544 simplify_pat (ConPat id ty ps) = ConPat id ty (map simplify_pat ps)
546 simplify_pat (ConOpPat p1 id p2 ty) = ConPat id ty (map simplify_pat [p1,p2])
548 simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [x, y])
549 (ConPat nilDataCon list_ty [])
550 (map simplify_pat ps)
551 where list_ty = mkListTy ty
554 simplify_pat (TuplePat ps) = ConPat (tupleCon arity)
555 (mkTupleTy arity (map outPatType ps))
556 (map simplify_pat ps)
560 simplify_pat (RecPat id ty idps) = ConPat id ty pats
562 pats = map (\ (id,p,_)-> simplify_pat p) idps
564 simplify_pat pat@(LitPat lit lit_ty)
565 | isPrimType lit_ty = LitPat lit lit_ty
567 | lit_ty `eqTy` charTy = ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy]
569 | otherwise = pprPanic "tidy1:LitPat:" (ppr PprDebug pat)
571 mk_char (HsChar c) = HsCharPrim c
573 simplify_pat (NPat lit lit_ty hsexpr) = better_pat
576 | lit_ty `eqTy` charTy = ConPat charDataCon lit_ty [LitPat (mk_char lit) charPrimTy]
577 | lit_ty `eqTy` intTy = ConPat intDataCon lit_ty [LitPat (mk_int lit) intPrimTy]
578 | lit_ty `eqTy` wordTy = ConPat wordDataCon lit_ty [LitPat (mk_word lit) wordPrimTy]
579 | lit_ty `eqTy` addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy]
580 | lit_ty `eqTy` floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy]
581 | lit_ty `eqTy` doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy]
583 -- Convert the literal pattern "" to the constructor pattern [].
584 | null_str_lit lit = ConPat nilDataCon lit_ty []
586 | otherwise = NPat lit lit_ty hsexpr
588 mk_int (HsInt i) = HsIntPrim i
589 mk_int l@(HsLitLit s) = l
591 mk_char (HsChar c) = HsCharPrim c
592 mk_char l@(HsLitLit s) = l
594 mk_word l@(HsLitLit s) = l
596 mk_addr l@(HsLitLit s) = l
598 mk_float (HsInt i) = HsFloatPrim (fromInteger i)
599 mk_float (HsFrac f) = HsFloatPrim f
600 mk_float l@(HsLitLit s) = l
602 mk_double (HsInt i) = HsDoublePrim (fromInteger i)
603 mk_double (HsFrac f) = HsDoublePrim f
604 mk_double l@(HsLitLit s) = l
606 null_str_lit (HsString s) = _NULL_ s
607 null_str_lit other_lit = False
609 simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) = --NPlusKPat id hslit ty hsexpr1 hsexpr2
611 where ty = panic "Check.simplify_pat: Never used"
613 simplify_pat (DictPat dicts methods) =
614 case num_of_d_and_ms of
615 0 -> simplify_pat (TuplePat [])
616 1 -> simplify_pat (head dict_and_method_pats)
617 _ -> simplify_pat (TuplePat dict_and_method_pats)
619 num_of_d_and_ms = length dicts + length methods
620 dict_and_method_pats = map VarPat (dicts ++ methods)