2 % (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
4 % Author: Juan J. Quintela <quintela@krilin.dc.fi.udc.es>
5 \section{Module @Check@ in @deSugar@}
10 module Check ( check , ExhaustivePat ) where
14 import TcHsSyn ( TypecheckedPat, outPatType )
15 import TcType ( tcTyConAppTyCon, tcTyConAppArgs )
16 import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet,
17 CanItFail(..), tidyLitPat, tidyNPat,
20 import DataCon ( DataCon, dataConTyCon, dataConArgTys,
21 dataConSourceArity, dataConFieldLabels )
22 import Name ( Name, mkInternalName, getOccName, isDataSymOcc, getName, mkVarOcc )
23 import TcType ( mkTyVarTys )
24 import TysPrim ( charPrimTy )
26 import PrelNames ( unboundKey )
27 import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
28 import BasicTypes ( Boxity(..) )
29 import SrcLoc ( noSrcLoc )
31 import Util ( takeList, splitAtList, notNull )
35 #include "HsVersions.h"
38 This module performs checks about if one list of equations are:
43 To discover that we go through the list of equations in a tree-like fashion.
45 If you like theory, a similar algorithm is described in:
47 {\em Two Techniques for Compiling Lazy Pattern Matching},
49 INRIA Rocquencourt (RR-2385, 1994)
51 The algorithm is based on the first technique, but there are some differences:
53 \item We don't generate code
54 \item We have constructors and literals (not only literals as in the
56 \item We don't use directions, we must select the columns from
59 (By the way the second technique is really similar to the one used in
60 @Match.lhs@ to generate code)
62 This function takes the equations of a pattern and returns:
64 \item The patterns that are not recognized
65 \item The equations that are not overlapped
67 It simplify the patterns and then call @check'@ (the same semantics), and it
68 needs to reconstruct the patterns again ....
70 The problem appear with things like:
75 We want to put the two patterns with the same syntax, (prefix form) and
76 then all the constructors are equal:
78 f (: x (: y [])) = ....
81 (more about that in @simplify_eqns@)
83 We would prefer to have a @WarningPat@ of type @String@, but Strings and the
84 Pretty Printer are not friends.
86 We use @InPat@ in @WarningPat@ instead of @OutPat@
87 because we need to print the
88 warning messages in the same way they are introduced, i.e. if the user
93 He don't want a warning message written:
95 f (: x (: y [])) ........
97 Then we need to use InPats.
99 Juan Quintela 5 JUL 1998\\
100 User-friendliness and compiler writers are no friends.
104 type WarningPat = InPat Name
105 type ExhaustivePat = ([WarningPat], [(Name, [HsLit])])
108 check :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
109 check qs = (untidy_warns, incomplete)
111 (warns, incomplete) = check' (simplify_eqns qs)
112 untidy_warns = map untidy_exhaustive warns
114 untidy_exhaustive :: ExhaustivePat -> ExhaustivePat
115 untidy_exhaustive ([pat], messages) =
116 ([untidy_no_pars pat], map untidy_message messages)
117 untidy_exhaustive (pats, messages) =
118 (map untidy_pars pats, map untidy_message messages)
120 untidy_message :: (Name, [HsLit]) -> (Name, [HsLit])
121 untidy_message (string, lits) = (string, map untidy_lit lits)
124 The function @untidy@ does the reverse work of the @simplify_pat@ funcion.
130 untidy_no_pars :: WarningPat -> WarningPat
131 untidy_no_pars p = untidy False p
133 untidy_pars :: WarningPat -> WarningPat
134 untidy_pars p = untidy True p
136 untidy :: NeedPars -> WarningPat -> WarningPat
137 untidy _ p@WildPatIn = p
138 untidy _ p@(VarPatIn name) = p
139 untidy _ (LitPatIn lit) = LitPatIn (untidy_lit lit)
140 untidy _ p@(ConPatIn name []) = p
141 untidy b (ConPatIn name pats) =
142 pars b (ConPatIn name (map untidy_pars pats))
143 untidy b (ConOpPatIn pat1 name fixity pat2) =
144 pars b (ConOpPatIn (untidy_pars pat1) name fixity (untidy_pars pat2))
145 untidy _ (ListPatIn pats) = ListPatIn (map untidy_no_pars pats)
146 untidy _ (PArrPatIn pats) =
147 panic "Check.untidy: Shouldn't get a parallel array here!"
148 untidy _ (TuplePatIn pats boxed) = TuplePatIn (map untidy_no_pars pats) boxed
150 untidy _ pat = pprPanic "Check.untidy: SigPatIn" (ppr pat)
152 pars :: NeedPars -> WarningPat -> WarningPat
153 pars True p = ParPatIn p
156 untidy_lit :: HsLit -> HsLit
157 untidy_lit (HsCharPrim c) = HsChar c
158 --untidy_lit (HsStringPrim s) = HsString s
162 This equation is the same that check, the only difference is that the
163 boring work is done, that work needs to be done only once, this is
164 the reason top have two functions, check is the external interface,
165 @check'@ is called recursively.
167 There are several cases:
170 \item There are no equations: Everything is OK.
171 \item There are only one equation, that can fail, and all the patterns are
172 variables. Then that equation is used and the same equation is
174 \item All the patterns are variables, and the match can fail, there are
175 more equations then the results is the result of the rest of equations
176 and this equation is used also.
178 \item The general case, if all the patterns are variables (here the match
179 can't fail) then the result is that this equation is used and this
180 equation doesn't generate non-exhaustive cases.
182 \item In the general case, there can exist literals ,constructors or only
183 vars in the first column, we actuate in consequence.
190 check' :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
191 check' [] = ([([],[])],emptyUniqSet)
193 check' [EqnInfo n ctx ps (MatchResult CanFail _)]
194 | all_vars ps = ([(takeList ps (repeat new_wild_pat),[])], unitUniqSet n)
196 check' qs@((EqnInfo n ctx ps (MatchResult CanFail _)):rs)
197 | all_vars ps = (pats, addOneToUniqSet indexs n)
199 (pats,indexs) = check' rs
201 check' qs@((EqnInfo n ctx ps result):_)
202 | all_vars ps = ([], unitUniqSet n)
203 -- | nplusk = panic "Check.check': Work in progress: nplusk"
204 -- | npat = panic "Check.check': Work in progress: npat ?????"
205 | literals = split_by_literals qs
206 | constructors = split_by_constructor qs
207 | only_vars = first_column_only_vars qs
208 | otherwise = panic "Check.check': Not implemented :-("
210 -- Note: RecPats will have been simplified to ConPats
212 constructors = or (map is_con qs)
213 literals = or (map is_lit qs)
214 only_vars = and (map is_var qs)
215 -- npat = or (map is_npat qs)
216 -- nplusk = or (map is_nplusk qs)
219 Here begins the code to deal with literals, we need to split the matrix
220 in different matrix beginning by each literal and a last matrix with the
224 split_by_literals :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
225 split_by_literals qs = process_literals used_lits qs
227 used_lits = get_used_lits qs
230 @process_explicit_literals@ is a function that process each literal that appears
231 in the column of the matrix.
234 process_explicit_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
235 process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)
237 pats_indexs = map (\x -> construct_literal_matrix x qs) lits
238 (pats,indexs) = unzip pats_indexs
243 @process_literals@ calls @process_explicit_literals@ to deal with the literals
244 that appears in the matrix and deal also with the rest of the cases. It
245 must be one Variable to be complete.
249 process_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
250 process_literals used_lits qs
251 | null default_eqns = ([make_row_vars used_lits (head qs)]++pats,indexs)
252 | otherwise = (pats_default,indexs_default)
254 (pats,indexs) = process_explicit_literals used_lits qs
255 default_eqns = (map remove_var (filter is_var qs))
256 (pats',indexs') = check' default_eqns
257 pats_default = [(new_wild_pat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats
258 indexs_default = unionUniqSets indexs' indexs
261 Here we have selected the literal and we will select all the equations that
262 begins for that literal and create a new matrix.
265 construct_literal_matrix :: HsLit -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
266 construct_literal_matrix lit qs =
267 (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)
269 (pats,indexs) = (check' (remove_first_column_lit lit qs))
270 new_lit = LitPatIn lit
272 remove_first_column_lit :: HsLit
275 remove_first_column_lit lit qs =
276 map shift_pat (filter (is_var_lit lit) qs)
278 shift_pat (EqnInfo n ctx [] result) = panic "Check.shift_var: no patterns"
279 shift_pat (EqnInfo n ctx (_:ps) result) = EqnInfo n ctx ps result
283 This function splits the equations @qs@ in groups that deal with the
288 split_by_constructor :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
290 split_by_constructor qs
291 | notNull unused_cons = need_default_case used_cons unused_cons qs
292 | otherwise = no_need_default_case used_cons qs
294 used_cons = get_used_cons qs
295 unused_cons = get_unused_cons used_cons
299 The first column of the patterns matrix only have vars, then there is
303 first_column_only_vars :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
304 first_column_only_vars qs = (map (\ (xs,ys) -> (new_wild_pat:xs,ys)) pats,indexs)
306 (pats,indexs) = check' (map remove_var qs)
310 This equation takes a matrix of patterns and split the equations by
311 constructor, using all the constructors that appears in the first column
312 of the pattern matching.
314 We can need a default clause or not ...., it depends if we used all the
315 constructors or not explicitly. The reasoning is similar to @process_literals@,
316 the difference is that here the default case is not always needed.
319 no_need_default_case :: [TypecheckedPat] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
320 no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
322 pats_indexs = map (\x -> construct_matrix x qs) cons
323 (pats,indexs) = unzip pats_indexs
325 need_default_case :: [TypecheckedPat] -> [DataCon] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
326 need_default_case used_cons unused_cons qs
327 | null default_eqns = (pats_default_no_eqns,indexs)
328 | otherwise = (pats_default,indexs_default)
330 (pats,indexs) = no_need_default_case used_cons qs
331 default_eqns = (map remove_var (filter is_var qs))
332 (pats',indexs') = check' default_eqns
333 pats_default = [(make_whole_con c:ps,constraints) |
334 c <- unused_cons, (ps,constraints) <- pats'] ++ pats
335 new_wilds = make_row_vars_for_constructor (head qs)
336 pats_default_no_eqns = [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats
337 indexs_default = unionUniqSets indexs' indexs
339 construct_matrix :: TypecheckedPat -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
340 construct_matrix con qs =
341 (map (make_con con) pats,indexs)
343 (pats,indexs) = (check' (remove_first_column con qs))
346 Here remove first column is more difficult that with literals due to the fact
347 that constructors can have arguments.
349 For instance, the matrix
361 remove_first_column :: TypecheckedPat -- Constructor
364 remove_first_column (ConPat con _ _ _ con_pats) qs =
365 map shift_var (filter (is_var_con con) qs)
367 new_wilds = [WildPat (outPatType arg_pat) | arg_pat <- con_pats]
368 shift_var (EqnInfo n ctx (ConPat _ _ _ _ ps':ps) result) =
369 EqnInfo n ctx (ps'++ps) result
370 shift_var (EqnInfo n ctx (WildPat _ :ps) result) =
371 EqnInfo n ctx (new_wilds ++ ps) result
372 shift_var _ = panic "Check.Shift_var:No done"
374 make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat
375 make_row_vars used_lits (EqnInfo _ _ pats _ ) =
376 (VarPatIn new_var:takeList (tail pats) (repeat new_wild_pat),[(new_var,used_lits)])
377 where new_var = hash_x
379 hash_x = mkInternalName unboundKey {- doesn't matter much -}
380 (mkVarOcc FSLIT("#x"))
383 make_row_vars_for_constructor :: EquationInfo -> [WarningPat]
384 make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = takeList (tail pats) (repeat new_wild_pat)
386 compare_cons :: TypecheckedPat -> TypecheckedPat -> Bool
387 compare_cons (ConPat id1 _ _ _ _) (ConPat id2 _ _ _ _) = id1 == id2
389 remove_dups :: [TypecheckedPat] -> [TypecheckedPat]
391 remove_dups (x:xs) | or (map (\y -> compare_cons x y) xs) = remove_dups xs
392 | otherwise = x : remove_dups xs
394 get_used_cons :: [EquationInfo] -> [TypecheckedPat]
395 get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPat _ _ _ _ _):_) _) <- qs ]
397 remove_dups' :: [HsLit] -> [HsLit]
399 remove_dups' (x:xs) | x `elem` xs = remove_dups' xs
400 | otherwise = x : remove_dups' xs
403 get_used_lits :: [EquationInfo] -> [HsLit]
404 get_used_lits qs = remove_dups' all_literals
406 all_literals = get_used_lits' qs
408 get_used_lits' :: [EquationInfo] -> [HsLit]
409 get_used_lits' [] = []
410 get_used_lits' ((EqnInfo _ _ ((LitPat lit _):_) _):qs) =
411 lit : get_used_lits qs
412 get_used_lits' ((EqnInfo _ _ ((NPat lit _ _):_) _):qs) =
413 lit : get_used_lits qs
414 get_used_lits' (q:qs) =
417 get_unused_cons :: [TypecheckedPat] -> [DataCon]
418 get_unused_cons used_cons = unused_cons
420 (ConPat _ ty _ _ _) = head used_cons
421 ty_con = tcTyConAppTyCon ty -- Newtype observable
422 all_cons = tyConDataCons ty_con
423 used_cons_as_id = map (\ (ConPat d _ _ _ _) -> d) used_cons
424 unused_cons = uniqSetToList
425 (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
427 all_vars :: [TypecheckedPat] -> Bool
429 all_vars (WildPat _:ps) = all_vars ps
432 remove_var :: EquationInfo -> EquationInfo
433 remove_var (EqnInfo n ctx (WildPat _:ps) result) = EqnInfo n ctx ps result
435 panic "Check.remove_var: equation does not begin with a variable"
437 is_con :: EquationInfo -> Bool
438 is_con (EqnInfo _ _ ((ConPat _ _ _ _ _):_) _) = True
441 is_lit :: EquationInfo -> Bool
442 is_lit (EqnInfo _ _ ((LitPat _ _):_) _) = True
443 is_lit (EqnInfo _ _ ((NPat _ _ _):_) _) = True
446 is_npat :: EquationInfo -> Bool
447 is_npat (EqnInfo _ _ ((NPat _ _ _):_) _) = True
450 is_nplusk :: EquationInfo -> Bool
451 is_nplusk (EqnInfo _ _ ((NPlusKPat _ _ _ _ _):_) _) = True
454 is_var :: EquationInfo -> Bool
455 is_var (EqnInfo _ _ ((WildPat _):_) _) = True
458 is_var_con :: DataCon -> EquationInfo -> Bool
459 is_var_con con (EqnInfo _ _ ((WildPat _):_) _) = True
460 is_var_con con (EqnInfo _ _ ((ConPat id _ _ _ _):_) _) | id == con = True
461 is_var_con con _ = False
463 is_var_lit :: HsLit -> EquationInfo -> Bool
464 is_var_lit lit (EqnInfo _ _ ((WildPat _):_) _) = True
465 is_var_lit lit (EqnInfo _ _ ((LitPat lit' _):_) _) | lit == lit' = True
466 is_var_lit lit (EqnInfo _ _ ((NPat lit' _ _):_) _) | lit == lit' = True
467 is_var_lit lit _ = False
470 The difference beteewn @make_con@ and @make_whole_con@ is that
471 @make_wole_con@ creates a new constructor with all their arguments, and
472 @make_con@ takes a list of argumntes, creates the contructor getting their
473 arguments from the list. See where \fbox{\ ???\ } are used for details.
475 We need to reconstruct the patterns (make the constructors infix and
476 similar) at the same time that we create the constructors.
478 You can tell tuple constructors using
482 You can see if one constructor is infix with this clearer code :-))))))))))
484 Lex.isLexConSym (Name.occNameString (Name.getOccName con))
487 Rather clumsy but it works. (Simon Peyton Jones)
490 We don't mind the @nilDataCon@ because it doesn't change the way to
491 print the messsage, we are searching only for things like: @[1,2,3]@,
494 In @reconstruct_pat@ we want to ``undo'' the work
495 that we have done in @simplify_pat@.
498 @((,) x y)@ & returns to be & @(x, y)@
499 \\ @((:) x xs)@ & returns to be & @(x:xs)@
500 \\ @(x:(...:[])@ & returns to be & @[x,...]@
503 The difficult case is the third one becouse we need to follow all the
504 contructors until the @[]@ to know that we need to use the second case,
505 not the second. \fbox{\ ???\ }
508 isInfixCon con = isDataSymOcc (getOccName con)
510 is_nil (ConPatIn con []) = con == getName nilDataCon
513 is_list (ListPatIn _) = True
516 return_list id q = id == consDataCon && (is_nil q || is_list q)
518 make_list p q | is_nil q = ListPatIn [p]
519 make_list p (ListPatIn ps) = ListPatIn (p:ps)
520 make_list _ _ = panic "Check.make_list: Invalid argument"
522 make_con :: TypecheckedPat -> ExhaustivePat -> ExhaustivePat
523 make_con (ConPat id _ _ _ _) (p:q:ps, constraints)
524 | return_list id q = (make_list p q : ps, constraints)
525 | isInfixCon id = ((ConOpPatIn p name fixity q) : ps, constraints)
526 where name = getName id
527 fixity = panic "Check.make_con: Guessing fixity"
529 make_con (ConPat id _ _ _ pats) (ps, constraints)
530 | isTupleTyCon tc = (TuplePatIn pats_con (tupleTyConBoxity tc) : rest_pats, constraints)
531 | otherwise = (ConPatIn name pats_con : rest_pats, constraints)
532 where name = getName id
533 (pats_con, rest_pats) = splitAtList pats ps
536 -- reconstruct parallel array pattern
538 -- * don't check for the type only; we need to make sure that we are really
539 -- dealing with one of the fake constructors and not with the real
542 make_con (ConPat id _ _ _ pats) (ps, constraints)
543 | isPArrFakeCon id = (PArrPatIn patsCon : restPats, constraints)
544 | otherwise = (ConPatIn name patsCon : restPats, constraints)
547 (patsCon, restPats) = splitAtList pats ps
551 make_whole_con :: DataCon -> WarningPat
552 make_whole_con con | isInfixCon con = ConOpPatIn new_wild_pat name fixity new_wild_pat
553 | otherwise = ConPatIn name pats
555 fixity = panic "Check.make_whole_con: Guessing fixity"
557 arity = dataConSourceArity con
558 pats = replicate arity new_wild_pat
561 new_wild_pat :: WarningPat
562 new_wild_pat = WildPatIn
565 This equation makes the same thing as @tidy@ in @Match.lhs@, the
566 difference is that here we can do all the tidy in one place and in the
567 @Match@ tidy it must be done one column each time due to bookkeeping
572 simplify_eqns :: [EquationInfo] -> [EquationInfo]
573 simplify_eqns [] = []
574 simplify_eqns ((EqnInfo n ctx pats result):qs) =
575 (EqnInfo n ctx pats' result) : simplify_eqns qs
577 pats' = map simplify_pat pats
579 simplify_pat :: TypecheckedPat -> TypecheckedPat
581 simplify_pat pat@(WildPat gt) = pat
582 simplify_pat (VarPat id) = WildPat (idType id)
584 simplify_pat (LazyPat p) = simplify_pat p
585 simplify_pat (AsPat id p) = simplify_pat p
586 simplify_pat (SigPat p ty fn) = simplify_pat p -- I'm not sure this is right
588 simplify_pat (ConPat id ty tvs dicts ps) = ConPat id ty tvs dicts (map simplify_pat ps)
590 simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y])
591 (ConPat nilDataCon list_ty [] [] [])
592 (map simplify_pat ps)
593 where list_ty = mkListTy ty
595 -- introduce fake parallel array constructors to be able to handle parallel
596 -- arrays with the existing machinery for constructor pattern
598 simplify_pat (PArrPat ty ps)
599 = ConPat (parrFakeCon arity) (mkPArrTy ty) [] [] (map simplify_pat ps)
603 simplify_pat (TuplePat ps boxity)
604 = ConPat (tupleCon boxity arity)
605 (mkTupleTy boxity arity (map outPatType ps)) [] []
606 (map simplify_pat ps)
610 simplify_pat (RecPat dc ty ex_tvs dicts [])
611 = ConPat dc ty ex_tvs dicts all_wild_pats
613 all_wild_pats = map WildPat con_arg_tys
615 -- Identical to machinations in Match.tidy1:
616 inst_tys = tcTyConAppArgs ty -- Newtype is observable
617 con_arg_tys = dataConArgTys dc (inst_tys ++ mkTyVarTys ex_tvs)
619 simplify_pat (RecPat dc ty ex_tvs dicts idps)
620 = ConPat dc ty ex_tvs dicts pats
622 pats = map (simplify_pat.snd) all_pats
624 -- pad out all the missing fields with WildPats.
625 field_pats = map (\ f -> (getName f, WildPat (panic "simplify_pat(RecPat-2)")))
626 (dataConFieldLabels dc)
629 ( \ (id,p,_) acc -> insertNm (getName id) p acc)
633 insertNm nm p [] = [(nm,p)]
634 insertNm nm p (x@(n,_):xs)
635 | nm == n = (nm,p):xs
636 | otherwise = x : insertNm nm p xs
638 simplify_pat pat@(LitPat lit lit_ty) = tidyLitPat lit pat
640 -- unpack string patterns fully, so we can see when they overlap with
641 -- each other, or even explicit lists of Chars.
642 simplify_pat pat@(NPat (HsString s) _ _) =
643 foldr (\c pat -> ConPat consDataCon stringTy [] [] [mk_char_lit c,pat])
644 (ConPat nilDataCon stringTy [] [] []) (unpackIntFS s)
646 mk_char_lit c = ConPat charDataCon charTy [] []
647 [LitPat (HsCharPrim c) charPrimTy]
649 simplify_pat pat@(NPat lit lit_ty hsexpr) = tidyNPat lit lit_ty pat
651 simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) =
653 where ty = panic "Check.simplify_pat: Gessing ty"
655 simplify_pat (DictPat dicts methods) =
656 case num_of_d_and_ms of
657 0 -> simplify_pat (TuplePat [] Boxed)
658 1 -> simplify_pat (head dict_and_method_pats)
659 _ -> simplify_pat (TuplePat dict_and_method_pats Boxed)
661 num_of_d_and_ms = length dicts + length methods
662 dict_and_method_pats = map VarPat (dicts ++ methods)