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, occNameString,
  26                           getOccName, getOccString, isLexConSym
  27                         )
  28 import Type             ( Type,
  29                           isUnboxedType,
  30                           splitTyConApp_maybe
  31                         )
  32 import TysPrim          ( intPrimTy,
  33                           charPrimTy,
  34                           floatPrimTy,
  35                           doublePrimTy,
  36                           addrPrimTy,
  37                           wordPrimTy
  38                         )
  39 import TysWiredIn       ( nilDataCon, consDataCon,
  40                           mkTupleTy, tupleCon,
  41                           mkUnboxedTupleTy, unboxedTupleCon,
  42                           mkListTy,
  43                           charTy, charDataCon,
  44                           intTy, intDataCon,
  45                           floatTy, floatDataCon,
  46                           doubleTy, doubleDataCon,
  47                           addrTy, addrDataCon,
  48                           wordTy, wordDataCon,
  49                           stringTy
  50                         )
  51 import TyCon            ( tyConDataCons )
  52 import UniqSet
  53 import Outputable
  54
  55 #include "HsVersions.h"
  56 \end{code}
  57
  58 This module performs checks about if one list of equations are:
  59         - Overlapped
  60         - Non exhaustive
  61
  62 To discover that we go through the list of equations in a tree-like fashion.
  63
  64 If you like theory, a similar algorithm is described in:
  65         Two Techniques for Compiling Lazy Pattern Matching
  66         Luc Maranguet
  67         INRIA Rocquencourt (RR-2385, 1994)
  68
  69 The algorithm is based in the first Technique, but there are some differences:
  70         - We don't generate code
  71         - We have constructors and literals (not only literals as in the
  72           article)
  73         - We don't use directions, we must select the columns from
  74           left-to-right
  75
  76 (By the way the second technique is really similar to the one used in
  77  Match.lhs to generate code)
  78
  79 This function takes the equations of a pattern and returns:
  80   - The patterns that are not recognized
  81   - The equations that are not overlapped
  82
  83 It simplify the patterns and then call check' (the same semantics),and it
  84 needs to reconstruct the patterns again ....
  85
  86 The problem appear with things like:
  87   f [x,y]   = ....
  88   f (x:xs)  = .....
  89
  90 We want to put the two patterns with the same syntax, (prefix form) and
  91 then all the constructors are equal:
  92   f (: x (: y []))   = ....
  93   f (: x xs)         = .....
  94
  95 (more about that in simplify_eqns)
  96
  97 We would prefer to have a WarningPat of type String, but Strings and the
  98 Pretty Printer are not friends.
  99
 100 We use InPat in WarningPat instead of OutPat because we need to print the
 101 warning messages in the same way they are introduced, i.e. if the user
 102 wrote:
 103         f [x,y] = ..
 104
 105 He don't want a warning message written:
 106
 107         f (: x (: y [])) ........
 108
 109 Then we need to use InPats.
 110
 111      Juan Quintela 5 JUL 1998
 112           User-friendliness and compiler writers are no friends.
 113
 114 \begin{code}
 115
 116 newtype BoxedString = BS String
 117
 118 type WarningPat = InPat BoxedString
 119 type ExhaustivePat = ([WarningPat], [(BoxedString, [HsLit])])
 120
 121
 122 instance Outputable BoxedString where
 123     ppr (BS s) = text s
 124
 125
 126 check :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
 127 check qs = (untidy_warns, incomplete)
 128       where
 129         (warns, incomplete) = check' (simplify_eqns qs)
 130         untidy_warns = map untidy_exhaustive warns
 131
 132 untidy_exhaustive :: ExhaustivePat -> ExhaustivePat
 133 untidy_exhaustive ([pat], messages) =
 134                   ([untidy_no_pars pat], map untidy_message messages)
 135 untidy_exhaustive (pats, messages) =
 136                   (map untidy_pars pats, map untidy_message messages)
 137
 138 untidy_message :: (BoxedString, [HsLit]) -> (BoxedString, [HsLit])
 139 untidy_message (string, lits) = (string, map untidy_lit lits)
 140 \end{code}
 141
 142 The function @untidy@ does the reverse work of the @simplify_pat@ funcion.
 143
 144 \begin{code}
 145
 146 type NeedPars = Bool
 147
 148 untidy_no_pars :: WarningPat -> WarningPat
 149 untidy_no_pars p = untidy False p
 150
 151 untidy_pars :: WarningPat -> WarningPat
 152 untidy_pars p = untidy True p
 153
 154 untidy :: NeedPars -> WarningPat -> WarningPat
 155 untidy _ p@WildPatIn = p
 156 untidy _ p@(VarPatIn name) = p
 157 untidy _ (LitPatIn lit) = LitPatIn (untidy_lit lit)
 158 untidy _ p@(ConPatIn name []) = p
 159 untidy b (ConPatIn name pats)  =
 160        pars b (ConPatIn name (map untidy_pars pats))
 161 untidy b (ConOpPatIn pat1 name fixity pat2) =
 162        pars b (ConOpPatIn (untidy_pars pat1) name fixity (untidy_pars pat2))
 163 untidy _ (ListPatIn pats)  = ListPatIn (map untidy_no_pars pats)
 164 untidy _ (TuplePatIn pats boxed) = TuplePatIn (map untidy_no_pars pats) boxed
 165
 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 "#x"
 397
 398 make_row_vars_for_constructor :: EquationInfo -> [WarningPat]
 399 make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = take (length (tail pats)) (repeat new_wild_pat)
 400
 401 compare_cons :: TypecheckedPat -> TypecheckedPat -> Bool
 402 compare_cons (ConPat id1 _ _ _ _) (ConPat id2 _ _ _ _) = id1 == id2
 403
 404 remove_dups :: [TypecheckedPat] -> [TypecheckedPat]
 405 remove_dups []     = []
 406 remove_dups (x:xs) | or (map (\y -> compare_cons x y) xs) = remove_dups  xs
 407                    | otherwise                            = x : remove_dups xs
 408
 409 get_used_cons :: [EquationInfo] -> [TypecheckedPat]
 410 get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPat _ _ _ _ _):_) _) <- qs]
 411
 412 remove_dups' :: [HsLit] -> [HsLit]
 413 remove_dups' []                   = []
 414 remove_dups' (x:xs) | x `elem` xs = remove_dups' xs
 415                     | otherwise   = x : remove_dups' xs
 416
 417
 418 get_used_lits :: [EquationInfo] -> [HsLit]
 419 get_used_lits qs = remove_dups' all_literals
 420                  where
 421                    all_literals = get_used_lits' qs
 422
 423 get_used_lits' :: [EquationInfo] -> [HsLit]
 424 get_used_lits' [] = []
 425 get_used_lits' ((EqnInfo _ _ ((LitPat lit _):_) _):qs) =
 426                lit : get_used_lits qs
 427 get_used_lits' ((EqnInfo _ _ ((NPat lit _ _):_) _):qs) =
 428                lit : get_used_lits qs
 429 get_used_lits' (q:qs)                                  =
 430                get_used_lits qs
 431
 432 get_unused_cons :: [TypecheckedPat] -> [DataCon]
 433 get_unused_cons used_cons = unused_cons
 434      where
 435        (ConPat _ ty _ _ _) = head used_cons
 436        Just (ty_con,_)     = splitTyConApp_maybe ty
 437        all_cons            = tyConDataCons ty_con
 438        used_cons_as_id     = map (\ (ConPat id _ _ _ _) -> id) used_cons
 439        unused_cons         = uniqSetToList (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
 440
 441 all_vars :: [TypecheckedPat] -> Bool
 442 all_vars []              = True
 443 all_vars (WildPat _:ps)  = all_vars ps
 444 all_vars _               = False
 445
 446 remove_var :: EquationInfo -> EquationInfo
 447 remove_var (EqnInfo n ctx (WildPat _:ps) result) = EqnInfo n ctx ps result
 448 remove_var _                                     = panic "Check:remove_var: equation not begin with a variable"
 449
 450 is_con :: EquationInfo -> Bool
 451 is_con (EqnInfo _ _ ((ConPat _ _ _ _ _):_) _) = True
 452 is_con _                                  = False
 453
 454 is_lit :: EquationInfo -> Bool
 455 is_lit (EqnInfo _ _ ((LitPat _ _):_) _) = True
 456 is_lit (EqnInfo _ _ ((NPat _ _ _):_) _) = True
 457 is_lit _                                = False
 458
 459 is_npat :: EquationInfo -> Bool
 460 is_npat (EqnInfo _ _ ((NPat _ _ _):_) _) = True
 461 is_npat _                                 = False
 462
 463 is_nplusk :: EquationInfo -> Bool
 464 is_nplusk (EqnInfo _ _ ((NPlusKPat _ _ _ _ _):_) _) = True
 465 is_nplusk _                                         = False
 466
 467 is_var :: EquationInfo -> Bool
 468 is_var (EqnInfo _ _ ((WildPat _):_) _)  = True
 469 is_var _                                = False
 470
 471 is_var_con :: DataCon -> EquationInfo -> Bool
 472 is_var_con con (EqnInfo _ _ ((WildPat _):_)     _)                 = True
 473 is_var_con con (EqnInfo _ _ ((ConPat id _ _ _ _):_) _) | id == con = True
 474 is_var_con con _                                                   = False
 475
 476 is_var_lit :: HsLit -> EquationInfo -> Bool
 477 is_var_lit lit (EqnInfo _ _ ((WildPat _):_)     _)               = True
 478 is_var_lit lit (EqnInfo _ _ ((LitPat lit' _):_) _) | lit == lit' = True
 479 is_var_lit lit (EqnInfo _ _ ((NPat lit' _ _):_) _) | lit == lit' = True
 480 is_var_lit lit _                                                 = False
 481 \end{code}
 482
 483 The difference beteewn make_con and make_whole_con is that
 484 make_wole_con creates a new constructor with all their arguments, and
 485 make_Con takes a list of argumntes, creates the contructor geting thir
 486 argumnts from the list. See where are used for details.
 487
 488 We need to reconstruct the patterns (make the constructors infix and
 489 similar) at the same time that we create the constructors.
 490
 491 You can tell tuple constructors using
 492
 493         Id.isTupleCon
 494
 495 You can see if one constructor is infix with this clearer code :-))))))))))
 496
 497         Lex.isLexConSym (Name.occNameString (Name.getOccName con))
 498
 499        Rather clumsy but it works. (Simon Peyton Jones)
 500
 501
 502 We con't mind the nilDataCon because it doesn't change the way to
 503 print the messsage, we are searching only for things like: [1,2,3],
 504 not x:xs ....
 505
 506 In reconstruct_pat we want to "undo" the work that we have done in simplify_pat
 507 In particular:
 508         ((,) x y)  returns to be (x, y)
 509         ((:) x xs) returns to be (x:xs)
 510         (x:(...:[]) returns to be [x,...]
 511
 512 The difficult case is the third one becouse we need to follow all the
 513 contructors until the [] to know taht we need to use the second case,
 514 not the second.
 515
 516 \begin{code}
 517
 518 isInfixCon con = isLexConSym (occNameString (getOccName con))
 519
 520 is_nil (ConPatIn (BS con) []) = con == getOccString nilDataCon
 521 is_nil _                      = False
 522
 523 is_list (ListPatIn _) = True
 524 is_list _             = False
 525
 526 return_list id q = id == consDataCon && (is_nil q || is_list q)
 527
 528 make_list p q | is_nil q   = ListPatIn [p]
 529 make_list p (ListPatIn ps) = ListPatIn (p:ps)
 530 make_list _ _              = panic "Check.make_list: Invalid argument"
 531
 532 make_con :: TypecheckedPat -> ExhaustivePat -> ExhaustivePat
 533 make_con (ConPat id _ _ _ _) (p:q:ps, constraints)
 534      | return_list id q = (make_list p q : ps, constraints)
 535      | isInfixCon id = ((ConOpPatIn p name fixity q) : ps, constraints)
 536     where name   = BS (getOccString id)
 537           fixity = panic "Check.make_con: Guessing fixity"
 538
 539 make_con (ConPat id _ _ _ pats) (ps,constraints)
 540       | isTupleCon id        = (TuplePatIn pats_con True : rest_pats,    constraints)
 541       | isUnboxedTupleCon id = (TuplePatIn pats_con False : rest_pats, constraints)
 542       | otherwise     = (ConPatIn name pats_con : rest_pats, constraints)
 543     where num_args  = length pats
 544           name      = BS (getOccString id)
 545           pats_con  = take num_args ps
 546           rest_pats = drop num_args ps
 547
 548
 549 make_whole_con :: DataCon -> WarningPat
 550 make_whole_con con | isInfixCon con = ConOpPatIn new_wild_pat name fixity new_wild_pat
 551                    | otherwise      = ConPatIn name pats
 552                 where
 553                   fixity = panic "Check.make_whole_con: Guessing fixity"
 554                   name   = BS (getOccString con)
 555                   arity  = dataConSourceArity con
 556                   pats   = take arity (repeat new_wild_pat)
 557
 558
 559 new_wild_pat :: WarningPat
 560 new_wild_pat = WildPatIn
 561 \end{code}
 562
 563 This equation makes the same thing that tidy in Match.lhs, the
 564 difference is that here we can do all the tidy in one place and in the
 565 Match tidy it must be done one column each time due to bookkeeping
 566 constraints.
 567
 568 \begin{code}
 569
 570 simplify_eqns :: [EquationInfo] -> [EquationInfo]
 571 simplify_eqns []                               = []
 572 simplify_eqns ((EqnInfo n ctx pats result):qs) =
 573  (EqnInfo n ctx pats' result) : simplify_eqns qs
 574  where
 575   pats' = map simplify_pat pats
 576
 577 simplify_pat :: TypecheckedPat -> TypecheckedPat
 578
 579 simplify_pat pat@(WildPat gt) = pat
 580 simplify_pat (VarPat id)      = WildPat (idType id)
 581
 582 simplify_pat (LazyPat p)   = simplify_pat p
 583
 584 simplify_pat (AsPat id p)  = simplify_pat p
 585
 586 simplify_pat (ConPat id ty tvs dicts ps) = ConPat id ty tvs dicts (map simplify_pat ps)
 587
 588 simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon  list_ty [] [] [x, y])
 589                                                     (ConPat nilDataCon list_ty [] [] [])
 590                                                     (map simplify_pat ps)
 591                              where list_ty = mkListTy ty
 592
 593
 594 simplify_pat (TuplePat ps True) = ConPat (tupleCon arity)
 595                                     (mkTupleTy arity (map outPatType ps)) [] []
 596                                     (map simplify_pat ps)
 597                            where
 598                               arity = length ps
 599
 600 simplify_pat (TuplePat ps False)
 601   = ConPat (unboxedTupleCon arity)
 602            (mkUnboxedTupleTy arity (map outPatType ps)) [] []
 603            (map simplify_pat ps)
 604   where
 605     arity = length ps
 606
 607 simplify_pat (RecPat id ty tvs dicts [])
 608   = ConPat id ty tvs dicts [wild_pat]
 609   where
 610     wild_pat = WildPat gt
 611     gt = panic "Check.symplify_pat: gessing gt"
 612
 613 simplify_pat (RecPat id ty tvs dicts idps)
 614   = ConPat id ty tvs dicts pats
 615   where
 616     pats = map (\ (id,p,_)-> simplify_pat p) idps
 617
 618 simplify_pat pat@(LitPat lit lit_ty)
 619   | isUnboxedType lit_ty = pat
 620
 621   | lit_ty == charTy = ConPat charDataCon charTy [] [] [LitPat (mk_char lit) charPrimTy]
 622
 623   | otherwise = pprPanic "Check.simplify_pat: LitPat:" (ppr pat)
 624   where
 625     mk_char (HsChar c)    = HsCharPrim c
 626
 627 simplify_pat (NPat lit lit_ty hsexpr) = better_pat
 628   where
 629     better_pat
 630       | lit_ty == charTy   = ConPat charDataCon   lit_ty [] [] [LitPat (mk_char lit)   charPrimTy]
 631       | lit_ty == intTy    = ConPat intDataCon    lit_ty [] [] [LitPat (mk_int lit)    intPrimTy]
 632       | lit_ty == wordTy   = ConPat wordDataCon   lit_ty [] [] [LitPat (mk_word lit)   wordPrimTy]
 633       | lit_ty == addrTy   = ConPat addrDataCon   lit_ty [] [] [LitPat (mk_addr lit)   addrPrimTy]
 634       | lit_ty == floatTy  = ConPat floatDataCon  lit_ty [] [] [LitPat (mk_float lit)  floatPrimTy]
 635       | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
 636
 637                 -- Convert the literal pattern "" to the constructor pattern [].
 638       | null_str_lit lit      = ConPat nilDataCon  lit_ty [] [] []
 639       | lit_ty == stringTy =
 640             foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y])
 641                                 (ConPat nilDataCon  list_ty [] [] [])
 642                                 (mk_string lit)
 643       | otherwise              = NPat lit lit_ty hsexpr
 644
 645     list_ty = mkListTy lit_ty
 646
 647     mk_int    (HsInt i)      = HsIntPrim i
 648     mk_int    l@(HsLitLit s) = l
 649
 650     mk_head_char (HsString s) = HsCharPrim (_HEAD_ s)
 651     mk_string    (HsString s) =
 652        map (\ c -> ConPat charDataCon charTy [] []
 653                          [LitPat (HsCharPrim c) charPrimTy])
 654            (_UNPK_ s)
 655
 656     mk_char   (HsChar c)     = HsCharPrim c
 657     mk_char   l@(HsLitLit s) = l
 658
 659     mk_word   l@(HsLitLit s) = l
 660
 661     mk_addr   l@(HsLitLit s) = l
 662
 663     mk_float  (HsInt i)      = HsFloatPrim (fromInteger i)
 664     mk_float  (HsFrac f)     = HsFloatPrim f
 665     mk_float  l@(HsLitLit s) = l
 666
 667     mk_double (HsInt i)      = HsDoublePrim (fromInteger i)
 668     mk_double (HsFrac f)     = HsDoublePrim f
 669     mk_double l@(HsLitLit s) = l
 670
 671     null_str_lit (HsString s) = _NULL_ s
 672     null_str_lit other_lit    = False
 673
 674     one_str_lit (HsString s) = _LENGTH_ s == (1::Int)
 675     one_str_lit other_lit    = False
 676
 677 simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) =
 678      WildPat ty
 679    where ty = panic "Check.simplify_pat: Gessing ty"
 680
 681 simplify_pat (DictPat dicts methods) =
 682     case num_of_d_and_ms of
 683        0 -> simplify_pat (TuplePat [] True)
 684        1 -> simplify_pat (head dict_and_method_pats)
 685        _ -> simplify_pat (TuplePat dict_and_method_pats True)
 686     where
 687        num_of_d_and_ms   = length dicts + length methods
 688        dict_and_method_pats = map VarPat (dicts ++ methods)
 689
 690 \end{code}