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