Check.lhs 29.2 KB
Newer Older
sof's avatar
sof committed
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
sof's avatar
sof committed
4
%
5
% Author: Juan J. Quintela    <quintela@krilin.dc.fi.udc.es>
sof's avatar
sof committed
6 7

\begin{code}
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
Gergő Érdi's avatar
Gergő Érdi committed
19
import ConLike
Simon Marlow's avatar
Simon Marlow committed
20
import DataCon
Gergő Érdi's avatar
Gergő Érdi 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 33
\end{code}

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.lhs@ 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}
sof's avatar
sof committed
98

99
\begin{code}
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 125 126
untidy_message (string, lits) = (string, map untidy_lit lits)
\end{code}

Gabor Greif's avatar
Gabor Greif committed
127
The function @untidy@ does the reverse work of the @tidy_pat@ function.
sof's avatar
sof committed
128

129 130
\begin{code}

Ian Lynagh's avatar
Ian Lynagh committed
131
type NeedPars = Bool
132 133 134 135 136 137 138 139

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
140 141
untidy b (L loc p) = L loc (untidy' b p)
  where
142 143 144 145
    untidy' _ p@(WildPat _)          = p
    untidy' _ p@(VarPat _)           = p
    untidy' _ (LitPat lit)           = LitPat (untidy_lit lit)
    untidy' _ p@(ConPatIn _ (PrefixCon [])) = p
146
    untidy' b (ConPatIn name ps)     = pars b (L loc (ConPatIn name (untidy_con ps)))
147
    untidy' _ (ListPat pats ty Nothing)     = ListPat (map untidy_no_pars pats) ty Nothing   
148
    untidy' _ (TuplePat pats box tys) = TuplePat (map untidy_no_pars pats) box tys
149
    untidy' _ (ListPat _ _ (Just _)) = panic "Check.untidy: Overloaded ListPat"    
Ian Lynagh's avatar
Ian Lynagh committed
150 151
    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
152 153 154 155 156 157
    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
158
    untidy' _ (SplicePat {})         = panic "Check.untidy: SplicePat"
Ian Lynagh's avatar
Ian Lynagh committed
159 160 161 162 163
    untidy' _ (QuasiQuotePat {})     = panic "Check.untidy: QuasiQuotePat"
    untidy' _ (NPat {})              = panic "Check.untidy: NPat"
    untidy' _ (NPlusKPat {})         = panic "Check.untidy: NPlusKPat"
    untidy' _ (SigPatOut {})         = panic "Check.untidy: SigPatOut"
    untidy' _ (CoPat {})             = panic "Check.untidy: CoPat"
164

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

172
pars :: NeedPars -> WarningPat -> Pat Name
173
pars True p = ParPat p
174
pars _    p = unLoc p
175 176 177

untidy_lit :: HsLit -> HsLit
untidy_lit (HsCharPrim c) = HsChar c
Ian Lynagh's avatar
Ian Lynagh committed
178
untidy_lit lit            = lit
sof's avatar
sof committed
179 180 181
\end{code}

This equation is the same that check, the only difference is that the
182 183
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,
184
@check'@ is called recursively.
sof's avatar
sof committed
185 186 187

There are several cases:

Ian Lynagh's avatar
Ian Lynagh committed
188 189
\begin{itemize}
\item There are no equations: Everything is OK.
sof's avatar
sof committed
190
\item There are only one equation, that can fail, and all the patterns are
Ian Lynagh's avatar
Ian Lynagh committed
191
      variables. Then that equation is used and the same equation is
192
      non-exhaustive.
Ian Lynagh's avatar
Ian Lynagh committed
193 194
\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
195
      and this equation is used also.
sof's avatar
sof committed
196

Ian Lynagh's avatar
Ian Lynagh committed
197 198
\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
199
      equation doesn't generate non-exhaustive cases.
sof's avatar
sof committed
200

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

204
\end{itemize}
sof's avatar
sof committed
205 206 207 208


\begin{code}

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

213 214 215 216
check' [] = ([],emptyUniqSet)
  -- Was    ([([],[])], emptyUniqSet)
  -- But that (a) seems weird, and (b) triggered Trac #7669 
  -- So now I'm just doing the simple obvious thing
sof's avatar
sof committed
217

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

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

Ian Lynagh's avatar
Ian Lynagh committed
225
   | first_eqn_all_vars         -- Several eqns, first can fail
226
   = (pats, addOneToUniqSet indexs n)
sof's avatar
sof committed
227
  where
228
    first_eqn_all_vars = all_vars ps
sof's avatar
sof committed
229
    (pats,indexs) = check' rs
sof's avatar
sof committed
230

231
check' qs
232 233 234 235
   | 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
236
                 -- Shouldn't happen
sof's avatar
sof committed
237
  where
sof's avatar
sof committed
238 239
     -- Note: RecPats will have been simplified to ConPats
     --       at this stage.
240 241 242 243
    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
244 245
\end{code}

246
Here begins the code to deal with literals, we need to split the matrix
Ian Lynagh's avatar
Ian Lynagh committed
247
in different matrix beginning by each literal and a last matrix with the
248
rest of values.
sof's avatar
sof committed
249 250

\begin{code}
251
split_by_literals :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
sof's avatar
sof committed
252 253 254 255 256
split_by_literals qs = process_literals used_lits qs
           where
             used_lits = get_used_lits qs
\end{code}

Ian Lynagh's avatar
Ian Lynagh committed
257 258
@process_explicit_literals@ is a function that process each literal that appears
in the column of the matrix.
sof's avatar
sof committed
259 260

\begin{code}
261
process_explicit_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
sof's avatar
sof committed
262
process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)
Ian Lynagh's avatar
Ian Lynagh committed
263
    where
sof's avatar
sof committed
264
      pats_indexs   = map (\x -> construct_literal_matrix x qs) lits
Ian Lynagh's avatar
Ian Lynagh committed
265
      (pats,indexs) = unzip pats_indexs
sof's avatar
sof committed
266 267 268
\end{code}


Ian Lynagh's avatar
Ian Lynagh committed
269 270
@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
271
must be one Variable to be complete.
sof's avatar
sof committed
272 273 274

\begin{code}

275
process_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
Ian Lynagh's avatar
Ian Lynagh committed
276
process_literals used_lits qs
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
277
  | null default_eqns  = ASSERT( not (null qs) ) ([make_row_vars used_lits (head qs)] ++ pats,indexs)
sof's avatar
sof committed
278
  | otherwise          = (pats_default,indexs_default)
sof's avatar
sof committed
279 280
     where
       (pats,indexs)   = process_explicit_literals used_lits qs
Ian Lynagh's avatar
Ian Lynagh committed
281 282 283
       default_eqns    = ASSERT2( okGroup qs, pprGroup qs )
                         [remove_var q | q <- qs, is_var (firstPatN q)]
       (pats',indexs') = check' default_eqns
284 285
       pats_default    = [(nlWildPatName:ps,constraints) |
                                        (ps,constraints) <- (pats')] ++ pats
sof's avatar
sof committed
286 287 288
       indexs_default  = unionUniqSets indexs' indexs
\end{code}

Ian Lynagh's avatar
Ian Lynagh committed
289
Here we have selected the literal and we will select all the equations that
290
begins for that literal and create a new matrix.
sof's avatar
sof committed
291 292

\begin{code}
293
construct_literal_matrix :: HsLit -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
sof's avatar
sof committed
294
construct_literal_matrix lit qs =
Ian Lynagh's avatar
Ian Lynagh committed
295
    (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)
sof's avatar
sof committed
296
  where
Ian Lynagh's avatar
Ian Lynagh committed
297
    (pats,indexs) = (check' (remove_first_column_lit lit qs))
298
    new_lit = nlLitPat lit
sof's avatar
sof committed
299 300

remove_first_column_lit :: HsLit
Ian Lynagh's avatar
Ian Lynagh committed
301
                        -> [(EqnNo, EquationInfo)]
302
                        -> [(EqnNo, EquationInfo)]
303
remove_first_column_lit lit qs
Ian Lynagh's avatar
Ian Lynagh committed
304
  = ASSERT2( okGroup qs, pprGroup qs )
305
    [(n, shift_pat eqn) | q@(n,eqn) <- qs, is_var_lit lit (firstPatN q)]
sof's avatar
sof committed
306
  where
307
     shift_pat eqn@(EqnInfo { eqn_pats = _:ps}) = eqn { eqn_pats = ps }
308
     shift_pat _                                = panic "Check.shift_var: no patterns"
sof's avatar
sof committed
309 310
\end{code}

Ian Lynagh's avatar
Ian Lynagh committed
311
This function splits the equations @qs@ in groups that deal with the
312
same constructor.
sof's avatar
sof committed
313 314

\begin{code}
315
split_by_constructor :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
Ian Lynagh's avatar
Ian Lynagh committed
316
split_by_constructor qs
Gergő Érdi's avatar
Gergő Érdi committed
317
  | null used_cons      = ([], mkUniqSet $ map fst qs)
Ian Lynagh's avatar
Ian Lynagh committed
318 319 320 321 322
  | 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
323 324
\end{code}

Ian Lynagh's avatar
Ian Lynagh committed
325
The first column of the patterns matrix only have vars, then there is
326
nothing to do.
sof's avatar
sof committed
327 328

\begin{code}
329
first_column_only_vars :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
330 331 332 333
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
334 335
\end{code}

Ian Lynagh's avatar
Ian Lynagh committed
336 337
This equation takes a matrix of patterns and split the equations by
constructor, using all the constructors that appears in the first column
338
of the pattern matching.
sof's avatar
sof committed
339

Ian Lynagh's avatar
Ian Lynagh committed
340
We can need a default clause or not ...., it depends if we used all the
341
constructors or not explicitly. The reasoning is similar to @process_literals@,
342
the difference is that here the default case is not always needed.
sof's avatar
sof committed
343 344

\begin{code}
345
no_need_default_case :: [Pat Id] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
sof's avatar
sof committed
346
no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
Ian Lynagh's avatar
Ian Lynagh committed
347
    where
sof's avatar
sof committed
348
      pats_indexs   = map (\x -> construct_matrix x qs) cons
Ian Lynagh's avatar
Ian Lynagh committed
349
      (pats,indexs) = unzip pats_indexs
sof's avatar
sof committed
350

351
need_default_case :: [Pat Id] -> [DataCon] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
Ian Lynagh's avatar
Ian Lynagh committed
352
need_default_case used_cons unused_cons qs
sof's avatar
sof committed
353 354
  | null default_eqns  = (pats_default_no_eqns,indexs)
  | otherwise          = (pats_default,indexs_default)
sof's avatar
sof committed
355 356
     where
       (pats,indexs)   = no_need_default_case used_cons qs
Ian Lynagh's avatar
Ian Lynagh committed
357 358 359 360
       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
361
                          c <- unused_cons, (ps,constraints) <- pats'] ++ pats
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
362
       new_wilds       = ASSERT( not (null qs) ) make_row_vars_for_constructor (head qs)
sof's avatar
sof committed
363 364 365
       pats_default_no_eqns =  [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats
       indexs_default  = unionUniqSets indexs' indexs

366
construct_matrix :: Pat Id -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
sof's avatar
sof committed
367
construct_matrix con qs =
Ian Lynagh's avatar
Ian Lynagh committed
368
    (map (make_con con) pats,indexs)
sof's avatar
sof committed
369
  where
Ian Lynagh's avatar
Ian Lynagh committed
370
    (pats,indexs) = (check' (remove_first_column con qs))
sof's avatar
sof committed
371 372
\end{code}

Ian Lynagh's avatar
Ian Lynagh committed
373
Here remove first column is more difficult that with literals due to the fact
374
that constructors can have arguments.
sof's avatar
sof committed
375

376
For instance, the matrix
377
\begin{verbatim}
sof's avatar
sof committed
378 379
 (: x xs) y
 z        y
380
\end{verbatim}
sof's avatar
sof committed
381
is transformed in:
382
\begin{verbatim}
sof's avatar
sof committed
383 384
 x xs y
 _ _  y
385
\end{verbatim}
sof's avatar
sof committed
386 387

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

403 404
make_row_vars :: [HsLit] -> (EqnNo, EquationInfo) -> ExhaustivePat
make_row_vars used_lits (_, EqnInfo { eqn_pats = pats})
405 406
   = (nlVarPat new_var:takeList (tail pats) (repeat nlWildPatName)
     ,[(new_var,used_lits)])
Ian Lynagh's avatar
Ian Lynagh committed
407
  where
408
     new_var = hash_x
409

410
hash_x :: Name
411
hash_x = mkInternalName unboundKey {- doesn't matter much -}
Ian Lynagh's avatar
Ian Lynagh committed
412 413
                     (mkVarOccFS (fsLit "#x"))
                     noSrcSpan
sof's avatar
sof committed
414

415
make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat]
Ian Lynagh's avatar
Ian Lynagh committed
416
make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats})
417
  = takeList (tail pats) (repeat nlWildPatName)
sof's avatar
sof committed
418

419
compare_cons :: Pat Id -> Pat Id -> Bool
Gergő Érdi's avatar
Gergő Érdi committed
420 421 422 423 424
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
425

426
remove_dups :: [Pat Id] -> [Pat Id]
sof's avatar
sof committed
427
remove_dups []     = []
Joachim Breitner's avatar
Joachim Breitner committed
428 429
remove_dups (x:xs) | any (\y -> compare_cons x y) xs = remove_dups  xs
                   | otherwise                       = x : remove_dups xs
sof's avatar
sof committed
430

431
get_used_cons :: [(EqnNo, EquationInfo)] -> [Pat Id]
Ian Lynagh's avatar
Ian Lynagh committed
432 433
get_used_cons qs = remove_dups [pat | q <- qs, let pat = firstPatN q,
                                      isConPatOut pat]
434

435
isConPatOut :: Pat Id -> Bool
Gergő Érdi's avatar
Gergő Érdi committed
436 437
isConPatOut ConPatOut{ pat_con = L _ RealDataCon{} } = True
isConPatOut _                                        = False
sof's avatar
sof committed
438

Ian Lynagh's avatar
Ian Lynagh committed
439
remove_dups' :: [HsLit] -> [HsLit]
sof's avatar
sof committed
440 441
remove_dups' []                   = []
remove_dups' (x:xs) | x `elem` xs = remove_dups' xs
Ian Lynagh's avatar
Ian Lynagh committed
442
                    | otherwise   = x : remove_dups' xs
sof's avatar
sof committed
443 444


445
get_used_lits :: [(EqnNo, EquationInfo)] -> [HsLit]
446
get_used_lits qs = remove_dups' all_literals
Ian Lynagh's avatar
Ian Lynagh committed
447 448
                 where
                   all_literals = get_used_lits' qs
sof's avatar
sof committed
449

450
get_used_lits' :: [(EqnNo, EquationInfo)] -> [HsLit]
451
get_used_lits' [] = []
Ian Lynagh's avatar
Ian Lynagh committed
452
get_used_lits' (q:qs)
453
  | Just lit <- get_lit (firstPatN q) = lit : get_used_lits' qs
Ian Lynagh's avatar
Ian Lynagh committed
454
  | otherwise                         = get_used_lits qs
sof's avatar
sof committed
455

Ian Lynagh's avatar
Ian Lynagh committed
456
get_lit :: Pat id -> Maybe HsLit
457 458 459
-- 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
460
get_lit (LitPat lit)                                      = Just lit
461 462
get_lit (NPat (OverLit { ol_val = HsIntegral i})    mb _) = Just (HsIntPrim   (mb_neg negate              mb i))
get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg negateFractionalLit mb f))
463
get_lit (NPat (OverLit { ol_val = HsIsString s })   _  _) = Just (HsStringPrim (fastStringToByteString s))
Ian Lynagh's avatar
Ian Lynagh committed
464
get_lit _                                                 = Nothing
465

466 467 468
mb_neg :: (a -> a) -> Maybe b -> a -> a
mb_neg _      Nothing  v = v
mb_neg negate (Just _) v = negate v
469

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

481 482 483 484
all_vars :: [Pat Id] -> Bool
all_vars []             = True
all_vars (WildPat _:ps) = all_vars ps
all_vars _              = False
sof's avatar
sof committed
485

486 487 488
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
489

490
-----------------------
491 492
eqnPats :: (EqnNo, EquationInfo) -> [Pat Id]
eqnPats (_, eqn) = eqn_pats eqn
493

494
okGroup :: [(EqnNo, EquationInfo)] -> Bool
495 496 497 498
-- 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
499 500
               where
                 n_pats = length (eqnPats e)
501 502

-- Half-baked print
503 504
pprGroup :: [(EqnNo, EquationInfo)] -> SDoc
pprEqnInfo :: (EqnNo, EquationInfo) -> SDoc
505 506 507
pprGroup es = vcat (map pprEqnInfo es)
pprEqnInfo e = ppr (eqnPats e)

508 509 510 511

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

512
is_con :: Pat Id -> Bool
513 514
is_con (ConPatOut {}) = True
is_con _              = False
515

516
is_lit :: Pat Id -> Bool
517
is_lit (LitPat _)      = True
518
is_lit (NPat _ _ _)  = True
519 520
is_lit _               = False

521
is_var :: Pat Id -> Bool
522 523 524
is_var (WildPat _) = True
is_var _           = False

Gergő Érdi's avatar
Gergő Érdi committed
525 526 527 528
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
529

530
is_var_lit :: HsLit -> Pat Id -> Bool
531
is_var_lit _   (WildPat _)   = True
Ian Lynagh's avatar
Ian Lynagh committed
532
is_var_lit lit pat
533
  | Just lit' <- get_lit pat = lit == lit'
Ian Lynagh's avatar
Ian Lynagh committed
534
  | otherwise                = False
sof's avatar
sof committed
535 536
\end{code}

537 538 539 540
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
541

542
We need to reconstruct the patterns (make the constructors infix and
543
similar) at the same time that we create the constructors.
sof's avatar
sof committed
544 545

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

       Rather clumsy but it works. (Simon Peyton Jones)


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

561
In @reconstruct_pat@ we want to ``undo'' the work
562
that we have done in @tidy_pat@.
sof's avatar
sof committed
563
In particular:
564
\begin{tabular}{lll}
Ian Lynagh's avatar
Ian Lynagh committed
565
        @((,) x y)@   & returns to be & @(x, y)@
566 567 568 569
\\      @((:) x xs)@  & returns to be & @(x:xs)@
\\      @(x:(...:[])@ & returns to be & @[x,...]@
\end{tabular}
%
570
The difficult case is the third one becouse we need to follow all the
571 572 573
contructors until the @[]@ to know that we need to use the second case,
not the second. \fbox{\ ???\ }
%
sof's avatar
sof committed
574
\begin{code}
575
isInfixCon :: DataCon -> Bool
576
isInfixCon con = isDataSymOcc (getOccName con)
sof's avatar
sof committed
577

578
is_nil :: Pat Name -> Bool
579
is_nil (ConPatIn con (PrefixCon [])) = unLoc con == getName nilDataCon
Ian Lynagh's avatar
Ian Lynagh committed
580
is_nil _                             = False
sof's avatar
sof committed
581

582
is_list :: Pat Name -> Bool
583
is_list (ListPat _ _ Nothing) = True
sof's avatar
sof committed
584 585
is_list _             = False

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

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

Ian Lynagh's avatar
Ian Lynagh committed
594
make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat
Gergő Érdi's avatar
Gergő Érdi committed
595
make_con (ConPatOut{ pat_con = L _ (RealDataCon id) }) (lp:lq:ps, constraints)
596
     | return_list id q = (noLoc (make_list lp q) : ps, constraints)
Ian Lynagh's avatar
Ian Lynagh committed
597 598
     | isInfixCon id    = (nlInfixConPat (getName id) lp lq : ps, constraints)
   where q  = unLoc lq
599

600 601 602 603 604 605 606 607
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
608 609 610 611
    where
        name                  = getName id
        (pats_con, rest_pats) = splitAtList pats ps
        tc                    = dataConTyCon id
chak's avatar
chak committed
612

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

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

621
make_whole_con :: DataCon -> WarningPat
622 623 624
make_whole_con con | isInfixCon con = nlInfixConPat name
                                           nlWildPatName nlWildPatName
                   | otherwise      = nlConPatName name pats
Ian Lynagh's avatar
Ian Lynagh committed
625
                where
sof's avatar
sof committed
626
                  name   = getName con
627
                  pats   = [nlWildPatName | _ <- dataConOrigArgTys con]
sof's avatar
sof committed
628 629
\end{code}

630 631 632
------------------------------------------------------------------------
                   Tidying equations
------------------------------------------------------------------------
sof's avatar
sof committed
633

634 635 636
tidy_eqn does more or less the same thing as @tidy@ in @Match.lhs@;
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
637
that here we can do *all* the tidying at once (recursively), rather
638
than doing it incrementally.
sof's avatar
sof committed
639

640 641
\begin{code}
tidy_eqn :: EquationInfo -> EquationInfo
Ian Lynagh's avatar
Ian Lynagh committed
642 643
tidy_eqn eqn = eqn { eqn_pats = map tidy_pat (eqn_pats eqn),
                     eqn_rhs  = tidy_rhs (eqn_rhs eqn) }
644
  where
Ian Lynagh's avatar
Ian Lynagh committed
645 646 647
        -- 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.
648
    tidy_rhs (MatchResult can_fail body)
Ian Lynagh's avatar
Ian Lynagh committed
649 650
        | any might_fail_pat (eqn_pats eqn) = MatchResult CanFail body
        | otherwise                         = MatchResult can_fail body
651

652 653
--------------
might_fail_pat :: Pat Id -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
654
-- Returns True of patterns that might fail (i.e. fall through) in a way
655
-- that is not covered by the checking algorithm.  Specifically:
Ian Lynagh's avatar
Ian Lynagh committed
656 657
--         NPlusKPat
--         ViewPat (if refutable)
Gergő Érdi's avatar
Gergő Érdi committed
658
--         ConPatOut of a PatSynCon
659 660

-- First the two special cases
Ian Lynagh's avatar
Ian Lynagh committed
661 662
might_fail_pat (NPlusKPat {})                = True
might_fail_pat (ViewPat _ p _)               = not (isIrrefutableHsPat p)
663 664

-- Now the recursive stuff
Ian Lynagh's avatar
Ian Lynagh committed
665 666 667
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
668 669
might_fail_pat (ListPat ps _ Nothing)        = any might_fail_lpat ps
might_fail_pat (ListPat _ _ (Just _))      = True
Ian Lynagh's avatar
Ian Lynagh committed
670 671 672
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
Gergő Érdi's avatar
Gergő Érdi committed
673 674 675 676
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
677 678 679

-- 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
680
might_fail_pat _                             = False -- VarPat, WildPat, LitPat, NPat
681 682 683 684 685 686

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

--------------
Ian Lynagh's avatar
Ian Lynagh committed
687
tidy_lpat :: LPat Id -> LPat Id
688 689 690 691 692
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
693
tidy_pat (VarPat id)      = WildPat (idType id)
694
tidy_pat (ParPat p)       = tidy_pat (unLoc p)
Ian Lynagh's avatar
Ian Lynagh committed
695 696
tidy_pat (LazyPat p)      = WildPat (hsLPatType p)      -- For overlap and exhaustiveness checking
                                                        -- purposes, a ~pat is like a wildcard
697 698 699 700
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
701

702 703 704 705 706
-- 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
707
tidy_pat (ListPat _ _ (Just (ty,_))) = WildPat ty
708 709
tidy_pat (ConPatOut { pat_con = L _ (PatSynCon syn), pat_arg_tys = tys })
  = WildPat (patSynInstResTy syn tys)
710

Gergő Érdi's avatar
Gergő Érdi committed
711 712
tidy_pat pat@(ConPatOut { pat_con = L _ con, pat_args = ps })
  = pat { pat_args = tidy_con con ps }
sof's avatar
sof committed
713

714
tidy_pat (ListPat ps ty Nothing)
715 716
  = unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] [ty])
                                  (mkNilPat ty)
Ian Lynagh's avatar
Ian Lynagh committed
717
                                  (map tidy_lpat ps)
sof's avatar
sof committed
718

chak's avatar
chak committed
719 720 721
-- introduce fake parallel array constructors to be able to handle parallel
-- arrays with the existing machinery for constructor pattern
--
722
tidy_pat (PArrPat ps ty)
723
  = unLoc $ mkPrefixConPat (parrFakeCon (length ps))
Ian Lynagh's avatar
Ian Lynagh committed
724
                           (map tidy_lpat ps)
725
                           [ty]
sof's avatar
sof committed
726

727
tidy_pat (TuplePat ps boxity tys)
batterseapower's avatar
batterseapower committed
728
  = unLoc $ mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity)
729
                           (map tidy_lpat ps) tys
730 731 732
  where
    arity = length ps

733 734 735
tidy_pat (NPat lit mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq
tidy_pat (LitPat lit)         = tidy_lit_pat lit

Ian Lynagh's avatar
Ian Lynagh committed
736
tidy_pat (ConPatIn {})        = panic "Check.tidy_pat: ConPatIn"
gmainland's avatar
gmainland committed
737
tidy_pat (SplicePat {})       = panic "Check.tidy_pat: SplicePat"