compiler/deSugar/Check.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
   3 %
   4 % Author: Juan J. Quintela    <quintela@krilin.dc.fi.udc.es>
   5 \section{Module @Check@ in @deSugar@}
   6
   7 \begin{code}
   8
   9
  10 module Check ( check , ExhaustivePat ) where
  11
  12
  13 import HsSyn
  14 import TcHsSyn          ( hsLPatType, 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,
  22                           getName, mkVarOccFS )
  23 import TysWiredIn
  24 import PrelNames        ( unboundKey )
  25 import TyCon            ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
  26 import BasicTypes       ( Boxity(..) )
  27 import SrcLoc           ( noSrcLoc, Located(..), unLoc, noLoc )
  28 import UniqSet
  29 import Util             ( takeList, splitAtList, notNull )
  30 import Outputable
  31 import FastString
  32
  33 #include "HsVersions.h"
  34 \end{code}
  35
  36 This module performs checks about if one list of equations are:
  37 \begin{itemize}
  38 \item Overlapped
  39 \item Non exhaustive
  40 \end{itemize}
  41 To discover that we go through the list of equations in a tree-like fashion.
  42
  43 If you like theory, a similar algorithm is described in:
  44 \begin{quotation}
  45         {\em Two Techniques for Compiling Lazy Pattern Matching},
  46         Luc Maranguet,
  47         INRIA Rocquencourt (RR-2385, 1994)
  48 \end{quotation}
  49 The algorithm is based on the first technique, but there are some differences:
  50 \begin{itemize}
  51 \item We don't generate code
  52 \item We have constructors and literals (not only literals as in the
  53           article)
  54 \item We don't use directions, we must select the columns from
  55           left-to-right
  56 \end{itemize}
  57 (By the way the second technique is really similar to the one used in
  58  @Match.lhs@ to generate code)
  59
  60 This function takes the equations of a pattern and returns:
  61 \begin{itemize}
  62 \item The patterns that are not recognized
  63 \item The equations that are not overlapped
  64 \end{itemize}
  65 It simplify the patterns and then call @check'@ (the same semantics), and it
  66 needs to reconstruct the patterns again ....
  67
  68 The problem appear with things like:
  69 \begin{verbatim}
  70   f [x,y]   = ....
  71   f (x:xs)  = .....
  72 \end{verbatim}
  73 We want to put the two patterns with the same syntax, (prefix form) and
  74 then all the constructors are equal:
  75 \begin{verbatim}
  76   f (: x (: y []))   = ....
  77   f (: x xs)         = .....
  78 \end{verbatim}
  79 (more about that in @simplify_eqns@)
  80
  81 We would prefer to have a @WarningPat@ of type @String@, but Strings and the
  82 Pretty Printer are not friends.
  83
  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
  87 wrote:
  88 \begin{verbatim}
  89         f [x,y] = ..
  90 \end{verbatim}
  91 He don't want a warning message written:
  92 \begin{verbatim}
  93         f (: x (: y [])) ........
  94 \end{verbatim}
  95 Then we need to use InPats.
  96 \begin{quotation}
  97      Juan Quintela 5 JUL 1998\\
  98           User-friendliness and compiler writers are no friends.
  99 \end{quotation}
 100
 101 \begin{code}
 102 type WarningPat = InPat Name
 103 type ExhaustivePat = ([WarningPat], [(Name, [HsLit])])
 104 type EqnNo  = Int
 105 type EqnSet = UniqSet EqnNo
 106
 107
 108 check :: [EquationInfo] -> ([ExhaustivePat], [EquationInfo])
 109         -- Second result is the shadowed equations
 110 check qs = (untidy_warns, shadowed_eqns)
 111       where
 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)]
 116
 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)
 122
 123 untidy_message :: (Name, [HsLit]) -> (Name, [HsLit])
 124 untidy_message (string, lits) = (string, map untidy_lit lits)
 125 \end{code}
 126
 127 The function @untidy@ does the reverse work of the @simplify_pat@ funcion.
 128
 129 \begin{code}
 130
 131 type NeedPars = Bool
 132
 133 untidy_no_pars :: WarningPat -> WarningPat
 134 untidy_no_pars p = untidy False p
 135
 136 untidy_pars :: WarningPat -> WarningPat
 137 untidy_pars p = untidy True p
 138
 139 untidy :: NeedPars -> WarningPat -> WarningPat
 140 untidy b (L loc p) = L loc (untidy' b p)
 141   where
 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"
 151
 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]
 155
 156 pars :: NeedPars -> WarningPat -> Pat Name
 157 pars True p = ParPat p
 158 pars _    p = unLoc p
 159
 160 untidy_lit :: HsLit -> HsLit
 161 untidy_lit (HsCharPrim c) = HsChar c
 162 untidy_lit lit            = lit
 163 \end{code}
 164
 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.
 169
 170 There are several cases:
 171
 172 \begin{itemize}
 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
 176       non-exhaustive.
 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.
 180
 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.
 184
 185 \item In the general case, there can exist literals ,constructors or only
 186       vars in the first column, we actuate in consequence.
 187
 188 \end{itemize}
 189
 190
 191 \begin{code}
 192
 193 check' :: [(EqnNo, EquationInfo)]
 194         -> ([ExhaustivePat],    -- Pattern scheme that might not be matched at all
 195             EqnSet)             -- Eqns that are used (others are overlapped)
 196
 197 check' [] = ([([],[])],emptyUniqSet)
 198
 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
 202
 203    | first_eqn_all_vars && null rs      -- One eqn, but it can fail
 204    = ([(takeList ps (repeat nlWildPat),[])], unitUniqSet n)
 205
 206    | first_eqn_all_vars         -- Several eqns, first can fail
 207    = (pats, addOneToUniqSet indexs n)
 208   where
 209     first_eqn_all_vars = all_vars ps
 210     (pats,indexs) = check' rs
 211
 212 check' qs
 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)
 217   where
 218      -- Note: RecPats will have been simplified to ConPats
 219      --       at this stage.
 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
 224 \end{code}
 225
 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
 228 rest of values.
 229
 230 \begin{code}
 231 split_by_literals :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
 232 split_by_literals qs = process_literals used_lits qs
 233            where
 234              used_lits = get_used_lits qs
 235 \end{code}
 236
 237 @process_explicit_literals@ is a function that process each literal that appears
 238 in the column of the matrix.
 239
 240 \begin{code}
 241 process_explicit_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
 242 process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)
 243     where
 244       pats_indexs   = map (\x -> construct_literal_matrix x qs) lits
 245       (pats,indexs) = unzip pats_indexs
 246 \end{code}
 247
 248
 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.
 252
 253 \begin{code}
 254
 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)
 259      where
 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
 266 \end{code}
 267
 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.
 270
 271 \begin{code}
 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)
 275   where
 276     (pats,indexs) = (check' (remove_first_column_lit lit qs))
 277     new_lit = nlLitPat lit
 278
 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)]
 285   where
 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"
 288 \end{code}
 289
 290 This function splits the equations @qs@ in groups that deal with the
 291 same constructor.
 292
 293 \begin{code}
 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
 298                        where
 299                           used_cons   = get_used_cons qs
 300                           unused_cons = get_unused_cons used_cons
 301 \end{code}
 302
 303 The first column of the patterns matrix only have vars, then there is
 304 nothing to do.
 305
 306 \begin{code}
 307 first_column_only_vars :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
 308 first_column_only_vars qs = (map (\ (xs,ys) -> (nlWildPat:xs,ys)) pats,indexs)
 309                           where
 310                             (pats, indexs) = check' (map remove_var qs)
 311 \end{code}
 312
 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.
 316
 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.
 320
 321 \begin{code}
 322 no_need_default_case :: [Pat Id] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
 323 no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
 324     where
 325       pats_indexs   = map (\x -> construct_matrix x qs) cons
 326       (pats,indexs) = unzip pats_indexs
 327
 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)
 332      where
 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
 342
 343 construct_matrix :: Pat Id -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
 344 construct_matrix con qs =
 345     (map (make_con con) pats,indexs)
 346   where
 347     (pats,indexs) = (check' (remove_first_column con qs))
 348 \end{code}
 349
 350 Here remove first column is more difficult that with literals due to the fact
 351 that constructors can have arguments.
 352
 353 For instance, the matrix
 354 \begin{verbatim}
 355  (: x xs) y
 356  z        y
 357 \end{verbatim}
 358 is transformed in:
 359 \begin{verbatim}
 360  x xs y
 361  _ _  y
 362 \end{verbatim}
 363
 364 \begin{code}
 365 remove_first_column :: Pat Id                -- Constructor
 366                     -> [(EqnNo, EquationInfo)]
 367                     -> [(EqnNo, EquationInfo)]
 368 remove_first_column (ConPatOut{ pat_con = L _ con, pat_args = 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)]
 371   where
 372      new_wilds = [WildPat (hsLPatType arg_pat) | arg_pat <- con_pats]
 373      shift_var eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_args = 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"
 378
 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)])
 382   where
 383      new_var = hash_x
 384
 385 hash_x = mkInternalName unboundKey {- doesn't matter much -}
 386                      (mkVarOccFS FSLIT("#x"))
 387                      noSrcLoc
 388
 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)
 392
 393 compare_cons :: Pat Id -> Pat Id -> Bool
 394 compare_cons (ConPatOut{ pat_con = L _ id1 }) (ConPatOut { pat_con = L _ id2 }) = id1 == id2
 395
 396 remove_dups :: [Pat Id] -> [Pat Id]
 397 remove_dups []     = []
 398 remove_dups (x:xs) | or (map (\y -> compare_cons x y) xs) = remove_dups  xs
 399                    | otherwise                            = x : remove_dups xs
 400
 401 get_used_cons :: [(EqnNo, EquationInfo)] -> [Pat Id]
 402 get_used_cons qs = remove_dups [pat | q <- qs, let pat = firstPatN q,
 403                                       isConPatOut pat]
 404
 405 isConPatOut (ConPatOut {}) = True
 406 isConPatOut other          = False
 407
 408 remove_dups' :: [HsLit] -> [HsLit]
 409 remove_dups' []                   = []
 410 remove_dups' (x:xs) | x `elem` xs = remove_dups' xs
 411                     | otherwise   = x : remove_dups' xs
 412
 413
 414 get_used_lits :: [(EqnNo, EquationInfo)] -> [HsLit]
 415 get_used_lits qs = remove_dups' all_literals
 416                  where
 417                    all_literals = get_used_lits' qs
 418
 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
 424
 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
 433
 434 mb_neg :: Num a => Maybe b -> a -> a
 435 mb_neg Nothing  v = v
 436 mb_neg (Just _) v = -v
 437
 438 get_unused_cons :: [Pat Id] -> [DataCon]
 439 get_unused_cons used_cons = unused_cons
 440      where
 441        (ConPatOut { pat_ty = ty }) = head used_cons
 442        ty_con                 = tcTyConAppTyCon ty              -- Newtype observable
 443        all_cons               = tyConDataCons ty_con
 444        used_cons_as_id        = map (\ (ConPatOut{ pat_con = L _ d}) -> d) used_cons
 445        unused_cons            = uniqSetToList
 446                  (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
 447
 448 all_vars :: [Pat Id] -> Bool
 449 all_vars []             = True
 450 all_vars (WildPat _:ps) = all_vars ps
 451 all_vars _              = False
 452
 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"
 456
 457 -----------------------
 458 eqnPats :: (EqnNo, EquationInfo) -> [Pat Id]
 459 eqnPats (_, eqn) = eqn_pats eqn
 460
 461 okGroup :: [(EqnNo, EquationInfo)] -> Bool
 462 -- True if all equations have at least one pattern, and
 463 -- all have the same number of patterns
 464 okGroup [] = True
 465 okGroup (e:es) = n_pats > 0 && and [length (eqnPats e) == n_pats | e <- es]
 466                where
 467                  n_pats = length (eqnPats e)
 468
 469 -- Half-baked print
 470 pprGroup es = vcat (map pprEqnInfo es)
 471 pprEqnInfo e = ppr (eqnPats e)
 472
 473
 474 firstPatN :: (EqnNo, EquationInfo) -> Pat Id
 475 firstPatN (_, eqn) = firstPat eqn
 476
 477 is_con :: Pat Id -> Bool
 478 is_con (ConPatOut {}) = True
 479 is_con _              = False
 480
 481 is_lit :: Pat Id -> Bool
 482 is_lit (LitPat _)      = True
 483 is_lit (NPat _ _ _ _)  = True
 484 is_lit _               = False
 485
 486 is_var :: Pat Id -> Bool
 487 is_var (WildPat _) = True
 488 is_var _           = False
 489
 490 is_var_con :: DataCon -> Pat Id -> Bool
 491 is_var_con con (WildPat _)                                 = True
 492 is_var_con con (ConPatOut{ pat_con = L _ id }) | id == con = True
 493 is_var_con con _                                           = False
 494
 495 is_var_lit :: HsLit -> Pat Id -> Bool
 496 is_var_lit lit (WildPat _)   = True
 497 is_var_lit lit pat
 498   | Just lit' <- get_lit pat = lit == lit'
 499   | otherwise                = False
 500 \end{code}
 501
 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.
 506
 507 We need to reconstruct the patterns (make the constructors infix and
 508 similar) at the same time that we create the constructors.
 509
 510 You can tell tuple constructors using
 511 \begin{verbatim}
 512         Id.isTupleCon
 513 \end{verbatim}
 514 You can see if one constructor is infix with this clearer code :-))))))))))
 515 \begin{verbatim}
 516         Lex.isLexConSym (Name.occNameString (Name.getOccName con))
 517 \end{verbatim}
 518
 519        Rather clumsy but it works. (Simon Peyton Jones)
 520
 521
 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]@,
 524 not @x:xs@ ....
 525
 526 In @reconstruct_pat@ we want to ``undo'' the work
 527 that we have done in @simplify_pat@.
 528 In particular:
 529 \begin{tabular}{lll}
 530         @((,) x y)@   & returns to be & @(x, y)@
 531 \\      @((:) x xs)@  & returns to be & @(x:xs)@
 532 \\      @(x:(...:[])@ & returns to be & @[x,...]@
 533 \end{tabular}
 534 %
 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{\ ???\ }
 538 %
 539 \begin{code}
 540 isInfixCon con = isDataSymOcc (getOccName con)
 541
 542 is_nil (ConPatIn con (PrefixCon [])) = unLoc con == getName nilDataCon
 543 is_nil _                             = False
 544
 545 is_list (ListPat _ _) = True
 546 is_list _             = False
 547
 548 return_list id q = id == consDataCon && (is_nil q || is_list q)
 549
 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"
 553
 554 make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat
 555 make_con (ConPatOut{ pat_con = 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)
 558    where q  = unLoc lq
 559
 560 make_con (ConPatOut{ pat_con = L _ id, pat_args = PrefixCon pats, pat_ty = 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)
 564     where
 565         name                  = getName id
 566         (pats_con, rest_pats) = splitAtList pats ps
 567         tc                    = dataConTyCon id
 568
 569 -- reconstruct parallel array pattern
 570 --
 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
 573 --   representation
 574
 575 make_whole_con :: DataCon -> WarningPat
 576 make_whole_con con | isInfixCon con = nlInfixConPat name nlWildPat nlWildPat
 577                    | otherwise      = nlConPat name pats
 578                 where
 579                   name   = getName con
 580                   pats   = [nlWildPat | t <- dataConOrigArgTys con]
 581 \end{code}
 582
 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
 586 constraints.
 587
 588 \begin{code}
 589
 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) }
 593   where
 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
 601
 602 has_nplusk_lpat :: LPat Id -> Bool
 603 has_nplusk_lpat (L _ p) = has_nplusk_pat p
 604
 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 (ListPat ps _)                = any has_nplusk_lpat ps
 611 has_nplusk_pat (TuplePat ps _ _)             = any has_nplusk_lpat ps
 612 has_nplusk_pat (PArrPat ps _)                = any has_nplusk_lpat ps
 613 has_nplusk_pat (LazyPat p)                   = False    -- Why?
 614 has_nplusk_pat (BangPat p)                   = has_nplusk_lpat p        -- I think
 615 has_nplusk_pat (ConPatOut { pat_args = ps }) = any has_nplusk_lpat (hsConArgs ps)
 616 has_nplusk_pat p = False        -- VarPat, VarPatOut, WildPat, LitPat, NPat, TypePat, DictPat
 617
 618 simplify_lpat :: LPat Id -> LPat Id
 619 simplify_lpat p = fmap simplify_pat p
 620
 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 (hsLPatType 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
 631
 632 simplify_pat pat@(ConPatOut { pat_con = L loc id, pat_args = ps })
 633   = pat { pat_args = simplify_con id ps }
 634
 635 simplify_pat (ListPat ps ty) =
 636   unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty)
 637                                   (mkNilPat list_ty)
 638                                   (map simplify_lpat ps)
 639          where list_ty = mkListTy ty
 640
 641 -- introduce fake parallel array constructors to be able to handle parallel
 642 -- arrays with the existing machinery for constructor pattern
 643 --
 644 simplify_pat (PArrPat ps ty)
 645   = unLoc $ mkPrefixConPat (parrFakeCon (length ps))
 646                            (map simplify_lpat ps)
 647                            (mkPArrTy ty)
 648
 649 simplify_pat (TuplePat ps boxity ty)
 650   = unLoc $ mkPrefixConPat (tupleCon boxity arity)
 651                            (map simplify_lpat ps) ty
 652   where
 653     arity = length ps
 654
 655 -- unpack string patterns fully, so we can see when they overlap with
 656 -- each other, or even explicit lists of Chars.
 657 simplify_pat pat@(LitPat (HsString s)) =
 658    unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mk_char_lit c, pat] stringTy)
 659                  (mkPrefixConPat nilDataCon [] stringTy) (unpackFS s)
 660   where
 661     mk_char_lit c = mkPrefixConPat charDataCon [nlLitPat (HsCharPrim c)] charTy
 662
 663 simplify_pat (LitPat lit)                = tidyLitPat lit
 664 simplify_pat (NPat lit mb_neg eq lit_ty) = tidyNPat lit mb_neg eq lit_ty
 665
 666 simplify_pat (NPlusKPat id hslit hsexpr1 hsexpr2)
 667    = WildPat (idType (unLoc id))
 668
 669 simplify_pat (DictPat dicts methods)
 670   = case num_of_d_and_ms of
 671        0 -> simplify_pat (TuplePat [] Boxed unitTy)
 672        1 -> simplify_pat (head dict_and_method_pats)
 673        _ -> simplify_pat (mkVanillaTuplePat (map noLoc dict_and_method_pats) Boxed)
 674     where
 675        num_of_d_and_ms   = length dicts + length methods
 676        dict_and_method_pats = map VarPat (dicts ++ methods)
 677
 678 simplify_pat (CoPat co pat ty) = simplify_pat pat
 679
 680 -----------------
 681 simplify_con con (PrefixCon ps)   = PrefixCon (map simplify_lpat ps)
 682 simplify_con con (InfixCon p1 p2) = PrefixCon [simplify_lpat p1, simplify_lpat p2]
 683 simplify_con con (RecCon fs)
 684   | null fs   = PrefixCon [nlWildPat | t <- dataConOrigArgTys con]
 685                 -- Special case for null patterns; maybe not a record at all
 686   | otherwise = PrefixCon (map (simplify_lpat.snd) all_pats)
 687   where
 688      -- pad out all the missing fields with WildPats.
 689     field_pats = map (\ f -> (f, nlWildPat)) (dataConFieldLabels con)
 690     all_pats = foldr (\ (id,p) acc -> insertNm (getName (unLoc id)) p acc)
 691                      field_pats fs
 692
 693     insertNm nm p [] = [(nm,p)]
 694     insertNm nm p (x@(n,_):xs)
 695       | nm == n    = (nm,p):xs
 696       | otherwise  = x : insertNm nm p xs
 697 \end{code}