ghc/compiler/deSugar/Check.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1997
   3 %
   4 % Author: Juan J. Quintela    <quintela@dc.fi.udc.es>
   5
   6 \begin{code}
   7
   8 #include "HsVersions.h"
   9
  10 module Check ( check , SYN_IE(ExhaustivePat), SYN_IE(WarningPat), BoxedString(..) ) where
  11
  12 IMP_Ubiq()
  13 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
  14 IMPORT_DELOOPER(DsLoop) -- here for paranoia-checking reasons
  15                         -- and to break dsExpr/dsBinds-ish loop
  16 #else
  17 import {-# SOURCE #-} DsExpr  ( dsExpr  )
  18 import {-# SOURCE #-} DsBinds ( dsBinds )
  19 #endif
  20
  21 import HsSyn
  22 import TcHsSyn          ( SYN_IE(TypecheckedPat),
  23                           SYN_IE(TypecheckedMatch),
  24                           SYN_IE(TypecheckedHsBinds),
  25                           SYN_IE(TypecheckedHsExpr)
  26                         )
  27 import DsHsSyn          ( outPatType )
  28 import CoreSyn
  29
  30 import DsMonad          ( SYN_IE(DsM), DsMatchContext(..),
  31                           DsMatchKind(..)
  32                         )
  33 import DsUtils          ( EquationInfo(..),
  34                           MatchResult(..),
  35                           SYN_IE(EqnNo),
  36                           SYN_IE(EqnSet),
  37                           CanItFail(..)
  38                         )
  39 import Id               ( idType,
  40                           GenId{-instance-},
  41                           SYN_IE(Id),
  42                           idName,
  43                           isTupleCon,
  44                           getIdArity
  45                         )
  46 import IdInfo           ( ArityInfo(..) )
  47 import Lex              ( isLexConSym )
  48 import Name             ( occNameString,
  49                           Name,
  50                           getName,
  51                           nameUnique,
  52                           getOccName,
  53                           getOccString
  54                         )
  55 import Outputable       ( PprStyle(..),
  56                           Outputable(..)
  57                         )
  58 import PprType          ( GenType{-instance-},
  59                           GenTyVar{-ditto-}
  60                         )
  61 import Pretty
  62 import Type             ( isPrimType,
  63                           eqTy,
  64                           SYN_IE(Type),
  65                           getAppTyCon
  66                         )
  67 import TyVar            ( GenTyVar{-instance Eq-}, SYN_IE(TyVar) )
  68 import TysPrim          ( intPrimTy,
  69                           charPrimTy,
  70                           floatPrimTy,
  71                           doublePrimTy,
  72                           addrPrimTy,
  73                           wordPrimTy
  74                         )
  75 import TysWiredIn       ( nilDataCon, consDataCon,
  76                           mkTupleTy, tupleCon,
  77                           mkListTy,
  78                           charTy, charDataCon,
  79                           intTy, intDataCon,
  80                           floatTy, floatDataCon,
  81                           doubleTy, doubleDataCon,
  82                           addrTy, addrDataCon,
  83                           wordTy, wordDataCon
  84                         )
  85 import TyCon            ( tyConDataCons )
  86 import UniqSet
  87 import Unique           ( Unique{-instance Eq-} )
  88 import Util             ( pprTrace,
  89                           panic,
  90                           pprPanic
  91                         )
  92 \end{code}
  93
  94 This module perfoms checks about if one list of equations are:
  95         - Overlapped
  96         - Non exhaustive
  97
  98 To discover that we go through the list of equations in a tree-like fashion.
  99
 100 If you like theory, a similar algoritm is described in:
 101         Two Tecniques for Compiling Lazy Pattern Matching
 102         Luc Maranguet
 103         INRIA Rocquencourt (RR-2385, 1994)
 104
 105 The algorithm is based in the first Technique, but there are somo diferences:
 106         - We don't generate code
 107         - We have constructors and literals (not only literals as in the article)
 108         - We don't use directions, we must select the columns from left-to-right
 109
 110 (By the wat the second technique is really similar to the one used in MAtch.lhs to generate code)
 111
 112
 113 This function takes the equations of a pattern and returns:
 114   - The patterns that are not recognized
 115   - The equations that are not overlapped
 116
 117 It symplify the patterns and then call check' (the same semantics),and it needs to
 118 reconstruct the patterns again ....
 119
 120 The problem appear with things like:
 121   f [x,y]   = ....
 122   f (x:xs)  = .....
 123
 124 We want to put the two patterns with the same syntax, (prefix form) and then all the
 125 constructors are equal:
 126   f (: x (: y []))   = ....
 127   f (: x xs)         = .....
 128
 129 (more about that in symplify_eqns)
 130
 131 We would preffer to have a WarningPat of type String, but Strings and the
 132 Pretty Printer are not friends.
 133
 134 \begin{code}
 135
 136 data BoxedString = BS String
 137
 138 type WarningPat = InPat BoxedString --Name --String
 139 type ExhaustivePat = ([WarningPat], [(BoxedString, [HsLit])])
 140
 141
 142 instance Outputable BoxedString where
 143     ppr sty (BS s) = text s
 144
 145
 146 check :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
 147 check qs = check' (simplify_eqns qs)
 148
 149 \end{code}
 150
 151 This equation is the same that check, the only difference is that the
 152 boring work is done, that woprk needs to be done only once, this is
 153 the reason top have two funtions, check is the external interface,
 154 check' is called recursively.
 155
 156 There are several cases:
 157
 158 \begin{item}
 159 \item There are no equations: Everything is okey.
 160 \item There are only one equation, that can fail, and all the patterns are
 161       variables. Then that equation is used and the same equation is
 162       nonexhaustive.
 163 \item All the patterns are variables, and the match can fail,therr are more equations
 164       then the results is the result of the rest of equations and this equation is used also.
 165
 166 \item The general case, if all the patterns are variables (here the match can't fail)
 167       then the result is that this equation is used and this equation doesn't generate
 168       non-exustive cases.
 169
 170 \item In the general case, there can exist literals ,constructors or only vars in the
 171       first column, we actuate in consecuence.
 172
 173 \end{item}
 174
 175
 176 \begin{code}
 177
 178 check' :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
 179 check' []                                              = ([([],[])],emptyUniqSet)
 180
 181 check' [EqnInfo n ctx ps (MatchResult CanFail _ _)]
 182    | all_vars ps  = ([(take (length ps) (repeat new_wild_pat),[])],  unitUniqSet n)
 183
 184 check' qs@((EqnInfo n ctx ps (MatchResult CanFail _ _)):_)
 185    | all_vars ps  = (pats,  addOneToUniqSet indexs n)
 186   where
 187     (pats,indexs) = check' (tail qs)
 188
 189 check' qs@((EqnInfo n ctx ps result):_)
 190    | all_vars ps  = ([],  unitUniqSet n)
 191 --   | nplusk       = panic "Check.check': Work in progress: nplusk"
 192 --   | npat         = panic "Check.check': Work in progress: npat ?????"
 193    | literals     = split_by_literals qs
 194    | constructors = split_by_constructor qs
 195    | only_vars    = first_column_only_vars qs
 196    | otherwise    = panic "Check.check': Not implemented :-("
 197   where
 198     constructors = or (map is_con qs)
 199     literals     = or (map is_lit qs)
 200 --    npat         = or (map is_npat qs)
 201 --    nplusk       = or (map is_nplusk qs)
 202     only_vars    = and (map is_var qs)
 203 \end{code}
 204
 205 Here begins the code to deal with literals, we need to split the matrix in diferent matrix
 206 begining by each literal and a last matrix with the rest of values.
 207
 208 \begin{code}
 209 split_by_literals :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
 210 split_by_literals qs = process_literals used_lits qs
 211            where
 212              used_lits = get_used_lits qs
 213 \end{code}
 214
 215 process_explicit_literals is a funtion taht process each literal that appears in
 216 the column of the matrix.
 217
 218 \begin{code}
 219 process_explicit_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
 220 process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)
 221     where
 222       pats_indexs   = map (\x -> construct_literal_matrix x qs) lits
 223       (pats,indexs) = unzip pats_indexs
 224
 225 \end{code}
 226
 227
 228 Process_literals calls process_explicit_literals to deal with the literals taht apears in
 229 the matrix and deal also sith ther rest of the cases. It must be one Variable to be complete.
 230
 231 \begin{code}
 232
 233 process_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
 234 process_literals used_lits qs
 235   | length default_eqns == 0 = ([make_row_vars used_lits (head qs)]++pats,indexs)
 236   | otherwise                = (pats_default,indexs_default)
 237      where
 238        (pats,indexs)   = process_explicit_literals used_lits qs
 239        default_eqns    = (map remove_var (filter is_var qs))
 240        (pats',indexs') = check' default_eqns
 241        pats_default    = [(new_wild_pat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats
 242        indexs_default  = unionUniqSets indexs' indexs
 243 \end{code}
 244
 245 Here we have selected the literal and we will select all the equations that begins for that
 246 literal and create a new matrix.
 247
 248 \begin{code}
 249 construct_literal_matrix :: HsLit -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
 250 construct_literal_matrix lit qs =
 251     (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)
 252   where
 253     (pats,indexs) = (check' (remove_first_column_lit lit qs))
 254     new_lit = LitPatIn lit
 255
 256 remove_first_column_lit :: HsLit
 257                         -> [EquationInfo]
 258                         -> [EquationInfo]
 259 remove_first_column_lit lit qs =
 260     map shift_pat (filter (is_var_lit lit) qs)
 261   where
 262      shift_pat (EqnInfo n ctx []     result) =  panic "Check.shift_var: no patterns"
 263      shift_pat (EqnInfo n ctx (_:ps) result) =  EqnInfo n ctx ps result
 264
 265 \end{code}
 266
 267 This function splits the equations @qs@ in groups that deal with the same constructor
 268
 269 \begin{code}
 270
 271 split_by_constructor :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
 272
 273 split_by_constructor qs | length unused_cons /= 0 = need_default_case used_cons unused_cons qs
 274                         | otherwise               = no_need_default_case used_cons qs
 275                        where
 276                           used_cons   = get_used_cons qs
 277                           unused_cons = get_unused_cons used_cons
 278
 279 \end{code}
 280
 281 The first column of the patterns matrix only have vars, then there is nothing to do.
 282
 283 \begin{code}
 284 first_column_only_vars :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
 285 first_column_only_vars qs = (map (\ (xs,ys) -> (WildPatIn:xs,ys)) pats,indexs)
 286                           where
 287                             (pats,indexs) = check' (map remove_var qs)
 288
 289 \end{code}
 290
 291 This equation takes a matrix of patterns and split the equations by constructor, using all
 292 the constructors that appears in the first column of the pattern matching.
 293
 294 We can need a default clause or not ...., it depends if we used all the constructors or not
 295 explicitily. The reasoning is similar to process_literals, the difference is that here
 296 the default case is not allways needed.
 297
 298 \begin{code}
 299 no_need_default_case :: [TypecheckedPat] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
 300 no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
 301     where
 302       pats_indexs   = map (\x -> construct_matrix x qs) cons
 303       (pats,indexs) = unzip pats_indexs
 304
 305 need_default_case :: [TypecheckedPat] -> [Id] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
 306 need_default_case used_cons unused_cons qs
 307   | length default_eqns == 0 = (pats_default_no_eqns,indexs)
 308   | otherwise                = (pats_default,indexs_default)
 309      where
 310        (pats,indexs)   = no_need_default_case used_cons qs
 311        default_eqns    = (map remove_var (filter is_var qs))
 312        (pats',indexs') = check' default_eqns
 313        pats_default    = [(make_whole_con c:ps,constraints) |
 314                           c <- unused_cons, (ps,constraints) <- pats'] ++ pats
 315        new_wilds       = make_row_vars_for_constructor (head qs)
 316        pats_default_no_eqns =  [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats
 317        indexs_default  = unionUniqSets indexs' indexs
 318
 319 construct_matrix :: TypecheckedPat -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
 320 construct_matrix con qs =
 321
 322     (map (make_con con) pats,indexs)
 323   where
 324     (pats,indexs) = (check' (remove_first_column con qs))
 325 \end{code}
 326
 327 Here remove first column is more difficult that with literals due to the fact that
 328 constructors can have arguments.
 329
 330 for instance, the matrix
 331
 332  (: x xs) y
 333  z        y
 334
 335 is transformed in:
 336
 337  x xs y
 338  _ _  y
 339
 340
 341 \begin{code}
 342 remove_first_column :: TypecheckedPat                -- Constructor
 343                     -> [EquationInfo]
 344                     -> [EquationInfo]
 345 remove_first_column (ConPat con _ con_pats) qs =
 346     map shift_var (filter (is_var_con con) qs)
 347   where
 348      new_wilds = [WildPat (outPatType arg_pat) | arg_pat <- con_pats]
 349      shift_var (EqnInfo n ctx (ConPat _ _ ps':ps) result) =
 350                 EqnInfo n ctx (ps'++ps)           result
 351      shift_var (EqnInfo n ctx (WildPat _     :ps) result) =
 352                 EqnInfo n ctx (new_wilds ++   ps) result
 353      shift_var _                                          = panic "Check.Shift_var:No done"
 354
 355 make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat
 356 make_row_vars used_lits (EqnInfo _ _ pats _ ) =
 357    (VarPatIn new_var:take (length (tail pats)) (repeat WildPatIn),[(new_var,used_lits)])
 358   where new_var = BS "#x"
 359
 360 make_row_vars_for_constructor :: EquationInfo -> [WarningPat]
 361 make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = take (length (tail pats)) (repeat WildPatIn)
 362
 363 compare_cons :: TypecheckedPat -> TypecheckedPat -> Bool
 364 compare_cons (ConPat id1 _ _) (ConPat id2 _ _) = id1 == id2
 365
 366 remove_dups :: [TypecheckedPat] -> [TypecheckedPat]
 367 remove_dups []     = []
 368 remove_dups (x:xs) | or (map (\y -> compare_cons x y) xs) = remove_dups  xs
 369                    | otherwise                            = x : remove_dups xs
 370
 371 get_used_cons :: [EquationInfo] -> [TypecheckedPat]
 372 get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPat _ _ _):_) _) <- qs]
 373
 374 remove_dups' :: [HsLit] -> [HsLit]
 375 remove_dups' []                   = []
 376 remove_dups' (x:xs) | x `elem` xs = remove_dups' xs
 377                     | otherwise   = x : remove_dups' xs
 378
 379
 380 get_used_lits :: [EquationInfo] -> [HsLit]
 381 get_used_lits qs = remove_dups' (get_used_lits' qs)
 382
 383 get_used_lits' :: [EquationInfo] -> [HsLit]
 384 get_used_lits' []                                      = []
 385 get_used_lits' ((EqnInfo _ _ ((LitPat lit _):_) _):qs) = lit : get_used_lits qs
 386 get_used_lits' ((EqnInfo _ _ ((NPat lit _ _):_) _):qs) = lit : get_used_lits qs
 387 get_used_lits' (q:qs)                                  =       get_used_lits qs
 388
 389 get_unused_cons :: [TypecheckedPat] -> [Id]
 390 get_unused_cons used_cons = unused_cons
 391      where
 392        (ConPat _ ty _) = head used_cons
 393        (ty_con,_)      = getAppTyCon ty
 394        all_cons        = tyConDataCons ty_con
 395        used_cons_as_id = map (\ (ConPat id _ _) -> id) used_cons
 396        unused_cons     = uniqSetToList (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
 397
 398 all_vars :: [TypecheckedPat] -> Bool
 399 all_vars []              = True
 400 all_vars (WildPat _:ps)  = all_vars ps
 401 all_vars _               = False
 402
 403 remove_var :: EquationInfo -> EquationInfo
 404 remove_var (EqnInfo n ctx (WildPat _:ps) result) = EqnInfo n ctx ps result
 405 remove_var _                                     = panic "Check:remove_var: equation not begin with a variable"
 406
 407 is_con :: EquationInfo -> Bool
 408 is_con (EqnInfo _ _ ((ConPat _ _ _):_) _) = True
 409 is_con _                                  = False
 410
 411 is_lit :: EquationInfo -> Bool
 412 is_lit (EqnInfo _ _ ((LitPat _ _):_) _) = True
 413 is_lit (EqnInfo _ _ ((NPat _ _ _):_) _) = True
 414 is_lit _                                = False
 415
 416 is_npat :: EquationInfo -> Bool
 417 is_npat (EqnInfo _ _ ((NPat _ _ _):_) _) = True
 418 is_npat _                                 = False
 419
 420 is_nplusk :: EquationInfo -> Bool
 421 is_nplusk (EqnInfo _ _ ((NPlusKPat _ _ _ _ _):_) _) = True
 422 is_nplusk _                                         = False
 423
 424 is_var :: EquationInfo -> Bool
 425 is_var (EqnInfo _ _ ((WildPat _):_) _)  = True
 426 is_var _                                = False
 427
 428 is_var_con :: Id -> EquationInfo -> Bool
 429 is_var_con con (EqnInfo _ _ ((WildPat _):_)     _)             = True
 430 is_var_con con (EqnInfo _ _ ((ConPat id _ _):_) _) | id == con = True
 431 is_var_con con _                                               = False
 432
 433 is_var_lit :: HsLit -> EquationInfo -> Bool
 434 is_var_lit lit (EqnInfo _ _ ((WildPat _):_)     _)               = True
 435 is_var_lit lit (EqnInfo _ _ ((LitPat lit' _):_) _) | lit == lit' = True
 436 is_var_lit lit (EqnInfo _ _ ((NPat lit' _ _):_) _) | lit == lit' = True
 437 is_var_lit lit _                                                 = False
 438 \end{code}
 439
 440 The difference beteewn make_con and make_whole_con is that make_wole_con creates a new
 441 constructor with all their arguments, and make_Con takes a list of argumntes, creates
 442 the contructor geting thir argumnts from the list. See where are used for details.
 443
 444 We need to reconstruct the patterns (make the constructors infix and similar) at the
 445 same time that we create the constructors.
 446
 447 You can tell tuple constructors using
 448
 449         Id.isTupleCon
 450
 451 You can see if one contructur is infix with this clearer code :-))))))))))
 452
 453         Lex.isLexConSym (Name.occNameString (Name.getOccName con))
 454
 455        Rather clumsy but it works. (Simon Peyton Jones)
 456
 457
 458 We con't mind the nilDataCon because it doesn't change the way to print the messsage,
 459 we are searching only for things like: [1,2,3], not x:xs ....
 460
 461
 462 In recontruct_pat we want to "undo" the work taht we have done in simplify_pat
 463 In particular:
 464         ((,) x y)  returns to be (x, y)
 465         ((:) x xs) returns to be (x:xs)
 466         (x:(...:[]) returns to be [x,...]
 467
 468 The dificult case is the third one becouse we need to follow all the contructors until the []
 469 to know taht we need to use the second case, not the second.
 470
 471 \begin{code}
 472
 473 isInfixCon con = isLexConSym (occNameString (getOccName con))
 474
 475 is_nil (ConPatIn (BS con) []) = con == getOccString nilDataCon
 476 is_nil _                      = False
 477
 478 is_list (ListPatIn _) = True
 479 is_list _             = False
 480
 481 return_list id q = id == consDataCon && (is_nil q || is_list q)
 482
 483 make_list p q | is_nil q   = ListPatIn [p]
 484 make_list p (ListPatIn ps) = ListPatIn (p:ps)
 485 make_list _ _              = panic "Check.make_list: Invalid argument"
 486
 487 make_con :: TypecheckedPat -> ExhaustivePat -> ExhaustivePat
 488 make_con (ConPat id ty pats) (p:q:ps, constraints)
 489      | return_list id q = (make_list p q : ps, constraints)
 490      | isInfixCon id = (ParPatIn (ConOpPatIn p name fixity q) : ps, constraints)
 491     where name   = BS (getOccString id)
 492           fixity = panic "Check.make_con: Guessing fixity"
 493 make_con (ConPat id ty pats) (ps,constraints)
 494       | isTupleCon id = (TuplePatIn pats_con : rest_pats,    constraints)
 495       | otherwise     = (ConPatIn name pats_con : rest_pats, constraints)
 496     where num_args  = length pats
 497           name      = BS (getOccString id)
 498           pats_con  = (take num_args ps)
 499           rest_pats = drop num_args ps
 500
 501 make_whole_con :: Id -> WarningPat
 502 make_whole_con con | isInfixCon con = ParPatIn(ConOpPatIn new_wild_pat name fixity new_wild_pat)
 503                    | otherwise      = ConPatIn name pats
 504                 where
 505                   fixity = panic "Check.make_whole_con: Guessing fixity"
 506                   name   = BS (getOccString con)
 507                   arity  = get_int_arity con
 508                   pats   = take arity (repeat new_wild_pat)
 509
 510
 511 new_wild_pat :: WarningPat
 512 new_wild_pat = WildPatIn
 513
 514 get_int_arity :: Id -> Int
 515 get_int_arity id = arity_to_int (getIdArity id)
 516     where
 517       arity_to_int (ArityExactly n) = n
 518       arity_to_int _                = panic "getIntArity: Unknown arity"
 519
 520 \end{code}
 521
 522 This equation makes the same thing that tidy in Match.lhs, the
 523 diference is that here we can do all the tidy in one place and in the
 524 Match tidy it must be done one column each time due to bookeping
 525 constraints.
 526
 527 \begin{code}
 528
 529 simplify_eqns :: [EquationInfo] -> [EquationInfo]
 530 simplify_eqns []                               = []
 531 simplify_eqns ((EqnInfo n ctx pats result):qs) =
 532     (EqnInfo n ctx(map simplify_pat pats) result) :
 533     simplify_eqns qs
 534
 535 simplify_pat :: TypecheckedPat -> TypecheckedPat
 536 simplify_pat (WildPat gt ) = WildPat gt
 537
 538 simplify_pat (VarPat id)   = WildPat (idType id)
 539
 540 simplify_pat (LazyPat p)   = simplify_pat p
 541
 542 simplify_pat (AsPat id p)  = simplify_pat p
 543
 544 simplify_pat (ConPat id ty ps) = ConPat id ty (map simplify_pat ps)
 545
 546 simplify_pat (ConOpPat p1 id p2 ty) = ConPat id ty (map simplify_pat [p1,p2])
 547
 548 simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [x, y])
 549                                                     (ConPat nilDataCon  list_ty [])
 550                                                     (map simplify_pat ps)
 551                              where list_ty = mkListTy ty
 552
 553
 554 simplify_pat (TuplePat ps) = ConPat (tupleCon arity)
 555                                      (mkTupleTy arity (map outPatType ps))
 556                                      (map simplify_pat ps)
 557                            where
 558                               arity = length ps
 559
 560 simplify_pat (RecPat id ty idps) = ConPat id ty pats
 561                                  where
 562                                    pats = map (\ (id,p,_)-> simplify_pat p) idps
 563
 564 simplify_pat pat@(LitPat lit lit_ty)
 565   | isPrimType lit_ty = LitPat lit lit_ty
 566
 567   | lit_ty `eqTy` charTy = ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy]
 568
 569   | otherwise = pprPanic "tidy1:LitPat:" (ppr PprDebug pat)
 570   where
 571     mk_char (HsChar c)    = HsCharPrim c
 572
 573 simplify_pat (NPat lit lit_ty hsexpr) = better_pat
 574   where
 575     better_pat
 576       | lit_ty `eqTy` charTy   = ConPat charDataCon   lit_ty [LitPat (mk_char lit)   charPrimTy]
 577       | lit_ty `eqTy` intTy    = ConPat intDataCon    lit_ty [LitPat (mk_int lit)    intPrimTy]
 578       | lit_ty `eqTy` wordTy   = ConPat wordDataCon   lit_ty [LitPat (mk_word lit)   wordPrimTy]
 579       | lit_ty `eqTy` addrTy   = ConPat addrDataCon   lit_ty [LitPat (mk_addr lit)   addrPrimTy]
 580       | lit_ty `eqTy` floatTy  = ConPat floatDataCon  lit_ty [LitPat (mk_float lit)  floatPrimTy]
 581       | lit_ty `eqTy` doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy]
 582
 583                 -- Convert the literal pattern "" to the constructor pattern [].
 584       | null_str_lit lit       = ConPat nilDataCon    lit_ty []
 585
 586       | otherwise              = NPat lit lit_ty hsexpr
 587
 588     mk_int    (HsInt i)      = HsIntPrim i
 589     mk_int    l@(HsLitLit s) = l
 590
 591     mk_char   (HsChar c)     = HsCharPrim c
 592     mk_char   l@(HsLitLit s) = l
 593
 594     mk_word   l@(HsLitLit s) = l
 595
 596     mk_addr   l@(HsLitLit s) = l
 597
 598     mk_float  (HsInt i)      = HsFloatPrim (fromInteger i)
 599     mk_float  (HsFrac f)     = HsFloatPrim f
 600     mk_float  l@(HsLitLit s) = l
 601
 602     mk_double (HsInt i)      = HsDoublePrim (fromInteger i)
 603     mk_double (HsFrac f)     = HsDoublePrim f
 604     mk_double l@(HsLitLit s) = l
 605
 606     null_str_lit (HsString s) = _NULL_ s
 607     null_str_lit other_lit    = False
 608
 609 simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) = --NPlusKPat id hslit ty hsexpr1 hsexpr2
 610      WildPat ty
 611    where ty = panic "Check.simplify_pat: Never used"
 612
 613 simplify_pat (DictPat dicts methods) =
 614     case num_of_d_and_ms of
 615        0 -> simplify_pat (TuplePat [])
 616        1 -> simplify_pat (head dict_and_method_pats)
 617        _ -> simplify_pat (TuplePat dict_and_method_pats)
 618     where
 619        num_of_d_and_ms   = length dicts + length methods
 620        dict_and_method_pats = map VarPat (dicts ++ methods)
 621
 622 \end{code}