04ba5681b033a61575536fbaf816af0a42f317b4
[ghc.git] / compiler / deSugar / Check.hs
1 {-
2 Author: George Karachalias <george.karachalias@cs.kuleuven.be>
3
4 Pattern Matching Coverage Checking.
5 -}
6
7 {-# LANGUAGE CPP, GADTs, DataKinds, KindSignatures #-}
8
9 module Check (
10 -- Checking and printing
11 checkSingle, checkMatches, isAnyPmCheckEnabled,
12
13 -- See Note [Type and Term Equality Propagation]
14 genCaseTmCs1, genCaseTmCs2
15 ) where
16
17 #include "HsVersions.h"
18
19 import TmOracle
20
21 import DynFlags
22 import HsSyn
23 import TcHsSyn
24 import Id
25 import ConLike
26 import DataCon
27 import Name
28 import FamInstEnv
29 import TysWiredIn
30 import TyCon
31 import SrcLoc
32 import Util
33 import Outputable
34 import FastString
35
36 import DsMonad
37 import TcSimplify (tcCheckSatisfiability)
38 import TcType (toTcType, isStringTy, isIntTy, isWordTy)
39 import Bag
40 import ErrUtils
41 import Var (EvVar)
42 import Type
43 import UniqSupply
44 import DsGRHSs (isTrueLHsExpr)
45
46 import Data.List (find)
47 import Data.Maybe (isJust)
48 import Control.Monad (forM, when, forM_)
49 import Coercion
50 import TcEvidence
51 import IOEnv
52
53 import ListT (ListT(..), fold)
54
55 {-
56 This module checks pattern matches for:
57 \begin{enumerate}
58 \item Equations that are redundant
59 \item Equations with inaccessible right-hand-side
60 \item Exhaustiveness
61 \end{enumerate}
62
63 The algorithm is based on the paper:
64
65 "GADTs Meet Their Match:
66 Pattern-matching Warnings That Account for GADTs, Guards, and Laziness"
67
68 http://people.cs.kuleuven.be/~george.karachalias/papers/p424-karachalias.pdf
69
70 %************************************************************************
71 %* *
72 Pattern Match Check Types
73 %* *
74 %************************************************************************
75 -}
76
77 -- We use the non-determinism monad to apply the algorithm to several
78 -- possible sets of constructors. Users can specify complete sets of
79 -- constructors by using COMPLETE pragmas.
80 -- The algorithm only picks out constructor
81 -- sets deep in the bowels which makes a simpler `mapM` more difficult to
82 -- implement. The non-determinism is only used in one place, see the ConVar
83 -- case in `pmCheckHd`.
84
85 type PmM a = ListT DsM a
86
87 liftD :: DsM a -> PmM a
88 liftD m = ListT $ \sk fk -> m >>= \a -> sk a fk
89
90
91 myRunListT :: PmM a -> DsM [a]
92 myRunListT pm = fold pm go (return [])
93 where
94 go a mas =
95 mas >>= \as -> return (a:as)
96
97 data PatTy = PAT | VA -- Used only as a kind, to index PmPat
98
99 -- The *arity* of a PatVec [p1,..,pn] is
100 -- the number of p1..pn that are not Guards
101
102 data PmPat :: PatTy -> * where
103 PmCon :: { pm_con_con :: DataCon
104 , pm_con_arg_tys :: [Type]
105 , pm_con_tvs :: [TyVar]
106 , pm_con_dicts :: [EvVar]
107 , pm_con_args :: [PmPat t] } -> PmPat t
108 -- For PmCon arguments' meaning see @ConPatOut@ in hsSyn/HsPat.hs
109 PmVar :: { pm_var_id :: Id } -> PmPat t
110 PmLit :: { pm_lit_lit :: PmLit } -> PmPat t -- See Note [Literals in PmPat]
111 PmNLit :: { pm_lit_id :: Id
112 , pm_lit_not :: [PmLit] } -> PmPat 'VA
113 PmGrd :: { pm_grd_pv :: PatVec
114 , pm_grd_expr :: PmExpr } -> PmPat 'PAT
115
116 -- data T a where
117 -- MkT :: forall p q. (Eq p, Ord q) => p -> q -> T [p]
118 -- or MkT :: forall p q r. (Eq p, Ord q, [p] ~ r) => p -> q -> T r
119
120 type Pattern = PmPat 'PAT -- ^ Patterns
121 type ValAbs = PmPat 'VA -- ^ Value Abstractions
122
123 type PatVec = [Pattern] -- ^ Pattern Vectors
124 data ValVec = ValVec [ValAbs] Delta -- ^ Value Vector Abstractions
125
126 -- | Term and type constraints to accompany each value vector abstraction.
127 -- For efficiency, we store the term oracle state instead of the term
128 -- constraints. TODO: Do the same for the type constraints?
129 data Delta = MkDelta { delta_ty_cs :: Bag EvVar
130 , delta_tm_cs :: TmState }
131
132 type ValSetAbs = [ValVec] -- ^ Value Set Abstractions
133 type Uncovered = ValSetAbs
134
135 -- Instead of keeping the whole sets in memory, we keep a boolean for both the
136 -- covered and the divergent set (we store the uncovered set though, since we
137 -- want to print it). For both the covered and the divergent we have:
138 --
139 -- True <=> The set is non-empty
140 --
141 -- hence:
142 -- C = True ==> Useful clause (no warning)
143 -- C = False, D = True ==> Clause with inaccessible RHS
144 -- C = False, D = False ==> Redundant clause
145
146 data Covered = Covered | NotCovered
147 deriving Show
148
149 instance Outputable Covered where
150 ppr (Covered) = text "Covered"
151 ppr (NotCovered) = text "NotCovered"
152
153 -- Like the or monoid for booleans
154 -- Covered = True, Uncovered = False
155 instance Monoid Covered where
156 mempty = NotCovered
157 Covered `mappend` _ = Covered
158 _ `mappend` Covered = Covered
159 NotCovered `mappend` NotCovered = NotCovered
160
161 data Diverged = Diverged | NotDiverged
162 deriving Show
163
164 instance Outputable Diverged where
165 ppr Diverged = text "Diverged"
166 ppr NotDiverged = text "NotDiverged"
167
168 instance Monoid Diverged where
169 mempty = NotDiverged
170 Diverged `mappend` _ = Diverged
171 _ `mappend` Diverged = Diverged
172 NotDiverged `mappend` NotDiverged = NotDiverged
173
174 data PartialResult = PartialResult {
175 presultCovered :: Covered
176 , presultUncovered :: Uncovered
177 , presultDivergent :: Diverged }
178
179 instance Outputable PartialResult where
180 ppr (PartialResult c vsa d) = text "PartialResult" <+> ppr c
181 <+> ppr d <+> ppr vsa
182
183 instance Monoid PartialResult where
184 mempty = PartialResult mempty [] mempty
185 (PartialResult cs1 vsa1 ds1)
186 `mappend` (PartialResult cs2 vsa2 ds2)
187 = PartialResult (cs1 `mappend` cs2)
188 (vsa1 `mappend` vsa2)
189 (ds1 `mappend` ds2)
190
191 -- newtype ChoiceOf a = ChoiceOf [a]
192
193 -- | Pattern check result
194 --
195 -- * Redundant clauses
196 -- * Not-covered clauses
197 -- * Clauses with inaccessible RHS
198 data PmResult =
199 PmResult {
200 pmresultRedundant :: [Located [LPat Id]]
201 , pmresultUncovered :: Uncovered
202 , pmresultInaccessible :: [Located [LPat Id]] }
203
204 {-
205 %************************************************************************
206 %* *
207 Entry points to the checker: checkSingle and checkMatches
208 %* *
209 %************************************************************************
210 -}
211
212 -- | Check a single pattern binding (let)
213 checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat Id -> DsM ()
214 checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do
215 tracePmD "checkSingle" (vcat [ppr ctxt, ppr var, ppr p])
216 mb_pm_res <- tryM (head <$> myRunListT (checkSingle' locn var p))
217 case mb_pm_res of
218 Left _ -> warnPmIters dflags ctxt
219 Right res -> dsPmWarn dflags ctxt res
220
221 -- | Check a single pattern binding (let)
222 checkSingle' :: SrcSpan -> Id -> Pat Id -> PmM PmResult
223 checkSingle' locn var p = do
224 liftD resetPmIterDs -- set the iter-no to zero
225 fam_insts <- liftD dsGetFamInstEnvs
226 clause <- liftD $ translatePat fam_insts p
227 missing <- mkInitialUncovered [var]
228 tracePm "checkSingle: missing" (vcat (map pprValVecDebug missing))
229 PartialResult cs us ds <- runMany (pmcheckI clause []) missing -- no guards
230 return $ case (cs,ds) of
231 (Covered, _ ) -> PmResult [] us [] -- useful
232 (NotCovered, NotDiverged) -> PmResult m us [] -- redundant
233 (NotCovered, Diverged ) -> PmResult [] us m -- inaccessible rhs
234 where m = [L locn [L locn p]]
235
236 -- | Check a matchgroup (case, functions, etc.)
237 checkMatches :: DynFlags -> DsMatchContext
238 -> [Id] -> [LMatch Id (LHsExpr Id)] -> DsM ()
239 checkMatches dflags ctxt vars matches = do
240 tracePmD "checkMatches" (hang (vcat [ppr ctxt
241 , ppr vars
242 , text "Matches:"])
243 2
244 (vcat (map ppr matches)))
245 mb_pm_res <- tryM (head <$> myRunListT (checkMatches' vars matches))
246 case mb_pm_res of
247 Left _ -> warnPmIters dflags ctxt
248 Right res -> dsPmWarn dflags ctxt res
249
250 -- | Check a matchgroup (case, functions, etc.)
251 checkMatches' :: [Id] -> [LMatch Id (LHsExpr Id)] -> PmM PmResult
252 checkMatches' vars matches
253 | null matches = return $ PmResult [] [] []
254 | otherwise = do
255 liftD resetPmIterDs -- set the iter-no to zero
256 missing <- mkInitialUncovered vars
257 tracePm "checkMatches: missing" (vcat (map pprValVecDebug missing))
258 (rs,us,ds) <- go matches missing
259 return $ PmResult (map hsLMatchToLPats rs) us (map hsLMatchToLPats ds)
260 where
261 go :: [LMatch Id (LHsExpr Id)] -> Uncovered
262 -> PmM ([LMatch Id (LHsExpr Id)] , Uncovered , [LMatch Id (LHsExpr Id)])
263 go [] missing = return ([], missing, [])
264 go (m:ms) missing = do
265 tracePm "checMatches': go" (ppr m $$ ppr missing)
266 fam_insts <- liftD dsGetFamInstEnvs
267 (clause, guards) <- liftD $ translateMatch fam_insts m
268 r@(PartialResult cs missing' ds)
269 <- runMany (pmcheckI clause guards) missing
270 tracePm "checMatches': go: res" (ppr r)
271 (rs, final_u, is) <- go ms missing'
272 return $ case (cs, ds) of
273 (Covered, _ ) -> ( rs, final_u, is) -- useful
274 (NotCovered, NotDiverged) -> (m:rs, final_u, is) -- redundant
275 (NotCovered, Diverged ) -> ( rs, final_u, m:is) -- inaccessible
276
277 hsLMatchToLPats :: LMatch id body -> Located [LPat id]
278 hsLMatchToLPats (L l (Match _ pats _ _)) = L l pats
279
280 {-
281 %************************************************************************
282 %* *
283 Transform source syntax to *our* syntax
284 %* *
285 %************************************************************************
286 -}
287
288 -- -----------------------------------------------------------------------
289 -- * Utilities
290
291 nullaryConPattern :: DataCon -> Pattern
292 -- Nullary data constructor and nullary type constructor
293 nullaryConPattern con =
294 PmCon { pm_con_con = con, pm_con_arg_tys = []
295 , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = [] }
296 {-# INLINE nullaryConPattern #-}
297
298 truePattern :: Pattern
299 truePattern = nullaryConPattern trueDataCon
300 {-# INLINE truePattern #-}
301
302 -- | A fake guard pattern (True <- _) used to represent cases we cannot handle
303 fake_pat :: Pattern
304 fake_pat = PmGrd { pm_grd_pv = [truePattern]
305 , pm_grd_expr = PmExprOther EWildPat }
306 {-# INLINE fake_pat #-}
307
308 -- | Check whether a guard pattern is generated by the checker (unhandled)
309 isFakeGuard :: [Pattern] -> PmExpr -> Bool
310 isFakeGuard [PmCon { pm_con_con = c }] (PmExprOther EWildPat)
311 | c == trueDataCon = True
312 | otherwise = False
313 isFakeGuard _pats _e = False
314
315 -- | Generate a `canFail` pattern vector of a specific type
316 mkCanFailPmPat :: Type -> DsM PatVec
317 mkCanFailPmPat ty = do
318 var <- mkPmVar ty
319 return [var, fake_pat]
320
321 vanillaConPattern :: DataCon -> [Type] -> PatVec -> Pattern
322 -- ADT constructor pattern => no existentials, no local constraints
323 vanillaConPattern con arg_tys args =
324 PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys
325 , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = args }
326 {-# INLINE vanillaConPattern #-}
327
328 -- | Create an empty list pattern of a given type
329 nilPattern :: Type -> Pattern
330 nilPattern ty =
331 PmCon { pm_con_con = nilDataCon, pm_con_arg_tys = [ty]
332 , pm_con_tvs = [], pm_con_dicts = []
333 , pm_con_args = [] }
334 {-# INLINE nilPattern #-}
335
336 mkListPatVec :: Type -> PatVec -> PatVec -> PatVec
337 mkListPatVec ty xs ys = [PmCon { pm_con_con = consDataCon
338 , pm_con_arg_tys = [ty]
339 , pm_con_tvs = [], pm_con_dicts = []
340 , pm_con_args = xs++ys }]
341 {-# INLINE mkListPatVec #-}
342
343 -- | Create a (non-overloaded) literal pattern
344 mkLitPattern :: HsLit -> Pattern
345 mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit }
346 {-# INLINE mkLitPattern #-}
347
348 -- -----------------------------------------------------------------------
349 -- * Transform (Pat Id) into of (PmPat Id)
350
351 translatePat :: FamInstEnvs -> Pat Id -> DsM PatVec
352 translatePat fam_insts pat = case pat of
353 WildPat ty -> mkPmVars [ty]
354 VarPat id -> return [PmVar (unLoc id)]
355 ParPat p -> translatePat fam_insts (unLoc p)
356 LazyPat _ -> mkPmVars [hsPatType pat] -- like a variable
357
358 -- ignore strictness annotations for now
359 BangPat p -> translatePat fam_insts (unLoc p)
360
361 AsPat lid p -> do
362 -- Note [Translating As Patterns]
363 ps <- translatePat fam_insts (unLoc p)
364 let [e] = map vaToPmExpr (coercePatVec ps)
365 g = PmGrd [PmVar (unLoc lid)] e
366 return (ps ++ [g])
367
368 SigPatOut p _ty -> translatePat fam_insts (unLoc p)
369
370 -- See Note [Translate CoPats]
371 CoPat wrapper p ty
372 | isIdHsWrapper wrapper -> translatePat fam_insts p
373 | WpCast co <- wrapper, isReflexiveCo co -> translatePat fam_insts p
374 | otherwise -> do
375 ps <- translatePat fam_insts p
376 (xp,xe) <- mkPmId2Forms ty
377 let g = mkGuard ps (HsWrap wrapper (unLoc xe))
378 return [xp,g]
379
380 -- (n + k) ===> x (True <- x >= k) (n <- x-k)
381 NPlusKPat (L _ _n) _k1 _k2 _ge _minus ty -> mkCanFailPmPat ty
382
383 -- (fun -> pat) ===> x (pat <- fun x)
384 ViewPat lexpr lpat arg_ty -> do
385 ps <- translatePat fam_insts (unLoc lpat)
386 -- See Note [Guards and Approximation]
387 case all cantFailPattern ps of
388 True -> do
389 (xp,xe) <- mkPmId2Forms arg_ty
390 let g = mkGuard ps (HsApp lexpr xe)
391 return [xp,g]
392 False -> mkCanFailPmPat arg_ty
393
394 -- list
395 ListPat ps ty Nothing -> do
396 foldr (mkListPatVec ty) [nilPattern ty]
397 <$> translatePatVec fam_insts (map unLoc ps)
398
399 -- overloaded list
400 ListPat lpats elem_ty (Just (pat_ty, _to_list))
401 | Just e_ty <- splitListTyConApp_maybe pat_ty
402 , (_, norm_elem_ty) <- normaliseType fam_insts Nominal elem_ty
403 -- elem_ty is frequently something like
404 -- `Item [Int]`, but we prefer `Int`
405 , norm_elem_ty `eqType` e_ty ->
406 -- We have to ensure that the element types are exactly the same.
407 -- Otherwise, one may give an instance IsList [Int] (more specific than
408 -- the default IsList [a]) with a different implementation for `toList'
409 translatePat fam_insts (ListPat lpats e_ty Nothing)
410 -- See Note [Guards and Approximation]
411 | otherwise -> mkCanFailPmPat pat_ty
412
413 ConPatOut { pat_con = L _ (PatSynCon _) } ->
414 -- Pattern synonyms have a "matcher"
415 -- (see Note [Pattern synonym representation] in PatSyn.hs
416 -- We should be able to transform (P x y)
417 -- to v (Just (x, y) <- matchP v (\x y -> Just (x,y)) Nothing
418 -- That is, a combination of a variable pattern and a guard
419 -- But there are complications with GADTs etc, and this isn't done yet
420 mkCanFailPmPat (hsPatType pat)
421
422 ConPatOut { pat_con = L _ (RealDataCon con)
423 , pat_arg_tys = arg_tys
424 , pat_tvs = ex_tvs
425 , pat_dicts = dicts
426 , pat_args = ps } -> do
427 args <- translateConPatVec fam_insts arg_tys ex_tvs con ps
428 return [PmCon { pm_con_con = con
429 , pm_con_arg_tys = arg_tys
430 , pm_con_tvs = ex_tvs
431 , pm_con_dicts = dicts
432 , pm_con_args = args }]
433
434 NPat (L _ ol) mb_neg _eq ty -> translateNPat fam_insts ol mb_neg ty
435
436 LitPat lit
437 -- If it is a string then convert it to a list of characters
438 | HsString src s <- lit ->
439 foldr (mkListPatVec charTy) [nilPattern charTy] <$>
440 translatePatVec fam_insts (map (LitPat . HsChar src) (unpackFS s))
441 | otherwise -> return [mkLitPattern lit]
442
443 PArrPat ps ty -> do
444 tidy_ps <- translatePatVec fam_insts (map unLoc ps)
445 let fake_con = parrFakeCon (length ps)
446 return [vanillaConPattern fake_con [ty] (concat tidy_ps)]
447
448 TuplePat ps boxity tys -> do
449 tidy_ps <- translatePatVec fam_insts (map unLoc ps)
450 let tuple_con = tupleDataCon boxity (length ps)
451 return [vanillaConPattern tuple_con tys (concat tidy_ps)]
452
453 SumPat p alt arity ty -> do
454 tidy_p <- translatePat fam_insts (unLoc p)
455 let sum_con = sumDataCon alt arity
456 return [vanillaConPattern sum_con ty tidy_p]
457
458 -- --------------------------------------------------------------------------
459 -- Not supposed to happen
460 ConPatIn {} -> panic "Check.translatePat: ConPatIn"
461 SplicePat {} -> panic "Check.translatePat: SplicePat"
462 SigPatIn {} -> panic "Check.translatePat: SigPatIn"
463
464 -- | Translate an overloaded literal (see `tidyNPat' in deSugar/MatchLit.hs)
465 translateNPat :: FamInstEnvs
466 -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> Type -> DsM PatVec
467 translateNPat fam_insts (OverLit val False _ ty) mb_neg outer_ty
468 | not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg
469 = translatePat fam_insts (LitPat (HsString src s))
470 | not type_change, isIntTy ty, HsIntegral src i <- val
471 = translatePat fam_insts (mk_num_lit HsInt src i)
472 | not type_change, isWordTy ty, HsIntegral src i <- val
473 = translatePat fam_insts (mk_num_lit HsWordPrim src i)
474 where
475 type_change = not (outer_ty `eqType` ty)
476 mk_num_lit c src i = LitPat $ case mb_neg of
477 Nothing -> c src i
478 Just _ -> c src (-i)
479 translateNPat _ ol mb_neg _
480 = return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) ol }]
481
482 -- | Translate a list of patterns (Note: each pattern is translated
483 -- to a pattern vector but we do not concatenate the results).
484 translatePatVec :: FamInstEnvs -> [Pat Id] -> DsM [PatVec]
485 translatePatVec fam_insts pats = mapM (translatePat fam_insts) pats
486
487 -- | Translate a constructor pattern
488 translateConPatVec :: FamInstEnvs -> [Type] -> [TyVar]
489 -> DataCon -> HsConPatDetails Id -> DsM PatVec
490 translateConPatVec fam_insts _univ_tys _ex_tvs _ (PrefixCon ps)
491 = concat <$> translatePatVec fam_insts (map unLoc ps)
492 translateConPatVec fam_insts _univ_tys _ex_tvs _ (InfixCon p1 p2)
493 = concat <$> translatePatVec fam_insts (map unLoc [p1,p2])
494 translateConPatVec fam_insts univ_tys ex_tvs c (RecCon (HsRecFields fs _))
495 -- Nothing matched. Make up some fresh term variables
496 | null fs = mkPmVars arg_tys
497 -- The data constructor was not defined using record syntax. For the
498 -- pattern to be in record syntax it should be empty (e.g. Just {}).
499 -- So just like the previous case.
500 | null orig_lbls = ASSERT(null matched_lbls) mkPmVars arg_tys
501 -- Some of the fields appear, in the original order (there may be holes).
502 -- Generate a simple constructor pattern and make up fresh variables for
503 -- the rest of the fields
504 | matched_lbls `subsetOf` orig_lbls
505 = ASSERT(length orig_lbls == length arg_tys)
506 let translateOne (lbl, ty) = case lookup lbl matched_pats of
507 Just p -> translatePat fam_insts p
508 Nothing -> mkPmVars [ty]
509 in concatMapM translateOne (zip orig_lbls arg_tys)
510 -- The fields that appear are not in the correct order. Make up fresh
511 -- variables for all fields and add guards after matching, to force the
512 -- evaluation in the correct order.
513 | otherwise = do
514 arg_var_pats <- mkPmVars arg_tys
515 translated_pats <- forM matched_pats $ \(x,pat) -> do
516 pvec <- translatePat fam_insts pat
517 return (x, pvec)
518
519 let zipped = zip orig_lbls [ x | PmVar x <- arg_var_pats ]
520 guards = map (\(name,pvec) -> case lookup name zipped of
521 Just x -> PmGrd pvec (PmExprVar (idName x))
522 Nothing -> panic "translateConPatVec: lookup")
523 translated_pats
524
525 return (arg_var_pats ++ guards)
526 where
527 -- The actual argument types (instantiated)
528 arg_tys = dataConInstOrigArgTys c (univ_tys ++ mkTyVarTys ex_tvs)
529
530 -- Some label information
531 orig_lbls = map flSelector $ dataConFieldLabels c
532 matched_pats = [ (getName (unLoc (hsRecFieldId x)), unLoc (hsRecFieldArg x))
533 | L _ x <- fs]
534 matched_lbls = [ name | (name, _pat) <- matched_pats ]
535
536 subsetOf :: Eq a => [a] -> [a] -> Bool
537 subsetOf [] _ = True
538 subsetOf (_:_) [] = False
539 subsetOf (x:xs) (y:ys)
540 | x == y = subsetOf xs ys
541 | otherwise = subsetOf (x:xs) ys
542
543 -- Translate a single match
544 translateMatch :: FamInstEnvs -> LMatch Id (LHsExpr Id) -> DsM (PatVec,[PatVec])
545 translateMatch fam_insts (L _ (Match _ lpats _ grhss)) = do
546 pats' <- concat <$> translatePatVec fam_insts pats
547 guards' <- mapM (translateGuards fam_insts) guards
548 return (pats', guards')
549 where
550 extractGuards :: LGRHS Id (LHsExpr Id) -> [GuardStmt Id]
551 extractGuards (L _ (GRHS gs _)) = map unLoc gs
552
553 pats = map unLoc lpats
554 guards = map extractGuards (grhssGRHSs grhss)
555
556 -- -----------------------------------------------------------------------
557 -- * Transform source guards (GuardStmt Id) to PmPats (Pattern)
558
559 -- | Translate a list of guard statements to a pattern vector
560 translateGuards :: FamInstEnvs -> [GuardStmt Id] -> DsM PatVec
561 translateGuards fam_insts guards = do
562 all_guards <- concat <$> mapM (translateGuard fam_insts) guards
563 return (replace_unhandled all_guards)
564 -- It should have been (return all_guards) but it is too expressive.
565 -- Since the term oracle does not handle all constraints we generate,
566 -- we (hackily) replace all constraints the oracle cannot handle with a
567 -- single one (we need to know if there is a possibility of falure).
568 -- See Note [Guards and Approximation] for all guard-related approximations
569 -- we implement.
570 where
571 replace_unhandled :: PatVec -> PatVec
572 replace_unhandled gv
573 | any_unhandled gv = fake_pat : [ p | p <- gv, shouldKeep p ]
574 | otherwise = gv
575
576 any_unhandled :: PatVec -> Bool
577 any_unhandled gv = any (not . shouldKeep) gv
578
579 shouldKeep :: Pattern -> Bool
580 shouldKeep p
581 | PmVar {} <- p = True
582 | PmCon {} <- p = length (allConstructors (pm_con_con p)) == 1
583 && all shouldKeep (pm_con_args p)
584 shouldKeep (PmGrd pv e)
585 | all shouldKeep pv = True
586 | isNotPmExprOther e = True -- expensive but we want it
587 shouldKeep _other_pat = False -- let the rest..
588
589 -- | Check whether a pattern can fail to match
590 cantFailPattern :: Pattern -> Bool
591 cantFailPattern p
592 | PmVar {} <- p = True
593 | PmCon {} <- p = length (allConstructors (pm_con_con p)) == 1
594 && all cantFailPattern (pm_con_args p)
595 cantFailPattern (PmGrd pv _e)
596 = all cantFailPattern pv
597 cantFailPattern _ = False
598
599 -- | Translate a guard statement to Pattern
600 translateGuard :: FamInstEnvs -> GuardStmt Id -> DsM PatVec
601 translateGuard fam_insts guard = case guard of
602 BodyStmt e _ _ _ -> translateBoolGuard e
603 LetStmt binds -> translateLet (unLoc binds)
604 BindStmt p e _ _ _ -> translateBind fam_insts p e
605 LastStmt {} -> panic "translateGuard LastStmt"
606 ParStmt {} -> panic "translateGuard ParStmt"
607 TransStmt {} -> panic "translateGuard TransStmt"
608 RecStmt {} -> panic "translateGuard RecStmt"
609 ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt"
610
611 -- | Translate let-bindings
612 translateLet :: HsLocalBinds Id -> DsM PatVec
613 translateLet _binds = return []
614
615 -- | Translate a pattern guard
616 translateBind :: FamInstEnvs -> LPat Id -> LHsExpr Id -> DsM PatVec
617 translateBind fam_insts (L _ p) e = do
618 ps <- translatePat fam_insts p
619 return [mkGuard ps (unLoc e)]
620
621 -- | Translate a boolean guard
622 translateBoolGuard :: LHsExpr Id -> DsM PatVec
623 translateBoolGuard e
624 | isJust (isTrueLHsExpr e) = return []
625 -- The formal thing to do would be to generate (True <- True)
626 -- but it is trivial to solve so instead we give back an empty
627 -- PatVec for efficiency
628 | otherwise = return [mkGuard [truePattern] (unLoc e)]
629
630 {- Note [Guards and Approximation]
631 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
632 Even if the algorithm is really expressive, the term oracle we use is not.
633 Hence, several features are not translated *properly* but we approximate.
634 The list includes:
635
636 1. View Patterns
637 ----------------
638 A view pattern @(f -> p)@ should be translated to @x (p <- f x)@. The term
639 oracle does not handle function applications so we know that the generated
640 constraints will not be handled at the end. Hence, we distinguish between two
641 cases:
642 a) Pattern @p@ cannot fail. Then this is just a binding and we do the *right
643 thing*.
644 b) Pattern @p@ can fail. This means that when checking the guard, we will
645 generate several cases, with no useful information. E.g.:
646
647 h (f -> [a,b]) = ...
648 h x ([a,b] <- f x) = ...
649
650 uncovered set = { [x |> { False ~ (f x ~ []) }]
651 , [x |> { False ~ (f x ~ (t1:[])) }]
652 , [x |> { False ~ (f x ~ (t1:t2:t3:t4)) }] }
653
654 So we have two problems:
655 1) Since we do not print the constraints in the general case (they may
656 be too many), the warning will look like this:
657
658 Pattern match(es) are non-exhaustive
659 In an equation for `h':
660 Patterns not matched:
661 _
662 _
663 _
664 Which is not short and not more useful than a single underscore.
665 2) The size of the uncovered set increases a lot, without gaining more
666 expressivity in our warnings.
667
668 Hence, in this case, we replace the guard @([a,b] <- f x)@ with a *dummy*
669 @fake_pat@: @True <- _@. That is, we record that there is a possibility
670 of failure but we minimize it to a True/False. This generates a single
671 warning and much smaller uncovered sets.
672
673 2. Overloaded Lists
674 -------------------
675 An overloaded list @[...]@ should be translated to @x ([...] <- toList x)@. The
676 problem is exactly like above, as its solution. For future reference, the code
677 below is the *right thing to do*:
678
679 ListPat lpats elem_ty (Just (pat_ty, to_list))
680 otherwise -> do
681 (xp, xe) <- mkPmId2Forms pat_ty
682 ps <- translatePatVec (map unLoc lpats)
683 let pats = foldr (mkListPatVec elem_ty) [nilPattern elem_ty] ps
684 g = mkGuard pats (HsApp (noLoc to_list) xe)
685 return [xp,g]
686
687 3. Overloaded Literals
688 ----------------------
689 The case with literals is a bit different. a literal @l@ should be translated
690 to @x (True <- x == from l)@. Since we want to have better warnings for
691 overloaded literals as it is a very common feature, we treat them differently.
692 They are mainly covered in Note [Undecidable Equality on Overloaded Literals]
693 in PmExpr.
694
695 4. N+K Patterns & Pattern Synonyms
696 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
697 An n+k pattern (n+k) should be translated to @x (True <- x >= k) (n <- x-k)@.
698 Since the only pattern of the three that causes failure is guard @(n <- x-k)@,
699 and has two possible outcomes. Hence, there is no benefit in using a dummy and
700 we implement the proper thing. Pattern synonyms are simply not implemented yet.
701 Hence, to be conservative, we generate a dummy pattern, assuming that the
702 pattern can fail.
703
704 5. Actual Guards
705 ----------------
706 During translation, boolean guards and pattern guards are translated properly.
707 Let bindings though are omitted by function @translateLet@. Since they are lazy
708 bindings, we do not actually want to generate a (strict) equality (like we do
709 in the pattern bind case). Hence, we safely drop them.
710
711 Additionally, top-level guard translation (performed by @translateGuards@)
712 replaces guards that cannot be reasoned about (like the ones we described in
713 1-4) with a single @fake_pat@ to record the possibility of failure to match.
714
715 Note [Translate CoPats]
716 ~~~~~~~~~~~~~~~~~~~~~~~
717 The pattern match checker did not know how to handle coerced patterns `CoPat`
718 efficiently, which gave rise to #11276. The original approach translated
719 `CoPat`s:
720
721 pat |> co ===> x (pat <- (e |> co))
722
723 Instead, we now check whether the coercion is a hole or if it is just refl, in
724 which case we can drop it. Unfortunately, data families generate useful
725 coercions so guards are still generated in these cases and checking data
726 families is not really efficient.
727
728 %************************************************************************
729 %* *
730 Utilities for Pattern Match Checking
731 %* *
732 %************************************************************************
733 -}
734
735 -- ----------------------------------------------------------------------------
736 -- * Basic utilities
737
738 -- | Get the type out of a PmPat. For guard patterns (ps <- e) we use the type
739 -- of the first (or the single -WHEREVER IT IS- valid to use?) pattern
740 pmPatType :: PmPat p -> Type
741 pmPatType (PmCon { pm_con_con = con, pm_con_arg_tys = tys })
742 = mkTyConApp (dataConTyCon con) tys
743 pmPatType (PmVar { pm_var_id = x }) = idType x
744 pmPatType (PmLit { pm_lit_lit = l }) = pmLitType l
745 pmPatType (PmNLit { pm_lit_id = x }) = idType x
746 pmPatType (PmGrd { pm_grd_pv = pv })
747 = ASSERT(patVecArity pv == 1) (pmPatType p)
748 where Just p = find ((==1) . patternArity) pv
749
750 -- | Generate a value abstraction for a given constructor (generate
751 -- fresh variables of the appropriate type for arguments)
752 mkOneConFull :: Id -> DataCon -> DsM (ValAbs, ComplexEq, Bag EvVar)
753 -- * x :: T tys, where T is an algebraic data type
754 -- NB: in the case of a data familiy, T is the *representation* TyCon
755 -- e.g. data instance T (a,b) = T1 a b
756 -- leads to
757 -- data TPair a b = T1 a b -- The "representation" type
758 -- It is TPair, not T, that is given to mkOneConFull
759 --
760 -- * 'con' K is a constructor of data type T
761 --
762 -- After instantiating the universal tyvars of K we get
763 -- K tys :: forall bs. Q => s1 .. sn -> T tys
764 --
765 -- Results: ValAbs: K (y1::s1) .. (yn::sn)
766 -- ComplexEq: x ~ K y1..yn
767 -- [EvVar]: Q
768 mkOneConFull x con = do
769 let -- res_ty == TyConApp (dataConTyCon cabs_con) cabs_arg_tys
770 res_ty = idType x
771 (univ_tvs, ex_tvs, eq_spec, thetas, arg_tys, _) = dataConFullSig con
772 data_tc = dataConTyCon con -- The representation TyCon
773 tc_args = case splitTyConApp_maybe res_ty of
774 Just (tc, tys) -> ASSERT( tc == data_tc ) tys
775 Nothing -> pprPanic "mkOneConFull: Not TyConApp:" (ppr res_ty)
776 subst1 = zipTvSubst univ_tvs tc_args
777
778 (subst, ex_tvs') <- cloneTyVarBndrs subst1 ex_tvs <$> getUniqueSupplyM
779
780 -- Fresh term variables (VAs) as arguments to the constructor
781 arguments <- mapM mkPmVar (substTys subst arg_tys)
782 -- All constraints bound by the constructor (alpha-renamed)
783 let theta_cs = substTheta subst (eqSpecPreds eq_spec ++ thetas)
784 evvars <- mapM (nameType "pm") theta_cs
785 let con_abs = PmCon { pm_con_con = con
786 , pm_con_arg_tys = tc_args
787 , pm_con_tvs = ex_tvs'
788 , pm_con_dicts = evvars
789 , pm_con_args = arguments }
790 return (con_abs, (PmExprVar (idName x), vaToPmExpr con_abs), listToBag evvars)
791
792 -- ----------------------------------------------------------------------------
793 -- * More smart constructors and fresh variable generation
794
795 -- | Create a guard pattern
796 mkGuard :: PatVec -> HsExpr Id -> Pattern
797 mkGuard pv e
798 | all cantFailPattern pv = PmGrd pv expr
799 | PmExprOther {} <- expr = fake_pat
800 | otherwise = PmGrd pv expr
801 where
802 expr = hsExprToPmExpr e
803
804 -- | Create a term equality of the form: `(False ~ (x ~ lit))`
805 mkNegEq :: Id -> PmLit -> ComplexEq
806 mkNegEq x l = (falsePmExpr, PmExprVar (idName x) `PmExprEq` PmExprLit l)
807 {-# INLINE mkNegEq #-}
808
809 -- | Create a term equality of the form: `(x ~ lit)`
810 mkPosEq :: Id -> PmLit -> ComplexEq
811 mkPosEq x l = (PmExprVar (idName x), PmExprLit l)
812 {-# INLINE mkPosEq #-}
813
814 -- | Generate a variable pattern of a given type
815 mkPmVar :: Type -> DsM (PmPat p)
816 mkPmVar ty = PmVar <$> mkPmId ty
817 {-# INLINE mkPmVar #-}
818
819 -- | Generate many variable patterns, given a list of types
820 mkPmVars :: [Type] -> DsM PatVec
821 mkPmVars tys = mapM mkPmVar tys
822 {-# INLINE mkPmVars #-}
823
824 -- | Generate a fresh `Id` of a given type
825 mkPmId :: Type -> DsM Id
826 mkPmId ty = getUniqueM >>= \unique ->
827 let occname = mkVarOccFS (fsLit (show unique))
828 name = mkInternalName unique occname noSrcSpan
829 in return (mkLocalId name ty)
830
831 -- | Generate a fresh term variable of a given and return it in two forms:
832 -- * A variable pattern
833 -- * A variable expression
834 mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr Id)
835 mkPmId2Forms ty = do
836 x <- mkPmId ty
837 return (PmVar x, noLoc (HsVar (noLoc x)))
838
839 -- ----------------------------------------------------------------------------
840 -- * Converting between Value Abstractions, Patterns and PmExpr
841
842 -- | Convert a value abstraction an expression
843 vaToPmExpr :: ValAbs -> PmExpr
844 vaToPmExpr (PmCon { pm_con_con = c, pm_con_args = ps })
845 = PmExprCon c (map vaToPmExpr ps)
846 vaToPmExpr (PmVar { pm_var_id = x }) = PmExprVar (idName x)
847 vaToPmExpr (PmLit { pm_lit_lit = l }) = PmExprLit l
848 vaToPmExpr (PmNLit { pm_lit_id = x }) = PmExprVar (idName x)
849
850 -- | Convert a pattern vector to a list of value abstractions by dropping the
851 -- guards (See Note [Translating As Patterns])
852 coercePatVec :: PatVec -> [ValAbs]
853 coercePatVec pv = concatMap coercePmPat pv
854
855 -- | Convert a pattern to a list of value abstractions (will be either an empty
856 -- list if the pattern is a guard pattern, or a singleton list in all other
857 -- cases) by dropping the guards (See Note [Translating As Patterns])
858 coercePmPat :: Pattern -> [ValAbs]
859 coercePmPat (PmVar { pm_var_id = x }) = [PmVar { pm_var_id = x }]
860 coercePmPat (PmLit { pm_lit_lit = l }) = [PmLit { pm_lit_lit = l }]
861 coercePmPat (PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys
862 , pm_con_tvs = tvs, pm_con_dicts = dicts
863 , pm_con_args = args })
864 = [PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys
865 , pm_con_tvs = tvs, pm_con_dicts = dicts
866 , pm_con_args = coercePatVec args }]
867 coercePmPat (PmGrd {}) = [] -- drop the guards
868
869 -- | Get all constructors in the family (including given)
870 allConstructors :: DataCon -> [DataCon]
871 allConstructors = tyConDataCons . dataConTyCon
872
873 -- -----------------------------------------------------------------------
874 -- * Types and constraints
875
876 newEvVar :: Name -> Type -> EvVar
877 newEvVar name ty = mkLocalId name (toTcType ty)
878
879 nameType :: String -> Type -> DsM EvVar
880 nameType name ty = do
881 unique <- getUniqueM
882 let occname = mkVarOccFS (fsLit (name++"_"++show unique))
883 idname = mkInternalName unique occname noSrcSpan
884 return (newEvVar idname ty)
885
886 {-
887 %************************************************************************
888 %* *
889 The type oracle
890 %* *
891 %************************************************************************
892 -}
893
894 -- | Check whether a set of type constraints is satisfiable.
895 tyOracle :: Bag EvVar -> PmM Bool
896 tyOracle evs
897 = liftD $
898 do { ((_warns, errs), res) <- initTcDsForSolver $ tcCheckSatisfiability evs
899 ; case res of
900 Just sat -> return sat
901 Nothing -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc errs) }
902
903 {-
904 %************************************************************************
905 %* *
906 Sanity Checks
907 %* *
908 %************************************************************************
909 -}
910
911 -- | The arity of a pattern/pattern vector is the
912 -- number of top-level patterns that are not guards
913 type PmArity = Int
914
915 -- | Compute the arity of a pattern vector
916 patVecArity :: PatVec -> PmArity
917 patVecArity = sum . map patternArity
918
919 -- | Compute the arity of a pattern
920 patternArity :: Pattern -> PmArity
921 patternArity (PmGrd {}) = 0
922 patternArity _other_pat = 1
923
924 {-
925 %************************************************************************
926 %* *
927 Heart of the algorithm: Function pmcheck
928 %* *
929 %************************************************************************
930
931 Main functions are:
932
933 * mkInitialUncovered :: [Id] -> PmM Uncovered
934
935 Generates the initial uncovered set. Term and type constraints in scope
936 are checked, if they are inconsistent, the set is empty, otherwise, the
937 set contains only a vector of variables with the constraints in scope.
938
939 * pmcheck :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult
940
941 Checks redundancy, coverage and inaccessibility, using auxilary functions
942 `pmcheckGuards` and `pmcheckHd`. Mainly handles the guard case which is
943 common in all three checks (see paper) and calls `pmcheckGuards` when the
944 whole clause is checked, or `pmcheckHd` when the pattern vector does not
945 start with a guard.
946
947 * pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult
948
949 Processes the guards.
950
951 * pmcheckHd :: Pattern -> PatVec -> [PatVec]
952 -> ValAbs -> ValVec -> PmM PartialResult
953
954 Worker: This function implements functions `covered`, `uncovered` and
955 `divergent` from the paper at once. Slightly different from the paper because
956 it does not even produce the covered and uncovered sets. Since we only care
957 about whether a clause covers SOMETHING or if it may forces ANY argument, we
958 only store a boolean in both cases, for efficiency.
959 -}
960
961 -- | Lift a pattern matching action from a single value vector abstration to a
962 -- value set abstraction, but calling it on every vector and the combining the
963 -- results.
964 runMany :: (ValVec -> PmM PartialResult) -> (Uncovered -> PmM PartialResult)
965 runMany _ [] = return $ PartialResult mempty mempty mempty
966 runMany pm (m:ms) = do
967 (PartialResult c v d) <- pm m
968 (PartialResult cs vs ds) <- runMany pm ms
969 return (PartialResult (c `mappend` cs) (v `mappend` vs) (d `mappend` ds))
970 {-# INLINE runMany #-}
971
972 -- | Generate the initial uncovered set. It initializes the
973 -- delta with all term and type constraints in scope.
974 mkInitialUncovered :: [Id] -> PmM Uncovered
975 mkInitialUncovered vars = do
976 ty_cs <- liftD getDictsDs
977 tm_cs <- map toComplex . bagToList <$> liftD getTmCsDs
978 sat_ty <- tyOracle ty_cs
979 return $ case (sat_ty, tmOracle initialTmState tm_cs) of
980 (True, Just tm_state) -> [ValVec patterns (MkDelta ty_cs tm_state)]
981 -- If any of the term/type constraints are non
982 -- satisfiable, the initial uncovered set is empty
983 _non_satisfiable -> []
984 where
985 patterns = map PmVar vars
986
987 -- | Increase the counter for elapsed algorithm iterations, check that the
988 -- limit is not exceeded and call `pmcheck`
989 pmcheckI :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult
990 pmcheckI ps guards vva = do
991 n <- liftD incrCheckPmIterDs
992 tracePm "pmCheck" (ppr n <> colon <+> pprPatVec ps
993 $$ hang (text "guards:") 2 (vcat (map pprPatVec guards))
994 $$ pprValVecDebug vva)
995 res <- pmcheck ps guards vva
996 tracePm "pmCheckResult:" (ppr res)
997 return res
998 {-# INLINE pmcheckI #-}
999
1000 -- | Increase the counter for elapsed algorithm iterations, check that the
1001 -- limit is not exceeded and call `pmcheckGuards`
1002 pmcheckGuardsI :: [PatVec] -> ValVec -> PmM PartialResult
1003 pmcheckGuardsI gvs vva = liftD incrCheckPmIterDs >> pmcheckGuards gvs vva
1004 {-# INLINE pmcheckGuardsI #-}
1005
1006 -- | Increase the counter for elapsed algorithm iterations, check that the
1007 -- limit is not exceeded and call `pmcheckHd`
1008 pmcheckHdI :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec -> PmM PartialResult
1009 pmcheckHdI p ps guards va vva = do
1010 n <- liftD incrCheckPmIterDs
1011 tracePm "pmCheckHdI" (ppr n <> colon <+> pprPmPatDebug p
1012 $$ pprPatVec ps
1013 $$ hang (text "guards:") 2 (vcat (map pprPatVec guards))
1014 $$ pprPmPatDebug va
1015 $$ pprValVecDebug vva)
1016
1017 res <- pmcheckHd p ps guards va vva
1018 tracePm "pmCheckHdI: res" (ppr res)
1019 return res
1020 {-# INLINE pmcheckHdI #-}
1021
1022 -- | Matching function: Check simultaneously a clause (takes separately the
1023 -- patterns and the list of guards) for exhaustiveness, redundancy and
1024 -- inaccessibility.
1025 pmcheck :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult
1026 pmcheck [] guards vva@(ValVec [] _)
1027 | null guards = return $ mempty { presultCovered = Covered }
1028 | otherwise = pmcheckGuardsI guards vva
1029
1030 -- Guard
1031 pmcheck (p@(PmGrd pv e) : ps) guards vva@(ValVec vas delta)
1032 -- short-circuit if the guard pattern is useless.
1033 -- we just have two possible outcomes: fail here or match and recurse
1034 -- none of the two contains any useful information about the failure
1035 -- though. So just have these two cases but do not do all the boilerplate
1036 | isFakeGuard pv e = forces . mkCons vva <$> pmcheckI ps guards vva
1037 | otherwise = do
1038 y <- liftD $ mkPmId (pmPatType p)
1039 let tm_state = extendSubst y e (delta_tm_cs delta)
1040 delta' = delta { delta_tm_cs = tm_state }
1041 utail <$> pmcheckI (pv ++ ps) guards (ValVec (PmVar y : vas) delta')
1042
1043 pmcheck [] _ (ValVec (_:_) _) = panic "pmcheck: nil-cons"
1044 pmcheck (_:_) _ (ValVec [] _) = panic "pmcheck: cons-nil"
1045
1046 pmcheck (p:ps) guards (ValVec (va:vva) delta)
1047 = pmcheckHdI p ps guards va (ValVec vva delta)
1048
1049 -- | Check the list of guards
1050 pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult
1051 pmcheckGuards [] vva = return (usimple [vva])
1052 pmcheckGuards (gv:gvs) vva = do
1053 (PartialResult cs vsa ds) <- pmcheckI gv [] vva
1054 (PartialResult css vsas dss) <- runMany (pmcheckGuardsI gvs) vsa
1055 return $ PartialResult (cs `mappend` css) vsas (ds `mappend` dss)
1056
1057 -- | Worker function: Implements all cases described in the paper for all three
1058 -- functions (`covered`, `uncovered` and `divergent`) apart from the `Guard`
1059 -- cases which are handled by `pmcheck`
1060 pmcheckHd :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec -> PmM PartialResult
1061
1062 -- Var
1063 pmcheckHd (PmVar x) ps guards va (ValVec vva delta)
1064 | Just tm_state <- solveOneEq (delta_tm_cs delta)
1065 (PmExprVar (idName x), vaToPmExpr va)
1066 = ucon va <$> pmcheckI ps guards (ValVec vva (delta {delta_tm_cs = tm_state}))
1067 | otherwise = return mempty
1068
1069 -- ConCon
1070 pmcheckHd ( p@(PmCon {pm_con_con = c1, pm_con_args = args1})) ps guards
1071 (va@(PmCon {pm_con_con = c2, pm_con_args = args2})) (ValVec vva delta)
1072 | c1 /= c2 =
1073 return (usimple [ValVec (va:vva) delta])
1074 | otherwise = kcon c1 (pm_con_arg_tys p) (pm_con_tvs p) (pm_con_dicts p)
1075 <$> pmcheckI (args1 ++ ps) guards (ValVec (args2 ++ vva) delta)
1076
1077 -- LitLit
1078 pmcheckHd (PmLit l1) ps guards (va@(PmLit l2)) vva =
1079 case eqPmLit l1 l2 of
1080 True -> ucon va <$> pmcheckI ps guards vva
1081 False -> return $ ucon va (usimple [vva])
1082
1083 -- ConVar
1084 pmcheckHd (p@(PmCon { pm_con_con = con })) ps guards
1085 (PmVar x) (ValVec vva delta) = do
1086 cons_cs <- mapM (liftD . mkOneConFull x) (allConstructors con)
1087
1088 inst_vsa <- flip concatMapM cons_cs $ \(va, tm_ct, ty_cs) -> do
1089 let ty_state = ty_cs `unionBags` delta_ty_cs delta -- not actually a state
1090 sat_ty <- if isEmptyBag ty_cs then return True
1091 else tyOracle ty_state
1092 return $ case (sat_ty, solveOneEq (delta_tm_cs delta) tm_ct) of
1093 (True, Just tm_state) -> [ValVec (va:vva) (MkDelta ty_state tm_state)]
1094 _ty_or_tm_failed -> []
1095
1096 force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>
1097 runMany (pmcheckI (p:ps) guards) inst_vsa
1098
1099 -- LitVar
1100 pmcheckHd (p@(PmLit l)) ps guards (PmVar x) (ValVec vva delta)
1101 = force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>
1102 mkUnion non_matched <$>
1103 case solveOneEq (delta_tm_cs delta) (mkPosEq x l) of
1104 Just tm_state -> pmcheckHdI p ps guards (PmLit l) $
1105 ValVec vva (delta {delta_tm_cs = tm_state})
1106 Nothing -> return mempty
1107 where
1108 us | Just tm_state <- solveOneEq (delta_tm_cs delta) (mkNegEq x l)
1109 = [ValVec (PmNLit x [l] : vva) (delta { delta_tm_cs = tm_state })]
1110 | otherwise = []
1111
1112 non_matched = usimple us
1113
1114 -- LitNLit
1115 pmcheckHd (p@(PmLit l)) ps guards
1116 (PmNLit { pm_lit_id = x, pm_lit_not = lits }) (ValVec vva delta)
1117 | all (not . eqPmLit l) lits
1118 , Just tm_state <- solveOneEq (delta_tm_cs delta) (mkPosEq x l)
1119 -- Both guards check the same so it would be sufficient to have only
1120 -- the second one. Nevertheless, it is much cheaper to check whether
1121 -- the literal is in the list so we check it first, to avoid calling
1122 -- the term oracle (`solveOneEq`) if possible
1123 = mkUnion non_matched <$>
1124 pmcheckHdI p ps guards (PmLit l)
1125 (ValVec vva (delta { delta_tm_cs = tm_state }))
1126 | otherwise = return non_matched
1127 where
1128 us | Just tm_state <- solveOneEq (delta_tm_cs delta) (mkNegEq x l)
1129 = [ValVec (PmNLit x (l:lits) : vva) (delta { delta_tm_cs = tm_state })]
1130 | otherwise = []
1131
1132 non_matched = usimple us
1133
1134 -- ----------------------------------------------------------------------------
1135 -- The following three can happen only in cases like #322 where constructors
1136 -- and overloaded literals appear in the same match. The general strategy is
1137 -- to replace the literal (positive/negative) by a variable and recurse. The
1138 -- fact that the variable is equal to the literal is recorded in `delta` so
1139 -- no information is lost
1140
1141 -- LitCon
1142 pmcheckHd (PmLit l) ps guards (va@(PmCon {})) (ValVec vva delta)
1143 = do y <- liftD $ mkPmId (pmPatType va)
1144 let tm_state = extendSubst y (PmExprLit l) (delta_tm_cs delta)
1145 delta' = delta { delta_tm_cs = tm_state }
1146 pmcheckHdI (PmVar y) ps guards va (ValVec vva delta')
1147
1148 -- ConLit
1149 pmcheckHd (p@(PmCon {})) ps guards (PmLit l) (ValVec vva delta)
1150 = do y <- liftD $ mkPmId (pmPatType p)
1151 let tm_state = extendSubst y (PmExprLit l) (delta_tm_cs delta)
1152 delta' = delta { delta_tm_cs = tm_state }
1153 pmcheckHdI p ps guards (PmVar y) (ValVec vva delta')
1154
1155 -- ConNLit
1156 pmcheckHd (p@(PmCon {})) ps guards (PmNLit { pm_lit_id = x }) vva
1157 = pmcheckHdI p ps guards (PmVar x) vva
1158
1159 -- Impossible: handled by pmcheck
1160 pmcheckHd (PmGrd {}) _ _ _ _ = panic "pmcheckHd: Guard"
1161
1162 -- ----------------------------------------------------------------------------
1163 -- * Utilities for main checking
1164
1165 updateVsa :: (ValSetAbs -> ValSetAbs) -> (PartialResult -> PartialResult)
1166 updateVsa f p@(PartialResult { presultUncovered = old })
1167 = p { presultUncovered = f old }
1168
1169
1170 -- | Initialise with default values for covering and divergent information.
1171 usimple :: ValSetAbs -> PartialResult
1172 usimple vsa = mempty { presultUncovered = vsa }
1173
1174 -- | Take the tail of all value vector abstractions in the uncovered set
1175 utail :: PartialResult -> PartialResult
1176 utail = updateVsa upd
1177 where upd vsa = [ ValVec vva delta | ValVec (_:vva) delta <- vsa ]
1178
1179 -- | Prepend a value abstraction to all value vector abstractions in the
1180 -- uncovered set
1181 ucon :: ValAbs -> PartialResult -> PartialResult
1182 ucon va = updateVsa upd
1183 where
1184 upd vsa = [ ValVec (va:vva) delta | ValVec vva delta <- vsa ]
1185
1186 -- | Given a data constructor of arity `a` and an uncovered set containing
1187 -- value vector abstractions of length `(a+n)`, pass the first `n` value
1188 -- abstractions to the constructor (Hence, the resulting value vector
1189 -- abstractions will have length `n+1`)
1190 kcon :: DataCon -> [Type] -> [TyVar] -> [EvVar]
1191 -> PartialResult -> PartialResult
1192 kcon con arg_tys ex_tvs dicts
1193 = let n = dataConSourceArity con
1194 upd vsa =
1195 [ ValVec (va:vva) delta
1196 | ValVec vva' delta <- vsa
1197 , let (args, vva) = splitAt n vva'
1198 , let va = PmCon { pm_con_con = con
1199 , pm_con_arg_tys = arg_tys
1200 , pm_con_tvs = ex_tvs
1201 , pm_con_dicts = dicts
1202 , pm_con_args = args } ]
1203 in updateVsa upd
1204
1205 -- | Get the union of two covered, uncovered and divergent value set
1206 -- abstractions. Since the covered and divergent sets are represented by a
1207 -- boolean, union means computing the logical or (at least one of the two is
1208 -- non-empty).
1209
1210 mkUnion :: PartialResult -> PartialResult -> PartialResult
1211 mkUnion = mappend
1212
1213 -- | Add a value vector abstraction to a value set abstraction (uncovered).
1214 mkCons :: ValVec -> PartialResult -> PartialResult
1215 mkCons vva = updateVsa (vva:)
1216
1217 -- | Set the divergent set to not empty
1218 forces :: PartialResult -> PartialResult
1219 forces pres = pres { presultDivergent = Diverged }
1220
1221 -- | Set the divergent set to non-empty if the flag is `True`
1222 force_if :: Bool -> PartialResult -> PartialResult
1223 force_if True pres = forces pres
1224 force_if False pres = pres
1225
1226 -- ----------------------------------------------------------------------------
1227 -- * Propagation of term constraints inwards when checking nested matches
1228
1229 {- Note [Type and Term Equality Propagation]
1230 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1231 When checking a match it would be great to have all type and term information
1232 available so we can get more precise results. For this reason we have functions
1233 `addDictsDs' and `addTmCsDs' in PmMonad that store in the environment type and
1234 term constraints (respectively) as we go deeper.
1235
1236 The type constraints we propagate inwards are collected by `collectEvVarsPats'
1237 in HsPat.hs. This handles bug #4139 ( see example
1238 https://ghc.haskell.org/trac/ghc/attachment/ticket/4139/GADTbug.hs )
1239 where this is needed.
1240
1241 For term equalities we do less, we just generate equalities for HsCase. For
1242 example we accurately give 2 redundancy warnings for the marked cases:
1243
1244 f :: [a] -> Bool
1245 f x = case x of
1246
1247 [] -> case x of -- brings (x ~ []) in scope
1248 [] -> True
1249 (_:_) -> False -- can't happen
1250
1251 (_:_) -> case x of -- brings (x ~ (_:_)) in scope
1252 (_:_) -> True
1253 [] -> False -- can't happen
1254
1255 Functions `genCaseTmCs1' and `genCaseTmCs2' are responsible for generating
1256 these constraints.
1257 -}
1258
1259 -- | Generate equalities when checking a case expression:
1260 -- case x of { p1 -> e1; ... pn -> en }
1261 -- When we go deeper to check e.g. e1 we record two equalities:
1262 -- (x ~ y), where y is the initial uncovered when checking (p1; .. ; pn)
1263 -- and (x ~ p1).
1264 genCaseTmCs2 :: Maybe (LHsExpr Id) -- Scrutinee
1265 -> [Pat Id] -- LHS (should have length 1)
1266 -> [Id] -- MatchVars (should have length 1)
1267 -> DsM (Bag SimpleEq)
1268 genCaseTmCs2 Nothing _ _ = return emptyBag
1269 genCaseTmCs2 (Just scr) [p] [var] = do
1270 fam_insts <- dsGetFamInstEnvs
1271 [e] <- map vaToPmExpr . coercePatVec <$> translatePat fam_insts p
1272 let scr_e = lhsExprToPmExpr scr
1273 return $ listToBag [(var, e), (var, scr_e)]
1274 genCaseTmCs2 _ _ _ = panic "genCaseTmCs2: HsCase"
1275
1276 -- | Generate a simple equality when checking a case expression:
1277 -- case x of { matches }
1278 -- When checking matches we record that (x ~ y) where y is the initial
1279 -- uncovered. All matches will have to satisfy this equality.
1280 genCaseTmCs1 :: Maybe (LHsExpr Id) -> [Id] -> Bag SimpleEq
1281 genCaseTmCs1 Nothing _ = emptyBag
1282 genCaseTmCs1 (Just scr) [var] = unitBag (var, lhsExprToPmExpr scr)
1283 genCaseTmCs1 _ _ = panic "genCaseTmCs1: HsCase"
1284
1285 {- Note [Literals in PmPat]
1286 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1287 Instead of translating a literal to a variable accompanied with a guard, we
1288 treat them like constructor patterns. The following example from
1289 "./libraries/base/GHC/IO/Encoding.hs" shows why:
1290
1291 mkTextEncoding' :: CodingFailureMode -> String -> IO TextEncoding
1292 mkTextEncoding' cfm enc = case [toUpper c | c <- enc, c /= '-'] of
1293 "UTF8" -> return $ UTF8.mkUTF8 cfm
1294 "UTF16" -> return $ UTF16.mkUTF16 cfm
1295 "UTF16LE" -> return $ UTF16.mkUTF16le cfm
1296 ...
1297
1298 Each clause gets translated to a list of variables with an equal number of
1299 guards. For every guard we generate two cases (equals True/equals False) which
1300 means that we generate 2^n cases to feed the oracle with, where n is the sum of
1301 the length of all strings that appear in the patterns. For this particular
1302 example this means over 2^40 cases. Instead, by representing them like with
1303 constructor we get the following:
1304 1. We exploit the common prefix with our representation of VSAs
1305 2. We prune immediately non-reachable cases
1306 (e.g. False == (x == "U"), True == (x == "U"))
1307
1308 Note [Translating As Patterns]
1309 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1310 Instead of translating x@p as: x (p <- x)
1311 we instead translate it as: p (x <- coercePattern p)
1312 for performance reasons. For example:
1313
1314 f x@True = 1
1315 f y@False = 2
1316
1317 Gives the following with the first translation:
1318
1319 x |> {x == False, x == y, y == True}
1320
1321 If we use the second translation we get an empty set, independently of the
1322 oracle. Since the pattern `p' may contain guard patterns though, it cannot be
1323 used as an expression. That's why we call `coercePatVec' to drop the guard and
1324 `vaToPmExpr' to transform the value abstraction to an expression in the
1325 guard pattern (value abstractions are a subset of expressions). We keep the
1326 guards in the first pattern `p' though.
1327
1328
1329 %************************************************************************
1330 %* *
1331 Pretty printing of exhaustiveness/redundancy check warnings
1332 %* *
1333 %************************************************************************
1334 -}
1335
1336 -- | Check whether any part of pattern match checking is enabled (does not
1337 -- matter whether it is the redundancy check or the exhaustiveness check).
1338 isAnyPmCheckEnabled :: DynFlags -> DsMatchContext -> Bool
1339 isAnyPmCheckEnabled dflags (DsMatchContext kind _loc)
1340 = wopt Opt_WarnOverlappingPatterns dflags || exhaustive dflags kind
1341
1342 instance Outputable ValVec where
1343 ppr (ValVec vva delta)
1344 = let (residual_eqs, subst) = wrapUpTmState (delta_tm_cs delta)
1345 vector = substInValAbs subst vva
1346 in ppr_uncovered (vector, residual_eqs)
1347
1348 -- | Apply a term substitution to a value vector abstraction. All VAs are
1349 -- transformed to PmExpr (used only before pretty printing).
1350 substInValAbs :: PmVarEnv -> [ValAbs] -> [PmExpr]
1351 substInValAbs subst = map (exprDeepLookup subst . vaToPmExpr)
1352
1353 -- | Wrap up the term oracle's state once solving is complete. Drop any
1354 -- information about unhandled constraints (involving HsExprs) and flatten
1355 -- (height 1) the substitution.
1356 wrapUpTmState :: TmState -> ([ComplexEq], PmVarEnv)
1357 wrapUpTmState (residual, (_, subst)) = (residual, flattenPmVarEnv subst)
1358
1359 -- | Issue all the warnings (coverage, exhaustiveness, inaccessibility)
1360 dsPmWarn :: DynFlags -> DsMatchContext -> PmResult -> DsM ()
1361 dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
1362 = when (flag_i || flag_u) $ do
1363 let exists_r = flag_i && notNull redundant
1364 exists_i = flag_i && notNull inaccessible
1365 exists_u = flag_u && notNull uncovered
1366 when exists_r $ forM_ redundant $ \(L l q) -> do
1367 putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
1368 (pprEqn q "is redundant"))
1369 when exists_i $ forM_ inaccessible $ \(L l q) -> do
1370 putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
1371 (pprEqn q "has inaccessible right hand side"))
1372 when exists_u $
1373 putSrcSpanDs loc (warnDs flag_u_reason (pprEqns uncovered))
1374 where
1375 PmResult
1376 { pmresultRedundant = redundant
1377 , pmresultUncovered = uncovered
1378 , pmresultInaccessible = inaccessible } = pm_result
1379
1380 flag_i = wopt Opt_WarnOverlappingPatterns dflags
1381 flag_u = exhaustive dflags kind
1382 flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)
1383
1384 maxPatterns = maxUncoveredPatterns dflags
1385
1386 -- Print a single clause (for redundant/with-inaccessible-rhs)
1387 pprEqn q txt = pp_context True ctx (text txt) $ \f -> ppr_eqn f kind q
1388
1389 -- Print several clauses (for uncovered clauses)
1390 pprEqns qs = pp_context False ctx (text "are non-exhaustive") $ \_ ->
1391 case qs of -- See #11245
1392 [ValVec [] _]
1393 -> text "Guards do not cover entire pattern space"
1394 _missing -> let us = map ppr qs
1395 in hang (text "Patterns not matched:") 4
1396 (vcat (take maxPatterns us)
1397 $$ dots maxPatterns us)
1398
1399 -- | Issue a warning when the predefined number of iterations is exceeded
1400 -- for the pattern match checker
1401 warnPmIters :: DynFlags -> DsMatchContext -> DsM ()
1402 warnPmIters dflags (DsMatchContext kind loc)
1403 = when (flag_i || flag_u) $ do
1404 iters <- maxPmCheckIterations <$> getDynFlags
1405 putSrcSpanDs loc (warnDs NoReason (msg iters))
1406 where
1407 ctxt = pprMatchContext kind
1408 msg is = fsep [ text "Pattern match checker exceeded"
1409 , parens (ppr is), text "iterations in", ctxt <> dot
1410 , text "(Use -fmax-pmcheck-iterations=n"
1411 , text "to set the maximun number of iterations to n)" ]
1412
1413 flag_i = wopt Opt_WarnOverlappingPatterns dflags
1414 flag_u = exhaustive dflags kind
1415
1416 dots :: Int -> [a] -> SDoc
1417 dots maxPatterns qs
1418 | qs `lengthExceeds` maxPatterns = text "..."
1419 | otherwise = empty
1420
1421 -- | Check whether the exhaustiveness checker should run (exhaustiveness only)
1422 exhaustive :: DynFlags -> HsMatchContext id -> Bool
1423 exhaustive dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag
1424
1425 -- | Denotes whether an exhaustiveness check is supported, and if so,
1426 -- via which 'WarningFlag' it's controlled.
1427 -- Returns 'Nothing' if check is not supported.
1428 exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag
1429 exhaustiveWarningFlag (FunRhs {}) = Just Opt_WarnIncompletePatterns
1430 exhaustiveWarningFlag CaseAlt = Just Opt_WarnIncompletePatterns
1431 exhaustiveWarningFlag IfAlt = Nothing
1432 exhaustiveWarningFlag LambdaExpr = Just Opt_WarnIncompleteUniPatterns
1433 exhaustiveWarningFlag PatBindRhs = Just Opt_WarnIncompleteUniPatterns
1434 exhaustiveWarningFlag ProcExpr = Just Opt_WarnIncompleteUniPatterns
1435 exhaustiveWarningFlag RecUpd = Just Opt_WarnIncompletePatternsRecUpd
1436 exhaustiveWarningFlag ThPatSplice = Nothing
1437 exhaustiveWarningFlag PatSyn = Nothing
1438 exhaustiveWarningFlag ThPatQuote = Nothing
1439 exhaustiveWarningFlag (StmtCtxt {}) = Nothing -- Don't warn about incomplete patterns
1440 -- in list comprehensions, pattern guards
1441 -- etc. They are often *supposed* to be
1442 -- incomplete
1443
1444 -- True <==> singular
1445 pp_context :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
1446 pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun
1447 = vcat [text txt <+> msg,
1448 sep [ text "In" <+> ppr_match <> char ':'
1449 , nest 4 (rest_of_msg_fun pref)]]
1450 where
1451 txt | singular = "Pattern match"
1452 | otherwise = "Pattern match(es)"
1453
1454 (ppr_match, pref)
1455 = case kind of
1456 FunRhs (L _ fun) _ -> (pprMatchContext kind,
1457 \ pp -> ppr fun <+> pp)
1458 _ -> (pprMatchContext kind, \ pp -> pp)
1459
1460 ppr_pats :: HsMatchContext Name -> [Pat Id] -> SDoc
1461 ppr_pats kind pats
1462 = sep [sep (map ppr pats), matchSeparator kind, text "..."]
1463
1464 ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> [LPat Id] -> SDoc
1465 ppr_eqn prefixF kind eqn = prefixF (ppr_pats kind (map unLoc eqn))
1466
1467 ppr_constraint :: (SDoc,[PmLit]) -> SDoc
1468 ppr_constraint (var, lits) = var <+> text "is not one of"
1469 <+> braces (pprWithCommas ppr lits)
1470
1471 ppr_uncovered :: ([PmExpr], [ComplexEq]) -> SDoc
1472 ppr_uncovered (expr_vec, complex)
1473 | null cs = fsep vec -- there are no literal constraints
1474 | otherwise = hang (fsep vec) 4 $
1475 text "where" <+> vcat (map ppr_constraint cs)
1476 where
1477 sdoc_vec = mapM pprPmExprWithParens expr_vec
1478 (vec,cs) = runPmPprM sdoc_vec (filterComplex complex)
1479
1480 {- Note [Representation of Term Equalities]
1481 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1482 In the paper, term constraints always take the form (x ~ e). Of course, a more
1483 general constraint of the form (e1 ~ e1) can always be transformed to an
1484 equivalent set of the former constraints, by introducing a fresh, intermediate
1485 variable: { y ~ e1, y ~ e1 }. Yet, implementing this representation gave rise
1486 to #11160 (incredibly bad performance for literal pattern matching). Two are
1487 the main sources of this problem (the actual problem is how these two interact
1488 with each other):
1489
1490 1. Pattern matching on literals generates twice as many constraints as needed.
1491 Consider the following (tests/ghci/should_run/ghcirun004):
1492
1493 foo :: Int -> Int
1494 foo 1 = 0
1495 ...
1496 foo 5000 = 4999
1497
1498 The covered and uncovered set *should* look like:
1499 U0 = { x |> {} }
1500
1501 C1 = { 1 |> { x ~ 1 } }
1502 U1 = { x |> { False ~ (x ~ 1) } }
1503 ...
1504 C10 = { 10 |> { False ~ (x ~ 1), .., False ~ (x ~ 9), x ~ 10 } }
1505 U10 = { x |> { False ~ (x ~ 1), .., False ~ (x ~ 9), False ~ (x ~ 10) } }
1506 ...
1507
1508 If we replace { False ~ (x ~ 1) } with { y ~ False, y ~ (x ~ 1) }
1509 we get twice as many constraints. Also note that half of them are just the
1510 substitution [x |-> False].
1511
1512 2. The term oracle (`tmOracle` in deSugar/TmOracle) uses equalities of the form
1513 (x ~ e) as substitutions [x |-> e]. More specifically, function
1514 `extendSubstAndSolve` applies such substitutions in the residual constraints
1515 and partitions them in the affected and non-affected ones, which are the new
1516 worklist. Essentially, this gives quadradic behaviour on the number of the
1517 residual constraints. (This would not be the case if the term oracle used
1518 mutable variables but, since we use it to handle disjunctions on value set
1519 abstractions (`Union` case), we chose a pure, incremental interface).
1520
1521 Now the problem becomes apparent (e.g. for clause 300):
1522 * Set U300 contains 300 substituting constraints [y_i |-> False] and 300
1523 constraints that we know that will not reduce (stay in the worklist).
1524 * To check for consistency, we apply the substituting constraints ONE BY ONE
1525 (since `tmOracle` is called incrementally, it does not have all of them
1526 available at once). Hence, we go through the (non-progressing) constraints
1527 over and over, achieving over-quadradic behaviour.
1528
1529 If instead we allow constraints of the form (e ~ e),
1530 * All uncovered sets Ui contain no substituting constraints and i
1531 non-progressing constraints of the form (False ~ (x ~ lit)) so the oracle
1532 behaves linearly.
1533 * All covered sets Ci contain exactly (i-1) non-progressing constraints and
1534 a single substituting constraint. So the term oracle goes through the
1535 constraints only once.
1536
1537 The performance improvement becomes even more important when more arguments are
1538 involved.
1539 -}
1540
1541 -- Debugging Infrastructre
1542
1543 tracePm :: String -> SDoc -> PmM ()
1544 tracePm herald doc = liftD $ tracePmD herald doc
1545
1546
1547 tracePmD :: String -> SDoc -> DsM ()
1548 tracePmD herald doc = do
1549 dflags <- getDynFlags
1550 printer <- mkPrintUnqualifiedDs
1551 liftIO $ dumpIfSet_dyn_printer printer dflags
1552 Opt_D_dump_ec_trace (text herald $$ (nest 2 doc))
1553
1554
1555 pprPmPatDebug :: PmPat a -> SDoc
1556 pprPmPatDebug (PmCon cc _arg_tys _con_tvs _con_dicts con_args)
1557 = hsep [text "PmCon", ppr cc, hsep (map pprPmPatDebug con_args)]
1558 pprPmPatDebug (PmVar vid) = text "PmVar" <+> ppr vid
1559 pprPmPatDebug (PmLit li) = text "PmLit" <+> ppr li
1560 pprPmPatDebug (PmNLit i nl) = text "PmNLit" <+> ppr i <+> ppr nl
1561 pprPmPatDebug (PmGrd pv ge) = text "PmGrd" <+> hsep (map pprPmPatDebug pv)
1562 <+> ppr ge
1563
1564 pprPatVec :: PatVec -> SDoc
1565 pprPatVec ps = hang (text "Pattern:") 2
1566 (brackets $ sep
1567 $ punctuate (comma <> char '\n') (map pprPmPatDebug ps))
1568
1569 pprValAbs :: [ValAbs] -> SDoc
1570 pprValAbs ps = hang (text "ValAbs:") 2
1571 (brackets $ sep
1572 $ punctuate (comma) (map pprPmPatDebug ps))
1573
1574 pprValVecDebug :: ValVec -> SDoc
1575 pprValVecDebug (ValVec vas _d) = text "ValVec" <+>
1576 parens (pprValAbs vas)