[commit: ghc] master: Reconstruct record expression in bidir pattern synonym (52879d1)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/52879d1f5d804bf1a32d11d9cefc36d7b6fea382/ghc

>---------------------------------------------------------------

commit 52879d1f5d804bf1a32d11d9cefc36d7b6fea382
Author: Matthew Pickering <matthewtpickering at gmail.com>
Date:   Thu Feb 25 14:52:39 2016 +0100

    Reconstruct record expression in bidir pattern synonym
    
    Reviewers: austin, rdragon, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: rdragon, thomie
    
    Differential Revision: https://phabricator.haskell.org/D1949


>---------------------------------------------------------------

52879d1f5d804bf1a32d11d9cefc36d7b6fea382
 compiler/hsSyn/HsPat.hs                         |  9 ++++++---
 compiler/typecheck/TcPatSyn.hs                  | 25 ++++++++++++++++++++-----
 testsuite/tests/patsyn/should_compile/T11633.hs | 12 ++++++++++++
 testsuite/tests/patsyn/should_compile/all.T     |  1 +
 4 files changed, 39 insertions(+), 8 deletions(-)

diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index 5b7f6d4..36c4faf 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -6,7 +6,9 @@
 -}
 
 {-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
@@ -244,9 +246,10 @@ data HsRecFields id arg         -- A bunch of record fields
         -- Used for both expressions and patterns
   = HsRecFields { rec_flds   :: [LHsRecField id arg],
                   rec_dotdot :: Maybe Int }  -- Note [DotDot fields]
-  deriving (Typeable)
+  deriving (Typeable, Functor, Foldable, Traversable)
 deriving instance (DataId id, Data arg) => Data (HsRecFields id arg)
 
+
 -- Note [DotDot fields]
 -- ~~~~~~~~~~~~~~~~~~~~
 -- The rec_dotdot field means this:
@@ -275,7 +278,7 @@ data HsRecField' id arg = HsRecField {
         hsRecFieldLbl :: Located id,
         hsRecFieldArg :: arg,           -- ^ Filled in by renamer when punning
         hsRecPun      :: Bool           -- ^ Note [Punning]
-  } deriving (Data, Typeable)
+  } deriving (Data, Typeable, Functor, Foldable, Traversable)
 
 
 -- Note [Punning]
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index b627cd4..06f2042 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -813,15 +813,30 @@ tcPatToExpr args = go
     lhsVars = mkNameSet (map unLoc args)
 
     go :: LPat Name -> Maybe (LHsExpr Name)
-    go (L loc (ConPatIn (L _ con) info))
-      = do { exprs <- mapM go (hsConPatArgs info)
-           ; return $ L loc $
-             foldl (\x y -> HsApp (L loc x) y) (HsVar (L loc con)) exprs }
+    go (L loc (ConPatIn con info))
+      = case info of
+          PrefixCon ps  -> mkPrefixConExpr con ps
+          InfixCon l r  -> mkPrefixConExpr con [l,r]
+          RecCon fields -> L loc <$> mkRecordConExpr con fields
 
     go (L _ (SigPatIn pat _)) = go pat
         -- See Note [Type signatures and the builder expression]
 
-    go (L loc p) = fmap (L loc) $ go1 p
+    go (L loc p) = L loc <$> go1 p
+
+    -- Make a prefix con for prefix and infix patterns for simplicity
+    mkPrefixConExpr :: Located Name -> [LPat Name] -> Maybe (LHsExpr Name)
+    mkPrefixConExpr con pats = do
+      exprs <- traverse go pats
+      return $ foldl (\x y -> L (combineLocs x y) (HsApp x y))
+                     (L (getLoc con) (HsVar con))
+                     exprs
+
+
+    mkRecordConExpr :: Located Name -> HsRecFields Name (LPat Name) -> Maybe (HsExpr Name)
+    mkRecordConExpr con fields = do
+      exprFields <- traverse go fields
+      return $ RecordCon con PlaceHolder noPostTcExpr exprFields
 
     go1 :: Pat Name -> Maybe (HsExpr Name)
     go1   (VarPat (L l var))
diff --git a/testsuite/tests/patsyn/should_compile/T11633.hs b/testsuite/tests/patsyn/should_compile/T11633.hs
new file mode 100644
index 0000000..45caec8
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T11633.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module T11633 where
+
+data ARecord = ARecord {anInt :: Int, aString :: String}
+
+-- This works...
+pattern AGoodPat :: Int -> String -> ARecord
+pattern AGoodPat n s = ARecord {anInt=n, aString=s}
+
+pattern ABadPat :: Int -> String -> ARecord
+pattern ABadPat n s = ARecord {aString=s, anInt=n}
diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T
index 7668398..0fc26cb 100644
--- a/testsuite/tests/patsyn/should_compile/all.T
+++ b/testsuite/tests/patsyn/should_compile/all.T
@@ -50,3 +50,4 @@ test('T11283', normal, compile, [''])
 test('T11336', normal, compile, [''])
 test('T11367', normal, compile, [''])
 test('T11351', normal, compile, [''])
+test('T11633', normal, compile, [''])