COMPLETE pragmas for enhanced pattern exhaustiveness checking
authorMatthew Pickering <matthewtpickering@gmail.com>
Wed, 18 Jan 2017 13:25:30 +0000 (13:25 +0000)
committerMatthew Pickering <matthewtpickering@gmail.com>
Thu, 26 Jan 2017 00:22:46 +0000 (00:22 +0000)
This patch adds a new pragma so that users can specify `COMPLETE` sets of
`ConLike`s in order to sate the pattern match checker.

A function which matches on all the patterns in a complete grouping
will not cause the exhaustiveness checker to emit warnings.

```
pattern P :: ()
pattern P = ()

{-# COMPLETE P #-}

foo P = ()
```

This example would previously have caused the checker to warn that
all cases were not matched even though matching on `P` is sufficient to
make `foo` covering. With the addition of the pragma, the compiler
will recognise that matching on `P` alone is enough and not emit
any warnings.

Reviewers: goldfire, gkaracha, alanz, austin, bgamari

Reviewed By: alanz

Subscribers: lelf, nomeata, gkaracha, thomie

Differential Revision: https://phabricator.haskell.org/D2669

GHC Trac Issues: #8779

51 files changed:
compiler/basicTypes/ConLike.hs
compiler/deSugar/Check.hs
compiler/deSugar/Desugar.hs
compiler/deSugar/DsMeta.hs
compiler/deSugar/DsMonad.hs
compiler/deSugar/PmExpr.hs
compiler/deSugar/TmOracle.hs
compiler/hsSyn/HsBinds.hs
compiler/iface/IfaceSyn.hs
compiler/iface/MkIface.hs
compiler/iface/TcIface.hs
compiler/main/HscTypes.hs
compiler/main/TidyPgm.hs
compiler/parser/Lexer.x
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/rename/RnBinds.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcRnTypes.hs
compiler/vectorise/Vectorise/Monad.hs
docs/users_guide/glasgow_exts.rst
testsuite/tests/pmcheck/complete_sigs/Completesig03.hs [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/Completesig03.stderr [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/Completesig03A.hs [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/Makefile [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/all.T [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig01.hs [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig02.hs [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig02.stderr [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig04.hs [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig04.stderr [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig05.hs [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig06.hs [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig06.stderr [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig07.hs [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig07.stderr [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig08.hs [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig09.hs [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig10.hs [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig10.stderr [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig11.hs [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig11.stderr [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig12.hs [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig13.hs [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig14.hs [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig14.stderr [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig15.hs [new file with mode: 0644]
testsuite/tests/pmcheck/complete_sigs/completesig15.stderr [new file with mode: 0644]
testsuite/tests/pmcheck/should_compile/all.T

index b8bab31..aa6a362 100644 (file)
@@ -21,6 +21,7 @@ module ConLike (
         , conLikeResTy
         , conLikeFieldType
         , conLikesWithFields
+        , conLikeIsInfix
     ) where
 
 #include "HsVersions.h"
@@ -185,3 +186,7 @@ conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike]
 conLikesWithFields con_likes lbls = filter has_flds con_likes
   where has_flds dc = all (has_fld dc) lbls
         has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc)
+
+conLikeIsInfix :: ConLike -> Bool
+conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc
+conLikeIsInfix (PatSynCon ps)   = patSynIsInfix  ps
index 04ba568..80f7fa5 100644 (file)
@@ -5,6 +5,7 @@ Pattern Matching Coverage Checking.
 -}
 
 {-# LANGUAGE CPP, GADTs, DataKinds, KindSignatures #-}
+{-# LANGUAGE TupleSections #-}
 
 module Check (
         -- Checking and printing
@@ -23,7 +24,6 @@ import HsSyn
 import TcHsSyn
 import Id
 import ConLike
-import DataCon
 import Name
 import FamInstEnv
 import TysWiredIn
@@ -32,6 +32,8 @@ import SrcLoc
 import Util
 import Outputable
 import FastString
+import DataCon
+import HscTypes (CompleteMatch(..))
 
 import DsMonad
 import TcSimplify    (tcCheckSatisfiability)
@@ -49,8 +51,9 @@ import Control.Monad (forM, when, forM_)
 import Coercion
 import TcEvidence
 import IOEnv
+import Data.Monoid   ( Monoid(mappend) )
 
-import ListT (ListT(..), fold)
+import ListT (ListT(..), fold, select)
 
 {-
 This module checks pattern matches for:
@@ -87,12 +90,39 @@ type PmM a = ListT DsM a
 liftD :: DsM a -> PmM a
 liftD m = ListT $ \sk fk -> m >>= \a -> sk a fk
 
-
-myRunListT :: PmM a -> DsM [a]
-myRunListT pm = fold pm go (return [])
+-- Pick the first match complete covered match or otherwise the "best" match.
+-- The best match is the one with the least uncovered clauses, ties broken
+-- by the number of inaccessible clauses followed by number of redudant
+-- clauses
+getResult :: PmM PmResult -> DsM PmResult
+getResult ls = do
+  res <- fold ls goM (pure Nothing)
+  case res of
+    Nothing -> panic "getResult is empty"
+    Just a -> return a
   where
-    go a mas =
-      mas >>= \as -> return (a:as)
+    goM :: PmResult -> DsM (Maybe PmResult) -> DsM (Maybe PmResult)
+    goM mpm dpm = do
+      pmr <- dpm
+      return $ go pmr mpm
+    -- Careful not to force unecessary results
+    go :: Maybe PmResult -> PmResult -> Maybe PmResult
+    go Nothing rs = Just rs
+    go old@(Just (PmResult prov rs us is)) new
+      | null us && null rs && null is = old
+      | otherwise =
+        let PmResult prov' rs' us' is' = new
+            lr  = length rs
+            lr' = length rs'
+            li  = length is
+            li' = length is'
+        in case compare (length us) (length us')
+                `mappend` (compare li li')
+                `mappend` (compare lr lr')
+                `mappend` (compare prov prov') of
+              GT  -> Just new
+              EQ  -> Just new
+              LT  -> old
 
 data PatTy = PAT | VA -- Used only as a kind, to index PmPat
 
@@ -100,7 +130,7 @@ data PatTy = PAT | VA -- Used only as a kind, to index PmPat
 -- the number of p1..pn that are not Guards
 
 data PmPat :: PatTy -> * where
-  PmCon  :: { pm_con_con     :: DataCon
+  PmCon  :: { pm_con_con     :: ConLike
             , pm_con_arg_tys :: [Type]
             , pm_con_tvs     :: [TyVar]
             , pm_con_dicts   :: [EvVar]
@@ -171,20 +201,42 @@ instance Monoid Diverged where
   _ `mappend` Diverged = Diverged
   NotDiverged `mappend` NotDiverged = NotDiverged
 
+-- | When we learned that a given match group is complete
+data Provenance =
+                  FromBuiltin -- ^  From the original definition of the type
+                              --    constructor.
+                | FromComplete -- ^ From a user-provided @COMPLETE@ pragma
+  deriving (Show, Eq, Ord)
+
+instance Outputable Provenance where
+  ppr  = text . show
+
+instance Monoid Provenance where
+  mempty = FromBuiltin
+  FromComplete `mappend` _ = FromComplete
+  _ `mappend` FromComplete = FromComplete
+  _ `mappend` _ = FromBuiltin
+
 data PartialResult = PartialResult {
-                      presultCovered :: Covered
+                        presultProvenence :: Provenance
+                         -- keep track of provenance because we don't want
+                         -- to warn about redundant matches if the result
+                         -- is contaiminated with a COMPLETE pragma
+                      , presultCovered :: Covered
                       , presultUncovered :: Uncovered
                       , presultDivergent :: Diverged }
 
 instance Outputable PartialResult where
-  ppr (PartialResult c vsa d) = text "PartialResult" <+> ppr c
+  ppr (PartialResult prov c vsa d)
+           = text "PartialResult" <+> ppr prov <+> ppr c
                                   <+> ppr d <+> ppr vsa
 
 instance Monoid PartialResult where
-  mempty = PartialResult mempty [] mempty
-  (PartialResult cs1 vsa1 ds1)
-    `mappend` (PartialResult cs2 vsa2 ds2)
-      = PartialResult (cs1 `mappend` cs2)
+  mempty = PartialResult mempty mempty [] mempty
+  (PartialResult prov1 cs1 vsa1 ds1)
+    `mappend` (PartialResult prov2 cs2 vsa2 ds2)
+      = PartialResult (prov1 `mappend` prov2)
+                      (cs1 `mappend` cs2)
                       (vsa1 `mappend` vsa2)
                       (ds1 `mappend` ds2)
 
@@ -197,7 +249,8 @@ instance Monoid PartialResult where
 -- * Clauses with inaccessible RHS
 data PmResult =
   PmResult {
-    pmresultRedundant :: [Located [LPat Id]]
+      pmresultProvenance :: Provenance
+    , pmresultRedundant :: [Located [LPat Id]]
     , pmresultUncovered :: Uncovered
     , pmresultInaccessible :: [Located [LPat Id]] }
 
@@ -213,7 +266,7 @@ data PmResult =
 checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat Id -> DsM ()
 checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do
   tracePmD "checkSingle" (vcat [ppr ctxt, ppr var, ppr p])
-  mb_pm_res <- tryM (head <$> myRunListT (checkSingle' locn var p))
+  mb_pm_res <- tryM (getResult (checkSingle' locn var p))
   case mb_pm_res of
     Left  _   -> warnPmIters dflags ctxt
     Right res -> dsPmWarn dflags ctxt res
@@ -226,11 +279,12 @@ checkSingle' locn var p = do
   clause    <- liftD $ translatePat fam_insts p
   missing   <- mkInitialUncovered [var]
   tracePm "checkSingle: missing" (vcat (map pprValVecDebug missing))
-  PartialResult cs us ds <- runMany (pmcheckI clause []) missing -- no guards
+                                 -- no guards
+  PartialResult prov cs us ds <- runMany (pmcheckI clause []) missing
   return $ case (cs,ds) of
-    (Covered,  _    )         -> PmResult [] us [] -- useful
-    (NotCovered, NotDiverged) -> PmResult m us []  -- redundant
-    (NotCovered, Diverged )   -> PmResult [] us m  -- inaccessible rhs
+    (Covered,  _    )         -> PmResult prov [] us [] -- useful
+    (NotCovered, NotDiverged) -> PmResult prov m us []  -- redundant
+    (NotCovered, Diverged )   -> PmResult prov [] us m  -- inaccessible rhs
   where m = [L locn [L locn p]]
 
 -- | Check a matchgroup (case, functions, etc.)
@@ -242,7 +296,7 @@ checkMatches dflags ctxt vars matches = do
                                , text "Matches:"])
                                2
                                (vcat (map ppr matches)))
-  mb_pm_res <- tryM (head <$> myRunListT (checkMatches' vars matches))
+  mb_pm_res <- tryM (getResult (checkMatches' vars matches))
   case mb_pm_res of
     Left  _   -> warnPmIters dflags ctxt
     Right res -> dsPmWarn dflags ctxt res
@@ -250,29 +304,37 @@ checkMatches dflags ctxt vars matches = do
 -- | Check a matchgroup (case, functions, etc.)
 checkMatches' :: [Id] -> [LMatch Id (LHsExpr Id)] -> PmM PmResult
 checkMatches' vars matches
-  | null matches = return $ PmResult [] [] []
+  | null matches = return $ PmResult FromBuiltin [] [] []
   | otherwise = do
       liftD resetPmIterDs -- set the iter-no to zero
       missing    <- mkInitialUncovered vars
       tracePm "checkMatches: missing" (vcat (map pprValVecDebug missing))
-      (rs,us,ds) <- go matches missing
-      return $ PmResult (map hsLMatchToLPats rs) us (map hsLMatchToLPats ds)
+      (prov, rs,us,ds) <- go matches missing
+      return
+        $ PmResult prov (map hsLMatchToLPats rs) us (map hsLMatchToLPats ds)
   where
     go :: [LMatch Id (LHsExpr Id)] -> Uncovered
-       -> PmM ([LMatch Id (LHsExpr Id)] , Uncovered , [LMatch Id (LHsExpr Id)])
-    go []     missing = return ([], missing, [])
+       -> PmM (Provenance
+              , [LMatch Id (LHsExpr Id)]
+              , Uncovered
+              , [LMatch Id (LHsExpr Id)])
+    go []     missing = return (mempty, [], missing, [])
     go (m:ms) missing = do
       tracePm "checMatches': go" (ppr m $$ ppr missing)
       fam_insts          <- liftD dsGetFamInstEnvs
       (clause, guards)   <- liftD $ translateMatch fam_insts m
-      r@(PartialResult cs missing' ds)
+      r@(PartialResult prov cs missing' ds)
         <- runMany (pmcheckI clause guards) missing
       tracePm "checMatches': go: res" (ppr r)
-      (rs, final_u, is)  <- go ms missing'
+      (ms_prov, rs, final_u, is)  <- go ms missing'
+      let final_prov = prov `mappend` ms_prov
       return $ case (cs, ds) of
-        (Covered,  _    )        -> (  rs, final_u,   is) -- useful
-        (NotCovered, NotDiverged) -> (m:rs, final_u,   is) -- redundant
-        (NotCovered, Diverged )   -> (  rs, final_u, m:is) -- inaccessible
+        -- useful
+        (Covered,  _    )        -> (final_prov,  rs, final_u,   is)
+        -- redundant
+        (NotCovered, NotDiverged) -> (final_prov, m:rs, final_u,is)
+        -- inaccessible
+        (NotCovered, Diverged )   -> (final_prov,  rs, final_u, m:is)
 
     hsLMatchToLPats :: LMatch id body -> Located [LPat id]
     hsLMatchToLPats (L l (Match _ pats _ _)) = L l pats
@@ -288,7 +350,7 @@ checkMatches' vars matches
 -- -----------------------------------------------------------------------
 -- * Utilities
 
-nullaryConPattern :: DataCon -> Pattern
+nullaryConPattern :: ConLike -> Pattern
 -- Nullary data constructor and nullary type constructor
 nullaryConPattern con =
   PmCon { pm_con_con = con, pm_con_arg_tys = []
@@ -296,7 +358,7 @@ nullaryConPattern con =
 {-# INLINE nullaryConPattern #-}
 
 truePattern :: Pattern
-truePattern = nullaryConPattern trueDataCon
+truePattern = nullaryConPattern (RealDataCon trueDataCon)
 {-# INLINE truePattern #-}
 
 -- | A fake guard pattern (True <- _) used to represent cases we cannot handle
@@ -307,7 +369,7 @@ fake_pat = PmGrd { pm_grd_pv   = [truePattern]
 
 -- | Check whether a guard pattern is generated by the checker (unhandled)
 isFakeGuard :: [Pattern] -> PmExpr -> Bool
-isFakeGuard [PmCon { pm_con_con = c }] (PmExprOther EWildPat)
+isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther EWildPat)
   | c == trueDataCon = True
   | otherwise        = False
 isFakeGuard _pats _e = False
@@ -318,7 +380,7 @@ mkCanFailPmPat ty = do
   var <- mkPmVar ty
   return [var, fake_pat]
 
-vanillaConPattern :: DataCon -> [Type] -> PatVec -> Pattern
+vanillaConPattern :: ConLike -> [Type] -> PatVec -> Pattern
 -- ADT constructor pattern => no existentials, no local constraints
 vanillaConPattern con arg_tys args =
   PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys
@@ -328,13 +390,13 @@ vanillaConPattern con arg_tys args =
 -- | Create an empty list pattern of a given type
 nilPattern :: Type -> Pattern
 nilPattern ty =
-  PmCon { pm_con_con = nilDataCon, pm_con_arg_tys = [ty]
+  PmCon { pm_con_con = RealDataCon nilDataCon, pm_con_arg_tys = [ty]
         , pm_con_tvs = [], pm_con_dicts = []
         , pm_con_args = [] }
 {-# INLINE nilPattern #-}
 
 mkListPatVec :: Type -> PatVec -> PatVec -> PatVec
-mkListPatVec ty xs ys = [PmCon { pm_con_con = consDataCon
+mkListPatVec ty xs ys = [PmCon { pm_con_con = RealDataCon consDataCon
                                , pm_con_arg_tys = [ty]
                                , pm_con_tvs = [], pm_con_dicts = []
                                , pm_con_args = xs++ys }]
@@ -410,26 +472,21 @@ translatePat fam_insts pat = case pat of
       -- See Note [Guards and Approximation]
     | otherwise -> mkCanFailPmPat pat_ty
 
-  ConPatOut { pat_con = L _ (PatSynCon _) } ->
-    -- Pattern synonyms have a "matcher"
-    -- (see Note [Pattern synonym representation] in PatSyn.hs
-    -- We should be able to transform (P x y)
-    -- to   v (Just (x, y) <- matchP v (\x y -> Just (x,y)) Nothing
-    -- That is, a combination of a variable pattern and a guard
-    -- But there are complications with GADTs etc, and this isn't done yet
-    mkCanFailPmPat (hsPatType pat)
-
-  ConPatOut { pat_con     = L _ (RealDataCon con)
+  ConPatOut { pat_con     = L _ con
             , pat_arg_tys = arg_tys
             , pat_tvs     = ex_tvs
             , pat_dicts   = dicts
             , pat_args    = ps } -> do
-    args <- translateConPatVec fam_insts arg_tys ex_tvs con ps
-    return [PmCon { pm_con_con     = con
-                  , pm_con_arg_tys = arg_tys
-                  , pm_con_tvs     = ex_tvs
-                  , pm_con_dicts   = dicts
-                  , pm_con_args    = args }]
+    groups <- allCompleteMatches con arg_tys
+    case groups of
+      [] -> mkCanFailPmPat (conLikeResTy con arg_tys)
+      _  -> do
+        args <- translateConPatVec fam_insts arg_tys ex_tvs con ps
+        return [PmCon { pm_con_con     = con
+                      , pm_con_arg_tys = arg_tys
+                      , pm_con_tvs     = ex_tvs
+                      , pm_con_dicts   = dicts
+                      , pm_con_args    = args }]
 
   NPat (L _ ol) mb_neg _eq ty -> translateNPat fam_insts ol mb_neg ty
 
@@ -442,17 +499,17 @@ translatePat fam_insts pat = case pat of
 
   PArrPat ps ty -> do
     tidy_ps <- translatePatVec fam_insts (map unLoc ps)
-    let fake_con = parrFakeCon (length ps)
+    let fake_con = RealDataCon (parrFakeCon (length ps))
     return [vanillaConPattern fake_con [ty] (concat tidy_ps)]
 
   TuplePat ps boxity tys -> do
     tidy_ps <- translatePatVec fam_insts (map unLoc ps)
-    let tuple_con = tupleDataCon boxity (length ps)
+    let tuple_con = RealDataCon (tupleDataCon boxity (length ps))
     return [vanillaConPattern tuple_con tys (concat tidy_ps)]
 
   SumPat p alt arity ty -> do
     tidy_p <- translatePat fam_insts (unLoc p)
-    let sum_con = sumDataCon alt arity
+    let sum_con = RealDataCon (sumDataCon alt arity)
     return [vanillaConPattern sum_con ty tidy_p]
 
   -- --------------------------------------------------------------------------
@@ -486,7 +543,7 @@ translatePatVec fam_insts pats = mapM (translatePat fam_insts) pats
 
 -- | Translate a constructor pattern
 translateConPatVec :: FamInstEnvs -> [Type] -> [TyVar]
-                   -> DataCon -> HsConPatDetails Id -> DsM PatVec
+                   -> ConLike -> HsConPatDetails Id -> DsM PatVec
 translateConPatVec fam_insts _univ_tys _ex_tvs _ (PrefixCon ps)
   = concat <$> translatePatVec fam_insts (map unLoc ps)
 translateConPatVec fam_insts _univ_tys _ex_tvs _ (InfixCon p1 p2)
@@ -525,10 +582,10 @@ translateConPatVec fam_insts  univ_tys  ex_tvs c (RecCon (HsRecFields fs _))
       return (arg_var_pats ++ guards)
   where
     -- The actual argument types (instantiated)
-    arg_tys = dataConInstOrigArgTys c (univ_tys ++ mkTyVarTys ex_tvs)
+    arg_tys = conLikeInstOrigArgTys c (univ_tys ++ mkTyVarTys ex_tvs)
 
     -- Some label information
-    orig_lbls    = map flSelector $ dataConFieldLabels c
+    orig_lbls    = map flSelector $ conLikeFieldLabels c
     matched_pats = [ (getName (unLoc (hsRecFieldId x)), unLoc (hsRecFieldArg x))
                    | L _ x <- fs]
     matched_lbls = [ name | (name, _pat) <- matched_pats ]
@@ -579,7 +636,7 @@ translateGuards fam_insts guards = do
     shouldKeep :: Pattern -> Bool
     shouldKeep p
       | PmVar {} <- p      = True
-      | PmCon {} <- p      = length (allConstructors (pm_con_con p)) == 1
+      | PmCon {} <- p      = singleConstructor (pm_con_con p)
                              && all shouldKeep (pm_con_args p)
     shouldKeep (PmGrd pv e)
       | all shouldKeep pv  = True
@@ -590,7 +647,7 @@ translateGuards fam_insts guards = do
 cantFailPattern :: Pattern -> Bool
 cantFailPattern p
   | PmVar {} <- p = True
-  | PmCon {} <- p = length (allConstructors (pm_con_con p)) == 1
+  | PmCon {} <- p = singleConstructor (pm_con_con p)
                     && all cantFailPattern (pm_con_args p)
 cantFailPattern (PmGrd pv _e)
                   = all cantFailPattern pv
@@ -739,7 +796,7 @@ families is not really efficient.
 -- of the first (or the single -WHEREVER IT IS- valid to use?) pattern
 pmPatType :: PmPat p -> Type
 pmPatType (PmCon { pm_con_con = con, pm_con_arg_tys = tys })
-  = mkTyConApp (dataConTyCon con) tys
+  = conLikeResTy con tys
 pmPatType (PmVar  { pm_var_id  = x }) = idType x
 pmPatType (PmLit  { pm_lit_lit = l }) = pmLitType l
 pmPatType (PmNLit { pm_lit_id  = x }) = idType x
@@ -749,7 +806,7 @@ pmPatType (PmGrd  { pm_grd_pv  = pv })
 
 -- | Generate a value abstraction for a given constructor (generate
 -- fresh variables of the appropriate type for arguments)
-mkOneConFull :: Id -> DataCon -> DsM (ValAbs, ComplexEq, Bag EvVar)
+mkOneConFull :: Id -> ConLike -> DsM (ValAbs, ComplexEq, Bag EvVar)
 --  *  x :: T tys, where T is an algebraic data type
 --     NB: in the case of a data familiy, T is the *representation* TyCon
 --     e.g.   data instance T (a,b) = T1 a b
@@ -766,12 +823,12 @@ mkOneConFull :: Id -> DataCon -> DsM (ValAbs, ComplexEq, Bag EvVar)
 --          ComplexEq:       x ~ K y1..yn
 --          [EvVar]:         Q
 mkOneConFull x con = do
-  let -- res_ty == TyConApp (dataConTyCon cabs_con) cabs_arg_tys
+  let -- res_ty == TyConApp (ConLikeTyCon cabs_con) cabs_arg_tys
       res_ty  = idType x
-      (univ_tvs, ex_tvs, eq_spec, thetas, arg_tys, _) = dataConFullSig con
-      data_tc = dataConTyCon con   -- The representation TyCon
+      (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , arg_tys, _)
+        = conLikeFullSig con
       tc_args = case splitTyConApp_maybe res_ty of
-                  Just (tc, tys) -> ASSERT( tc == data_tc ) tys
+                  Just (_, tys) -> tys
                   Nothing -> pprPanic "mkOneConFull: Not TyConApp:" (ppr res_ty)
       subst1  = zipTvSubst univ_tvs tc_args
 
@@ -866,9 +923,38 @@ coercePmPat (PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys
            , pm_con_args = coercePatVec args }]
 coercePmPat (PmGrd {}) = [] -- drop the guards
 
--- | Get all constructors in the family (including given)
-allConstructors :: DataCon -> [DataCon]
-allConstructors = tyConDataCons . dataConTyCon
+-- | Check whether a data constructor is the only way to construct
+-- a data type.
+singleConstructor :: ConLike -> Bool
+singleConstructor (RealDataCon dc) =
+  case tyConDataCons (dataConTyCon dc) of
+    [_] -> True
+    _   -> False
+singleConstructor _ = False
+
+-- | For a given conlike, finds all the sets of patterns which could
+-- be relevant to that conlike by consulting the result type.
+--
+-- These come from two places.
+--  1. From data constructors defined with the result type constructor.
+--  2. From `COMPLETE` pragmas which have the same type as the result
+--     type constructor.
+allCompleteMatches :: ConLike -> [Type] -> DsM [(Provenance, [ConLike])]
+allCompleteMatches cl tys = do
+  let fam = case cl of
+           RealDataCon dc ->
+            [(FromBuiltin, map RealDataCon (tyConDataCons (dataConTyCon dc)))]
+           PatSynCon _    -> []
+
+
+  from_pragma <- map ((FromComplete,) . completeMatch) <$>
+                  case splitTyConApp_maybe (conLikeResTy cl tys) of
+                    Just (tc, _) -> dsGetCompleteMatches tc
+                    Nothing -> return []
+
+  let final_groups = fam ++ from_pragma
+  tracePmD "allCompleteMatches" (ppr final_groups)
+  return final_groups
 
 -- -----------------------------------------------------------------------
 -- * Types and constraints
@@ -962,11 +1048,8 @@ Main functions are:
 -- value set abstraction, but calling it on every vector and the combining the
 -- results.
 runMany :: (ValVec -> PmM PartialResult) -> (Uncovered -> PmM PartialResult)
-runMany _ [] = return $ PartialResult mempty mempty mempty
-runMany pm (m:ms) = do
-  (PartialResult c v d) <- pm m
-  (PartialResult cs vs ds) <- runMany pm ms
-  return (PartialResult (c `mappend` cs) (v `mappend` vs) (d `mappend` ds))
+runMany _ [] = return mempty
+runMany pm (m:ms) = mappend <$> pm m <*> runMany pm ms
 {-# INLINE runMany #-}
 
 -- | Generate the initial uncovered set. It initializes the
@@ -1005,7 +1088,8 @@ pmcheckGuardsI gvs vva = liftD incrCheckPmIterDs >> pmcheckGuards gvs vva
 
 -- | Increase the counter for elapsed algorithm iterations, check that the
 -- limit is not exceeded and call `pmcheckHd`
-pmcheckHdI :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec -> PmM PartialResult
+pmcheckHdI :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec
+           -> PmM PartialResult
 pmcheckHdI p ps guards va vva = do
   n <- liftD incrCheckPmIterDs
   tracePm "pmCheckHdI" (ppr n <> colon <+> pprPmPatDebug p
@@ -1050,14 +1134,18 @@ pmcheck (p:ps) guards (ValVec (va:vva) delta)
 pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult
 pmcheckGuards []       vva = return (usimple [vva])
 pmcheckGuards (gv:gvs) vva = do
-  (PartialResult cs vsa ds) <- pmcheckI gv [] vva
-  (PartialResult css vsas dss) <- runMany (pmcheckGuardsI gvs) vsa
-  return $ PartialResult (cs `mappend` css) vsas (ds `mappend` dss)
+  (PartialResult prov1 cs vsa ds) <- pmcheckI gv [] vva
+  (PartialResult prov2 css vsas dss) <- runMany (pmcheckGuardsI gvs) vsa
+  return $ PartialResult (prov1 `mappend` prov2)
+                         (cs `mappend` css)
+                         vsas
+                         (ds `mappend` dss)
 
 -- | Worker function: Implements all cases described in the paper for all three
 -- functions (`covered`, `uncovered` and `divergent`) apart from the `Guard`
 -- cases which are handled by `pmcheck`
-pmcheckHd :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec -> PmM PartialResult
+pmcheckHd :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec
+          -> PmM PartialResult
 
 -- Var
 pmcheckHd (PmVar x) ps guards va (ValVec vva delta)
@@ -1081,9 +1169,12 @@ pmcheckHd (PmLit l1) ps guards (va@(PmLit l2)) vva =
     False -> return $ ucon va (usimple [vva])
 
 -- ConVar
-pmcheckHd (p@(PmCon { pm_con_con = con })) ps guards
+pmcheckHd (p@(PmCon { pm_con_con = con, pm_con_arg_tys = tys }))
+          ps guards
           (PmVar x) (ValVec vva delta) = do
-  cons_cs  <- mapM (liftD . mkOneConFull x) (allConstructors con)
+  (prov, complete_match) <- select =<< liftD (allCompleteMatches con tys)
+
+  cons_cs <- mapM (liftD . mkOneConFull x) complete_match
 
   inst_vsa <- flip concatMapM cons_cs $ \(va, tm_ct, ty_cs) -> do
     let ty_state = ty_cs `unionBags` delta_ty_cs delta -- not actually a state
@@ -1093,8 +1184,9 @@ pmcheckHd (p@(PmCon { pm_con_con = con })) ps guards
       (True, Just tm_state) -> [ValVec (va:vva) (MkDelta ty_state tm_state)]
       _ty_or_tm_failed      -> []
 
-  force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>
-    runMany (pmcheckI (p:ps) guards) inst_vsa
+  set_provenance prov .
+    force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>
+      runMany (pmcheckI (p:ps) guards) inst_vsa
 
 -- LitVar
 pmcheckHd (p@(PmLit l)) ps guards (PmVar x) (ValVec vva delta)
@@ -1187,10 +1279,10 @@ ucon va = updateVsa upd
 -- value vector abstractions of length `(a+n)`, pass the first `n` value
 -- abstractions to the constructor (Hence, the resulting value vector
 -- abstractions will have length `n+1`)
-kcon :: DataCon -> [Type] -> [TyVar] -> [EvVar]
+kcon :: ConLike -> [Type] -> [TyVar] -> [EvVar]
      -> PartialResult -> PartialResult
 kcon con arg_tys ex_tvs dicts
-  = let n = dataConSourceArity con
+  = let n = conLikeArity con
         upd vsa =
           [ ValVec (va:vva) delta
           | ValVec vva' delta <- vsa
@@ -1223,6 +1315,9 @@ force_if :: Bool -> PartialResult -> PartialResult
 force_if True  pres = forces pres
 force_if False pres = pres
 
+set_provenance :: Provenance -> PartialResult -> PartialResult
+set_provenance prov pr = pr { presultProvenence = prov }
+
 -- ----------------------------------------------------------------------------
 -- * Propagation of term constraints inwards when checking nested matches
 
@@ -1360,8 +1455,8 @@ wrapUpTmState (residual, (_, subst)) = (residual, flattenPmVarEnv subst)
 dsPmWarn :: DynFlags -> DsMatchContext -> PmResult -> DsM ()
 dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
   = when (flag_i || flag_u) $ do
-      let exists_r = flag_i && notNull redundant
-          exists_i = flag_i && notNull inaccessible
+      let exists_r = flag_i && notNull redundant && onlyBuiltin
+          exists_i = flag_i && notNull inaccessible && onlyBuiltin
           exists_u = flag_u && notNull uncovered
       when exists_r $ forM_ redundant $ \(L l q) -> do
         putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
@@ -1373,7 +1468,8 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
         putSrcSpanDs loc (warnDs flag_u_reason (pprEqns uncovered))
   where
     PmResult
-      { pmresultRedundant = redundant
+      { pmresultProvenance = prov
+      , pmresultRedundant = redundant
       , pmresultUncovered = uncovered
       , pmresultInaccessible = inaccessible } = pm_result
 
@@ -1381,6 +1477,8 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
     flag_u = exhaustive dflags kind
     flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)
 
+    onlyBuiltin = prov == FromBuiltin
+
     maxPatterns = maxUncoveredPatterns dflags
 
     -- Print a single clause (for redundant/with-inaccessible-rhs)
index 1e117b3..1cd7979 100644 (file)
@@ -296,7 +296,9 @@ deSugar hsc_env
                             tcg_tcs          = tcs,
                             tcg_insts        = insts,
                             tcg_fam_insts    = fam_insts,
-                            tcg_hpc          = other_hpc_info})
+                            tcg_hpc          = other_hpc_info,
+                            tcg_complete_matches = complete_matches
+                            })
 
   = do { let dflags = hsc_dflags hsc_env
              print_unqual = mkPrintUnqualified dflags rdr_env
@@ -313,8 +315,9 @@ deSugar hsc_env
                               then addTicksToBinds hsc_env mod mod_loc
                                        export_set (typeEnvTyCons type_env) binds
                               else return (binds, hpcInfo, Nothing)
-
-        ; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $
+        ; (msgs, mb_res)
+            <- initDs hsc_env mod rdr_env type_env
+                      fam_inst_env complete_matches $
                        do { ds_ev_binds <- dsEvBinds ev_binds
                           ; core_prs <- dsTopLHsBinds binds_cvr
                           ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
@@ -396,7 +399,8 @@ deSugar hsc_env
                 mg_vect_decls   = ds_vects,
                 mg_vect_info    = noVectInfo,
                 mg_safe_haskell = safe_mode,
-                mg_trust_pkg    = imp_trust_own_pkg imports
+                mg_trust_pkg    = imp_trust_own_pkg imports,
+                mg_complete_sigs = complete_matches
               }
         ; return (msgs, Just mod_guts)
         }}}}
@@ -451,7 +455,7 @@ deSugarExpr hsc_env tc_expr
 
          -- Do desugaring
        ; (msgs, mb_core_expr) <- initDs hsc_env (icInteractiveModule icntxt) rdr_env
-                                        type_env fam_inst_env $
+                                        type_env fam_inst_env [] $
                                  dsLExpr tc_expr
 
        ; case mb_core_expr of
index 27106a2..049c226 100644 (file)
@@ -737,6 +737,7 @@ rep_sig (L loc (SpecSig nm tys ispec))
 rep_sig (L loc (SpecInstSig _ ty))    = rep_specialiseInst ty loc
 rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
 rep_sig (L _   (SCCFunSig {}))        = notHandled "SCC pragmas" empty
+rep_sig (L _   (CompleteMatchSig {})) = notHandled "CompleteMatchSig" empty
 
 rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name
            -> DsM (SrcSpan, Core TH.DecQ)
index 24cca5d..f9533e3 100644 (file)
@@ -35,7 +35,7 @@ module DsMonad (
         getDictsDs, addDictsDs, getTmCsDs, addTmCsDs,
 
         -- Iterations for pm checking
-        incrCheckPmIterDs, resetPmIterDs,
+        incrCheckPmIterDs, resetPmIterDs, dsGetCompleteMatches,
 
         -- Warnings and errors
         DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,
@@ -83,6 +83,7 @@ import FastString
 import Maybes
 import Var (EvVar)
 import qualified GHC.LanguageExtensions as LangExt
+import UniqFM ( lookupWithDefaultUFM )
 
 import Data.IORef
 import Control.Monad
@@ -152,17 +153,19 @@ type DsWarning = (SrcSpan, SDoc)
 
 initDs :: HscEnv
        -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
+       -> [CompleteMatch]
        -> DsM a
        -> IO (Messages, Maybe a)
 -- Print errors and warnings, if any arise
 
-initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside
+initDs hsc_env mod rdr_env type_env fam_inst_env complete_matches thing_inside
   = do  { msg_var <- newIORef (emptyBag, emptyBag)
+        ; let all_matches = (hptCompleteSigs hsc_env) ++ complete_matches
         ; pm_iter_var      <- newIORef 0
         ; let dflags                   = hsc_dflags hsc_env
               (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env
                                                   fam_inst_env msg_var
-                                                  pm_iter_var
+                                                  pm_iter_var all_matches
 
         ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
                           loadDAP $
@@ -241,8 +244,9 @@ initDsTc thing_inside
         ; let type_env = tcg_type_env tcg_env
               rdr_env  = tcg_rdr_env tcg_env
               fam_inst_env = tcg_fam_inst_env tcg_env
+              complete_matches = tcg_complete_matches tcg_env
               ds_envs  = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
-                                  msg_var pm_iter_var
+                                  msg_var pm_iter_var complete_matches
         ; setEnvs ds_envs thing_inside
         }
 
@@ -270,13 +274,15 @@ initTcDsForSolver thing_inside
          thing_inside }
 
 mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-         -> IORef Messages -> IORef Int -> (DsGblEnv, DsLclEnv)
-mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar
+         -> IORef Messages -> IORef Int -> [CompleteMatch]
+         -> (DsGblEnv, DsLclEnv)
+mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar complete_matches
   = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs",
                              if_rec_types = Just (mod, return type_env) }
         if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
                              False -- not boot!
         real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
+        completeMatchMap = mkCompleteMatchMap complete_matches
         gbl_env = DsGblEnv { ds_mod     = mod
                            , ds_fam_inst_env = fam_inst_env
                            , ds_if_env  = (if_genv, if_lenv)
@@ -284,6 +290,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar
                            , ds_msgs    = msg_var
                            , ds_dph_env = emptyGlobalRdrEnv
                            , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
+                           , ds_complete_matches = completeMatchMap
                            }
         lcl_env = DsLclEnv { dsl_meta    = emptyNameEnv
                            , dsl_loc     = real_span
@@ -293,6 +300,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar
                            }
     in (gbl_env, lcl_env)
 
+
 -- Attempt to load the given module and return its exported entities if successful.
 --
 loadModule :: SDoc -> Module -> DsM GlobalRdrEnv
@@ -608,6 +616,12 @@ dsGetFamInstEnvs
 dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
 dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
 
+-- | The @COMPLETE@ pragams provided by the user for a given `TyCon`.
+dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]
+dsGetCompleteMatches tc = do
+  env <- getGblEnv
+  return $ (lookupWithDefaultUFM (ds_complete_matches env) [] tc)
+
 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
 
index e35358f..8c3df96 100644 (file)
@@ -53,11 +53,15 @@ refer to variables that are otherwise substituted away.
 
 -- | Lifted expressions for pattern match checking.
 data PmExpr = PmExprVar   Name
-            | PmExprCon   DataCon [PmExpr]
+            | PmExprCon   ConLike [PmExpr]
             | PmExprLit   PmLit
             | PmExprEq    PmExpr PmExpr  -- Syntactic equality
             | PmExprOther (HsExpr Id)    -- Note [PmExprOther in PmExpr]
 
+
+mkPmExprData :: DataCon -> [PmExpr] -> PmExpr
+mkPmExprData dc args = PmExprCon (RealDataCon dc) args
+
 -- | Literals (simple and overloaded ones) for pattern match checking.
 data PmLit = PmSLit HsLit                                    -- simple
            | PmOLit Bool {- is it negated? -} (HsOverLit Id) -- overloaded
@@ -148,11 +152,11 @@ toComplex (x,e) = (PmExprVar (idName x), e)
 
 -- | Expression `True'
 truePmExpr :: PmExpr
-truePmExpr = PmExprCon trueDataCon []
+truePmExpr = mkPmExprData trueDataCon []
 
 -- | Expression `False'
 falsePmExpr :: PmExpr
-falsePmExpr = PmExprCon falseDataCon []
+falsePmExpr = mkPmExprData falseDataCon []
 
 -- ----------------------------------------------------------------------------
 -- ** Predicates on PmExpr
@@ -169,17 +173,17 @@ isNegatedPmLit _other_lit   = False
 
 -- | Check whether a PmExpr is syntactically equal to term `True'.
 isTruePmExpr :: PmExpr -> Bool
-isTruePmExpr (PmExprCon c []) = c == trueDataCon
+isTruePmExpr (PmExprCon c []) = c == RealDataCon trueDataCon
 isTruePmExpr _other_expr      = False
 
 -- | Check whether a PmExpr is syntactically equal to term `False'.
 isFalsePmExpr :: PmExpr -> Bool
-isFalsePmExpr (PmExprCon c []) = c == falseDataCon
+isFalsePmExpr (PmExprCon c []) = c == RealDataCon falseDataCon
 isFalsePmExpr _other_expr      = False
 
 -- | Check whether a PmExpr is syntactically e
 isNilPmExpr :: PmExpr -> Bool
-isNilPmExpr (PmExprCon c _) = c == nilDataCon
+isNilPmExpr (PmExprCon c _) = c == RealDataCon nilDataCon
 isNilPmExpr _other_expr     = False
 
 -- | Check whether a PmExpr is syntactically equal to (x == y).
@@ -242,7 +246,7 @@ hsExprToPmExpr e@(NegApp _ neg_e)
 hsExprToPmExpr (HsPar (L _ e)) = hsExprToPmExpr e
 
 hsExprToPmExpr e@(ExplicitTuple ps boxity)
-  | all tupArgPresent ps = PmExprCon tuple_con tuple_args
+  | all tupArgPresent ps = mkPmExprData tuple_con tuple_args
   | otherwise            = PmExprOther e
   where
     tuple_con  = tupleDataCon boxity (length ps)
@@ -252,11 +256,12 @@ hsExprToPmExpr e@(ExplicitList _elem_ty mb_ol elems)
   | Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems)
   | otherwise        = PmExprOther e {- overloaded list: No PmExprApp -}
   where
-    cons x xs = PmExprCon consDataCon [x,xs]
-    nil       = PmExprCon nilDataCon  []
+    cons x xs = mkPmExprData consDataCon [x,xs]
+    nil       = mkPmExprData nilDataCon  []
 
 hsExprToPmExpr (ExplicitPArr _elem_ty elems)
-  = PmExprCon (parrFakeCon (length elems)) (map lhsExprToPmExpr elems)
+  = mkPmExprData (parrFakeCon (length elems)) (map lhsExprToPmExpr elems)
+
 
 -- we want this but we would have to make everything monadic :/
 -- ./compiler/deSugar/DsMonad.hs:397:dsLookupDataCon :: Name -> DsM DataCon
@@ -388,30 +393,22 @@ needsParens (PmExprVar   {}) = False
 needsParens (PmExprLit    l) = isNegatedPmLit l
 needsParens (PmExprEq    {}) = False -- will become a wildcard
 needsParens (PmExprOther {}) = False -- will become a wildcard
-needsParens (PmExprCon c es)
+needsParens (PmExprCon (RealDataCon c) es)
   | isTupleDataCon c || isPArrFakeCon c
   || isConsDataCon c || null es = False
   | otherwise                   = True
+needsParens (PmExprCon (PatSynCon _) es) = not (null es)
 
 pprPmExprWithParens :: PmExpr -> PmPprM SDoc
 pprPmExprWithParens expr
   | needsParens expr = parens <$> pprPmExpr expr
   | otherwise        =            pprPmExpr expr
 
-pprPmExprCon :: DataCon -> [PmExpr] -> PmPprM SDoc
-pprPmExprCon con args
+pprPmExprCon :: ConLike -> [PmExpr] -> PmPprM SDoc
+pprPmExprCon (RealDataCon con) args
   | isTupleDataCon con = mkTuple <$> mapM pprPmExpr args
   |  isPArrFakeCon con = mkPArr  <$> mapM pprPmExpr args
   |  isConsDataCon con = pretty_list
-  | dataConIsInfix con = case args of
-      [x, y] -> do x' <- pprPmExprWithParens x
-                   y' <- pprPmExprWithParens y
-                   return (x' <+> ppr con <+> y')
-      -- can it be infix but have more than two arguments?
-      list   -> pprPanic "pprPmExprCon:" (ppr list)
-  | null args = return (ppr con)
-  | otherwise = do args' <- mapM pprPmExprWithParens args
-                   return (fsep (ppr con : args'))
   where
     mkTuple, mkPArr :: [SDoc] -> SDoc
     mkTuple = parens     . fsep . punctuate comma
@@ -426,10 +423,22 @@ pprPmExprCon con args
     list = list_elements args
 
     list_elements [x,y]
-      | PmExprCon c es <- y,  nilDataCon == c = ASSERT(null es) [x,y]
-      | PmExprCon c es <- y, consDataCon == c = x : list_elements es
+      | PmExprCon c es <- y,  RealDataCon nilDataCon == c
+          = ASSERT(null es) [x,y]
+      | PmExprCon c es <- y, RealDataCon consDataCon == c
+          = x : list_elements es
       | otherwise = [x,y]
     list_elements list  = pprPanic "list_elements:" (ppr list)
+pprPmExprCon cl args
+  | conLikeIsInfix cl = case args of
+      [x, y] -> do x' <- pprPmExprWithParens x
+                   y' <- pprPmExprWithParens y
+                   return (x' <+> ppr cl <+> y')
+      -- can it be infix but have more than two arguments?
+      list   -> pprPanic "pprPmExprCon:" (ppr list)
+  | null args = return (ppr cl)
+  | otherwise = do args' <- mapM pprPmExprWithParens args
+                   return (fsep (ppr cl : args'))
 
 instance Outputable PmLit where
   ppr (PmSLit     l) = pmPprHsLit l
index 05966cd..64f20e2 100644 (file)
@@ -26,7 +26,6 @@ import PmExpr
 
 import Id
 import Name
-import TysWiredIn
 import Type
 import HsLit
 import TcHsSyn
@@ -113,12 +112,12 @@ solveComplexEq solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case eq of
   (PmExprCon c1 ts1, PmExprCon c2 ts2)
     | c1 == c2  -> foldlM solveComplexEq solver_state (zip ts1 ts2)
     | otherwise -> Nothing
-  (PmExprCon c [], PmExprEq t1 t2)
-    | c == trueDataCon  -> solveComplexEq solver_state (t1, t2)
-    | c == falseDataCon -> Just (eq:standby, (unhandled, env))
-  (PmExprEq t1 t2, PmExprCon c [])
-    | c == trueDataCon  -> solveComplexEq solver_state (t1, t2)
-    | c == falseDataCon -> Just (eq:standby, (unhandled, env))
+  (PmExprCon _ [], PmExprEq t1 t2)
+    | isTruePmExpr e1  -> solveComplexEq solver_state (t1, t2)
+    | isFalsePmExpr e1 -> Just (eq:standby, (unhandled, env))
+  (PmExprEq t1 t2, PmExprCon _ [])
+    | isTruePmExpr e2   -> solveComplexEq solver_state (t1, t2)
+    | isFalsePmExpr e2  -> Just (eq:standby, (unhandled, env))
 
   (PmExprVar x, PmExprVar y)
     | x == y    -> Just solver_state
index e04dc89..1f38c38 100644 (file)
@@ -853,6 +853,7 @@ data Sig name
   | SCCFunSig  SourceText      -- Note [Pragma source text] in BasicTypes
                (Located name)  -- Function name
                (Maybe StringLiteral)
+  | CompleteMatchSig SourceText (Located [Located name]) (Maybe (Located name))
 
 deriving instance (DataId name) => Data (Sig name)
 
@@ -920,6 +921,7 @@ isPragLSig :: LSig name -> Bool
 isPragLSig (L _ (SpecSig {}))   = True
 isPragLSig (L _ (InlineSig {})) = True
 isPragLSig (L _ (SCCFunSig {})) = True
+isPragLSig (L _ (CompleteMatchSig {})) = True
 isPragLSig _                    = False
 
 isInlineLSig :: LSig name -> Bool
@@ -935,6 +937,10 @@ isSCCFunSig :: LSig name -> Bool
 isSCCFunSig (L _ (SCCFunSig {})) = True
 isSCCFunSig _                    = False
 
+isCompleteMatchSig :: LSig name -> Bool
+isCompleteMatchSig (L _ (CompleteMatchSig {} )) = True
+isCompleteMatchSig _                            = False
+
 hsSigDoc :: Sig name -> SDoc
 hsSigDoc (TypeSig {})           = text "type signature"
 hsSigDoc (PatSynSig {})         = text "pattern synonym signature"
@@ -948,6 +954,7 @@ hsSigDoc (SpecInstSig {})       = text "SPECIALISE instance pragma"
 hsSigDoc (FixSig {})            = text "fixity declaration"
 hsSigDoc (MinimalSig {})        = text "MINIMAL pragma"
 hsSigDoc (SCCFunSig {})         = text "SCC pragma"
+hsSigDoc (CompleteMatchSig {})  = text "COMPLETE pragma"
 
 {-
 Check if signatures overlap; this is used when checking for duplicate
@@ -983,6 +990,12 @@ ppr_sig (PatSynSig names sig_ty)
   = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty)
 ppr_sig (SCCFunSig src fn mlabel)
   = pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel )
+ppr_sig (CompleteMatchSig src cs mty)
+  = pragSrcBrackets src "{-# COMPLETE"
+      ((hsep (punctuate comma (map ppr (unLoc cs))))
+        <+> opt_sig)
+  where
+    opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty
 
 instance OutputableBndr name => Outputable (FixitySig name) where
   ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
index 72a5b57..7a1d427 100644 (file)
@@ -19,6 +19,7 @@ module IfaceSyn (
         IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..),
         IfaceAxBranch(..),
         IfaceTyConParent(..),
+        IfaceCompleteMatch(..),
 
         -- * Binding names
         IfaceTopBndr,
@@ -295,6 +296,11 @@ data IfaceAnnotation
 
 type IfaceAnnTarget = AnnTarget OccName
 
+data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] IfExtName
+
+
+
+
 -- Here's a tricky case:
 --   * Compile with -O module A, and B which imports A.f
 --   * Change function f in A, and recompile without -O
@@ -2090,3 +2096,7 @@ instance Binary IfaceTyConParent where
                 pr <- get bh
                 ty <- get bh
                 return $ IfDataInstance ax pr ty
+
+instance Binary IfaceCompleteMatch where
+  put_ bh (IfaceCompleteMatch cs ts) = put_ bh cs >> put_ bh ts
+  get bh = IfaceCompleteMatch <$> get bh <*> get bh
index bdc9f0f..5215965 100644 (file)
@@ -206,7 +206,8 @@ mkIface_ hsc_env maybe_old_fingerprint
                       md_anns      = anns,
                       md_vect_info = vect_info,
                       md_types     = type_env,
-                      md_exports   = exports }
+                      md_exports   = exports,
+                      md_complete_sigs = complete_sigs }
 -- NB:  notice that mkIface does not look at the bindings
 --      only at the TypeEnv.  The previous Tidy phase has
 --      put exactly the info into the TypeEnv that we want
@@ -241,6 +242,7 @@ mkIface_ hsc_env maybe_old_fingerprint
         iface_vect_info = flattenVectInfo vect_info
         trust_info  = setSafeMode safe_mode
         annotations = map mkIfaceAnnotation anns
+        icomplete_sigs = map mkIfaceCompleteSig complete_sigs
 
         intermediate_iface = ModIface {
               mi_module      = this_mod,
@@ -285,7 +287,8 @@ mkIface_ hsc_env maybe_old_fingerprint
 
               -- And build the cached values
               mi_warn_fn     = mkIfaceWarnCache warns,
-              mi_fix_fn      = mkIfaceFixCache fixities }
+              mi_fix_fn      = mkIfaceFixCache fixities,
+              mi_complete_sigs = icomplete_sigs }
 
     (new_iface, no_change_at_all)
           <- {-# SCC "versioninfo" #-}
@@ -993,6 +996,19 @@ mkOrphMap get_key decls
 {-
 ************************************************************************
 *                                                                      *
+       COMPLETE Pragmas
+*                                                                      *
+************************************************************************
+-}
+
+mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch
+mkIfaceCompleteSig (CompleteMatch cls tc) =
+  IfaceCompleteMatch (map conLikeName cls) (tyConName tc)
+
+
+{-
+************************************************************************
+*                                                                      *
        Keeping track of what we've slurped, and fingerprints
 *                                                                      *
 ************************************************************************
index c0b8464..e08a3d7 100644 (file)
@@ -177,6 +177,9 @@ typecheckIface iface
                 -- Exports
         ; exports <- ifaceExportNames (mi_exports iface)
 
+                -- Complete Sigs
+        ; complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
+
                 -- Finished
         ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
                          -- Careful! If we tug on the TyThing thunks too early
@@ -190,6 +193,7 @@ typecheckIface iface
                               , md_anns      = anns
                               , md_vect_info = vect_info
                               , md_exports   = exports
+                              , md_complete_sigs = complete_sigs
                               }
     }
 
@@ -327,6 +331,7 @@ typecheckIfacesForMerging mod ifaces tc_env_var =
         anns      <- tcIfaceAnnotations (mi_anns iface)
         vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)
         exports   <- ifaceExportNames (mi_exports iface)
+        complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
         return $ ModDetails { md_types     = type_env
                             , md_insts     = insts
                             , md_fam_insts = fam_insts
@@ -334,6 +339,7 @@ typecheckIfacesForMerging mod ifaces tc_env_var =
                             , md_anns      = anns
                             , md_vect_info = vect_info
                             , md_exports   = exports
+                            , md_complete_sigs = complete_sigs
                             }
     return (global_type_env, details)
 
@@ -366,6 +372,7 @@ typecheckIfaceForInstantiate nsubst iface =
     anns      <- tcIfaceAnnotations (mi_anns iface)
     vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)
     exports   <- ifaceExportNames (mi_exports iface)
+    complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
     return $ ModDetails { md_types     = type_env
                         , md_insts     = insts
                         , md_fam_insts = fam_insts
@@ -373,6 +380,7 @@ typecheckIfaceForInstantiate nsubst iface =
                         , md_anns      = anns
                         , md_vect_info = vect_info
                         , md_exports   = exports
+                        , md_complete_sigs = complete_sigs
                         }
 
 -- Note [Resolving never-exported Names in TcIface]
@@ -1016,6 +1024,21 @@ tcIfaceAnnTarget (ModuleTarget mod) = do
 {-
 ************************************************************************
 *                                                                      *
+                Complete Match Pragmas
+*                                                                      *
+************************************************************************
+-}
+
+tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
+tcIfaceCompleteSigs = mapM tcIfaceCompleteSig
+
+tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch
+tcIfaceCompleteSig (IfaceCompleteMatch ms t) =
+  CompleteMatch <$> (mapM tcIfaceConLike ms) <*> tcIfaceTyConByName t
+
+{-
+************************************************************************
+*                                                                      *
                 Vectorisation information
 *                                                                      *
 ************************************************************************
@@ -1668,6 +1691,14 @@ tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
                                 AConLike (RealDataCon dc) -> return dc
                                 _       -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
 
+tcIfaceConLike :: Name -> IfL ConLike
+tcIfaceConLike name =
+    do { thing <- tcIfaceGlobal name
+       ; case thing of
+        AConLike cl -> return cl
+        _           -> pprPanic "tcIfaceExtCL" (ppr name$$ ppr thing) }
+
+
 tcIfaceExtId :: Name -> IfL Id
 tcIfaceExtId name = do { thing <- tcIfaceGlobal name
                        ; case thing of
index 51cec26..0fcf582 100644 (file)
@@ -37,6 +37,7 @@ module HscTypes (
         HomePackageTable, HomeModInfo(..), emptyHomePackageTable,
         lookupHpt, eltsHpt, filterHpt, allHpt, mapHpt, delFromHpt,
         addToHpt, addListToHpt, lookupHptDirectly, listToHpt,
+        hptCompleteSigs,
         hptInstances, hptRules, hptVectInfo, pprHPT,
         hptObjs,
 
@@ -131,6 +132,9 @@ module HscTypes (
         SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
         throwOneError, handleSourceError,
         handleFlagWarnings, printOrThrowWarnings,
+
+        -- * COMPLETE signature
+        CompleteMatch(..)
     ) where
 
 #include "HsVersions.h"
@@ -614,6 +618,8 @@ lookupIfaceByModule _dflags hpt pit mod
 -- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package
 -- of its own, but it doesn't seem worth the bother.
 
+hptCompleteSigs :: HscEnv -> [CompleteMatch]
+hptCompleteSigs = hptAllThings  (md_complete_sigs . hm_details)
 
 -- | Find all the instance declarations (of classes and families) from
 -- the Home Package Table filtered by the provided predicate function.
@@ -916,13 +922,14 @@ data ModIface
         mi_trust     :: !IfaceTrustInfo,
                 -- ^ Safe Haskell Trust information for this module.
 
-        mi_trust_pkg :: !Bool
+        mi_trust_pkg :: !Bool,
                 -- ^ Do we require the package this module resides in be trusted
                 -- to trust this module? This is used for the situation where a
                 -- module is Safe (so doesn't require the package be trusted
                 -- itself) but imports some trustworthy modules from its own
                 -- package (which does require its own package be trusted).
                 -- See Note [RnNames . Trust Own Package]
+        mi_complete_sigs :: [IfaceCompleteMatch]
      }
 
 -- | Old-style accessor for whether or not the ModIface came from an hs-boot
@@ -997,7 +1004,8 @@ instance Binary ModIface where
                  mi_vect_info = vect_info,
                  mi_hpc       = hpc_info,
                  mi_trust     = trust,
-                 mi_trust_pkg = trust_pkg }) = do
+                 mi_trust_pkg = trust_pkg,
+                 mi_complete_sigs = complete_sigs }) = do
         put_ bh mod
         put_ bh sig_of
         put_ bh hsc_src
@@ -1023,6 +1031,7 @@ instance Binary ModIface where
         put_ bh hpc_info
         put_ bh trust
         put_ bh trust_pkg
+        put_ bh complete_sigs
 
    get bh = do
         mod         <- get bh
@@ -1050,6 +1059,7 @@ instance Binary ModIface where
         hpc_info    <- get bh
         trust       <- get bh
         trust_pkg   <- get bh
+        complete_sigs <- get bh
         return (ModIface {
                  mi_module      = mod,
                  mi_sig_of      = sig_of,
@@ -1080,7 +1090,8 @@ instance Binary ModIface where
                         -- And build the cached values
                  mi_warn_fn     = mkIfaceWarnCache warns,
                  mi_fix_fn      = mkIfaceFixCache fixities,
-                 mi_hash_fn     = mkIfaceHashCache decls })
+                 mi_hash_fn     = mkIfaceHashCache decls,
+                 mi_complete_sigs = complete_sigs })
 
 -- | The original names declared of a certain module that are exported
 type IfaceExport = AvailInfo
@@ -1116,7 +1127,8 @@ emptyModIface mod
                mi_hash_fn     = emptyIfaceHashCache,
                mi_hpc         = False,
                mi_trust       = noIfaceTrustInfo,
-               mi_trust_pkg   = False }
+               mi_trust_pkg   = False,
+               mi_complete_sigs = [] }
 
 
 -- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface'
@@ -1148,7 +1160,9 @@ data ModDetails
         md_rules     :: ![CoreRule],    -- ^ Domain may include 'Id's from other modules
         md_anns      :: ![Annotation],  -- ^ Annotations present in this module: currently
                                         -- they only annotate things also declared in this module
-        md_vect_info :: !VectInfo       -- ^ Module vectorisation information
+        md_vect_info :: !VectInfo,       -- ^ Module vectorisation information
+        md_complete_sigs :: [CompleteMatch]
+          -- ^ Complete match pragmas for this module
      }
 
 -- | Constructs an empty ModDetails
@@ -1160,7 +1174,8 @@ emptyModDetails
                  md_rules     = [],
                  md_fam_insts = [],
                  md_anns      = [],
-                 md_vect_info = noVectInfo }
+                 md_vect_info = noVectInfo,
+                 md_complete_sigs = [] }
 
 -- | Records the modules directly imported by a module for extracting e.g.
 -- usage information, and also to give better error message
@@ -1207,6 +1222,7 @@ data ModGuts
         mg_foreign   :: !ForeignStubs,   -- ^ Foreign exports declared in this module
         mg_warns     :: !Warnings,       -- ^ Warnings declared in the module
         mg_anns      :: [Annotation],    -- ^ Annotations declared in this module
+        mg_complete_sigs :: [CompleteMatch], -- ^ Complete Matches
         mg_hpc_info  :: !HpcInfo,        -- ^ Coverage tick boxes in the module
         mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module
         mg_vect_decls:: ![CoreVect],     -- ^ Vectorisation declarations in this module
@@ -2965,3 +2981,17 @@ nameOfObject other       = pprPanic "nameOfObject" (ppr other)
 byteCodeOfObject :: Unlinked -> CompiledByteCode
 byteCodeOfObject (BCOs bc) = bc
 byteCodeOfObject other     = pprPanic "byteCodeOfObject" (ppr other)
+
+
+-------------------------------------------
+
+-- | A list of conlikes which represents a complete pattern match.
+-- These arise from @COMPLETE@ signatures.
+data CompleteMatch = CompleteMatch {
+                          completeMatch :: [ConLike]
+                          , completeMatchType :: TyCon
+                          }
+
+instance Outputable CompleteMatch where
+  ppr (CompleteMatch cl ty) = text "CompleteMatch:" <+> ppr cl
+                                                   <+>  dcolon <+> ppr ty
index cbf7038..c546e5c 100644 (file)
@@ -163,6 +163,7 @@ mkBootModDetailsTc hsc_env
                              , md_anns      = []
                              , md_exports   = exports
                              , md_vect_info = noVectInfo
+                             , md_complete_sigs = []
                              })
         }
   where
@@ -318,6 +319,7 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
                               , mg_rules     = imp_rules
                               , mg_vect_info = vect_info
                               , mg_anns      = anns
+                              , mg_complete_sigs = complete_sigs
                               , mg_deps      = deps
                               , mg_foreign   = foreign_stubs
                               , mg_hpc_info  = hpc_info
@@ -425,7 +427,8 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
                                 md_vect_info = tidy_vect_info,
                                 md_fam_insts = fam_insts,
                                 md_exports   = exports,
-                                md_anns      = anns      -- are already tidy
+                                md_anns      = anns,      -- are already tidy
+                                md_complete_sigs = complete_sigs
                               })
         }
   where
index 6c4abe0..63715a0 100644 (file)
@@ -636,6 +636,7 @@ data Token
   | ITunpack_prag       SourceText
   | ITnounpack_prag     SourceText
   | ITann_prag          SourceText
+  | ITcomplete_prag     SourceText
   | ITclose_prag
   | IToptions_prag String
   | ITinclude_prag String
@@ -2716,7 +2717,7 @@ ignoredPrags = Map.fromList (map ignored pragmas)
                      -- CFILES is a hugs-only thing.
                      pragmas = options_pragmas ++ ["cfiles", "contract"]
 
-oneWordPrags = Map.fromList([
+oneWordPrags = Map.fromList [
      ("rules", rulePrag),
      ("inline",
          strtoken (\s -> (ITinline_prag (SourceText s) Inline FunLike))),
@@ -2744,7 +2745,9 @@ oneWordPrags = Map.fromList([
      ("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))),
      ("overlapping", strtoken (\s -> IToverlapping_prag (SourceText s))),
      ("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))),
-     ("ctype", strtoken (\s -> ITctype (SourceText s)))])
+     ("ctype", strtoken (\s -> ITctype (SourceText s))),
+     ("complete", strtoken (\s -> ITcomplete_prag (SourceText s)))
+     ]
 
 twoWordPrags = Map.fromList([
      ("inline conlike",
index 2228674..2b70fb7 100644 (file)
@@ -441,6 +441,7 @@ are the most common patterns, rewritten as regular expressions for clarity:
  '{-# OVERLAPPABLE'       { L _ (IToverlappable_prag _) }
  '{-# OVERLAPS'           { L _ (IToverlaps_prag _) }
  '{-# INCOHERENT'         { L _ (ITincoherent_prag _) }
+ '{-# COMPLETE'           { L _ (ITcomplete_prag _)   }
  '#-}'                    { L _ ITclose_prag }
 
  '..'           { L _ ITdotdot }                        -- reserved symbols
@@ -1672,6 +1673,10 @@ opt_asig :: { ([AddAnn],Maybe (LHsType RdrName)) }
         : {- empty -}                   { ([],Nothing) }
         | '::' atype                    { ([mu AnnDcolon $1],Just $2) }
 
+opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) }
+             : {- empty -}              { ([], Nothing) }
+             | '::' gtycon              { ([mu AnnDcolon $1], Just $2) }
+
 sigtype :: { LHsType RdrName }
         : ctype                            { $1 }
 
@@ -2248,6 +2253,13 @@ sigdecl :: { LHsDecl RdrName }
 
         | pattern_synonym_sig   { sLL $1 $> . SigD . unLoc $ $1 }
 
+        | '{-# COMPLETE' con_list opt_tyconsig  '#-}'
+                {% let (dcolon, tc) = $3
+                   in ams
+                       (sLL $1 $>
+                         (SigD (CompleteMatchSig (getCOMPLETE_PRAGs $1) $2 tc)))
+                    ([ mo $1 ] ++ dcolon ++ [mc $4]) }
+
         -- This rule is for both INLINE and INLINABLE pragmas
         | '{-# INLINE' activation qvar '#-}'
                 {% ams ((sLL $1 $> $ SigD (InlineSig $3
@@ -3393,6 +3405,7 @@ getTH_ID_TY_SPLICE (L _ (ITidTyEscape x)) = x
 getINLINE       (L _ (ITinline_prag _ inl conl)) = (inl,conl)
 getSPEC_INLINE  (L _ (ITspec_inline_prag _ True))  = (Inline,  FunLike)
 getSPEC_INLINE  (L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike)
+getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x
 
 getDOCNEXT (L _ (ITdocCommentNext x)) = x
 getDOCPREV (L _ (ITdocCommentPrev x)) = x
index 2c96004..64a60c4 100644 (file)
@@ -7,7 +7,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 
-module RdrHsSyn (
+module   RdrHsSyn (
         mkHsOpApp,
         mkHsIntegral, mkHsFractional, mkHsIsString,
         mkHsDo, mkSpliceDecl,
index c232e76..f6a22f5 100644 (file)
@@ -950,6 +950,13 @@ renameSig ctxt sig@(SCCFunSig st v s)
   = do  { new_v <- lookupSigOccRn ctxt sig v
         ; return (SCCFunSig st new_v s, emptyFVs) }
 
+-- COMPLETE Sigs can refer to imported IDs which is why we use
+-- lookupLocatedOccRn rather than lookupSigOccRn
+renameSig _ctxt (CompleteMatchSig s (L l bf) mty)
+  = do new_bf <- traverse lookupLocatedOccRn bf
+       new_mty  <- traverse lookupLocatedOccRn mty
+       return (CompleteMatchSig s (L l new_bf) new_mty, emptyFVs)
+
 ppr_sig_bndrs :: [Located RdrName] -> SDoc
 ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
 
@@ -991,6 +998,9 @@ okHsSig ctxt (L _ sig)
      (SCCFunSig {}, HsBootCtxt {}) -> False
      (SCCFunSig {}, _)             -> True
 
+     (CompleteMatchSig {}, TopSigCtxt {} ) -> True
+     (CompleteMatchSig {}, _)              -> False
+
 -------------------
 findDupSigs :: [LSig RdrName] -> [[(Located RdrName, Sig RdrName)]]
 -- Check for duplicates on RdrName version,
index 2ad00d5..25c4061 100644 (file)
@@ -37,7 +37,7 @@ import FamInstEnv( normaliseType )
 import FamInst( tcGetFamInstEnvs )
 import TyCon
 import TcType
-import Type( mkStrLitTy, tidyOpenType, mkTyVarBinder )
+import Type( mkStrLitTy, tidyOpenType, mkTyVarBinder, splitTyConApp_maybe)
 import TysPrim
 import TysWiredIn( cTupleTyConName )
 import Id
@@ -62,6 +62,7 @@ import TcValidity (checkValidType)
 import Unique (getUnique)
 import UniqFM
 import qualified GHC.LanguageExtensions as LangExt
+import ConLike
 
 import Control.Monad
 
@@ -185,13 +186,115 @@ tcTopBinds binds sigs
                ; return (gbl, lcl) }
         ; specs <- tcImpPrags sigs   -- SPECIALISE prags for imported Ids
 
-        ; let { tcg_env' = tcg_env { tcg_imp_specs = specs ++ tcg_imp_specs tcg_env }
+        ; complete_matches <- setEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs
+        ; traceTc "complete_matches" (ppr binds $$ ppr sigs)
+        ; traceTc "complete_matches" (ppr complete_matches)
+
+        ; let { tcg_env' = tcg_env { tcg_imp_specs
+                                      = specs ++ tcg_imp_specs tcg_env
+                                   , tcg_complete_matches
+                                      = complete_matches
+                                          ++ tcg_complete_matches tcg_env }
                            `addTypecheckedBinds` map snd binds' }
 
         ; return (tcg_env', tcl_env) }
         -- The top level bindings are flattened into a giant
         -- implicitly-mutually-recursive LHsBinds
 
+
+-- Note [Typechecking Complete Matches]
+-- Much like when a user bundled a pattern synonym, the result types of
+-- all the constructors in the match pragma must be consistent.
+--
+-- If we allowed pragmas with inconsistent types then it would be
+-- impossible to ever match every constructor in the list and so
+-- the pragma would be useless.
+
+
+
+
+
+-- This is only used in `tcCompleteSig`. We fold over all the conlikes,
+-- this accumulator keeps track of the first `ConLike` with a concrete
+-- return type. After fixing the return type, all other constructors with
+-- a fixed return type must agree with this.
+--
+-- The fields of `Fixed` cache the first conlike and its return type so
+-- that that we can compare all the other conlikes to it. The conlike is
+-- stored for error messages.
+--
+-- `Nothing` in the case that the type is fixed by a type signature
+data CompleteSigType = AcceptAny | Fixed (Maybe ConLike) TyCon
+
+tcCompleteSigs  :: [LSig Name] -> TcM [CompleteMatch]
+tcCompleteSigs sigs =
+  let
+      doOne :: Sig Name -> TcM (Maybe CompleteMatch)
+      doOne c@(CompleteMatchSig _ lns mtc)
+        = fmap Just $ do
+           addErrCtxt (text "In" <+> ppr c) $
+            case mtc of
+              Nothing -> infer_complete_match
+              Just tc -> check_complete_match tc
+        where
+
+          checkCLTypes acc = foldM checkCLType (acc, []) (unLoc lns)
+
+          infer_complete_match = do
+            (res, cls) <- checkCLTypes AcceptAny
+            case res of
+              AcceptAny -> failWithTc ambiguousError
+              Fixed _ tc  -> return $ CompleteMatch cls tc
+
+          check_complete_match tc_name = do
+            ty_con <- tcLookupLocatedTyCon tc_name
+            (_, cls) <- checkCLTypes (Fixed Nothing ty_con)
+            return $ CompleteMatch cls ty_con
+      doOne _ = return Nothing
+
+      ambiguousError :: SDoc
+      ambiguousError =
+        text "A type signature must be provided for a set of polymorphic"
+          <+> text "pattern synonyms."
+
+
+      -- See note [Typechecking Complete Matches]
+      checkCLType :: (CompleteSigType, [ConLike]) -> Located Name
+                  -> TcM (CompleteSigType, [ConLike])
+      checkCLType (cst, cs) n = do
+        cl <- addLocM tcLookupConLike n
+        let   (_,_,_,_,_,_, res_ty) = conLikeFullSig cl
+              res_ty_con = fst <$> splitTyConApp_maybe res_ty
+        case (cst, res_ty_con) of
+          (AcceptAny, Nothing) -> return (AcceptAny, cl:cs)
+          (AcceptAny, Just tc) -> return (Fixed (Just cl) tc, cl:cs)
+          (Fixed mfcl tc, Nothing)  -> return (Fixed mfcl tc, cl:cs)
+          (Fixed mfcl tc, Just tc') ->
+            if tc == tc'
+              then return (Fixed mfcl tc, cl:cs)
+              else case mfcl of
+                     Nothing ->
+                      addErrCtxt (text "In" <+> ppr cl) $
+                        failWithTc typeSigErrMsg
+                     Just cl -> failWithTc (errMsg cl)
+             where
+              typeSigErrMsg :: SDoc
+              typeSigErrMsg =
+                text "Couldn't match expected type"
+                      <+> quotes (ppr tc)
+                      <+> text "with"
+                      <+> quotes (ppr tc')
+
+              errMsg :: ConLike -> SDoc
+              errMsg fcl =
+                text "Cannot form a group of complete patterns from patterns"
+                  <+> quotes (ppr fcl) <+> text "and" <+> quotes (ppr cl)
+                  <+> text "as they match different type constructors"
+                  <+> parens (quotes (ppr tc)
+                               <+> text "resp."
+                               <+> quotes (ppr tc'))
+  in  mapMaybeM (addLocM doOne) sigs
+
 tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv
 tcRecSelBinds (ValBindsOut binds sigs)
   = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $
index 2d35e96..28ca41b 100644 (file)
@@ -253,7 +253,7 @@ tcRnModuleTcRnM hsc_env hsc_src
         tcg_env <- tcRnExports explicit_mod_hdr export_ies tcg_env ;
         traceRn "rn4b: after exports" empty ;
 
-                -- Check that main is exported (must be after rnExports)
+                -- Check that main is exported (must be after tcRnExports)
         checkMainExported tcg_env ;
 
         -- Compare the hi-boot iface (if any) with the real thing
index 4388b44..3c6a6c4 100644 (file)
@@ -297,7 +297,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_dependent_files = dependent_files_var,
                 tcg_tc_plugins     = [],
                 tcg_top_loc        = loc,
-                tcg_static_wc      = static_wc_var
+                tcg_static_wc      = static_wc_var,
+                tcg_complete_matches = []
              } ;
              lcl_env = TcLclEnv {
                 tcl_errs       = errs_var,
index a998e49..9e3ed5b 100644 (file)
@@ -43,11 +43,11 @@ module TcRnTypes(
         IdBindingInfo(..),
         IsGroupClosed(..),
         SelfBootInfo(..),
-        pprTcTyThingCategory, pprPECategory,
+        pprTcTyThingCategory, pprPECategory, CompleteMatch(..),
 
         -- Desugaring types
         DsM, DsLclEnv(..), DsGblEnv(..), PArrBuiltin(..),
-        DsMetaEnv, DsMetaVal(..),
+        DsMetaEnv, DsMetaVal(..), CompleteMatchMap, mkCompleteMatchMap,
 
         -- Template Haskell
         ThStage(..), SpliceType(..), PendingStuff(..),
@@ -174,6 +174,7 @@ import FastString
 import qualified GHC.LanguageExtensions as LangExt
 import Fingerprint
 import Util
+import UniqFM ( emptyUFM, addToUFM_C, UniqFM )
 
 import Control.Monad (ap, liftM, msum)
 #if __GLASGOW_HASKELL__ > 710
@@ -181,12 +182,14 @@ import qualified Control.Monad.Fail as MonadFail
 #endif
 import Data.Set      ( Set )
 
-import Data.Map      ( Map )
+import Data.Map ( Map )
 import Data.Dynamic  ( Dynamic )
 import Data.Typeable ( TypeRep )
 import GHCi.Message
 import GHCi.RemoteTypes
 
+import Data.List (foldl')
+
 import qualified Language.Haskell.TH as TH
 
 -- | A 'NameShape' is a substitution on 'Name's that can be used
@@ -376,8 +379,18 @@ data DsGblEnv
                                                 -- exported entities of 'Data.Array.Parallel' iff
                                                 -- '-XParallelArrays' was given; otherwise, empty
         , ds_parr_bi :: PArrBuiltin             -- desugarar names for '-XParallelArrays'
+        , ds_complete_matches :: CompleteMatchMap
+           -- Additional complete pattern matches
         }
 
+type CompleteMatchMap = UniqFM [CompleteMatch]
+
+mkCompleteMatchMap :: [CompleteMatch] -> CompleteMatchMap
+mkCompleteMatchMap cms = foldl' insertMatch emptyUFM cms
+  where
+    insertMatch :: CompleteMatchMap -> CompleteMatch -> CompleteMatchMap
+    insertMatch ufm c@(CompleteMatch _ t) = addToUFM_C (++) ufm t [c]
+
 instance ContainsModule DsGblEnv where
     extractModule = ds_mod
 
@@ -651,9 +664,10 @@ data TcGblEnv
         tcg_top_loc :: RealSrcSpan,
         -- ^ The RealSrcSpan this module came from
 
-        tcg_static_wc :: TcRef WantedConstraints
-        -- ^ Wanted constraints of static forms.
+        tcg_static_wc :: TcRef WantedConstraints,
+          -- ^ Wanted constraints of static forms.
         -- See Note [Constraints in static forms].
+        tcg_complete_matches :: [CompleteMatch]
     }
 
 -- NB: topModIdentity, not topModSemantic!
index 7c04dfe..c7909ef 100644 (file)
@@ -58,7 +58,7 @@ initV hsc_env guts info thing_inside
        ; let type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
        ; (_, Just res) <- initDs hsc_env (mg_module guts)
                                          (mg_rdr_env guts) type_env
-                                         (mg_fam_inst_env guts) go
+                                         (mg_fam_inst_env guts) [] go
 
        ; case res of
            Nothing
index 52163b9..2f322d5 100644 (file)
@@ -4512,6 +4512,10 @@ synonyms, there is no restriction on the right-hand side pattern.
 
 Pattern synonyms cannot be defined recursively.
 
+:ref:`complete-pragma` can be specified in order to tell
+the pattern match exhaustiveness checker that a set of pattern synonyms is
+complete.
+
 .. _patsyn-impexp:
 
 Import and export of pattern synonyms
@@ -12759,6 +12763,80 @@ The ``{-# SOURCE #-}`` pragma is used only in ``import`` declarations,
 to break a module loop. It is described in detail in
 :ref:`mutual-recursion`.
 
+.. _complete-pragma:
+
+``COMPLETE`` pragmas
+--------------------
+
+The ``COMPLETE`` pragma is used to inform the pattern match checker that a
+certain set of patterns is complete and that any function which matches
+on all the specified patterns is total.
+
+The most common usage of ``COMPLETE`` pragmas is with
+:ref:`pattern-synonyms`.
+On its own, the checker is very naive and assumes that any match involving
+a pattern synonym will fail. As a result, any pattern match on a
+pattern synonym is regarded as
+incomplete unless the user adds a catch-all case.
+
+For example, the data types ``2 * A`` and ``A + A`` are isomorphic but some
+computations are more naturally expressed in terms of one or the other. To
+get the best of both worlds, we can choose one as our implementation and then
+provide a set of pattern synonyms so that users can use the other representation
+if they desire. We can then specify a ``COMPLETE`` pragma in order to
+inform the pattern match checker that a function which matches on both ``LeftChoice``
+and ``RightChoice`` is total.
+
+::
+
+  data Choice a = Choice Bool a
+
+  pattern LeftChoice :: a -> Choice a
+  pattern LeftChoice a = Choice False a
+
+  pattern RightChoice :: a -> Choice a
+  pattern RightChoice a = Choice True a
+
+  {-# COMPLETE LeftChoice, RightChoice #-}
+
+  foo :: Choice Int -> Int
+  foo (LeftChoice n) = n * 2
+  foo (RightChoice n) = n - 2
+
+``COMPLETE`` pragmas are only used by the pattern match checker. If a function
+definition matches on all the constructors specified in the pragma then the
+compiler will produce no warning.
+
+``COMPLETE`` pragmas can contain any data constructors or pattern synonyms
+which are in scope. Once defined, they are automatically imported and exported
+from modules. ``COMPLETE`` pragmas should be thought of as asserting a universal
+truth about a set of patterns and as a result, should not be used to silence
+context specific incomplete match warnings.
+
+When specifing a ``COMPLETE`` pragma, the result types of all patterns must
+be consistent with each other. This is a sanity check as it would be impossible
+to match on all the patterns if the types were inconsistent.
+
+The result type must also be unambiguous. Usually this can be inferred but
+when all the pattern synonyms in a group are polymorphic in the constructor
+the user must provide a type signature.
+
+::
+  class LL f where
+    go :: f a -> ()
+
+  instance LL [] where
+    go _ = ()
+
+  pattern T :: LL f => f a
+  pattern T <- (go -> ())
+
+  {-# COMPLETE T :: [] #-}
+
+  -- No warning
+  foo :: [a] -> Int
+  foo T = 5
+
 .. _overlap-pragma:
 
 ``OVERLAPPING``, ``OVERLAPPABLE``, ``OVERLAPS``, and ``INCOHERENT`` pragmas
diff --git a/testsuite/tests/pmcheck/complete_sigs/Completesig03.hs b/testsuite/tests/pmcheck/complete_sigs/Completesig03.hs
new file mode 100644 (file)
index 0000000..5c6752a
--- /dev/null
@@ -0,0 +1,7 @@
+{-# OPTIONS_GHC -Wall #-}
+module Module where
+
+import Completesig03A
+
+foo :: A -> ()
+foo A = ()
diff --git a/testsuite/tests/pmcheck/complete_sigs/Completesig03.stderr b/testsuite/tests/pmcheck/complete_sigs/Completesig03.stderr
new file mode 100644 (file)
index 0000000..05dcb92
--- /dev/null
@@ -0,0 +1,2 @@
+[1 of 2] Compiling Completesig03A   ( Completesig03A.hs, Completesig03A.o )
+[2 of 2] Compiling Module           ( Completesig03.hs, Completesig03.o )
diff --git a/testsuite/tests/pmcheck/complete_sigs/Completesig03A.hs b/testsuite/tests/pmcheck/complete_sigs/Completesig03A.hs
new file mode 100644 (file)
index 0000000..c1b83df
--- /dev/null
@@ -0,0 +1,5 @@
+module Completesig03A where
+
+data A = A | B
+
+{-# COMPLETE A #-}
diff --git a/testsuite/tests/pmcheck/complete_sigs/Makefile b/testsuite/tests/pmcheck/complete_sigs/Makefile
new file mode 100644 (file)
index 0000000..9101fbd
--- /dev/null
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/pmcheck/complete_sigs/all.T b/testsuite/tests/pmcheck/complete_sigs/all.T
new file mode 100644 (file)
index 0000000..4e8c33d
--- /dev/null
@@ -0,0 +1,15 @@
+test('completesig01', normal, compile, [''])
+test('completesig02', normal, compile, [''])
+test('Completesig03', normal, multimod_compile, ['Completesig03', '-Wall'])
+test('completesig04', normal, compile_fail, [''])
+test('completesig05', normal, compile, [''])
+test('completesig06', normal, compile, [''])
+test('completesig07', normal, compile, [''])
+test('completesig08', normal, compile, [''])
+test('completesig09', normal, compile, [''])
+test('completesig10', normal, compile, [''])
+test('completesig11', normal, compile, [''])
+test('completesig12', normal, compile, [''])
+test('completesig13', normal, compile, [''])
+test('completesig14', normal, compile, [''])
+test('completesig15', normal, compile_fail, [''])
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig01.hs b/testsuite/tests/pmcheck/complete_sigs/completesig01.hs
new file mode 100644 (file)
index 0000000..9598aa6
--- /dev/null
@@ -0,0 +1,20 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -Wall #-}
+module Simple where
+
+pattern Foo :: ()
+pattern Foo = ()
+
+a :: () -> ()
+a Foo = ()
+
+data A = B | C | D
+
+{-# COMPLETE Foo #-}
+{-# COMPLETE B,C #-}
+{-# COMPLETE B #-}
+
+b :: A -> A
+b B = B
+b C = C
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig02.hs b/testsuite/tests/pmcheck/complete_sigs/completesig02.hs
new file mode 100644 (file)
index 0000000..282378b
--- /dev/null
@@ -0,0 +1,10 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -Wall #-}
+module Empty where
+
+pattern Foo :: ()
+pattern Foo = ()
+
+a :: () -> ()
+a Foo = ()
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig02.stderr b/testsuite/tests/pmcheck/complete_sigs/completesig02.stderr
new file mode 100644 (file)
index 0000000..25b24fd
--- /dev/null
@@ -0,0 +1,4 @@
+
+completesig02.hs:10:1: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘a’: Patterns not matched: _
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig04.hs b/testsuite/tests/pmcheck/complete_sigs/completesig04.hs
new file mode 100644 (file)
index 0000000..0d8eb81
--- /dev/null
@@ -0,0 +1,3 @@
+module TyMismatch where
+
+{-# COMPLETE Just, Left #-}
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig04.stderr b/testsuite/tests/pmcheck/complete_sigs/completesig04.stderr
new file mode 100644 (file)
index 0000000..b72cf6e
--- /dev/null
@@ -0,0 +1,4 @@
+
+completesig04.hs:3:1: error:
+    • Cannot form a group of complete patterns from patterns ‘Just’ and ‘Left’ as they match different type constructors (‘Maybe’ resp. ‘Either’)
+    • In {-# COMPLETE Just, Left #-}
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig05.hs b/testsuite/tests/pmcheck/complete_sigs/completesig05.hs
new file mode 100644 (file)
index 0000000..c277604
--- /dev/null
@@ -0,0 +1,14 @@
+{-# OPTIONS_GHC -Wall #-}
+module Completesig05 where
+
+-- Matching against multiple arguments
+
+data T = A | B | C
+data S = D | E | F
+
+{-# COMPLETE A, B #-}
+{-# COMPLETE D #-}
+
+match :: T -> S -> ()
+match A D = ()
+match B D = ()
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig06.hs b/testsuite/tests/pmcheck/complete_sigs/completesig06.hs
new file mode 100644 (file)
index 0000000..c3f1c75
--- /dev/null
@@ -0,0 +1,29 @@
+{-# OPTIONS_GHC -Wall #-}
+module Completesig06 where
+
+-- Some non-exhaustive examples
+
+data T = A | B | C
+data S = D | E | F
+
+{-# COMPLETE A, B #-}
+{-# COMPLETE D #-}
+
+m1 :: T -> ()
+m1 A = ()
+
+m2 :: T -> ()
+m2 B = ()
+m2 C = ()
+
+m3 :: T -> ()
+m3 C = ()
+
+m4 :: T -> S -> ()
+m4 A E = ()
+m4 A F = ()
+m4 B F = ()
+m4 B E = ()
+
+m5 :: T -> S -> ()
+m5 C D = ()
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig06.stderr b/testsuite/tests/pmcheck/complete_sigs/completesig06.stderr
new file mode 100644 (file)
index 0000000..50bc9bf
--- /dev/null
@@ -0,0 +1,29 @@
+
+completesig06.hs:13:1: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘m1’: Patterns not matched: B
+
+completesig06.hs:16:1: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘m2’: Patterns not matched: A
+
+completesig06.hs:20:1: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘m3’:
+        Patterns not matched:
+            A
+            B
+
+completesig06.hs:23:1: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘m4’:
+        Patterns not matched:
+            B D
+            A D
+
+completesig06.hs:29:1: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘m5’:
+        Patterns not matched:
+            A _
+            B _
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig07.hs b/testsuite/tests/pmcheck/complete_sigs/completesig07.hs
new file mode 100644 (file)
index 0000000..fb155a5
--- /dev/null
@@ -0,0 +1,24 @@
+{-# OPTIONS_GHC -Wall #-}
+module Completesig07 where
+
+-- Some overlapping examples
+
+data T = A | B | C
+data S = D | E | F
+
+{-# COMPLETE A, B #-}
+{-# COMPLETE D #-}
+
+m1 :: T -> ()
+m1 A = ()
+m1 A = ()
+m1 B = ()
+
+m2 :: T -> S -> ()
+m2 A D = ()
+m2 B D = ()
+m2 A D = ()
+
+m3 :: T -> ()
+m3 C = ()
+m3 C = ()
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig07.stderr b/testsuite/tests/pmcheck/complete_sigs/completesig07.stderr
new file mode 100644 (file)
index 0000000..bf5edb9
--- /dev/null
@@ -0,0 +1,11 @@
+
+completesig07.hs:23:1: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘m3’:
+        Patterns not matched:
+            A
+            B
+
+completesig07.hs:24:1: warning: [-Woverlapping-patterns (in -Wdefault)]
+    Pattern match is redundant
+    In an equation for ‘m3’: m3 C = ...
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig08.hs b/testsuite/tests/pmcheck/complete_sigs/completesig08.hs
new file mode 100644 (file)
index 0000000..323b139
--- /dev/null
@@ -0,0 +1,30 @@
+{-# OPTIONS_GHC -Wall #-}
+module Completesig08 where
+
+-- Some redundant examples
+
+data T = A | B | C
+data S = D | E | F
+
+{-# COMPLETE A, B #-}
+{-# COMPLETE D #-}
+
+m1 :: T -> ()
+m1 A = ()
+m1 B = ()
+m1 C = ()
+
+m2 :: T -> S -> ()
+m2 A D = ()
+m2 B D = ()
+m2 C D = ()
+
+m3 :: T -> S -> ()
+m3 A D = ()
+m3 B D = ()
+m3 A E = ()
+m3 A F = ()
+
+m4 :: S -> ()
+m4 D = ()
+m4 E = ()
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig09.hs b/testsuite/tests/pmcheck/complete_sigs/completesig09.hs
new file mode 100644 (file)
index 0000000..b02aefe
--- /dev/null
@@ -0,0 +1,13 @@
+{-# OPTIONS_GHC -Wall #-}
+module Completesig08 where
+
+-- Nested matching
+
+data T = A S | B
+data S = D | E
+
+{-# COMPLETE A #-}
+{-# COMPLETE D #-}
+
+m1 :: T -> ()
+m1 (A D) = ()
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig10.hs b/testsuite/tests/pmcheck/complete_sigs/completesig10.hs
new file mode 100644 (file)
index 0000000..66c446b
--- /dev/null
@@ -0,0 +1,33 @@
+{-# OPTIONS_GHC -Wall #-}
+module Completesig10 where
+
+-- Multiple competing COMPLETE sigs AHHH!!
+
+data T = A | B | C | D | E
+
+{-# COMPLETE A,B #-}
+{-# COMPLETE C,D #-}
+
+-- Completely overlapping
+m1 :: T -> ()
+m1 A = ()
+m1 B = ()
+m1 C = ()
+m1 D = ()
+
+-- Incomplete overlap
+m2 :: T -> ()
+m2 B = ()
+m2 D = ()
+
+-- Redudant incomplete overlap
+m3 :: T -> ()
+m3 B = ()
+m3 C = ()
+m3 D = ()
+
+-- One matches
+
+m4 :: T -> ()
+m4 C = ()
+m4 D = ()
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig10.stderr b/testsuite/tests/pmcheck/complete_sigs/completesig10.stderr
new file mode 100644 (file)
index 0000000..3d97bb4
--- /dev/null
@@ -0,0 +1,4 @@
+
+completesig10.hs:20:1: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘m2’: Patterns not matched: A
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig11.hs b/testsuite/tests/pmcheck/complete_sigs/completesig11.hs
new file mode 100644 (file)
index 0000000..69a386c
--- /dev/null
@@ -0,0 +1,14 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE PatternSynonyms #-}
+module Completesig11 where
+
+data T = A | B | C
+{-# COMPLETE A,B #-}
+{-# COMPLETE A,C #-}
+
+pattern BS :: T
+pattern BS = B
+{-# COMPLETE A,BS #-}
+
+m1  :: T -> ()
+m1 A = ()
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig11.stderr b/testsuite/tests/pmcheck/complete_sigs/completesig11.stderr
new file mode 100644 (file)
index 0000000..8107071
--- /dev/null
@@ -0,0 +1,4 @@
+
+completesig11.hs:14:1: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘m1’: Patterns not matched: BS
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig12.hs b/testsuite/tests/pmcheck/complete_sigs/completesig12.hs
new file mode 100644 (file)
index 0000000..a6bf400
--- /dev/null
@@ -0,0 +1,22 @@
+{-# LANGUAGE GADTs, PatternSynonyms #-}
+{-# OPTIONS_GHC -Wall #-}
+module Completesig11 where
+data G a where
+  G1' :: G Int
+  G2' :: G Bool
+
+pattern G1 :: () => (a ~ Int) => G a
+pattern G1 = G1'
+
+pattern G2 :: () => (a ~ Bool) => G a
+pattern G2 = G2'
+
+{-# COMPLETE G1, G2 #-}
+
+fa :: G a -> Int   -- exhaustive function
+fa G1 = 1
+fa G2 = 2
+
+fb :: G Int -> Int -- exhaustive function
+fb G1 = 1
+-- fb G2 = 2       -- inaccessible clause
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig13.hs b/testsuite/tests/pmcheck/complete_sigs/completesig13.hs
new file mode 100644 (file)
index 0000000..ac87baf
--- /dev/null
@@ -0,0 +1,19 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -Wall #-}
+module Completesig11 where
+
+class LL f where
+  go :: f a -> ()
+
+instance LL [] where
+  go _ = ()
+
+pattern T :: LL f => f a
+pattern T <- (go -> ())
+
+{-# COMPLETE T :: [] #-}
+
+foo :: [a] -> Int
+foo T = 5
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig14.hs b/testsuite/tests/pmcheck/complete_sigs/completesig14.hs
new file mode 100644 (file)
index 0000000..00331c9
--- /dev/null
@@ -0,0 +1,11 @@
+{-# OPTIONS_GHC -Wall #-}
+module Completesig11 where
+
+data A = A | B
+
+{-# COMPLETE A, B #-}
+
+foo :: A -> ()
+foo A = ()
+foo B = ()
+foo A = ()
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig14.stderr b/testsuite/tests/pmcheck/complete_sigs/completesig14.stderr
new file mode 100644 (file)
index 0000000..06e9da8
--- /dev/null
@@ -0,0 +1,4 @@
+
+completesig14.hs:11:1: warning: [-Woverlapping-patterns (in -Wdefault)]
+    Pattern match is redundant
+    In an equation for ‘foo’: foo A = ...
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig15.hs b/testsuite/tests/pmcheck/complete_sigs/completesig15.hs
new file mode 100644 (file)
index 0000000..5936379
--- /dev/null
@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+module Completesig15 where
+
+class C f where
+  foo :: f a -> ()
+
+pattern P :: C f => f a
+pattern P <- (foo -> ())
+
+{-# COMPLETE P #-}
diff --git a/testsuite/tests/pmcheck/complete_sigs/completesig15.stderr b/testsuite/tests/pmcheck/complete_sigs/completesig15.stderr
new file mode 100644 (file)
index 0000000..3bff495
--- /dev/null
@@ -0,0 +1,4 @@
+
+completesig15.hs:12:1: error:
+    • A type signature must be provided for a set of polymorphic pattern synonyms.
+    • In {-# COMPLETE P #-}
index 94d351e..3f4e0c8 100644 (file)
@@ -40,7 +40,7 @@ test('T11303', normal, compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-
 test('T11276', compile_timeout_multiplier(0.01), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M1G -RTS'])
 test('T11303b', compile_timeout_multiplier(0.01), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M1G -RTS'])
 test('T11374', compile_timeout_multiplier(0.01), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M1G -RTS'])
-test('T11195', compile_timeout_multiplier(0.40), compile, ['-package ghc -fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M1G -RTS'])
+test('T11195', compile_timeout_multiplier(0.40), compile, ['-package ghc -fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M2G -RTS'])
 
 # Other tests
 test('pmc001', [], compile,