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