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