Record pattern synonyms

This patch implements an extension to pattern synonyms which allows user
to specify pattern synonyms using record syntax. Doing so generates
appropriate selectors and update functions.

=== Interaction with Duplicate Record Fields ===

The implementation given here isn't quite as general as it could be with
respect to the recently-introduced `DuplicateRecordFields` extension.

Consider the following module:

    {-# LANGUAGE DuplicateRecordFields #-}
    {-# LANGUAGE PatternSynonyms #-}

    module Main where

    pattern S{a, b} = (a, b)
    pattern T{a}    = Just a

    main = do
      print S{ a = "fst", b = "snd" }
      print T{ a = "a" }

In principle, this ought to work, because there is no ambiguity. But at
the moment it leads to a "multiple declarations of a" error. The problem
is that pattern synonym record selectors don't do the same name mangling
as normal datatypes when DuplicateRecordFields is enabled. They could,
but this would require some work to track the field label and selector
name separately.

In particular, we currently represent datatype selectors in the third
component of AvailTC, but pattern synonym selectors are just represented
as Avails (because they don't have a corresponding type constructor).
Moreover, the GlobalRdrElt for a selector currently requires it to have
a parent tycon.

(example due to Adam Gundry)

=== Updating Explicitly Bidirectional Pattern Synonyms ===

Consider the following

```
pattern Silly{a} <- [a] where
  Silly a = [a, a]

f1 = a [5] -- 5

f2 = [5] {a = 6} -- currently [6,6]
```

=== Fixing Polymorphic Updates ===

They were fixed by adding these two lines in `dsExpr`. This might break
record updates but will be easy to fix.

```
+ ; let req_wrap = mkWpTyApps (mkTyVarTys univ_tvs)

- , pat_wrap = idHsWrapper }
+, pat_wrap = req_wrap }
```

=== Mixed selectors error ===

Note [Mixed Record Field Updates]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Consider the following pattern synonym.

    data MyRec = MyRec { foo :: Int, qux :: String }

    pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}

This allows updates such as the following

    updater :: MyRec -> MyRec
    updater a = a {f1 = 1 }

It would also make sense to allow the following update (which we
reject).

    updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two"

This leads to confusing behaviour when the selectors in fact refer the
same field.

    updater a = a {f1 = 1, foo = 2} ==? ???

For this reason, we reject a mixture of pattern synonym and normal
record selectors in the same update block. Although of course we still
allow the following.

    updater a = (a {f1 = 1}) {foo = 2}

    > updater (MyRec 0 "str")
    MyRec 2 "str"

1 files changed, 66 insertions, 3 deletions

diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index 18756f632f..b1b6e62f31 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -257,7 +257,7 @@ data PatSynBind idL idR
           psb_def  :: LPat idR,                      -- ^ Right-hand side
           psb_dir  :: HsPatSynDir idR                -- ^ Directionality
   } deriving (Typeable)
-deriving instance (DataId idL, DataId idR )
+deriving instance (DataId idL, DataId idR)
   => Data (PatSynBind idL idR)
 
 {-
@@ -525,6 +525,9 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL
       (is_infix, ppr_details) = case details of
           InfixPatSyn v1 v2 -> (True, hsep [ppr v1, pprInfixOcc psyn, ppr v2])
           PrefixPatSyn vs   -> (False, hsep (pprPrefixOcc psyn : map ppr vs))
+          RecordPatSyn vs   ->
+            (False, pprPrefixOcc psyn
+                      <> braces (sep (punctuate comma (map ppr vs))))
 
       ppr_rhs = case dir of
           Unidirectional           -> ppr_simple (ptext (sLit "<-"))
@@ -625,7 +628,7 @@ data Sig name
       --          'ApiAnnotation.AnnComma'
 
       -- For details on above see note [Api annotations] in ApiAnnotation
-    TypeSig 
+    TypeSig
        [Located name]         -- LHS of the signature; e.g.  f,g,h :: blah
        (LHsType name)         -- RHS of the signature
        (PostRn name [Name])   -- Wildcards (both named and anonymous) of the RHS
@@ -897,37 +900,97 @@ pprMinimalSig bf = ptext (sLit "MINIMAL") <+> ppr (fmap unLoc bf)
 data HsPatSynDetails a
   = InfixPatSyn a a
   | PrefixPatSyn [a]
-  deriving (Data, Typeable)
+  | RecordPatSyn [RecordPatSynField a]
+  deriving (Typeable, Data)
+
+
+-- See Note [Record PatSyn Fields]
+data RecordPatSynField a
+  = RecordPatSynField {
+      recordPatSynSelectorId :: a  -- Selector name visible in rest of the file
+      , recordPatSynPatVar :: a
+      -- Filled in by renamer, the name used internally
+      -- by the pattern
+      } deriving (Typeable, Data)
+
+
+
+{-
+Note [Record PatSyn Fields]
+
+Consider the following two pattern synonyms.
+
+pattern P x y = ([x,True], [y,'v'])
+pattern Q{ x, y } =([x,True], [y,'v'])
+
+In P, we just have two local binders, x and y.
+
+In Q, we have local binders but also top-level record selectors
+x :: ([Bool], [Char]) -> Bool and similarly for y.
+
+It would make sense to support record-like syntax
+
+pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v'])
+
+when we have a different name for the local and top-level binder
+the distinction between the two names clear
+
+-}
+instance Functor RecordPatSynField where
+    fmap f (RecordPatSynField visible hidden) =
+      RecordPatSynField (f visible) (f hidden)
+
+instance Outputable a => Outputable (RecordPatSynField a) where
+    ppr (RecordPatSynField v _) = ppr v
+
+instance Foldable RecordPatSynField  where
+    foldMap f (RecordPatSynField visible hidden) =
+      f visible `mappend` f hidden
+
+instance Traversable RecordPatSynField where
+    traverse f (RecordPatSynField visible hidden) =
+      RecordPatSynField <$> f visible <*> f hidden
+
 
 instance Functor HsPatSynDetails where
     fmap f (InfixPatSyn left right) = InfixPatSyn (f left) (f right)
     fmap f (PrefixPatSyn args) = PrefixPatSyn (fmap f args)
+    fmap f (RecordPatSyn args) = RecordPatSyn (map (fmap f) args)
 
 instance Foldable HsPatSynDetails where
     foldMap f (InfixPatSyn left right) = f left `mappend` f right
     foldMap f (PrefixPatSyn args) = foldMap f args
+    foldMap f (RecordPatSyn args) = foldMap (foldMap f) args
 
     foldl1 f (InfixPatSyn left right) = left `f` right
     foldl1 f (PrefixPatSyn args) = Data.List.foldl1 f args
+    foldl1 f (RecordPatSyn args) =
+      Data.List.foldl1 f (map (Data.Foldable.foldl1 f) args)
 
     foldr1 f (InfixPatSyn left right) = left `f` right
     foldr1 f (PrefixPatSyn args) = Data.List.foldr1 f args
+    foldr1 f (RecordPatSyn args) =
+      Data.List.foldr1 f (map (Data.Foldable.foldr1 f) args)
 
 -- TODO: After a few more versions, we should probably use these.
 #if __GLASGOW_HASKELL__ >= 709
     length (InfixPatSyn _ _) = 2
     length (PrefixPatSyn args) = Data.List.length args
+    length (RecordPatSyn args) = Data.List.length args
 
     null (InfixPatSyn _ _) = False
     null (PrefixPatSyn args) = Data.List.null args
+    null (RecordPatSyn args) = Data.List.null args
 
     toList (InfixPatSyn left right) = [left, right]
     toList (PrefixPatSyn args) = args
+    toList (RecordPatSyn args) = foldMap toList args
 #endif
 
 instance Traversable HsPatSynDetails where
     traverse f (InfixPatSyn left right) = InfixPatSyn <$> f left <*> f right
     traverse f (PrefixPatSyn args) = PrefixPatSyn <$> traverse f args
+    traverse f (RecordPatSyn args) = RecordPatSyn <$> traverse (traverse f) args
 
 data HsPatSynDir id
   = Unidirectional