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