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