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