Check.hs 29.1 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4 5 6
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1997-1998

Author: Juan J. Quintela    <quintela@krilin.dc.fi.udc.es>
-}
sof's avatar
sof committed
7

8 9
{-# LANGUAGE CPP #-}

sof's avatar
sof committed
10
module Check ( check , ExhaustivePat ) where
11

Simon Marlow's avatar
Simon Marlow committed
12
#include "HsVersions.h"
sof's avatar
sof committed
13

Ian Lynagh's avatar
Ian Lynagh committed
14
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
15 16 17 18
import TcHsSyn
import DsUtils
import MatchLit
import Id
cactus's avatar
cactus committed
19
import ConLike
Simon Marlow's avatar
Simon Marlow committed
20
import DataCon
cactus's avatar
cactus committed
21
import PatSyn
Simon Marlow's avatar
Simon Marlow committed
22
import Name
23
import TysWiredIn
Simon Marlow's avatar
Simon Marlow committed
24 25 26
import PrelNames
import TyCon
import SrcLoc
sof's avatar
sof committed
27
import UniqSet
Simon Marlow's avatar
Simon Marlow committed
28
import Util
29
import BasicTypes
30
import Outputable
31
import FastString
sof's avatar
sof committed
32

Austin Seipp's avatar
Austin Seipp committed
33
{-
34
This module performs checks about if one list of equations are:
35 36 37 38
\begin{itemize}
\item Overlapped
\item Non exhaustive
\end{itemize}
sof's avatar
sof committed
39 40
To discover that we go through the list of equations in a tree-like fashion.

41
If you like theory, a similar algorithm is described in:
42
\begin{quotation}
Ian Lynagh's avatar
Ian Lynagh committed
43 44 45
        {\em Two Techniques for Compiling Lazy Pattern Matching},
        Luc Maranguet,
        INRIA Rocquencourt (RR-2385, 1994)
46 47 48 49
\end{quotation}
The algorithm is based on the first technique, but there are some differences:
\begin{itemize}
\item We don't generate code
Ian Lynagh's avatar
Ian Lynagh committed
50 51 52 53
\item We have constructors and literals (not only literals as in the
          article)
\item We don't use directions, we must select the columns from
          left-to-right
54
\end{itemize}
Ian Lynagh's avatar
Ian Lynagh committed
55
(By the way the second technique is really similar to the one used in
56
 @Match.hs@ to generate code)
sof's avatar
sof committed
57 58

This function takes the equations of a pattern and returns:
59 60 61 62
\begin{itemize}
\item The patterns that are not recognized
\item The equations that are not overlapped
\end{itemize}
Ian Lynagh's avatar
Ian Lynagh committed
63
It simplify the patterns and then call @check'@ (the same semantics), and it
64
needs to reconstruct the patterns again ....
sof's avatar
sof committed
65 66

The problem appear with things like:
67
\begin{verbatim}
sof's avatar
sof committed
68 69
  f [x,y]   = ....
  f (x:xs)  = .....
70
\end{verbatim}
Ian Lynagh's avatar
Ian Lynagh committed
71
We want to put the two patterns with the same syntax, (prefix form) and
72
then all the constructors are equal:
73
\begin{verbatim}
sof's avatar
sof committed
74 75
  f (: x (: y []))   = ....
  f (: x xs)         = .....
76
\end{verbatim}
77
(more about that in @tidy_eqns@)
sof's avatar
sof committed
78

Ian Lynagh's avatar
Ian Lynagh committed
79
We would prefer to have a @WarningPat@ of type @String@, but Strings and the
sof's avatar
sof committed
80
Pretty Printer are not friends.
81

82
We use @InPat@ in @WarningPat@ instead of @OutPat@
Ian Lynagh's avatar
Ian Lynagh committed
83 84
because we need to print the
warning messages in the same way they are introduced, i.e. if the user
85
wrote:
86
\begin{verbatim}
Ian Lynagh's avatar
Ian Lynagh committed
87
        f [x,y] = ..
88
\end{verbatim}
89
He don't want a warning message written:
90
\begin{verbatim}
91
        f (: x (: y [])) ........
92
\end{verbatim}
93
Then we need to use InPats.
94 95
\begin{quotation}
     Juan Quintela 5 JUL 1998\\
Ian Lynagh's avatar
Ian Lynagh committed
96
          User-friendliness and compiler writers are no friends.
97
\end{quotation}
Austin Seipp's avatar
Austin Seipp committed
98
-}
sof's avatar
sof committed
99

sof's avatar
sof committed
100 101
type WarningPat = InPat Name
type ExhaustivePat = ([WarningPat], [(Name, [HsLit])])
102 103
type EqnNo  = Int
type EqnSet = UniqSet EqnNo
sof's avatar
sof committed
104 105


106
check :: [EquationInfo] -> ([ExhaustivePat], [EquationInfo])
107
  -- Second result is the shadowed equations
108
  -- if there are view patterns, just give up - don't know what the function is
Simon Peyton Jones's avatar
Simon Peyton Jones committed
109
check qs = (untidy_warns, shadowed_eqns)
110
      where
111
        tidy_qs = map tidy_eqn qs
Ian Lynagh's avatar
Ian Lynagh committed
112 113 114 115
        (warns, used_nos) = check' ([1..] `zip` tidy_qs)
        untidy_warns = map untidy_exhaustive warns
        shadowed_eqns = [eqn | (eqn,i) <- qs `zip` [1..],
                                not (i `elementOfUniqSet` used_nos)]
116 117

untidy_exhaustive :: ExhaustivePat -> ExhaustivePat
Ian Lynagh's avatar
Ian Lynagh committed
118 119 120 121
untidy_exhaustive ([pat], messages) =
                  ([untidy_no_pars pat], map untidy_message messages)
untidy_exhaustive (pats, messages) =
                  (map untidy_pars pats, map untidy_message messages)
122

sof's avatar
sof committed
123
untidy_message :: (Name, [HsLit]) -> (Name, [HsLit])
124
untidy_message (string, lits) = (string, map untidy_lit lits)
sof's avatar
sof committed
125

Austin Seipp's avatar
Austin Seipp committed
126
-- The function @untidy@ does the reverse work of the @tidy_pat@ function.
127

Ian Lynagh's avatar
Ian Lynagh committed
128
type NeedPars = Bool
129 130 131 132 133 134 135 136

untidy_no_pars :: WarningPat -> WarningPat
untidy_no_pars p = untidy False p

untidy_pars :: WarningPat -> WarningPat
untidy_pars p = untidy True p

untidy :: NeedPars -> WarningPat -> WarningPat
137 138
untidy b (L loc p) = L loc (untidy' b p)
  where
139 140 141 142
    untidy' _ p@(WildPat _)          = p
    untidy' _ p@(VarPat _)           = p
    untidy' _ (LitPat lit)           = LitPat (untidy_lit lit)
    untidy' _ p@(ConPatIn _ (PrefixCon [])) = p
143
    untidy' b (ConPatIn name ps)     = pars b (L loc (ConPatIn name (untidy_con ps)))
Austin Seipp's avatar
Austin Seipp committed
144
    untidy' _ (ListPat pats ty Nothing)     = ListPat (map untidy_no_pars pats) ty Nothing
145
    untidy' _ (TuplePat pats box tys) = TuplePat (map untidy_no_pars pats) box tys
Austin Seipp's avatar
Austin Seipp committed
146
    untidy' _ (ListPat _ _ (Just _)) = panic "Check.untidy: Overloaded ListPat"
Ian Lynagh's avatar
Ian Lynagh committed
147 148
    untidy' _ (PArrPat _ _)          = panic "Check.untidy: Shouldn't get a parallel array here!"
    untidy' _ (SigPatIn _ _)         = panic "Check.untidy: SigPat"
Ian Lynagh's avatar
Ian Lynagh committed
149 150 151 152 153 154
    untidy' _ (LazyPat {})           = panic "Check.untidy: LazyPat"
    untidy' _ (AsPat {})             = panic "Check.untidy: AsPat"
    untidy' _ (ParPat {})            = panic "Check.untidy: ParPat"
    untidy' _ (BangPat {})           = panic "Check.untidy: BangPat"
    untidy' _ (ConPatOut {})         = panic "Check.untidy: ConPatOut"
    untidy' _ (ViewPat {})           = panic "Check.untidy: ViewPat"
gmainland's avatar
gmainland committed
155
    untidy' _ (SplicePat {})         = panic "Check.untidy: SplicePat"
Ian Lynagh's avatar
Ian Lynagh committed
156 157 158 159
    untidy' _ (NPat {})              = panic "Check.untidy: NPat"
    untidy' _ (NPlusKPat {})         = panic "Check.untidy: NPlusKPat"
    untidy' _ (SigPatOut {})         = panic "Check.untidy: SigPatOut"
    untidy' _ (CoPat {})             = panic "Check.untidy: CoPat"
160

161
untidy_con :: HsConPatDetails Name -> HsConPatDetails Name
Ian Lynagh's avatar
Ian Lynagh committed
162
untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats)
163
untidy_con (InfixCon p1 p2) = InfixCon  (untidy_pars p1) (untidy_pars p2)
Ian Lynagh's avatar
Ian Lynagh committed
164
untidy_con (RecCon (HsRecFields flds dd))
165 166 167
  = RecCon (HsRecFields [ L l (fld { hsRecFieldArg
                                            = untidy_pars (hsRecFieldArg fld) })
                        | L l fld <- flds ] dd)
168

169
pars :: NeedPars -> WarningPat -> Pat Name
170
pars True p = ParPat p
171
pars _    p = unLoc p
172 173

untidy_lit :: HsLit -> HsLit
174 175
untidy_lit (HsCharPrim src c) = HsChar src c
untidy_lit lit                = lit
sof's avatar
sof committed
176

Austin Seipp's avatar
Austin Seipp committed
177
{-
sof's avatar
sof committed
178
This equation is the same that check, the only difference is that the
179 180
boring work is done, that work needs to be done only once, this is
the reason top have two functions, check is the external interface,
181
@check'@ is called recursively.
sof's avatar
sof committed
182 183 184

There are several cases:

Ian Lynagh's avatar
Ian Lynagh committed
185 186
\begin{itemize}
\item There are no equations: Everything is OK.
sof's avatar
sof committed
187
\item There are only one equation, that can fail, and all the patterns are
Ian Lynagh's avatar
Ian Lynagh committed
188
      variables. Then that equation is used and the same equation is
189
      non-exhaustive.
Ian Lynagh's avatar
Ian Lynagh committed
190 191
\item All the patterns are variables, and the match can fail, there are
      more equations then the results is the result of the rest of equations
192
      and this equation is used also.
sof's avatar
sof committed
193

Ian Lynagh's avatar
Ian Lynagh committed
194 195
\item The general case, if all the patterns are variables (here the match
      can't fail) then the result is that this equation is used and this
196
      equation doesn't generate non-exhaustive cases.
sof's avatar
sof committed
197

Ian Lynagh's avatar
Ian Lynagh committed
198
\item In the general case, there can exist literals ,constructors or only
199
      vars in the first column, we actuate in consequence.
sof's avatar
sof committed
200

201
\end{itemize}
Austin Seipp's avatar
Austin Seipp committed
202
-}
sof's avatar
sof committed
203

Ian Lynagh's avatar
Ian Lynagh committed
204 205 206
check' :: [(EqnNo, EquationInfo)]
        -> ([ExhaustivePat],    -- Pattern scheme that might not be matched at all
            EqnSet)             -- Eqns that are used (others are overlapped)
207

208 209
check' [] = ([],emptyUniqSet)
  -- Was    ([([],[])], emptyUniqSet)
Austin Seipp's avatar
Austin Seipp committed
210
  -- But that (a) seems weird, and (b) triggered Trac #7669
211
  -- So now I'm just doing the simple obvious thing
sof's avatar
sof committed
212

Ian Lynagh's avatar
Ian Lynagh committed
213
check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult can_fail _ }) : rs)
214
   | first_eqn_all_vars && case can_fail of { CantFail -> True; CanFail -> False }
Ian Lynagh's avatar
Ian Lynagh committed
215
   = ([], unitUniqSet n)        -- One eqn, which can't fail
216

Ian Lynagh's avatar
Ian Lynagh committed
217
   | first_eqn_all_vars && null rs      -- One eqn, but it can fail
218
   = ([(takeList ps (repeat nlWildPatName),[])], unitUniqSet n)
sof's avatar
sof committed
219

Ian Lynagh's avatar
Ian Lynagh committed
220
   | first_eqn_all_vars         -- Several eqns, first can fail
221
   = (pats, addOneToUniqSet indexs n)
sof's avatar
sof committed
222
  where
223
    first_eqn_all_vars = all_vars ps
sof's avatar
sof committed
224
    (pats,indexs) = check' rs
sof's avatar
sof committed
225

226
check' qs
227 228 229 230
   | some_literals     = split_by_literals qs
   | some_constructors = split_by_constructor qs
   | only_vars         = first_column_only_vars qs
   | otherwise = pprPanic "Check.check': Not implemented :-(" (ppr first_pats)
Ian Lynagh's avatar
Ian Lynagh committed
231
                 -- Shouldn't happen
sof's avatar
sof committed
232
  where
sof's avatar
sof committed
233 234
     -- Note: RecPats will have been simplified to ConPats
     --       at this stage.
235 236 237 238
    first_pats        = ASSERT2( okGroup qs, pprGroup qs ) map firstPatN qs
    some_constructors = any is_con first_pats
    some_literals     = any is_lit first_pats
    only_vars         = all is_var first_pats
sof's avatar
sof committed
239

Austin Seipp's avatar
Austin Seipp committed
240
{-
241
Here begins the code to deal with literals, we need to split the matrix
Ian Lynagh's avatar
Ian Lynagh committed
242
in different matrix beginning by each literal and a last matrix with the
243
rest of values.
Austin Seipp's avatar
Austin Seipp committed
244
-}
sof's avatar
sof committed
245

246
split_by_literals :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
sof's avatar
sof committed
247 248 249 250
split_by_literals qs = process_literals used_lits qs
           where
             used_lits = get_used_lits qs

Austin Seipp's avatar
Austin Seipp committed
251
{-
Ian Lynagh's avatar
Ian Lynagh committed
252 253
@process_explicit_literals@ is a function that process each literal that appears
in the column of the matrix.
Austin Seipp's avatar
Austin Seipp committed
254
-}
sof's avatar
sof committed
255

256
process_explicit_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
sof's avatar
sof committed
257
process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)
Ian Lynagh's avatar
Ian Lynagh committed
258
    where
sof's avatar
sof committed
259
      pats_indexs   = map (\x -> construct_literal_matrix x qs) lits
Ian Lynagh's avatar
Ian Lynagh committed
260
      (pats,indexs) = unzip pats_indexs
sof's avatar
sof committed
261

Austin Seipp's avatar
Austin Seipp committed
262
{-
Ian Lynagh's avatar
Ian Lynagh committed
263 264
@process_literals@ calls @process_explicit_literals@ to deal with the literals
that appears in the matrix and deal also with the rest of the cases. It
265
must be one Variable to be complete.
Austin Seipp's avatar
Austin Seipp committed
266
-}
sof's avatar
sof committed
267

268
process_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
Ian Lynagh's avatar
Ian Lynagh committed
269
process_literals used_lits qs
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
270
  | null default_eqns  = ASSERT( not (null qs) ) ([make_row_vars used_lits (head qs)] ++ pats,indexs)
sof's avatar
sof committed
271
  | otherwise          = (pats_default,indexs_default)
sof's avatar
sof committed
272 273
     where
       (pats,indexs)   = process_explicit_literals used_lits qs
Ian Lynagh's avatar
Ian Lynagh committed
274 275 276
       default_eqns    = ASSERT2( okGroup qs, pprGroup qs )
                         [remove_var q | q <- qs, is_var (firstPatN q)]
       (pats',indexs') = check' default_eqns
277 278
       pats_default    = [(nlWildPatName:ps,constraints) |
                                        (ps,constraints) <- (pats')] ++ pats
sof's avatar
sof committed
279 280
       indexs_default  = unionUniqSets indexs' indexs

Austin Seipp's avatar
Austin Seipp committed
281
{-
Ian Lynagh's avatar
Ian Lynagh committed
282
Here we have selected the literal and we will select all the equations that
283
begins for that literal and create a new matrix.
Austin Seipp's avatar
Austin Seipp committed
284
-}
sof's avatar
sof committed
285

286
construct_literal_matrix :: HsLit -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
sof's avatar
sof committed
287
construct_literal_matrix lit qs =
Ian Lynagh's avatar
Ian Lynagh committed
288
    (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)
sof's avatar
sof committed
289
  where
Ian Lynagh's avatar
Ian Lynagh committed
290
    (pats,indexs) = (check' (remove_first_column_lit lit qs))
291
    new_lit = nlLitPat lit
sof's avatar
sof committed
292 293

remove_first_column_lit :: HsLit
Ian Lynagh's avatar
Ian Lynagh committed
294
                        -> [(EqnNo, EquationInfo)]
295
                        -> [(EqnNo, EquationInfo)]
296
remove_first_column_lit lit qs
Ian Lynagh's avatar
Ian Lynagh committed
297
  = ASSERT2( okGroup qs, pprGroup qs )
298
    [(n, shift_pat eqn) | q@(n,eqn) <- qs, is_var_lit lit (firstPatN q)]
sof's avatar
sof committed
299
  where
300
     shift_pat eqn@(EqnInfo { eqn_pats = _:ps}) = eqn { eqn_pats = ps }
301
     shift_pat _                                = panic "Check.shift_var: no patterns"
sof's avatar
sof committed
302

Austin Seipp's avatar
Austin Seipp committed
303
{-
Ian Lynagh's avatar
Ian Lynagh committed
304
This function splits the equations @qs@ in groups that deal with the
305
same constructor.
Austin Seipp's avatar
Austin Seipp committed
306
-}
sof's avatar
sof committed
307

308
split_by_constructor :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
Ian Lynagh's avatar
Ian Lynagh committed
309
split_by_constructor qs
cactus's avatar
cactus committed
310
  | null used_cons      = ([], mkUniqSet $ map fst qs)
Ian Lynagh's avatar
Ian Lynagh committed
311 312 313 314 315
  | notNull unused_cons = need_default_case used_cons unused_cons qs
  | otherwise           = no_need_default_case used_cons qs
                       where
                          used_cons   = get_used_cons qs
                          unused_cons = get_unused_cons used_cons
sof's avatar
sof committed
316

Austin Seipp's avatar
Austin Seipp committed
317
{-
Ian Lynagh's avatar
Ian Lynagh committed
318
The first column of the patterns matrix only have vars, then there is
319
nothing to do.
Austin Seipp's avatar
Austin Seipp committed
320
-}
sof's avatar
sof committed
321

322
first_column_only_vars :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
323 324 325 326
first_column_only_vars qs
  = (map (\ (xs,ys) -> (nlWildPatName:xs,ys)) pats,indexs)
  where
    (pats, indexs) = check' (map remove_var qs)
sof's avatar
sof committed
327

Austin Seipp's avatar
Austin Seipp committed
328
{-
Ian Lynagh's avatar
Ian Lynagh committed
329 330
This equation takes a matrix of patterns and split the equations by
constructor, using all the constructors that appears in the first column
331
of the pattern matching.
sof's avatar
sof committed
332

Ian Lynagh's avatar
Ian Lynagh committed
333
We can need a default clause or not ...., it depends if we used all the
334
constructors or not explicitly. The reasoning is similar to @process_literals@,
335
the difference is that here the default case is not always needed.
Austin Seipp's avatar
Austin Seipp committed
336
-}
sof's avatar
sof committed
337

338
no_need_default_case :: [Pat Id] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
sof's avatar
sof committed
339
no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
Ian Lynagh's avatar
Ian Lynagh committed
340
    where
sof's avatar
sof committed
341
      pats_indexs   = map (\x -> construct_matrix x qs) cons
Ian Lynagh's avatar
Ian Lynagh committed
342
      (pats,indexs) = unzip pats_indexs
sof's avatar
sof committed
343

344
need_default_case :: [Pat Id] -> [DataCon] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
Ian Lynagh's avatar
Ian Lynagh committed
345
need_default_case used_cons unused_cons qs
sof's avatar
sof committed
346 347
  | null default_eqns  = (pats_default_no_eqns,indexs)
  | otherwise          = (pats_default,indexs_default)
sof's avatar
sof committed
348 349
     where
       (pats,indexs)   = no_need_default_case used_cons qs
Ian Lynagh's avatar
Ian Lynagh committed
350 351 352 353
       default_eqns    = ASSERT2( okGroup qs, pprGroup qs )
                         [remove_var q | q <- qs, is_var (firstPatN q)]
       (pats',indexs') = check' default_eqns
       pats_default    = [(make_whole_con c:ps,constraints) |
sof's avatar
sof committed
354
                          c <- unused_cons, (ps,constraints) <- pats'] ++ pats
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
355
       new_wilds       = ASSERT( not (null qs) ) make_row_vars_for_constructor (head qs)
sof's avatar
sof committed
356 357 358
       pats_default_no_eqns =  [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats
       indexs_default  = unionUniqSets indexs' indexs

359
construct_matrix :: Pat Id -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
sof's avatar
sof committed
360
construct_matrix con qs =
Ian Lynagh's avatar
Ian Lynagh committed
361
    (map (make_con con) pats,indexs)
sof's avatar
sof committed
362
  where
Ian Lynagh's avatar
Ian Lynagh committed
363
    (pats,indexs) = (check' (remove_first_column con qs))
sof's avatar
sof committed
364

Austin Seipp's avatar
Austin Seipp committed
365
{-
Ian Lynagh's avatar
Ian Lynagh committed
366
Here remove first column is more difficult that with literals due to the fact
367
that constructors can have arguments.
sof's avatar
sof committed
368

369
For instance, the matrix
370
\begin{verbatim}
sof's avatar
sof committed
371 372
 (: x xs) y
 z        y
373
\end{verbatim}
sof's avatar
sof committed
374
is transformed in:
375
\begin{verbatim}
sof's avatar
sof committed
376 377
 x xs y
 _ _  y
378
\end{verbatim}
Austin Seipp's avatar
Austin Seipp committed
379
-}
sof's avatar
sof committed
380

Ian Lynagh's avatar
Ian Lynagh committed
381 382
remove_first_column :: Pat Id                -- Constructor
                    -> [(EqnNo, EquationInfo)]
383
                    -> [(EqnNo, EquationInfo)]
384
remove_first_column (ConPatOut{ pat_con = L _ con, pat_args = PrefixCon con_pats }) qs
Ian Lynagh's avatar
Ian Lynagh committed
385
  = ASSERT2( okGroup qs, pprGroup qs )
386
    [(n, shift_var eqn) | q@(n, eqn) <- qs, is_var_con con (firstPatN q)]
sof's avatar
sof committed
387
  where
388
     new_wilds = [WildPat (hsLPatType arg_pat) | arg_pat <- con_pats]
Ian Lynagh's avatar
Ian Lynagh committed
389 390
     shift_var eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_args = PrefixCon ps' } : ps})
        = eqn { eqn_pats = map unLoc ps' ++ ps }
391
     shift_var eqn@(EqnInfo { eqn_pats = WildPat _ : ps })
Ian Lynagh's avatar
Ian Lynagh committed
392
        = eqn { eqn_pats = new_wilds ++ ps }
393
     shift_var _ = panic "Check.Shift_var:No done"
Ian Lynagh's avatar
Ian Lynagh committed
394
remove_first_column _ _ = panic "Check.remove_first_column: Not ConPatOut"
sof's avatar
sof committed
395

396 397
make_row_vars :: [HsLit] -> (EqnNo, EquationInfo) -> ExhaustivePat
make_row_vars used_lits (_, EqnInfo { eqn_pats = pats})
398 399
   = (nlVarPat new_var:takeList (tail pats) (repeat nlWildPatName)
     ,[(new_var,used_lits)])
Ian Lynagh's avatar
Ian Lynagh committed
400
  where
401
     new_var = hash_x
402

403
hash_x :: Name
404
hash_x = mkInternalName unboundKey {- doesn't matter much -}
Ian Lynagh's avatar
Ian Lynagh committed
405 406
                     (mkVarOccFS (fsLit "#x"))
                     noSrcSpan
sof's avatar
sof committed
407

408
make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat]
Ian Lynagh's avatar
Ian Lynagh committed
409
make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats})
410
  = takeList (tail pats) (repeat nlWildPatName)
sof's avatar
sof committed
411

412
compare_cons :: Pat Id -> Pat Id -> Bool
cactus's avatar
cactus committed
413 414 415 416 417
compare_cons (ConPatOut{ pat_con = L _ con1 }) (ConPatOut{ pat_con = L _ con2 })
  = case (con1, con2) of
    (RealDataCon id1, RealDataCon id2) -> id1 == id2
    _ -> False
compare_cons _ _ = panic "Check.compare_cons: Not ConPatOut with RealDataCon"
sof's avatar
sof committed
418

419
remove_dups :: [Pat Id] -> [Pat Id]
sof's avatar
sof committed
420
remove_dups []     = []
Joachim Breitner's avatar
Joachim Breitner committed
421 422
remove_dups (x:xs) | any (\y -> compare_cons x y) xs = remove_dups  xs
                   | otherwise                       = x : remove_dups xs
sof's avatar
sof committed
423

424
get_used_cons :: [(EqnNo, EquationInfo)] -> [Pat Id]
Ian Lynagh's avatar
Ian Lynagh committed
425 426
get_used_cons qs = remove_dups [pat | q <- qs, let pat = firstPatN q,
                                      isConPatOut pat]
427

428
isConPatOut :: Pat Id -> Bool
cactus's avatar
cactus committed
429 430
isConPatOut ConPatOut{ pat_con = L _ RealDataCon{} } = True
isConPatOut _                                        = False
sof's avatar
sof committed
431

Ian Lynagh's avatar
Ian Lynagh committed
432
remove_dups' :: [HsLit] -> [HsLit]
sof's avatar
sof committed
433 434
remove_dups' []                   = []
remove_dups' (x:xs) | x `elem` xs = remove_dups' xs
Ian Lynagh's avatar
Ian Lynagh committed
435
                    | otherwise   = x : remove_dups' xs
sof's avatar
sof committed
436 437


438
get_used_lits :: [(EqnNo, EquationInfo)] -> [HsLit]
439
get_used_lits qs = remove_dups' all_literals
Ian Lynagh's avatar
Ian Lynagh committed
440 441
                 where
                   all_literals = get_used_lits' qs
sof's avatar
sof committed
442

443
get_used_lits' :: [(EqnNo, EquationInfo)] -> [HsLit]
444
get_used_lits' [] = []
Ian Lynagh's avatar
Ian Lynagh committed
445
get_used_lits' (q:qs)
446
  | Just lit <- get_lit (firstPatN q) = lit : get_used_lits' qs
Ian Lynagh's avatar
Ian Lynagh committed
447
  | otherwise                         = get_used_lits qs
sof's avatar
sof committed
448

Ian Lynagh's avatar
Ian Lynagh committed
449
get_lit :: Pat id -> Maybe HsLit
450 451 452
-- Get a representative HsLit to stand for the OverLit
-- It doesn't matter which one, because they will only be compared
-- with other HsLits gotten in the same way
Ian Lynagh's avatar
Ian Lynagh committed
453
get_lit (LitPat lit)                                      = Just lit
Alan Zimmerman's avatar
Alan Zimmerman committed
454
get_lit (NPat (L _ (OverLit { ol_val = HsIntegral src i}))    mb _)
455
                        = Just (HsIntPrim src (mb_neg negate              mb i))
Alan Zimmerman's avatar
Alan Zimmerman committed
456
get_lit (NPat (L _ (OverLit { ol_val = HsFractional f })) mb _)
457
                        = Just (HsFloatPrim (mb_neg negateFractionalLit mb f))
Alan Zimmerman's avatar
Alan Zimmerman committed
458
get_lit (NPat (L _ (OverLit { ol_val = HsIsString src s }))   _  _)
459
                        = Just (HsStringPrim src (fastStringToByteString s))
Ian Lynagh's avatar
Ian Lynagh committed
460
get_lit _                                                 = Nothing
461

462 463 464
mb_neg :: (a -> a) -> Maybe b -> a -> a
mb_neg _      Nothing  v = v
mb_neg negate (Just _) v = negate v
465

466
get_unused_cons :: [Pat Id] -> [DataCon]
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
467
get_unused_cons used_cons = ASSERT( not (null used_cons) ) unused_cons
sof's avatar
sof committed
468
     where
469
       used_set :: UniqSet DataCon
cactus's avatar
cactus committed
470
       used_set = mkUniqSet [d | ConPatOut{ pat_con = L _ (RealDataCon d) } <- used_cons]
471 472
       (ConPatOut { pat_con = L _ (RealDataCon con1), pat_arg_tys = inst_tys }) = head used_cons
       ty_con      = dataConTyCon con1
473 474
       unused_cons = filterOut is_used (tyConDataCons ty_con)
       is_used con = con `elementOfUniqSet` used_set
Ian Lynagh's avatar
Ian Lynagh committed
475
                     || dataConCannotMatch inst_tys con
sof's avatar
sof committed
476

477 478 479 480
all_vars :: [Pat Id] -> Bool
all_vars []             = True
all_vars (WildPat _:ps) = all_vars ps
all_vars _              = False
sof's avatar
sof committed
481

482 483 484
remove_var :: (EqnNo, EquationInfo) -> (EqnNo, EquationInfo)
remove_var (n, eqn@(EqnInfo { eqn_pats = WildPat _ : ps})) = (n, eqn { eqn_pats = ps })
remove_var _  = panic "Check.remove_var: equation does not begin with a variable"
sof's avatar
sof committed
485

486
-----------------------
487 488
eqnPats :: (EqnNo, EquationInfo) -> [Pat Id]
eqnPats (_, eqn) = eqn_pats eqn
489

490
okGroup :: [(EqnNo, EquationInfo)] -> Bool
491 492 493 494
-- True if all equations have at least one pattern, and
-- all have the same number of patterns
okGroup [] = True
okGroup (e:es) = n_pats > 0 && and [length (eqnPats e) == n_pats | e <- es]
Ian Lynagh's avatar
Ian Lynagh committed
495 496
               where
                 n_pats = length (eqnPats e)
497 498

-- Half-baked print
499 500
pprGroup :: [(EqnNo, EquationInfo)] -> SDoc
pprEqnInfo :: (EqnNo, EquationInfo) -> SDoc
501 502 503
pprGroup es = vcat (map pprEqnInfo es)
pprEqnInfo e = ppr (eqnPats e)

504 505 506 507

firstPatN :: (EqnNo, EquationInfo) -> Pat Id
firstPatN (_, eqn) = firstPat eqn

508
is_con :: Pat Id -> Bool
509 510
is_con (ConPatOut {}) = True
is_con _              = False
511

512
is_lit :: Pat Id -> Bool
513
is_lit (LitPat _)      = True
514
is_lit (NPat _ _ _)  = True
515 516
is_lit _               = False

517
is_var :: Pat Id -> Bool
518 519 520
is_var (WildPat _) = True
is_var _           = False

cactus's avatar
cactus committed
521 522 523 524
is_var_con :: ConLike -> Pat Id -> Bool
is_var_con _   (WildPat _)                     = True
is_var_con con (ConPatOut{ pat_con = L _ id }) = id == con
is_var_con _   _                               = False
525

526
is_var_lit :: HsLit -> Pat Id -> Bool
527
is_var_lit _   (WildPat _)   = True
Ian Lynagh's avatar
Ian Lynagh committed
528
is_var_lit lit pat
529
  | Just lit' <- get_lit pat = lit == lit'
Ian Lynagh's avatar
Ian Lynagh committed
530
  | otherwise                = False
sof's avatar
sof committed
531

Austin Seipp's avatar
Austin Seipp committed
532
{-
533 534 535 536
The difference beteewn @make_con@ and @make_whole_con@ is that
@make_wole_con@ creates a new constructor with all their arguments, and
@make_con@ takes a list of argumntes, creates the contructor getting their
arguments from the list. See where \fbox{\ ???\ } are used for details.
sof's avatar
sof committed
537

538
We need to reconstruct the patterns (make the constructors infix and
539
similar) at the same time that we create the constructors.
sof's avatar
sof committed
540 541

You can tell tuple constructors using
542
\begin{verbatim}
543
        Id.isTupleDataCon
544
\end{verbatim}
545
You can see if one constructor is infix with this clearer code :-))))))))))
546
\begin{verbatim}
sof's avatar
sof committed
547
        Lex.isLexConSym (Name.occNameString (Name.getOccName con))
548
\end{verbatim}
sof's avatar
sof committed
549 550 551 552

       Rather clumsy but it works. (Simon Peyton Jones)


553
We don't mind the @nilDataCon@ because it doesn't change the way to
Krzysztof Gogolewski's avatar
Typo  
Krzysztof Gogolewski committed
554
print the message, we are searching only for things like: @[1,2,3]@,
555
not @x:xs@ ....
sof's avatar
sof committed
556

557
In @reconstruct_pat@ we want to ``undo'' the work
558
that we have done in @tidy_pat@.
sof's avatar
sof committed
559
In particular:
560
\begin{tabular}{lll}
Ian Lynagh's avatar
Ian Lynagh committed
561
        @((,) x y)@   & returns to be & @(x, y)@
562 563 564
\\      @((:) x xs)@  & returns to be & @(x:xs)@
\\      @(x:(...:[])@ & returns to be & @[x,...]@
\end{tabular}
Austin Seipp's avatar
Austin Seipp committed
565

566
The difficult case is the third one becouse we need to follow all the
567 568
contructors until the @[]@ to know that we need to use the second case,
not the second. \fbox{\ ???\ }
Austin Seipp's avatar
Austin Seipp committed
569 570
-}

571
isInfixCon :: DataCon -> Bool
572
isInfixCon con = isDataSymOcc (getOccName con)
sof's avatar
sof committed
573

574
is_nil :: Pat Name -> Bool
575
is_nil (ConPatIn con (PrefixCon [])) = unLoc con == getName nilDataCon
Ian Lynagh's avatar
Ian Lynagh committed
576
is_nil _                             = False
sof's avatar
sof committed
577

578
is_list :: Pat Name -> Bool
579
is_list (ListPat _ _ Nothing) = True
sof's avatar
sof committed
580 581
is_list _             = False

582
return_list :: DataCon -> Pat Name -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
583
return_list id q = id == consDataCon && (is_nil q || is_list q)
sof's avatar
sof committed
584

585
make_list :: LPat Name -> Pat Name -> Pat Name
586 587
make_list p q | is_nil q    = ListPat [p] placeHolderType Nothing
make_list p (ListPat ps ty Nothing) = ListPat (p:ps) ty Nothing
588
make_list _ _               = panic "Check.make_list: Invalid argument"
sof's avatar
sof committed
589

Ian Lynagh's avatar
Ian Lynagh committed
590
make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat
cactus's avatar
cactus committed
591
make_con (ConPatOut{ pat_con = L _ (RealDataCon id) }) (lp:lq:ps, constraints)
592
     | return_list id q = (noLoc (make_list lp q) : ps, constraints)
Ian Lynagh's avatar
Ian Lynagh committed
593 594
     | isInfixCon id    = (nlInfixConPat (getName id) lp lq : ps, constraints)
   where q  = unLoc lq
595

596 597 598 599 600 601 602 603
make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats})
         (ps, constraints)
      | isTupleTyCon tc  = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) [])
                                : rest_pats, constraints)
      | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType)
                                : rest_pats, constraints)
      | otherwise        = (nlConPatName name pats_con
                                : rest_pats, constraints)
Ian Lynagh's avatar
Ian Lynagh committed
604 605 606 607
    where
        name                  = getName id
        (pats_con, rest_pats) = splitAtList pats ps
        tc                    = dataConTyCon id
chak's avatar
chak committed
608

Ian Lynagh's avatar
Ian Lynagh committed
609 610
make_con _ _ = panic "Check.make_con: Not ConPatOut"

chak's avatar
chak committed
611 612
-- reconstruct parallel array pattern
--
613
--  * don't check for the type only; we need to make sure that we are really
chak's avatar
chak committed
614
--   dealing with one of the fake constructors and not with the real
Ian Lynagh's avatar
Ian Lynagh committed
615
--   representation
sof's avatar
sof committed
616

617
make_whole_con :: DataCon -> WarningPat
618 619 620
make_whole_con con | isInfixCon con = nlInfixConPat name
                                           nlWildPatName nlWildPatName
                   | otherwise      = nlConPatName name pats
Ian Lynagh's avatar
Ian Lynagh committed
621
                where
sof's avatar
sof committed
622
                  name   = getName con
623
                  pats   = [nlWildPatName | _ <- dataConOrigArgTys con]
sof's avatar
sof committed
624

Austin Seipp's avatar
Austin Seipp committed
625
{-
626 627 628
------------------------------------------------------------------------
                   Tidying equations
------------------------------------------------------------------------
sof's avatar
sof committed
629

630
tidy_eqn does more or less the same thing as @tidy@ in @Match.hs@;
631 632
that is, it removes syntactic sugar, reducing the number of cases that
must be handled by the main checking algorithm.  One difference is
Ian Lynagh's avatar
Ian Lynagh committed
633
that here we can do *all* the tidying at once (recursively), rather
634
than doing it incrementally.
Austin Seipp's avatar
Austin Seipp committed
635
-}
sof's avatar
sof committed
636

637
tidy_eqn :: EquationInfo -> EquationInfo
Ian Lynagh's avatar
Ian Lynagh committed
638 639
tidy_eqn eqn = eqn { eqn_pats = map tidy_pat (eqn_pats eqn),
                     eqn_rhs  = tidy_rhs (eqn_rhs eqn) }
640
  where
Ian Lynagh's avatar
Ian Lynagh committed
641 642 643
        -- Horrible hack.  The tidy_pat stuff converts "might-fail" patterns to
        -- WildPats which of course loses the info that they can fail to match.
        -- So we stick in a CanFail as if it were a guard.
644
    tidy_rhs (MatchResult can_fail body)
Ian Lynagh's avatar
Ian Lynagh committed
645 646
        | any might_fail_pat (eqn_pats eqn) = MatchResult CanFail body
        | otherwise                         = MatchResult can_fail body
647

648 649
--------------
might_fail_pat :: Pat Id -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
650
-- Returns True of patterns that might fail (i.e. fall through) in a way
651
-- that is not covered by the checking algorithm.  Specifically:
Ian Lynagh's avatar
Ian Lynagh committed
652 653
--         NPlusKPat
--         ViewPat (if refutable)
cactus's avatar
cactus committed
654
--         ConPatOut of a PatSynCon
655 656

-- First the two special cases
Ian Lynagh's avatar
Ian Lynagh committed
657 658
might_fail_pat (NPlusKPat {})                = True
might_fail_pat (ViewPat _ p _)               = not (isIrrefutableHsPat p)
659 660

-- Now the recursive stuff
Ian Lynagh's avatar
Ian Lynagh committed
661 662 663
might_fail_pat (ParPat p)                    = might_fail_lpat p
might_fail_pat (AsPat _ p)                   = might_fail_lpat p
might_fail_pat (SigPatOut p _ )              = might_fail_lpat p
664 665
might_fail_pat (ListPat ps _ Nothing)        = any might_fail_lpat ps
might_fail_pat (ListPat _ _ (Just _))      = True
Ian Lynagh's avatar
Ian Lynagh committed
666 667 668
might_fail_pat (TuplePat ps _ _)             = any might_fail_lpat ps
might_fail_pat (PArrPat ps _)                = any might_fail_lpat ps
might_fail_pat (BangPat p)                   = might_fail_lpat p
cactus's avatar
cactus committed
669 670 671 672
might_fail_pat (ConPatOut { pat_con = con, pat_args = ps })
  = case unLoc con of
    RealDataCon _dcon -> any might_fail_lpat (hsConPatArgs ps)
    PatSynCon _psyn -> True
673 674 675

-- Finally the ones that are sure to succeed, or which are covered by the checking algorithm
might_fail_pat (LazyPat _)                   = False -- Always succeeds
dreixel's avatar
dreixel committed
676
might_fail_pat _                             = False -- VarPat, WildPat, LitPat, NPat
677 678 679 680 681 682

--------------
might_fail_lpat :: LPat Id -> Bool
might_fail_lpat (L _ p) = might_fail_pat p

--------------
Ian Lynagh's avatar
Ian Lynagh committed
683
tidy_lpat :: LPat Id -> LPat Id
684 685 686 687 688
tidy_lpat p = fmap tidy_pat p

--------------
tidy_pat :: Pat Id -> Pat Id
tidy_pat pat@(WildPat _)  = pat
Ian Lynagh's avatar
Ian Lynagh committed
689
tidy_pat (VarPat id)      = WildPat (idType id)
690
tidy_pat (ParPat p)       = tidy_pat (unLoc p)
Ian Lynagh's avatar
Ian Lynagh committed
691 692
tidy_pat (LazyPat p)      = WildPat (hsLPatType p)      -- For overlap and exhaustiveness checking
                                                        -- purposes, a ~pat is like a wildcard
693 694 695 696
tidy_pat (BangPat p)      = tidy_pat (unLoc p)
tidy_pat (AsPat _ p)      = tidy_pat (unLoc p)
tidy_pat (SigPatOut p _)  = tidy_pat (unLoc p)
tidy_pat (CoPat _ pat _)  = tidy_pat pat
697

698 699 700 701 702
-- These two are might_fail patterns, so we map them to
-- WildPats.  The might_fail_pat stuff arranges that the
-- guard says "this equation might fall through".
tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id))
tidy_pat (ViewPat _ _ ty)     = WildPat ty
703
tidy_pat (ListPat _ _ (Just (ty,_))) = WildPat ty
704 705
tidy_pat (ConPatOut { pat_con = L _ (PatSynCon syn), pat_arg_tys = tys })
  = WildPat (patSynInstResTy syn tys)
706

cactus's avatar
cactus committed
707 708
tidy_pat pat@(ConPatOut { pat_con = L _ con, pat_args = ps })
  = pat { pat_args = tidy_con con ps }