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, dataConFieldLabels )
  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
 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 _)):rs)
 213    | all_vars ps  = (pats,  addOneToUniqSet indexs n)
 214   where
 215     (pats,indexs) = check' rs
 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      -- Note: RecPats will have been simplified to ConPats
 227      --       at this stage.
 228     constructors = or (map is_con qs)
 229     literals     = or (map is_lit qs)
 230     only_vars    = and (map is_var qs)
 231 --    npat         = or (map is_npat qs)
 232 --    nplusk       = or (map is_nplusk qs)
 233 \end{code}
 234
 235 Here begins the code to deal with literals, we need to split the matrix
 236 in different matrix beginning by each literal and a last matrix with the
 237 rest of values.
 238
 239 \begin{code}
 240 split_by_literals :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
 241 split_by_literals qs = process_literals used_lits qs
 242            where
 243              used_lits = get_used_lits qs
 244 \end{code}
 245
 246 process_explicit_literals is a function that process each literal that appears
 247 in the column of the matrix.
 248
 249 \begin{code}
 250 process_explicit_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
 251 process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)
 252     where
 253       pats_indexs   = map (\x -> construct_literal_matrix x qs) lits
 254       (pats,indexs) = unzip pats_indexs
 255
 256 \end{code}
 257
 258
 259 Process_literals calls process_explicit_literals to deal with the literals
 260 that appears in the matrix and deal also with the rest of the cases. It
 261 must be one Variable to be complete.
 262
 263 \begin{code}
 264
 265 process_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
 266 process_literals used_lits qs
 267   | length default_eqns == 0 = ([make_row_vars used_lits (head qs)]++pats,indexs)
 268   | otherwise                = (pats_default,indexs_default)
 269      where
 270        (pats,indexs)   = process_explicit_literals used_lits qs
 271        default_eqns    = (map remove_var (filter is_var qs))
 272        (pats',indexs') = check' default_eqns
 273        pats_default    = [(new_wild_pat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats
 274        indexs_default  = unionUniqSets indexs' indexs
 275 \end{code}
 276
 277 Here we have selected the literal and we will select all the equations that
 278 begins for that literal and create a new matrix.
 279
 280 \begin{code}
 281 construct_literal_matrix :: HsLit -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
 282 construct_literal_matrix lit qs =
 283     (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)
 284   where
 285     (pats,indexs) = (check' (remove_first_column_lit lit qs))
 286     new_lit = LitPatIn lit
 287
 288 remove_first_column_lit :: HsLit
 289                         -> [EquationInfo]
 290                         -> [EquationInfo]
 291 remove_first_column_lit lit qs =
 292     map shift_pat (filter (is_var_lit lit) qs)
 293   where
 294      shift_pat (EqnInfo n ctx []     result) =  panic "Check.shift_var: no patterns"
 295      shift_pat (EqnInfo n ctx (_:ps) result) =  EqnInfo n ctx ps result
 296
 297 \end{code}
 298
 299 This function splits the equations @qs@ in groups that deal with the
 300 same constructor
 301
 302 \begin{code}
 303
 304 split_by_constructor :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
 305
 306 split_by_constructor qs | length unused_cons /= 0 = need_default_case used_cons unused_cons qs
 307                         | otherwise               = no_need_default_case used_cons qs
 308                        where
 309                           used_cons   = get_used_cons qs
 310                           unused_cons = get_unused_cons used_cons
 311
 312 \end{code}
 313
 314 The first column of the patterns matrix only have vars, then there is
 315 nothing to do.
 316
 317 \begin{code}
 318 first_column_only_vars :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
 319 first_column_only_vars qs = (map (\ (xs,ys) -> (new_wild_pat:xs,ys)) pats,indexs)
 320                           where
 321                             (pats,indexs) = check' (map remove_var qs)
 322
 323 \end{code}
 324
 325 This equation takes a matrix of patterns and split the equations by
 326 constructor, using all the constructors that appears in the first column
 327 of the pattern matching.
 328
 329 We can need a default clause or not ...., it depends if we used all the
 330 constructors or not explicitly. The reasoning is similar to process_literals,
 331 the difference is that here the default case is not always needed.
 332
 333 \begin{code}
 334 no_need_default_case :: [TypecheckedPat] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
 335 no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
 336     where
 337       pats_indexs   = map (\x -> construct_matrix x qs) cons
 338       (pats,indexs) = unzip pats_indexs
 339
 340 need_default_case :: [TypecheckedPat] -> [DataCon] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
 341 need_default_case used_cons unused_cons qs
 342   | length default_eqns == 0 = (pats_default_no_eqns,indexs)
 343   | otherwise                = (pats_default,indexs_default)
 344      where
 345        (pats,indexs)   = no_need_default_case used_cons qs
 346        default_eqns    = (map remove_var (filter is_var qs))
 347        (pats',indexs') = check' default_eqns
 348        pats_default    = [(make_whole_con c:ps,constraints) |
 349                           c <- unused_cons, (ps,constraints) <- pats'] ++ pats
 350        new_wilds       = make_row_vars_for_constructor (head qs)
 351        pats_default_no_eqns =  [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats
 352        indexs_default  = unionUniqSets indexs' indexs
 353
 354 construct_matrix :: TypecheckedPat -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
 355 construct_matrix con qs =
 356     (map (make_con con) pats,indexs)
 357   where
 358     (pats,indexs) = (check' (remove_first_column con qs))
 359 \end{code}
 360
 361 Here remove first column is more difficult that with literals due to the fact
 362 that constructors can have arguments.
 363
 364 For instance, the matrix
 365
 366  (: x xs) y
 367  z        y
 368
 369 is transformed in:
 370
 371  x xs y
 372  _ _  y
 373
 374
 375 \begin{code}
 376 remove_first_column :: TypecheckedPat                -- Constructor
 377                     -> [EquationInfo]
 378                     -> [EquationInfo]
 379 remove_first_column (ConPat con _ _ _ con_pats) qs =
 380     map shift_var (filter (is_var_con con) qs)
 381   where
 382      new_wilds = [WildPat (outPatType arg_pat) | arg_pat <- con_pats]
 383      shift_var (EqnInfo n ctx (ConPat _ _ _ _ ps':ps) result) =
 384                 EqnInfo n ctx (ps'++ps)               result
 385      shift_var (EqnInfo n ctx (WildPat _     :ps)     result) =
 386                 EqnInfo n ctx (new_wilds ++   ps)     result
 387      shift_var _ = panic "Check.Shift_var:No done"
 388
 389 make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat
 390 make_row_vars used_lits (EqnInfo _ _ pats _ ) =
 391    (VarPatIn new_var:take (length (tail pats)) (repeat new_wild_pat),[(new_var,used_lits)])
 392   where new_var = hash_x
 393
 394 hash_x = mkLocalName unboundKey {- doesn't matter much -}
 395                      (mkSrcVarOcc SLIT("#x"))
 396                      noSrcLoc
 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 d _ _ _ _) -> d) used_cons
 439        unused_cons         = uniqSetToList (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
 440
 441
 442 all_vars :: [TypecheckedPat] -> Bool
 443 all_vars []              = True
 444 all_vars (WildPat _:ps)  = all_vars ps
 445 all_vars _               = False
 446
 447 remove_var :: EquationInfo -> EquationInfo
 448 remove_var (EqnInfo n ctx (WildPat _:ps) result) = EqnInfo n ctx ps result
 449 remove_var _                                     = panic "Check:remove_var: equation not begin with a variable"
 450
 451 is_con :: EquationInfo -> Bool
 452 is_con (EqnInfo _ _ ((ConPat _ _ _ _ _):_) _) = True
 453 is_con _                                      = False
 454
 455 is_lit :: EquationInfo -> Bool
 456 is_lit (EqnInfo _ _ ((LitPat _ _):_) _) = True
 457 is_lit (EqnInfo _ _ ((NPat _ _ _):_) _) = True
 458 is_lit _                                = False
 459
 460 is_npat :: EquationInfo -> Bool
 461 is_npat (EqnInfo _ _ ((NPat _ _ _):_) _) = True
 462 is_npat _                                 = False
 463
 464 is_nplusk :: EquationInfo -> Bool
 465 is_nplusk (EqnInfo _ _ ((NPlusKPat _ _ _ _ _):_) _) = True
 466 is_nplusk _                                         = False
 467
 468 is_var :: EquationInfo -> Bool
 469 is_var (EqnInfo _ _ ((WildPat _):_) _)  = True
 470 is_var _                                = False
 471
 472 is_var_con :: DataCon -> EquationInfo -> Bool
 473 is_var_con con (EqnInfo _ _ ((WildPat _):_)     _)                 = True
 474 is_var_con con (EqnInfo _ _ ((ConPat id _ _ _ _):_) _) | id == con = True
 475 is_var_con con _                                                   = False
 476
 477 is_var_lit :: HsLit -> EquationInfo -> Bool
 478 is_var_lit lit (EqnInfo _ _ ((WildPat _):_)     _)               = True
 479 is_var_lit lit (EqnInfo _ _ ((LitPat lit' _):_) _) | lit == lit' = True
 480 is_var_lit lit (EqnInfo _ _ ((NPat lit' _ _):_) _) | lit == lit' = True
 481 is_var_lit lit _                                                 = False
 482 \end{code}
 483
 484 The difference beteewn make_con and make_whole_con is that
 485 make_wole_con creates a new constructor with all their arguments, and
 486 make_Con takes a list of argumntes, creates the contructor geting thir
 487 argumnts from the list. See where are used for details.
 488
 489 We need to reconstruct the patterns (make the constructors infix and
 490 similar) at the same time that we create the constructors.
 491
 492 You can tell tuple constructors using
 493
 494         Id.isTupleCon
 495
 496 You can see if one constructor is infix with this clearer code :-))))))))))
 497
 498         Lex.isLexConSym (Name.occNameString (Name.getOccName con))
 499
 500        Rather clumsy but it works. (Simon Peyton Jones)
 501
 502
 503 We con't mind the nilDataCon because it doesn't change the way to
 504 print the messsage, we are searching only for things like: [1,2,3],
 505 not x:xs ....
 506
 507 In reconstruct_pat we want to "undo" the work that we have done in simplify_pat
 508 In particular:
 509         ((,) x y)  returns to be (x, y)
 510         ((:) x xs) returns to be (x:xs)
 511         (x:(...:[]) returns to be [x,...]
 512
 513 The difficult case is the third one becouse we need to follow all the
 514 contructors until the [] to know taht we need to use the second case,
 515 not the second.
 516
 517 \begin{code}
 518 isInfixCon con = isDataSymOcc (getOccName con)
 519
 520 is_nil (ConPatIn con []) = con == getName 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   = getName 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      = getName 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   = getName 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 simplify_pat (AsPat id p)   = simplify_pat p
 584
 585 simplify_pat (ConPat id ty tvs dicts ps) = ConPat id ty tvs dicts (map simplify_pat ps)
 586
 587 simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon  list_ty [] [] [x, y])
 588                                                     (ConPat nilDataCon list_ty [] [] [])
 589                                                     (map simplify_pat ps)
 590                              where list_ty = mkListTy ty
 591
 592
 593 simplify_pat (TuplePat ps True) = ConPat (tupleCon arity)
 594                                     (mkTupleTy arity (map outPatType ps)) [] []
 595                                     (map simplify_pat ps)
 596                            where
 597                               arity = length ps
 598
 599 simplify_pat (TuplePat ps False)
 600   = ConPat (unboxedTupleCon arity)
 601            (mkUnboxedTupleTy arity (map outPatType ps)) [] []
 602            (map simplify_pat ps)
 603   where
 604     arity = length ps
 605
 606 simplify_pat (RecPat dc ty tvs dicts [])
 607   = ConPat dc ty tvs dicts all_wild_pats
 608   where
 609     all_wild_pats = map (\ _ -> WildPat gt) (dataConFieldLabels dc)
 610     gt = panic "Check.symplify_pat{RecPat-1}"
 611
 612 simplify_pat (RecPat dc ty tvs dicts idps)
 613   = ConPat dc ty tvs dicts pats
 614   where
 615     pats = map (simplify_pat.snd) all_pats
 616
 617      -- pad out all the missing fields with WildPats.
 618     field_pats = map (\ f -> (getName f, WildPat (panic "simplify_pat(RecPat-2)")))
 619                      (dataConFieldLabels dc)
 620     all_pats =
 621       foldr
 622        ( \ (id,p,_) acc -> insertNm (getName id) p acc)
 623        field_pats
 624        idps
 625
 626     insertNm nm p [] = [(nm,p)]
 627     insertNm nm p (x@(n,_):xs)
 628       | nm == n    = (nm,p):xs
 629       | otherwise  = x : insertNm nm p xs
 630
 631 simplify_pat pat@(LitPat lit lit_ty)
 632   | isUnboxedType lit_ty = pat
 633
 634   | lit_ty == charTy = ConPat charDataCon charTy [] [] [LitPat (mk_char lit) charPrimTy]
 635
 636   | otherwise = pprPanic "Check.simplify_pat: LitPat:" (ppr pat)
 637   where
 638     mk_char (HsChar c)    = HsCharPrim c
 639
 640 simplify_pat (NPat lit lit_ty hsexpr) = better_pat
 641   where
 642     better_pat
 643       | lit_ty == charTy   = ConPat charDataCon   lit_ty [] [] [LitPat (mk_char lit)   charPrimTy]
 644       | lit_ty == intTy    = ConPat intDataCon    lit_ty [] [] [LitPat (mk_int lit)    intPrimTy]
 645       | lit_ty == wordTy   = ConPat wordDataCon   lit_ty [] [] [LitPat (mk_word lit)   wordPrimTy]
 646       | lit_ty == addrTy   = ConPat addrDataCon   lit_ty [] [] [LitPat (mk_addr lit)   addrPrimTy]
 647       | lit_ty == floatTy  = ConPat floatDataCon  lit_ty [] [] [LitPat (mk_float lit)  floatPrimTy]
 648       | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
 649
 650                 -- Convert the literal pattern "" to the constructor pattern [].
 651       | null_str_lit lit      = ConPat nilDataCon  lit_ty [] [] []
 652       | lit_ty == stringTy =
 653             foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y])
 654                                 (ConPat nilDataCon  list_ty [] [] [])
 655                                 (mk_string lit)
 656       | otherwise              = NPat lit lit_ty hsexpr
 657
 658     list_ty = mkListTy lit_ty
 659
 660     mk_int    (HsInt i)      = HsIntPrim i
 661     mk_int    l@(HsLitLit s) = l
 662
 663     mk_head_char (HsString s) = HsCharPrim (_HEAD_ s)
 664     mk_string    (HsString s) =
 665        map (\ c -> ConPat charDataCon charTy [] []
 666                          [LitPat (HsCharPrim c) charPrimTy])
 667            (_UNPK_ s)
 668
 669     mk_char   (HsChar c)     = HsCharPrim c
 670     mk_char   l@(HsLitLit s) = l
 671
 672     mk_word   l@(HsLitLit s) = l
 673
 674     mk_addr   l@(HsLitLit s) = l
 675
 676     mk_float  (HsInt i)      = HsFloatPrim (fromInteger i)
 677     mk_float  (HsFrac f)     = HsFloatPrim f
 678     mk_float  l@(HsLitLit s) = l
 679
 680     mk_double (HsInt i)      = HsDoublePrim (fromInteger i)
 681     mk_double (HsFrac f)     = HsDoublePrim f
 682     mk_double l@(HsLitLit s) = l
 683
 684     null_str_lit (HsString s) = _NULL_ s
 685     null_str_lit other_lit    = False
 686
 687     one_str_lit (HsString s) = _LENGTH_ s == (1::Int)
 688     one_str_lit other_lit    = False
 689
 690 simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) =
 691      WildPat ty
 692    where ty = panic "Check.simplify_pat: Gessing ty"
 693
 694 simplify_pat (DictPat dicts methods) =
 695     case num_of_d_and_ms of
 696        0 -> simplify_pat (TuplePat [] True)
 697        1 -> simplify_pat (head dict_and_method_pats)
 698        _ -> simplify_pat (TuplePat dict_and_method_pats True)
 699     where
 700        num_of_d_and_ms   = length dicts + length methods
 701        dict_and_method_pats = map VarPat (dicts ++ methods)
 702
 703 \end{code}