ghc/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          ( TypecheckedPat )
  15 import DsHsSyn          ( outPatType )
  16 import CoreSyn
  17
  18 import DsUtils          ( EquationInfo(..),
  19                           MatchResult(..),
  20                           EqnSet,
  21                           CanItFail(..),
  22                           tidyLitPat
  23                         )
  24 import Id               ( idType )
  25 import DataCon          ( DataCon, isTupleCon, isUnboxedTupleCon, dataConArgTys,
  26                           dataConSourceArity, dataConFieldLabels )
  27 import Name             ( Name, mkLocalName, getOccName, isDataSymOcc, getName, mkSrcVarOcc )
  28 import Type             ( Type, splitAlgTyConApp, mkTyVarTys,
  29                           isUnboxedType, splitTyConApp_maybe
  30                         )
  31 import TysPrim          ( intPrimTy,
  32                           charPrimTy,
  33                           floatPrimTy,
  34                           doublePrimTy,
  35                           addrPrimTy,
  36                           wordPrimTy
  37                         )
  38 import TysWiredIn       ( nilDataCon, consDataCon,
  39                           mkTupleTy, tupleCon,
  40                           mkUnboxedTupleTy, unboxedTupleCon,
  41                           mkListTy,
  42                           charTy, charDataCon,
  43                           intTy, intDataCon,
  44                           floatTy, floatDataCon,
  45                           doubleTy, doubleDataCon,
  46                           addrTy, addrDataCon,
  47                           wordTy, wordDataCon,
  48                           stringTy
  49                         )
  50 import Unique           ( unboundKey )
  51 import TyCon            ( tyConDataCons )
  52 import SrcLoc           ( noSrcLoc )
  53 import UniqSet
  54 import Outputable
  55
  56 #include "HsVersions.h"
  57 \end{code}
  58
  59 This module performs checks about if one list of equations are:
  60 \begin{itemize}
  61 \item Overlapped
  62 \item Non exhaustive
  63 \end{itemize}
  64 To discover that we go through the list of equations in a tree-like fashion.
  65
  66 If you like theory, a similar algorithm is described in:
  67 \begin{quotation}
  68         {\em Two Techniques for Compiling Lazy Pattern Matching},
  69         Luc Maranguet,
  70         INRIA Rocquencourt (RR-2385, 1994)
  71 \end{quotation}
  72 The algorithm is based on the first technique, but there are some differences:
  73 \begin{itemize}
  74 \item We don't generate code
  75 \item We have constructors and literals (not only literals as in the
  76           article)
  77 \item We don't use directions, we must select the columns from
  78           left-to-right
  79 \end{itemize}
  80 (By the way the second technique is really similar to the one used in
  81  @Match.lhs@ to generate code)
  82
  83 This function takes the equations of a pattern and returns:
  84 \begin{itemize}
  85 \item The patterns that are not recognized
  86 \item The equations that are not overlapped
  87 \end{itemize}
  88 It simplify the patterns and then call @check'@ (the same semantics), and it
  89 needs to reconstruct the patterns again ....
  90
  91 The problem appear with things like:
  92 \begin{verbatim}
  93   f [x,y]   = ....
  94   f (x:xs)  = .....
  95 \end{verbatim}
  96 We want to put the two patterns with the same syntax, (prefix form) and
  97 then all the constructors are equal:
  98 \begin{verbatim}
  99   f (: x (: y []))   = ....
 100   f (: x xs)         = .....
 101 \end{verbatim}
 102 (more about that in @simplify_eqns@)
 103
 104 We would prefer to have a @WarningPat@ of type @String@, but Strings and the
 105 Pretty Printer are not friends.
 106
 107 We use @InPat@ in @WarningPat@ instead of @OutPat@
 108 because we need to print the
 109 warning messages in the same way they are introduced, i.e. if the user
 110 wrote:
 111 \begin{verbatim}
 112         f [x,y] = ..
 113 \end{verbatim}
 114 He don't want a warning message written:
 115 \begin{verbatim}
 116         f (: x (: y [])) ........
 117 \end{verbatim}
 118 Then we need to use InPats.
 119 \begin{quotation}
 120      Juan Quintela 5 JUL 1998\\
 121           User-friendliness and compiler writers are no friends.
 122 \end{quotation}
 123 \begin{code}
 124
 125 type WarningPat = InPat Name
 126 type ExhaustivePat = ([WarningPat], [(Name, [HsLit])])
 127
 128
 129 check :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
 130 check qs = (untidy_warns, incomplete)
 131       where
 132         (warns, incomplete) = check' (simplify_eqns qs)
 133         untidy_warns = map untidy_exhaustive warns
 134
 135 untidy_exhaustive :: ExhaustivePat -> ExhaustivePat
 136 untidy_exhaustive ([pat], messages) =
 137                   ([untidy_no_pars pat], map untidy_message messages)
 138 untidy_exhaustive (pats, messages) =
 139                   (map untidy_pars pats, map untidy_message messages)
 140
 141 untidy_message :: (Name, [HsLit]) -> (Name, [HsLit])
 142 untidy_message (string, lits) = (string, map untidy_lit lits)
 143 \end{code}
 144
 145 The function @untidy@ does the reverse work of the @simplify_pat@ funcion.
 146
 147 \begin{code}
 148
 149 type NeedPars = Bool
 150
 151 untidy_no_pars :: WarningPat -> WarningPat
 152 untidy_no_pars p = untidy False p
 153
 154 untidy_pars :: WarningPat -> WarningPat
 155 untidy_pars p = untidy True p
 156
 157 untidy :: NeedPars -> WarningPat -> WarningPat
 158 untidy _ p@WildPatIn = p
 159 untidy _ p@(VarPatIn name) = p
 160 untidy _ (LitPatIn lit) = LitPatIn (untidy_lit lit)
 161 untidy _ p@(ConPatIn name []) = p
 162 untidy b (ConPatIn name pats)  =
 163        pars b (ConPatIn name (map untidy_pars pats))
 164 untidy b (ConOpPatIn pat1 name fixity pat2) =
 165        pars b (ConOpPatIn (untidy_pars pat1) name fixity (untidy_pars pat2))
 166 untidy _ (ListPatIn pats)  = ListPatIn (map untidy_no_pars pats)
 167 untidy _ (TuplePatIn pats boxed) = TuplePatIn (map untidy_no_pars pats) boxed
 168
 169 untidy _ (SigPatIn pat ty)      = panic "Check.untidy: SigPatIn"
 170 untidy _ (LazyPatIn pat)        = panic "Check.untidy: LazyPatIn"
 171 untidy _ (AsPatIn name pat)     = panic "Check.untidy: AsPatIn"
 172 untidy _ (NPlusKPatIn name lit) = panic "Check.untidy: NPlusKPatIn"
 173 untidy _ (NegPatIn ipat)        = panic "Check.untidy: NegPatIn"
 174 untidy _ (ParPatIn pat)         = panic "Check.untidy: ParPatIn"
 175 untidy _ (RecPatIn name fields) = panic "Check.untidy: RecPatIn"
 176
 177 pars :: NeedPars -> WarningPat -> WarningPat
 178 pars True p = ParPatIn p
 179 pars _    p = p
 180
 181 untidy_lit :: HsLit -> HsLit
 182 untidy_lit (HsCharPrim c) = HsChar c
 183 --untidy_lit (HsStringPrim s) = HsString s
 184 untidy_lit lit = lit
 185 \end{code}
 186
 187 This equation is the same that check, the only difference is that the
 188 boring work is done, that work needs to be done only once, this is
 189 the reason top have two functions, check is the external interface,
 190 @check'@ is called recursively.
 191
 192 There are several cases:
 193
 194 \begin{itemize}
 195 \item There are no equations: Everything is OK.
 196 \item There are only one equation, that can fail, and all the patterns are
 197       variables. Then that equation is used and the same equation is
 198       non-exhaustive.
 199 \item All the patterns are variables, and the match can fail, there are
 200       more equations then the results is the result of the rest of equations
 201       and this equation is used also.
 202
 203 \item The general case, if all the patterns are variables (here the match
 204       can't fail) then the result is that this equation is used and this
 205       equation doesn't generate non-exhaustive cases.
 206
 207 \item In the general case, there can exist literals ,constructors or only
 208       vars in the first column, we actuate in consequence.
 209
 210 \end{itemize}
 211
 212
 213 \begin{code}
 214
 215 check' :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
 216 check' []                                              = ([([],[])],emptyUniqSet)
 217
 218 check' [EqnInfo n ctx ps (MatchResult CanFail _)]
 219    | all_vars ps  = ([(take (length ps) (repeat new_wild_pat),[])],  unitUniqSet n)
 220
 221 check' qs@((EqnInfo n ctx ps (MatchResult CanFail _)):rs)
 222    | all_vars ps  = (pats,  addOneToUniqSet indexs n)
 223   where
 224     (pats,indexs) = check' rs
 225
 226 check' qs@((EqnInfo n ctx ps result):_)
 227    | all_vars ps  = ([],  unitUniqSet n)
 228 --   | nplusk       = panic "Check.check': Work in progress: nplusk"
 229 --   | npat         = panic "Check.check': Work in progress: npat ?????"
 230    | literals     = split_by_literals qs
 231    | constructors = split_by_constructor qs
 232    | only_vars    = first_column_only_vars qs
 233    | otherwise    = panic "Check.check': Not implemented :-("
 234   where
 235      -- Note: RecPats will have been simplified to ConPats
 236      --       at this stage.
 237     constructors = or (map is_con qs)
 238     literals     = or (map is_lit qs)
 239     only_vars    = and (map is_var qs)
 240 --    npat         = or (map is_npat qs)
 241 --    nplusk       = or (map is_nplusk qs)
 242 \end{code}
 243
 244 Here begins the code to deal with literals, we need to split the matrix
 245 in different matrix beginning by each literal and a last matrix with the
 246 rest of values.
 247
 248 \begin{code}
 249 split_by_literals :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
 250 split_by_literals qs = process_literals used_lits qs
 251            where
 252              used_lits = get_used_lits qs
 253 \end{code}
 254
 255 @process_explicit_literals@ is a function that process each literal that appears
 256 in the column of the matrix.
 257
 258 \begin{code}
 259 process_explicit_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
 260 process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)
 261     where
 262       pats_indexs   = map (\x -> construct_literal_matrix x qs) lits
 263       (pats,indexs) = unzip pats_indexs
 264
 265 \end{code}
 266
 267
 268 @process_literals@ calls @process_explicit_literals@ to deal with the literals
 269 that appears in the matrix and deal also with the rest of the cases. It
 270 must be one Variable to be complete.
 271
 272 \begin{code}
 273
 274 process_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
 275 process_literals used_lits qs
 276   | length default_eqns == 0 = ([make_row_vars used_lits (head qs)]++pats,indexs)
 277   | otherwise                = (pats_default,indexs_default)
 278      where
 279        (pats,indexs)   = process_explicit_literals used_lits qs
 280        default_eqns    = (map remove_var (filter is_var qs))
 281        (pats',indexs') = check' default_eqns
 282        pats_default    = [(new_wild_pat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats
 283        indexs_default  = unionUniqSets indexs' indexs
 284 \end{code}
 285
 286 Here we have selected the literal and we will select all the equations that
 287 begins for that literal and create a new matrix.
 288
 289 \begin{code}
 290 construct_literal_matrix :: HsLit -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
 291 construct_literal_matrix lit qs =
 292     (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)
 293   where
 294     (pats,indexs) = (check' (remove_first_column_lit lit qs))
 295     new_lit = LitPatIn lit
 296
 297 remove_first_column_lit :: HsLit
 298                         -> [EquationInfo]
 299                         -> [EquationInfo]
 300 remove_first_column_lit lit qs =
 301     map shift_pat (filter (is_var_lit lit) qs)
 302   where
 303      shift_pat (EqnInfo n ctx []     result) =  panic "Check.shift_var: no patterns"
 304      shift_pat (EqnInfo n ctx (_:ps) result) =  EqnInfo n ctx ps result
 305
 306 \end{code}
 307
 308 This function splits the equations @qs@ in groups that deal with the
 309 same constructor.
 310
 311 \begin{code}
 312
 313 split_by_constructor :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
 314
 315 split_by_constructor qs | length unused_cons /= 0 = need_default_case used_cons unused_cons qs
 316                         | otherwise               = no_need_default_case used_cons qs
 317                        where
 318                           used_cons   = get_used_cons qs
 319                           unused_cons = get_unused_cons used_cons
 320
 321 \end{code}
 322
 323 The first column of the patterns matrix only have vars, then there is
 324 nothing to do.
 325
 326 \begin{code}
 327 first_column_only_vars :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
 328 first_column_only_vars qs = (map (\ (xs,ys) -> (new_wild_pat:xs,ys)) pats,indexs)
 329                           where
 330                             (pats,indexs) = check' (map remove_var qs)
 331
 332 \end{code}
 333
 334 This equation takes a matrix of patterns and split the equations by
 335 constructor, using all the constructors that appears in the first column
 336 of the pattern matching.
 337
 338 We can need a default clause or not ...., it depends if we used all the
 339 constructors or not explicitly. The reasoning is similar to @process_literals@,
 340 the difference is that here the default case is not always needed.
 341
 342 \begin{code}
 343 no_need_default_case :: [TypecheckedPat] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
 344 no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
 345     where
 346       pats_indexs   = map (\x -> construct_matrix x qs) cons
 347       (pats,indexs) = unzip pats_indexs
 348
 349 need_default_case :: [TypecheckedPat] -> [DataCon] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
 350 need_default_case used_cons unused_cons qs
 351   | length default_eqns == 0 = (pats_default_no_eqns,indexs)
 352   | otherwise                = (pats_default,indexs_default)
 353      where
 354        (pats,indexs)   = no_need_default_case used_cons qs
 355        default_eqns    = (map remove_var (filter is_var qs))
 356        (pats',indexs') = check' default_eqns
 357        pats_default    = [(make_whole_con c:ps,constraints) |
 358                           c <- unused_cons, (ps,constraints) <- pats'] ++ pats
 359        new_wilds       = make_row_vars_for_constructor (head qs)
 360        pats_default_no_eqns =  [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats
 361        indexs_default  = unionUniqSets indexs' indexs
 362
 363 construct_matrix :: TypecheckedPat -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
 364 construct_matrix con qs =
 365     (map (make_con con) pats,indexs)
 366   where
 367     (pats,indexs) = (check' (remove_first_column con qs))
 368 \end{code}
 369
 370 Here remove first column is more difficult that with literals due to the fact
 371 that constructors can have arguments.
 372
 373 For instance, the matrix
 374 \begin{verbatim}
 375  (: x xs) y
 376  z        y
 377 \end{verbatim}
 378 is transformed in:
 379 \begin{verbatim}
 380  x xs y
 381  _ _  y
 382 \end{verbatim}
 383
 384 \begin{code}
 385 remove_first_column :: TypecheckedPat                -- Constructor
 386                     -> [EquationInfo]
 387                     -> [EquationInfo]
 388 remove_first_column (ConPat con _ _ _ con_pats) qs =
 389     map shift_var (filter (is_var_con con) qs)
 390   where
 391      new_wilds = [WildPat (outPatType arg_pat) | arg_pat <- con_pats]
 392      shift_var (EqnInfo n ctx (ConPat _ _ _ _ ps':ps) result) =
 393                 EqnInfo n ctx (ps'++ps)               result
 394      shift_var (EqnInfo n ctx (WildPat _     :ps)     result) =
 395                 EqnInfo n ctx (new_wilds ++   ps)     result
 396      shift_var _ = panic "Check.Shift_var:No done"
 397
 398 make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat
 399 make_row_vars used_lits (EqnInfo _ _ pats _ ) =
 400    (VarPatIn new_var:take (length (tail pats)) (repeat new_wild_pat),[(new_var,used_lits)])
 401   where new_var = hash_x
 402
 403 hash_x = mkLocalName unboundKey {- doesn't matter much -}
 404                      (mkSrcVarOcc SLIT("#x"))
 405                      noSrcLoc
 406
 407 make_row_vars_for_constructor :: EquationInfo -> [WarningPat]
 408 make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = take (length (tail pats)) (repeat new_wild_pat)
 409
 410 compare_cons :: TypecheckedPat -> TypecheckedPat -> Bool
 411 compare_cons (ConPat id1 _ _ _ _) (ConPat id2 _ _ _ _) = id1 == id2
 412
 413 remove_dups :: [TypecheckedPat] -> [TypecheckedPat]
 414 remove_dups []     = []
 415 remove_dups (x:xs) | or (map (\y -> compare_cons x y) xs) = remove_dups  xs
 416                    | otherwise                            = x : remove_dups xs
 417
 418 get_used_cons :: [EquationInfo] -> [TypecheckedPat]
 419 get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPat _ _ _ _ _):_) _) <- qs ]
 420
 421 remove_dups' :: [HsLit] -> [HsLit]
 422 remove_dups' []                   = []
 423 remove_dups' (x:xs) | x `elem` xs = remove_dups' xs
 424                     | otherwise   = x : remove_dups' xs
 425
 426
 427 get_used_lits :: [EquationInfo] -> [HsLit]
 428 get_used_lits qs = remove_dups' all_literals
 429                  where
 430                    all_literals = get_used_lits' qs
 431
 432 get_used_lits' :: [EquationInfo] -> [HsLit]
 433 get_used_lits' [] = []
 434 get_used_lits' ((EqnInfo _ _ ((LitPat lit _):_) _):qs) =
 435                lit : get_used_lits qs
 436 get_used_lits' ((EqnInfo _ _ ((NPat lit _ _):_) _):qs) =
 437                lit : get_used_lits qs
 438 get_used_lits' (q:qs)                                  =
 439                get_used_lits qs
 440
 441 get_unused_cons :: [TypecheckedPat] -> [DataCon]
 442 get_unused_cons used_cons = unused_cons
 443      where
 444        (ConPat _ ty _ _ _) = head used_cons
 445        Just (ty_con,_)     = splitTyConApp_maybe ty
 446        all_cons            = tyConDataCons ty_con
 447        used_cons_as_id     = map (\ (ConPat d _ _ _ _) -> d) used_cons
 448        unused_cons         = uniqSetToList
 449                  (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
 450
 451
 452 all_vars :: [TypecheckedPat] -> Bool
 453 all_vars []              = True
 454 all_vars (WildPat _:ps)  = all_vars ps
 455 all_vars _               = False
 456
 457 remove_var :: EquationInfo -> EquationInfo
 458 remove_var (EqnInfo n ctx (WildPat _:ps) result) = EqnInfo n ctx ps result
 459 remove_var _                                     =
 460          panic "Check.remove_var: equation does not begin with a variable"
 461
 462 is_con :: EquationInfo -> Bool
 463 is_con (EqnInfo _ _ ((ConPat _ _ _ _ _):_) _) = True
 464 is_con _                                      = False
 465
 466 is_lit :: EquationInfo -> Bool
 467 is_lit (EqnInfo _ _ ((LitPat _ _):_) _) = True
 468 is_lit (EqnInfo _ _ ((NPat _ _ _):_) _) = True
 469 is_lit _                                = False
 470
 471 is_npat :: EquationInfo -> Bool
 472 is_npat (EqnInfo _ _ ((NPat _ _ _):_) _) = True
 473 is_npat _                                 = False
 474
 475 is_nplusk :: EquationInfo -> Bool
 476 is_nplusk (EqnInfo _ _ ((NPlusKPat _ _ _ _ _):_) _) = True
 477 is_nplusk _                                         = False
 478
 479 is_var :: EquationInfo -> Bool
 480 is_var (EqnInfo _ _ ((WildPat _):_) _)  = True
 481 is_var _                                = False
 482
 483 is_var_con :: DataCon -> EquationInfo -> Bool
 484 is_var_con con (EqnInfo _ _ ((WildPat _):_)     _)                 = True
 485 is_var_con con (EqnInfo _ _ ((ConPat id _ _ _ _):_) _) | id == con = True
 486 is_var_con con _                                                   = False
 487
 488 is_var_lit :: HsLit -> EquationInfo -> Bool
 489 is_var_lit lit (EqnInfo _ _ ((WildPat _):_)     _)               = True
 490 is_var_lit lit (EqnInfo _ _ ((LitPat lit' _):_) _) | lit == lit' = True
 491 is_var_lit lit (EqnInfo _ _ ((NPat lit' _ _):_) _) | lit == lit' = True
 492 is_var_lit lit _                                                 = False
 493 \end{code}
 494
 495 The difference beteewn @make_con@ and @make_whole_con@ is that
 496 @make_wole_con@ creates a new constructor with all their arguments, and
 497 @make_con@ takes a list of argumntes, creates the contructor getting their
 498 arguments from the list. See where \fbox{\ ???\ } are used for details.
 499
 500 We need to reconstruct the patterns (make the constructors infix and
 501 similar) at the same time that we create the constructors.
 502
 503 You can tell tuple constructors using
 504 \begin{verbatim}
 505         Id.isTupleCon
 506 \end{verbatim}
 507 You can see if one constructor is infix with this clearer code :-))))))))))
 508 \begin{verbatim}
 509         Lex.isLexConSym (Name.occNameString (Name.getOccName con))
 510 \end{verbatim}
 511
 512        Rather clumsy but it works. (Simon Peyton Jones)
 513
 514
 515 We don't mind the @nilDataCon@ because it doesn't change the way to
 516 print the messsage, we are searching only for things like: @[1,2,3]@,
 517 not @x:xs@ ....
 518
 519 In @reconstruct_pat@ we want to ``undo'' the work
 520 that we have done in @simplify_pat@.
 521 In particular:
 522 \begin{tabular}{lll}
 523         @((,) x y)@   & returns to be & @(x, y)@
 524 \\      @((:) x xs)@  & returns to be & @(x:xs)@
 525 \\      @(x:(...:[])@ & returns to be & @[x,...]@
 526 \end{tabular}
 527 %
 528 The difficult case is the third one becouse we need to follow all the
 529 contructors until the @[]@ to know that we need to use the second case,
 530 not the second. \fbox{\ ???\ }
 531 %
 532 \begin{code}
 533 isInfixCon con = isDataSymOcc (getOccName con)
 534
 535 is_nil (ConPatIn con []) = con == getName nilDataCon
 536 is_nil _                 = False
 537
 538 is_list (ListPatIn _) = True
 539 is_list _             = False
 540
 541 return_list id q = id == consDataCon && (is_nil q || is_list q)
 542
 543 make_list p q | is_nil q   = ListPatIn [p]
 544 make_list p (ListPatIn ps) = ListPatIn (p:ps)
 545 make_list _ _              = panic "Check.make_list: Invalid argument"
 546
 547 make_con :: TypecheckedPat -> ExhaustivePat -> ExhaustivePat
 548 make_con (ConPat id _ _ _ _) (p:q:ps, constraints)
 549      | return_list id q = (make_list p q : ps, constraints)
 550      | isInfixCon id = ((ConOpPatIn p name fixity q) : ps, constraints)
 551     where name   = getName id
 552           fixity = panic "Check.make_con: Guessing fixity"
 553
 554 make_con (ConPat id _ _ _ pats) (ps,constraints)
 555       | isTupleCon id        = (TuplePatIn pats_con True : rest_pats,    constraints)
 556       | isUnboxedTupleCon id = (TuplePatIn pats_con False : rest_pats, constraints)
 557       | otherwise     = (ConPatIn name pats_con : rest_pats, constraints)
 558     where num_args  = length pats
 559           name      = getName id
 560           pats_con  = take num_args ps
 561           rest_pats = drop num_args ps
 562
 563
 564 make_whole_con :: DataCon -> WarningPat
 565 make_whole_con con | isInfixCon con = ConOpPatIn new_wild_pat name fixity new_wild_pat
 566                    | otherwise      = ConPatIn name pats
 567                 where
 568                   fixity = panic "Check.make_whole_con: Guessing fixity"
 569                   name   = getName con
 570                   arity  = dataConSourceArity con
 571                   pats   = take arity (repeat new_wild_pat)
 572
 573
 574 new_wild_pat :: WarningPat
 575 new_wild_pat = WildPatIn
 576 \end{code}
 577
 578 This equation makes the same thing as @tidy@ in @Match.lhs@, the
 579 difference is that here we can do all the tidy in one place and in the
 580 @Match@ tidy it must be done one column each time due to bookkeeping
 581 constraints.
 582
 583 \begin{code}
 584
 585 simplify_eqns :: [EquationInfo] -> [EquationInfo]
 586 simplify_eqns []                               = []
 587 simplify_eqns ((EqnInfo n ctx pats result):qs) =
 588  (EqnInfo n ctx pats' result) : simplify_eqns qs
 589  where
 590   pats' = map simplify_pat pats
 591
 592 simplify_pat :: TypecheckedPat -> TypecheckedPat
 593
 594 simplify_pat pat@(WildPat gt) = pat
 595 simplify_pat (VarPat id)      = WildPat (idType id)
 596
 597 simplify_pat (LazyPat p)    = simplify_pat p
 598 simplify_pat (AsPat id p)   = simplify_pat p
 599
 600 simplify_pat (ConPat id ty tvs dicts ps) = ConPat id ty tvs dicts (map simplify_pat ps)
 601
 602 simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y])
 603                                      (ConPat nilDataCon list_ty [] [] [])
 604                                      (map simplify_pat ps)
 605                              where list_ty = mkListTy ty
 606
 607
 608 simplify_pat (TuplePat ps True) = ConPat (tupleCon arity)
 609                                     (mkTupleTy arity (map outPatType ps)) [] []
 610                                     (map simplify_pat ps)
 611                            where
 612                               arity = length ps
 613
 614 simplify_pat (TuplePat ps False)
 615   = ConPat (unboxedTupleCon arity)
 616            (mkUnboxedTupleTy arity (map outPatType ps)) [] []
 617            (map simplify_pat ps)
 618   where
 619     arity = length ps
 620
 621 simplify_pat (RecPat dc ty ex_tvs dicts [])
 622   = ConPat dc ty ex_tvs dicts all_wild_pats
 623   where
 624     all_wild_pats = map WildPat con_arg_tys
 625
 626       -- identical to machinations in Match.tidy1:
 627     (_, inst_tys, _) = splitAlgTyConApp ty
 628     con_arg_tys      = dataConArgTys dc (inst_tys ++ mkTyVarTys ex_tvs)
 629
 630 simplify_pat (RecPat dc ty ex_tvs dicts idps)
 631   = ConPat dc ty ex_tvs dicts pats
 632   where
 633     pats = map (simplify_pat.snd) all_pats
 634
 635      -- pad out all the missing fields with WildPats.
 636     field_pats = map (\ f -> (getName f, WildPat (panic "simplify_pat(RecPat-2)")))
 637                      (dataConFieldLabels dc)
 638     all_pats =
 639       foldr
 640        ( \ (id,p,_) acc -> insertNm (getName id) p acc)
 641        field_pats
 642        idps
 643
 644     insertNm nm p [] = [(nm,p)]
 645     insertNm nm p (x@(n,_):xs)
 646       | nm == n    = (nm,p):xs
 647       | otherwise  = x : insertNm nm p xs
 648
 649 simplify_pat pat@(LitPat lit lit_ty)        = tidyLitPat lit lit_ty pat
 650 simplify_pat pat@(NPat   lit lit_ty hsexpr) = tidyLitPat lit lit_ty pat
 651
 652 simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) =
 653      WildPat ty
 654    where ty = panic "Check.simplify_pat: Gessing ty"
 655
 656 simplify_pat (DictPat dicts methods) =
 657     case num_of_d_and_ms of
 658        0 -> simplify_pat (TuplePat [] True)
 659        1 -> simplify_pat (head dict_and_method_pats)
 660        _ -> simplify_pat (TuplePat dict_and_method_pats True)
 661     where
 662        num_of_d_and_ms   = length dicts + length methods
 663        dict_and_method_pats = map VarPat (dicts ++ methods)
 664
 665 \end{code}