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