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 ( hsPatType, mkVanillaTuplePat )
15 import TcType ( tcTyConAppTyCon )
16 import DsUtils ( EquationInfo(..), MatchResult(..),
17 CanItFail(..), firstPat )
18 import MatchLit ( tidyLitPat, tidyNPat )
19 import Id ( Id, idType )
20 import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConFieldLabels )
21 import Name ( Name, mkInternalName, getOccName, isDataSymOcc,
24 import PrelNames ( unboundKey )
25 import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
26 import BasicTypes ( Boxity(..) )
27 import SrcLoc ( noSrcLoc, Located(..), unLoc, noLoc )
29 import Util ( takeList, splitAtList, notNull )
33 #include "HsVersions.h"
36 This module performs checks about if one list of equations are:
41 To discover that we go through the list of equations in a tree-like fashion.
43 If you like theory, a similar algorithm is described in:
45 {\em Two Techniques for Compiling Lazy Pattern Matching},
47 INRIA Rocquencourt (RR-2385, 1994)
49 The algorithm is based on the first technique, but there are some differences:
51 \item We don't generate code
52 \item We have constructors and literals (not only literals as in the
54 \item We don't use directions, we must select the columns from
57 (By the way the second technique is really similar to the one used in
58 @Match.lhs@ to generate code)
60 This function takes the equations of a pattern and returns:
62 \item The patterns that are not recognized
63 \item The equations that are not overlapped
65 It simplify the patterns and then call @check'@ (the same semantics), and it
66 needs to reconstruct the patterns again ....
68 The problem appear with things like:
73 We want to put the two patterns with the same syntax, (prefix form) and
74 then all the constructors are equal:
76 f (: x (: y [])) = ....
79 (more about that in @simplify_eqns@)
81 We would prefer to have a @WarningPat@ of type @String@, but Strings and the
82 Pretty Printer are not friends.
84 We use @InPat@ in @WarningPat@ instead of @OutPat@
85 because we need to print the
86 warning messages in the same way they are introduced, i.e. if the user
91 He don't want a warning message written:
93 f (: x (: y [])) ........
95 Then we need to use InPats.
97 Juan Quintela 5 JUL 1998\\
98 User-friendliness and compiler writers are no friends.
102 type WarningPat = InPat Name
103 type ExhaustivePat = ([WarningPat], [(Name, [HsLit])])
105 type EqnSet = UniqSet EqnNo
108 check :: [EquationInfo] -> ([ExhaustivePat], [EquationInfo])
109 -- Second result is the shadowed equations
110 check qs = (untidy_warns, shadowed_eqns)
112 (warns, used_nos) = check' ([1..] `zip` map simplify_eqn qs)
113 untidy_warns = map untidy_exhaustive warns
114 shadowed_eqns = [eqn | (eqn,i) <- qs `zip` [1..],
115 not (i `elementOfUniqSet` used_nos)]
117 untidy_exhaustive :: ExhaustivePat -> ExhaustivePat
118 untidy_exhaustive ([pat], messages) =
119 ([untidy_no_pars pat], map untidy_message messages)
120 untidy_exhaustive (pats, messages) =
121 (map untidy_pars pats, map untidy_message messages)
123 untidy_message :: (Name, [HsLit]) -> (Name, [HsLit])
124 untidy_message (string, lits) = (string, map untidy_lit lits)
127 The function @untidy@ does the reverse work of the @simplify_pat@ funcion.
133 untidy_no_pars :: WarningPat -> WarningPat
134 untidy_no_pars p = untidy False p
136 untidy_pars :: WarningPat -> WarningPat
137 untidy_pars p = untidy True p
139 untidy :: NeedPars -> WarningPat -> WarningPat
140 untidy b (L loc p) = L loc (untidy' b p)
142 untidy' _ p@(WildPat _) = p
143 untidy' _ p@(VarPat name) = p
144 untidy' _ (LitPat lit) = LitPat (untidy_lit lit)
145 untidy' _ p@(ConPatIn name (PrefixCon [])) = p
146 untidy' b (ConPatIn name ps) = pars b (L loc (ConPatIn name (untidy_con ps)))
147 untidy' _ (ListPat pats ty) = ListPat (map untidy_no_pars pats) ty
148 untidy' _ (TuplePat pats box ty) = TuplePat (map untidy_no_pars pats) box ty
149 untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!"
150 untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat"
152 untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats)
153 untidy_con (InfixCon p1 p2) = InfixCon (untidy_pars p1) (untidy_pars p2)
154 untidy_con (RecCon bs) = RecCon [(f,untidy_pars p) | (f,p) <- bs]
156 pars :: NeedPars -> WarningPat -> Pat Name
157 pars True p = ParPat p
160 untidy_lit :: HsLit -> HsLit
161 untidy_lit (HsCharPrim c) = HsChar c
165 This equation is the same that check, the only difference is that the
166 boring work is done, that work needs to be done only once, this is
167 the reason top have two functions, check is the external interface,
168 @check'@ is called recursively.
170 There are several cases:
173 \item There are no equations: Everything is OK.
174 \item There are only one equation, that can fail, and all the patterns are
175 variables. Then that equation is used and the same equation is
177 \item All the patterns are variables, and the match can fail, there are
178 more equations then the results is the result of the rest of equations
179 and this equation is used also.
181 \item The general case, if all the patterns are variables (here the match
182 can't fail) then the result is that this equation is used and this
183 equation doesn't generate non-exhaustive cases.
185 \item In the general case, there can exist literals ,constructors or only
186 vars in the first column, we actuate in consequence.
193 check' :: [(EqnNo, EquationInfo)]
194 -> ([ExhaustivePat], -- Pattern scheme that might not be matched at all
195 EqnSet) -- Eqns that are used (others are overlapped)
197 check' [] = ([([],[])],emptyUniqSet)
199 check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult can_fail _ }) : rs)
200 | first_eqn_all_vars && case can_fail of { CantFail -> True; CanFail -> False }
201 = ([], unitUniqSet n) -- One eqn, which can't fail
203 | first_eqn_all_vars && null rs -- One eqn, but it can fail
204 = ([(takeList ps (repeat nlWildPat),[])], unitUniqSet n)
206 | first_eqn_all_vars -- Several eqns, first can fail
207 = (pats, addOneToUniqSet indexs n)
209 first_eqn_all_vars = all_vars ps
210 (pats,indexs) = check' rs
213 | literals = split_by_literals qs
214 | constructors = split_by_constructor qs
215 | only_vars = first_column_only_vars qs
216 | otherwise = pprPanic "Check.check': Not implemented :-(" (ppr first_pats)
218 -- Note: RecPats will have been simplified to ConPats
220 first_pats = ASSERT2( okGroup qs, pprGroup qs ) map firstPatN qs
221 constructors = any is_con first_pats
222 literals = any is_lit first_pats
223 only_vars = all is_var first_pats
226 Here begins the code to deal with literals, we need to split the matrix
227 in different matrix beginning by each literal and a last matrix with the
231 split_by_literals :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
232 split_by_literals qs = process_literals used_lits qs
234 used_lits = get_used_lits qs
237 @process_explicit_literals@ is a function that process each literal that appears
238 in the column of the matrix.
241 process_explicit_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
242 process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)
244 pats_indexs = map (\x -> construct_literal_matrix x qs) lits
245 (pats,indexs) = unzip pats_indexs
249 @process_literals@ calls @process_explicit_literals@ to deal with the literals
250 that appears in the matrix and deal also with the rest of the cases. It
251 must be one Variable to be complete.
255 process_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
256 process_literals used_lits qs
257 | null default_eqns = ([make_row_vars used_lits (head qs)] ++ pats,indexs)
258 | otherwise = (pats_default,indexs_default)
260 (pats,indexs) = process_explicit_literals used_lits qs
261 default_eqns = ASSERT2( okGroup qs, pprGroup qs )
262 [remove_var q | q <- qs, is_var (firstPatN q)]
263 (pats',indexs') = check' default_eqns
264 pats_default = [(nlWildPat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats
265 indexs_default = unionUniqSets indexs' indexs
268 Here we have selected the literal and we will select all the equations that
269 begins for that literal and create a new matrix.
272 construct_literal_matrix :: HsLit -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
273 construct_literal_matrix lit qs =
274 (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)
276 (pats,indexs) = (check' (remove_first_column_lit lit qs))
277 new_lit = nlLitPat lit
279 remove_first_column_lit :: HsLit
280 -> [(EqnNo, EquationInfo)]
281 -> [(EqnNo, EquationInfo)]
282 remove_first_column_lit lit qs
283 = ASSERT2( okGroup qs, pprGroup qs )
284 [(n, shift_pat eqn) | q@(n,eqn) <- qs, is_var_lit lit (firstPatN q)]
286 shift_pat eqn@(EqnInfo { eqn_pats = _:ps}) = eqn { eqn_pats = ps }
287 shift_pat eqn@(EqnInfo { eqn_pats = []}) = panic "Check.shift_var: no patterns"
290 This function splits the equations @qs@ in groups that deal with the
294 split_by_constructor :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
295 split_by_constructor qs
296 | notNull unused_cons = need_default_case used_cons unused_cons qs
297 | otherwise = no_need_default_case used_cons qs
299 used_cons = get_used_cons qs
300 unused_cons = get_unused_cons used_cons
303 The first column of the patterns matrix only have vars, then there is
307 first_column_only_vars :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
308 first_column_only_vars qs = (map (\ (xs,ys) -> (nlWildPat:xs,ys)) pats,indexs)
310 (pats, indexs) = check' (map remove_var qs)
313 This equation takes a matrix of patterns and split the equations by
314 constructor, using all the constructors that appears in the first column
315 of the pattern matching.
317 We can need a default clause or not ...., it depends if we used all the
318 constructors or not explicitly. The reasoning is similar to @process_literals@,
319 the difference is that here the default case is not always needed.
322 no_need_default_case :: [Pat Id] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
323 no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
325 pats_indexs = map (\x -> construct_matrix x qs) cons
326 (pats,indexs) = unzip pats_indexs
328 need_default_case :: [Pat Id] -> [DataCon] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
329 need_default_case used_cons unused_cons qs
330 | null default_eqns = (pats_default_no_eqns,indexs)
331 | otherwise = (pats_default,indexs_default)
333 (pats,indexs) = no_need_default_case used_cons qs
334 default_eqns = ASSERT2( okGroup qs, pprGroup qs )
335 [remove_var q | q <- qs, is_var (firstPatN q)]
336 (pats',indexs') = check' default_eqns
337 pats_default = [(make_whole_con c:ps,constraints) |
338 c <- unused_cons, (ps,constraints) <- pats'] ++ pats
339 new_wilds = make_row_vars_for_constructor (head qs)
340 pats_default_no_eqns = [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats
341 indexs_default = unionUniqSets indexs' indexs
343 construct_matrix :: Pat Id -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
344 construct_matrix con qs =
345 (map (make_con con) pats,indexs)
347 (pats,indexs) = (check' (remove_first_column con qs))
350 Here remove first column is more difficult that with literals due to the fact
351 that constructors can have arguments.
353 For instance, the matrix
365 remove_first_column :: Pat Id -- Constructor
366 -> [(EqnNo, EquationInfo)]
367 -> [(EqnNo, EquationInfo)]
368 remove_first_column (ConPatOut (L _ con) _ _ _ (PrefixCon con_pats) _) qs
369 = ASSERT2( okGroup qs, pprGroup qs )
370 [(n, shift_var eqn) | q@(n, eqn) <- qs, is_var_con con (firstPatN q)]
372 new_wilds = [WildPat (hsPatType arg_pat) | arg_pat <- con_pats]
373 shift_var eqn@(EqnInfo { eqn_pats = ConPatOut _ _ _ _ (PrefixCon ps') _ : ps})
374 = eqn { eqn_pats = map unLoc ps' ++ ps }
375 shift_var eqn@(EqnInfo { eqn_pats = WildPat _ : ps })
376 = eqn { eqn_pats = new_wilds ++ ps }
377 shift_var _ = panic "Check.Shift_var:No done"
379 make_row_vars :: [HsLit] -> (EqnNo, EquationInfo) -> ExhaustivePat
380 make_row_vars used_lits (_, EqnInfo { eqn_pats = pats})
381 = (nlVarPat new_var:takeList (tail pats) (repeat nlWildPat),[(new_var,used_lits)])
385 hash_x = mkInternalName unboundKey {- doesn't matter much -}
386 (mkVarOccFS FSLIT("#x"))
389 make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat]
390 make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats})
391 = takeList (tail pats) (repeat nlWildPat)
393 compare_cons :: Pat Id -> Pat Id -> Bool
394 compare_cons (ConPatOut (L _ id1) _ _ _ _ _) (ConPatOut (L _ id2) _ _ _ _ _) = id1 == id2
396 remove_dups :: [Pat Id] -> [Pat Id]
398 remove_dups (x:xs) | or (map (\y -> compare_cons x y) xs) = remove_dups xs
399 | otherwise = x : remove_dups xs
401 get_used_cons :: [(EqnNo, EquationInfo)] -> [Pat Id]
402 get_used_cons qs = remove_dups [pat | q <- qs, let pat = firstPatN q,
405 isConPatOut (ConPatOut {}) = True
406 isConPatOut other = False
408 remove_dups' :: [HsLit] -> [HsLit]
410 remove_dups' (x:xs) | x `elem` xs = remove_dups' xs
411 | otherwise = x : remove_dups' xs
414 get_used_lits :: [(EqnNo, EquationInfo)] -> [HsLit]
415 get_used_lits qs = remove_dups' all_literals
417 all_literals = get_used_lits' qs
419 get_used_lits' :: [(EqnNo, EquationInfo)] -> [HsLit]
420 get_used_lits' [] = []
421 get_used_lits' (q:qs)
422 | Just lit <- get_lit (firstPatN q) = lit : get_used_lits' qs
423 | otherwise = get_used_lits qs
425 get_lit :: Pat id -> Maybe HsLit
426 -- Get a representative HsLit to stand for the OverLit
427 -- It doesn't matter which one, because they will only be compared
428 -- with other HsLits gotten in the same way
429 get_lit (LitPat lit) = Just lit
430 get_lit (NPat (HsIntegral i _) mb _ _) = Just (HsIntPrim (mb_neg mb i))
431 get_lit (NPat (HsFractional f _) mb _ _) = Just (HsFloatPrim (mb_neg mb f))
432 get_lit other_pat = Nothing
434 mb_neg :: Num a => Maybe b -> a -> a
436 mb_neg (Just _) v = -v
438 get_unused_cons :: [Pat Id] -> [DataCon]
439 get_unused_cons used_cons = unused_cons
441 (ConPatOut _ _ _ _ _ ty) = head used_cons
442 ty_con = tcTyConAppTyCon ty -- Newtype observable
443 all_cons = tyConDataCons ty_con
444 used_cons_as_id = map (\ (ConPatOut (L _ d) _ _ _ _ _) -> d) used_cons
445 unused_cons = uniqSetToList
446 (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
448 all_vars :: [Pat Id] -> Bool
450 all_vars (WildPat _:ps) = all_vars ps
453 remove_var :: (EqnNo, EquationInfo) -> (EqnNo, EquationInfo)
454 remove_var (n, eqn@(EqnInfo { eqn_pats = WildPat _ : ps})) = (n, eqn { eqn_pats = ps })
455 remove_var _ = panic "Check.remove_var: equation does not begin with a variable"
457 -----------------------
458 eqnPats :: (EqnNo, EquationInfo) -> [Pat Id]
459 eqnPats (_, eqn) = eqn_pats eqn
461 okGroup :: [(EqnNo, EquationInfo)] -> Bool
462 -- True if all equations have at least one pattern, and
463 -- all have the same number of patterns
465 okGroup (e:es) = n_pats > 0 && and [length (eqnPats e) == n_pats | e <- es]
467 n_pats = length (eqnPats e)
470 pprGroup es = vcat (map pprEqnInfo es)
471 pprEqnInfo e = ppr (eqnPats e)
474 firstPatN :: (EqnNo, EquationInfo) -> Pat Id
475 firstPatN (_, eqn) = firstPat eqn
477 is_con :: Pat Id -> Bool
478 is_con (ConPatOut _ _ _ _ _ _) = True
481 is_lit :: Pat Id -> Bool
482 is_lit (LitPat _) = True
483 is_lit (NPat _ _ _ _) = True
486 is_var :: Pat Id -> Bool
487 is_var (WildPat _) = True
490 is_var_con :: DataCon -> Pat Id -> Bool
491 is_var_con con (WildPat _) = True
492 is_var_con con (ConPatOut (L _ id) _ _ _ _ _) | id == con = True
493 is_var_con con _ = False
495 is_var_lit :: HsLit -> Pat Id -> Bool
496 is_var_lit lit (WildPat _) = True
498 | Just lit' <- get_lit pat = lit == lit'
502 The difference beteewn @make_con@ and @make_whole_con@ is that
503 @make_wole_con@ creates a new constructor with all their arguments, and
504 @make_con@ takes a list of argumntes, creates the contructor getting their
505 arguments from the list. See where \fbox{\ ???\ } are used for details.
507 We need to reconstruct the patterns (make the constructors infix and
508 similar) at the same time that we create the constructors.
510 You can tell tuple constructors using
514 You can see if one constructor is infix with this clearer code :-))))))))))
516 Lex.isLexConSym (Name.occNameString (Name.getOccName con))
519 Rather clumsy but it works. (Simon Peyton Jones)
522 We don't mind the @nilDataCon@ because it doesn't change the way to
523 print the messsage, we are searching only for things like: @[1,2,3]@,
526 In @reconstruct_pat@ we want to ``undo'' the work
527 that we have done in @simplify_pat@.
530 @((,) x y)@ & returns to be & @(x, y)@
531 \\ @((:) x xs)@ & returns to be & @(x:xs)@
532 \\ @(x:(...:[])@ & returns to be & @[x,...]@
535 The difficult case is the third one becouse we need to follow all the
536 contructors until the @[]@ to know that we need to use the second case,
537 not the second. \fbox{\ ???\ }
540 isInfixCon con = isDataSymOcc (getOccName con)
542 is_nil (ConPatIn con (PrefixCon [])) = unLoc con == getName nilDataCon
545 is_list (ListPat _ _) = True
548 return_list id q = id == consDataCon && (is_nil q || is_list q)
550 make_list p q | is_nil q = ListPat [p] placeHolderType
551 make_list p (ListPat ps ty) = ListPat (p:ps) ty
552 make_list _ _ = panic "Check.make_list: Invalid argument"
554 make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat
555 make_con (ConPatOut (L _ id) _ _ _ _ _) (lp:lq:ps, constraints)
556 | return_list id q = (noLoc (make_list lp q) : ps, constraints)
557 | isInfixCon id = (nlInfixConPat (getName id) lp lq : ps, constraints)
560 make_con (ConPatOut (L _ id) _ _ _ (PrefixCon pats) ty) (ps, constraints)
561 | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) ty) : rest_pats, constraints)
562 | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints)
563 | otherwise = (nlConPat name pats_con : rest_pats, constraints)
566 (pats_con, rest_pats) = splitAtList pats ps
569 -- reconstruct parallel array pattern
571 -- * don't check for the type only; we need to make sure that we are really
572 -- dealing with one of the fake constructors and not with the real
575 make_whole_con :: DataCon -> WarningPat
576 make_whole_con con | isInfixCon con = nlInfixConPat name nlWildPat nlWildPat
577 | otherwise = nlConPat name pats
580 pats = [nlWildPat | t <- dataConOrigArgTys con]
583 This equation makes the same thing as @tidy@ in @Match.lhs@, the
584 difference is that here we can do all the tidy in one place and in the
585 @Match@ tidy it must be done one column each time due to bookkeeping
590 simplify_eqn :: EquationInfo -> EquationInfo
591 simplify_eqn eqn = eqn { eqn_pats = map simplify_pat (eqn_pats eqn),
592 eqn_rhs = simplify_rhs (eqn_rhs eqn) }
594 -- Horrible hack. The simplify_pat stuff converts NPlusK pats to WildPats
595 -- which of course loses the info that they can fail to match. So we
596 -- stick in a CanFail as if it were a guard.
597 -- The Right Thing to do is for the whole system to treat NPlusK pats properly
598 simplify_rhs (MatchResult can_fail body)
599 | any has_nplusk_pat (eqn_pats eqn) = MatchResult CanFail body
600 | otherwise = MatchResult can_fail body
602 has_nplusk_lpat :: LPat Id -> Bool
603 has_nplusk_lpat (L _ p) = has_nplusk_pat p
605 has_nplusk_pat :: Pat Id -> Bool
606 has_nplusk_pat (NPlusKPat _ _ _ _) = True
607 has_nplusk_pat (ParPat p) = has_nplusk_lpat p
608 has_nplusk_pat (AsPat _ p) = has_nplusk_lpat p
609 has_nplusk_pat (SigPatOut p _ ) = has_nplusk_lpat p
610 has_nplusk_pat (ConPatOut _ _ _ _ ps ty) = any has_nplusk_lpat (hsConArgs ps)
611 has_nplusk_pat (ListPat ps _) = any has_nplusk_lpat ps
612 has_nplusk_pat (TuplePat ps _ _) = any has_nplusk_lpat ps
613 has_nplusk_pat (PArrPat ps _) = any has_nplusk_lpat ps
614 has_nplusk_pat (LazyPat p) = False -- Why?
615 has_nplusk_pat (BangPat p) = has_nplusk_lpat p -- I think
616 has_nplusk_pat p = False -- VarPat, VarPatOut, WildPat, LitPat, NPat, TypePat, DictPat
618 simplify_lpat :: LPat Id -> LPat Id
619 simplify_lpat p = fmap simplify_pat p
621 simplify_pat :: Pat Id -> Pat Id
622 simplify_pat pat@(WildPat gt) = pat
623 simplify_pat (VarPat id) = WildPat (idType id)
624 simplify_pat (VarPatOut id _) = WildPat (idType id) -- Ignore the bindings
625 simplify_pat (ParPat p) = unLoc (simplify_lpat p)
626 simplify_pat (LazyPat p) = WildPat (hsPatType p) -- For overlap and exhaustiveness checking
627 -- purposes, a ~pat is like a wildcard
628 simplify_pat (BangPat p) = unLoc (simplify_lpat p)
629 simplify_pat (AsPat id p) = unLoc (simplify_lpat p)
630 simplify_pat (SigPatOut p _) = unLoc (simplify_lpat p) -- I'm not sure this is right
632 simplify_pat (ConPatOut (L loc id) tvs dicts binds ps ty)
633 = ConPatOut (L loc id) tvs dicts binds (simplify_con id ps) ty
635 simplify_pat (ListPat ps ty) =
636 unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty)
638 (map simplify_lpat ps)
639 where list_ty = mkListTy ty
641 -- introduce fake parallel array constructors to be able to handle parallel
642 -- arrays with the existing machinery for constructor pattern
644 simplify_pat (PArrPat ps ty)
645 = mk_simple_con_pat (parrFakeCon (length ps))
646 (PrefixCon (map simplify_lpat ps))
649 simplify_pat (TuplePat ps boxity ty)
650 = mk_simple_con_pat (tupleCon boxity arity)
651 (PrefixCon (map simplify_lpat ps))
656 -- unpack string patterns fully, so we can see when they overlap with
657 -- each other, or even explicit lists of Chars.
658 simplify_pat pat@(LitPat (HsString s)) =
659 foldr (\c pat -> mk_simple_con_pat consDataCon (PrefixCon [mk_char_lit c,noLoc pat]) stringTy)
660 (mk_simple_con_pat nilDataCon (PrefixCon []) stringTy) (unpackFS s)
662 mk_char_lit c = noLoc (mk_simple_con_pat charDataCon (PrefixCon [nlLitPat (HsCharPrim c)]) charTy)
664 simplify_pat pat@(LitPat lit) = unLoc (tidyLitPat lit (noLoc pat))
666 simplify_pat pat@(NPat lit mb_neg _ lit_ty) = unLoc (tidyNPat lit mb_neg lit_ty (noLoc pat))
668 simplify_pat (NPlusKPat id hslit hsexpr1 hsexpr2)
669 = WildPat (idType (unLoc id))
671 simplify_pat (DictPat dicts methods)
672 = case num_of_d_and_ms of
673 0 -> simplify_pat (TuplePat [] Boxed unitTy)
674 1 -> simplify_pat (head dict_and_method_pats)
675 _ -> simplify_pat (mkVanillaTuplePat (map noLoc dict_and_method_pats) Boxed)
677 num_of_d_and_ms = length dicts + length methods
678 dict_and_method_pats = map VarPat (dicts ++ methods)
680 mk_simple_con_pat con args ty = ConPatOut (noLoc con) [] [] emptyLHsBinds args ty
683 simplify_con con (PrefixCon ps) = PrefixCon (map simplify_lpat ps)
684 simplify_con con (InfixCon p1 p2) = PrefixCon [simplify_lpat p1, simplify_lpat p2]
685 simplify_con con (RecCon fs)
686 | null fs = PrefixCon [nlWildPat | t <- dataConOrigArgTys con]
687 -- Special case for null patterns; maybe not a record at all
688 | otherwise = PrefixCon (map (simplify_lpat.snd) all_pats)
690 -- pad out all the missing fields with WildPats.
691 field_pats = map (\ f -> (f, nlWildPat)) (dataConFieldLabels con)
692 all_pats = foldr (\ (id,p) acc -> insertNm (getName (unLoc id)) p acc)
695 insertNm nm p [] = [(nm,p)]
696 insertNm nm p (x@(n,_):xs)
697 | nm == n = (nm,p):xs
698 | otherwise = x : insertNm nm p xs