Implement pattern synonyms

This patch implements Pattern Synonyms (enabled by -XPatternSynonyms),
allowing y ou to assign names to a pattern and abstract over it.

The rundown is this:

  * Named patterns are introduced by the new 'pattern' keyword, and can
    be either *unidirectional* or *bidirectional*. A unidirectional
    pattern is, in the simplest sense, simply an 'alias' for a pattern,
    where the LHS may mention variables to occur in the RHS. A
    bidirectional pattern synonym occurs when a pattern may also be used
    in expression context.

  * Unidirectional patterns are declared like thus:

        pattern P x <- x:_

    The synonym 'P' may only occur in a pattern context:

        foo :: [Int] -> Maybe Int
        foo (P x) = Just x
        foo _     = Nothing

  * Bidirectional patterns are declared like thus:

        pattern P x y = [x, y]

    Here, P may not only occur as a pattern, but also as an expression
    when given values for 'x' and 'y', i.e.

        bar :: Int -> [Int]
        bar x = P x 10

  * Patterns can't yet have their own type signatures; signatures are inferred.

  * Pattern synonyms may not be recursive, c.f. type synonyms.

  * Pattern synonyms are also exported/imported using the 'pattern'
    keyword in an import/export decl, i.e.

        module Foo (pattern Bar) where ...

    Note that pattern synonyms share the namespace of constructors, so
    this disambiguation is required as a there may also be a 'Bar'
    type in scope as well as the 'Bar' pattern.

  * The semantics of a pattern synonym differ slightly from a typical
    pattern: when using a synonym, the pattern itself is matched,
    followed by all the arguments. This means that the strictness
    differs slightly:

        pattern P x y <- [x, y]

        f (P True True) = True
        f _             = False

        g [True, True] = True
        g _            = False

    In the example, while `g (False:undefined)` evaluates to False,
    `f (False:undefined)` results in undefined as both `x` and `y`
    arguments are matched to `True`.

For more information, see the wiki:

    https://ghc.haskell.org/trac/ghc/wiki/PatternSynonyms
    https://ghc.haskell.org/trac/ghc/wiki/PatternSynonyms/Implementation

Reviewed-by: Simon Peyton Jones <simonpj@microsoft.com>
Signed-off-by: Austin Seipp <austin@well-typed.com>

1 files changed, 4 insertions, 4 deletions

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 79d2d966ec..b1e177a3a9 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -64,7 +64,7 @@ import RdrName          ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
 import OccName          ( tcClsName, isVarNameSpace )
 import Name             ( Name )
 import BasicTypes       ( maxPrecedence, Activation(..), RuleMatchInfo,
-                          InlinePragma(..), InlineSpec(..) )
+                          InlinePragma(..), InlineSpec(..), Origin(..) )
 import TcEvidence       ( idHsWrapper )
 import Lexer
 import TysWiredIn       ( unitTyCon, unitDataCon )
@@ -75,7 +75,7 @@ import PrelNames        ( forall_tv_RDR )
 import DynFlags
 import SrcLoc
 import OrdList          ( OrdList, fromOL )
-import Bag              ( Bag, emptyBag, consBag )
+import Bag              ( emptyBag, consBag )
 import Outputable
 import FastString
 import Maybes
@@ -305,7 +305,7 @@ cvBindGroup binding
             ValBindsIn mbs sigs
 
 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
-  -> (Bag ( LHsBind RdrName), [LSig RdrName], [LFamilyDecl RdrName]
+  -> (LHsBinds RdrName, [LSig RdrName], [LFamilyDecl RdrName]
           , [LTyFamInstDecl RdrName], [LDataFamInstDecl RdrName], [LDocDecl])
 -- Input decls contain just value bindings and signatures
 -- and in case of class or instance declarations also
@@ -315,7 +315,7 @@ cvBindsAndSigs  fb = go (fromOL fb)
     go []                  = (emptyBag, [], [], [], [], [])
     go (L l (SigD s) : ds) = (bs, L l s : ss, ts, tfis, dfis, docs)
                            where (bs, ss, ts, tfis, dfis, docs) = go ds
-    go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, tfis, dfis, docs)
+    go (L l (ValD b) : ds) = ((FromSource, b') `consBag` bs, ss, ts, tfis, dfis, docs)
                            where (b', ds')    = getMonoBind (L l b) ds
                                  (bs, ss, ts, tfis, dfis, docs) = go ds'
     go (L l (TyClD (FamDecl t)) : ds) = (bs, ss, L l t : ts, tfis, dfis, docs)