From 1a3f1eebf81952accb6340252816211c7d391300 Mon Sep 17 00:00:00 2001
From: Matthew Pickering <matthewtpickering@gmail.com>
Date: Wed, 18 Jan 2017 13:25:30 +0000
Subject: COMPLETE pragmas for enhanced pattern exhaustiveness checking

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
---
 compiler/parser/Parser.y | 13 +++++++++++++
 1 file changed, 13 insertions(+)

(limited to 'compiler/parser/Parser.y')

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 222867483c..2b70fb7999 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -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
-- 
cgit v1.2.1