Reconstruct record expression in bidir pattern synonym

Reviewers: austin, rdragon, bgamari

Reviewed By: bgamari

Subscribers: rdragon, thomie

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

4 files changed, 39 insertions, 8 deletions

diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index 5b7f6d4971..36c4fafc8f 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 b627cd4a2e..06f2042597 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 0000000000..45caec830e
--- /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 7668398c92..0fc26cba23 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, [''])