[commit: ghc] master: Fix panic when using pattern synonyms with DisambiguateRecordFields (4f69203)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/4f69203dd7892d3640e871c5914b7ee2be5f5dff/ghc

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

commit 4f69203dd7892d3640e871c5914b7ee2be5f5dff
Author: Adam Gundry <adam at well-typed.com>
Date:   Tue Dec 29 13:42:32 2015 +0100

    Fix panic when using pattern synonyms with DisambiguateRecordFields
    
    This fixes a `find_tycon` panic when constructing a record pattern
    synonym when `DisambiguateRecordFields` (turned on by `RecordWildCards`)
    is enabled.  The handling of record wild cards in such constructions
    isn't completely satisfactory, but doing better will require the
    `Parent` type to be more informative, as I'll explain on #11228.
    
    Test Plan: New test patsyn/should_compile/T11283.hs
    
    Reviewers: mpickering, austin, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D1695
    
    GHC Trac Issues: #11283


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

4f69203dd7892d3640e871c5914b7ee2be5f5dff
 compiler/rename/RnPat.hs                           | 26 +++++++++++++---------
 testsuite/tests/patsyn/should_compile/T11283.hs    |  7 ++++++
 .../tests/patsyn/should_compile/T11283.stderr      |  5 +++++
 testsuite/tests/patsyn/should_compile/all.T        |  1 +
 4 files changed, 28 insertions(+), 11 deletions(-)

diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index 38c832c..8ee2141 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -599,10 +599,10 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
                    = rdr `elemLocalRdrEnv` lcl_env
                    || notNull [ gre | gre <- lookupGRE_RdrName rdr rdr_env
                                     , case gre_par gre of
-                                        ParentIs p               -> p /= parent_tc
-                                        FldParent { par_is = p } -> p /= parent_tc
-                                        PatternSynonym           -> True
-                                        NoParent                 -> True ]
+                                        ParentIs p     -> Just p /= parent_tc
+                                        FldParent p _  -> Just p /= parent_tc
+                                        PatternSynonym -> False
+                                        NoParent       -> True ]
                    where
                      rdr = mkVarUnqual lbl
 
@@ -629,19 +629,23 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
     -- When disambiguation is on, return name of parent tycon.
     check_disambiguation disambig_ok mb_con
       | disambig_ok, Just con <- mb_con
-      = do { env <- getGlobalRdrEnv; return (Just (find_tycon env con)) }
+      = do { env <- getGlobalRdrEnv; return (find_tycon env con) }
       | otherwise = return Nothing
 
-    find_tycon :: GlobalRdrEnv -> Name {- DataCon -} -> Name {- TyCon -}
+    find_tycon :: GlobalRdrEnv -> Name {- DataCon -} -> Maybe Name {- TyCon -}
     -- Return the parent *type constructor* of the data constructor
-    -- That is, the parent of the data constructor.
+    -- (that is, the parent of the data constructor),
+    -- or 'Nothing' if it is a pattern synonym.
     -- That's the parent to use for looking up record fields.
     find_tycon env con
       | Just (AConLike (RealDataCon dc)) <- wiredInNameTyThing_maybe con
-      = tyConName (dataConTyCon dc)   -- Special case for [], which is built-in syntax
-                                      -- and not in the GlobalRdrEnv (Trac #8448)
-      | [GRE { gre_par = ParentIs p }] <- lookupGRE_Name env con
-      = p
+      = Just (tyConName (dataConTyCon dc))
+        -- Special case for [], which is built-in syntax
+        -- and not in the GlobalRdrEnv (Trac #8448)
+      | [gre] <- lookupGRE_Name env con
+      = case gre_par gre of
+          ParentIs p -> Just p
+          _          -> Nothing
 
       | otherwise
       = pprPanic "find_tycon" (ppr con $$ ppr (lookupGRE_Name env con))
diff --git a/testsuite/tests/patsyn/should_compile/T11283.hs b/testsuite/tests/patsyn/should_compile/T11283.hs
new file mode 100644
index 0000000..ed7471d
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T11283.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE PatternSynonyms, RecordWildCards #-}
+module T11283 where
+data P = MkP Bool
+pattern S{x} = MkP x
+d = S{x = True}
+e = S{..}
+f S{x=x} = x
diff --git a/testsuite/tests/patsyn/should_compile/T11283.stderr b/testsuite/tests/patsyn/should_compile/T11283.stderr
new file mode 100644
index 0000000..86d8575
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T11283.stderr
@@ -0,0 +1,5 @@
+
+T11283.hs:6:5: warning:
+    • Fields of ‘S’ not initialised: x
+    • In the expression: S {..}
+      In an equation for ‘e’: e = S {..}
diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T
index e1c8243..880d6b2 100644
--- a/testsuite/tests/patsyn/should_compile/all.T
+++ b/testsuite/tests/patsyn/should_compile/all.T
@@ -46,3 +46,4 @@ test('T10897', normal, multi_compile, ['T10897', [
                                       ], '-v0'])
 test('T11224b', normal, compile, [''])
 test('MoreEx', normal, compile, [''])
+test('T11283', normal, compile, [''])