Use data con name instead of parent in lookupRecFieldOcc

Test Plan: new tests rename/should_compile/{T14747,T15149}

Reviewers: simonpj, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #14747, #15149

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

10 files changed, 157 insertions, 84 deletions

diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index 3c0d8f5327..abfaf22c3e 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -80,6 +80,7 @@ import RnUtils
 import Data.Maybe (isJust)
 import qualified Data.Semigroup as Semi
 import Data.Either      ( partitionEithers )
+import Data.List        (find)
 
 {-
 *********************************************************
@@ -432,34 +433,122 @@ lookupExactOrOrig rdr_name res k
 
 
 -----------------------------------------------
--- Used for record construction and pattern matching
--- When the -XDisambiguateRecordFields flag is on, take account of the
--- constructor name to disambiguate which field to use; it's just the
--- same as for instance decls
+-- | Look up an occurrence of a field in record construction or pattern
+-- matching (but not update).  When the -XDisambiguateRecordFields
+-- flag is on, take account of the data constructor name to
+-- disambiguate which field to use.
 --
--- NB: Consider this:
---      module Foo where { data R = R { fld :: Int } }
---      module Odd where { import Foo; fld x = x { fld = 3 } }
--- Arguably this should work, because the reference to 'fld' is
--- unambiguous because there is only one field id 'fld' in scope.
--- But currently it's rejected.
-
-lookupRecFieldOcc :: Maybe Name -- Nothing    => just look it up as usual
-                                      -- Just tycon => use tycon to disambiguate
-                  -> SDoc -> RdrName
+-- See Note [DisambiguateRecordFields].
+lookupRecFieldOcc :: Maybe Name -- Nothing  => just look it up as usual
+                                -- Just con => use data con to disambiguate
+                  -> RdrName
                   -> RnM Name
-lookupRecFieldOcc parent doc rdr_name
-  | Just tc_name <- parent
-  = do { mb_name <- lookupSubBndrOcc True tc_name doc rdr_name
-       ; case mb_name of
-           Left err -> do { addErr err; return (mkUnboundNameRdr rdr_name) }
-           Right n  -> return n }
-
+lookupRecFieldOcc mb_con rdr_name
+  | Just con <- mb_con
+  , isUnboundName con  -- Avoid error cascade
+  = return (mkUnboundNameRdr rdr_name)
+  | Just con <- mb_con
+  = do { flds <- lookupConstructorFields con
+       ; env <- getGlobalRdrEnv
+       ; let lbl      = occNameFS (rdrNameOcc rdr_name)
+             mb_field = do fl <- find ((== lbl) . flLabel) flds
+                           -- We have the label, now check it is in
+                           -- scope (with the correct qualifier if
+                           -- there is one, hence calling pickGREs).
+                           gre <- lookupGRE_FieldLabel env fl
+                           guard (not (isQual rdr_name
+                                         && null (pickGREs rdr_name [gre])))
+                           return (fl, gre)
+       ; case mb_field of
+           Just (fl, gre) -> do { addUsedGRE True gre
+                                ; return (flSelector fl) }
+           Nothing        -> lookupGlobalOccRn rdr_name }
+             -- See Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]
   | otherwise
   -- This use of Global is right as we are looking up a selector which
   -- can only be defined at the top level.
   = lookupGlobalOccRn rdr_name
 
+{- Note [DisambiguateRecordFields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we are looking up record fields in record construction or pattern
+matching, we can take advantage of the data constructor name to
+resolve fields that would otherwise be ambiguous (provided the
+-XDisambiguateRecordFields flag is on).
+
+For example, consider:
+
+   data S = MkS { x :: Int }
+   data T = MkT { x :: Int }
+
+   e = MkS { x = 3 }
+
+When we are renaming the occurrence of `x` in `e`, instead of looking
+`x` up directly (and finding both fields), lookupRecFieldOcc will
+search the fields of `MkS` to find the only possible `x` the user can
+mean.
+
+Of course, we still have to check the field is in scope, using
+lookupGRE_FieldLabel.  The handling of qualified imports is slightly
+subtle: the occurrence may be unqualified even if the field is
+imported only qualified (but if the occurrence is qualified, the
+qualifier must be correct). For example:
+
+   module A where
+     data S = MkS { x :: Int }
+     data T = MkT { x :: Int }
+
+   module B where
+     import qualified A (S(..))
+     import A (T(MkT))
+
+     e1 = MkT   { x = 3 }   -- x not in scope, so fail
+     e2 = A.MkS { B.x = 3 } -- module qualifier is wrong, so fail
+     e3 = A.MkS { x = 3 }   -- x in scope (lack of module qualifier permitted)
+
+In case `e1`, lookupGRE_FieldLabel will return Nothing.  In case `e2`,
+lookupGRE_FieldLabel will return the GRE for `A.x`, but then the guard
+will fail because the field RdrName `B.x` is qualified and pickGREs
+rejects the GRE.  In case `e3`, lookupGRE_FieldLabel will return the
+GRE for `A.x` and the guard will succeed because the field RdrName `x`
+is unqualified.
+
+
+Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Whenever we fail to find the field or it is not in scope, mb_field
+will be False, and we fall back on looking it up normally using
+lookupGlobalOccRn.  We don't report an error immediately because the
+actual problem might be located elsewhere.  For example (Trac #9975):
+
+   data Test = Test { x :: Int }
+   pattern Test wat = Test { x = wat }
+
+Here there are multiple declarations of Test (as a data constructor
+and as a pattern synonym), which will be reported as an error.  We
+shouldn't also report an error about the occurrence of `x` in the
+pattern synonym RHS.  However, if the pattern synonym gets added to
+the environment first, we will try and fail to find `x` amongst the
+(nonexistent) fields of the pattern synonym.
+
+Alternatively, the scope check can fail due to Template Haskell.
+Consider (Trac #12130):
+
+   module Foo where
+     import M
+     b = $(funny)
+
+   module M(funny) where
+     data T = MkT { x :: Int }
+     funny :: Q Exp
+     funny = [| MkT { x = 3 } |]
+
+When we splice, `MkT` is not lexically in scope, so
+lookupGRE_FieldLabel will fail.  But there is no need for
+disambiguation anyway, because `x` is an original name, and
+lookupGlobalOccRn will find it.
+-}
+
 
 
 -- | Used in export lists to lookup the children.
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index 4601b948d2..6195309cab 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -53,15 +53,10 @@ import RnUtils             ( HsDocContext(..), newLocalBndrRn, bindLocalNames
                            , warnUnusedMatches, newLocalBndrRn
                            , checkDupNames, checkDupAndShadowedNames
                            , checkTupSize , unknownSubordinateErr )
-import RnUnbound           ( mkUnboundName )
 import RnTypes
 import PrelNames
-import TyCon               ( tyConName )
-import ConLike
-import Type                ( TyThing(..) )
 import Name
 import NameSet
-import OccName             ( setOccNameSpace, tcName )
 import RdrName
 import BasicTypes
 import Util
@@ -73,7 +68,7 @@ import TysWiredIn          ( nilDataCon )
 import DataCon
 import qualified GHC.LanguageExtensions as LangExt
 
-import Control.Monad       ( when, liftM, ap )
+import Control.Monad       ( when, liftM, ap, guard )
 import qualified Data.List.NonEmpty as NE
 import Data.Ratio
 
@@ -582,7 +577,7 @@ rnHsRecFields
 rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
   = do { pun_ok      <- xoptM LangExt.RecordPuns
        ; disambig_ok <- xoptM LangExt.DisambiguateRecordFields
-       ; parent <- check_disambiguation disambig_ok mb_con
+       ; let parent = guard disambig_ok >> mb_con
        ; flds1  <- mapM (rn_fld pun_ok parent) flds
        ; mapM_ (addErr . dupFieldErr ctxt) dup_flds
        ; dotdot_flds <- rn_dotdot dotdot mb_con flds1
@@ -595,17 +590,13 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
                 HsRecFieldPat con  -> Just con
                 _ {- update -}     -> Nothing
 
-    doc = case mb_con of
-            Nothing  -> text "constructor field name"
-            Just con -> text "field of constructor" <+> quotes (ppr con)
-
     rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg)
            -> RnM (LHsRecField GhcRn (Located arg))
     rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl
                                               = L loc (FieldOcc _ (L ll lbl))
                                           , hsRecFieldArg = arg
                                           , hsRecPun      = pun }))
-      = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent doc lbl
+      = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl
            ; arg' <- if pun
                      then do { checkErr pun_ok (badPun (L loc lbl))
                                -- Discard any module qualifier (#11662)
@@ -671,41 +662,6 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
       -- _mb_con = Nothing => Record update
       -- _mb_con = Just unbound => Out of scope data constructor
 
-    check_disambiguation :: Bool -> Maybe Name -> RnM (Maybe Name)
-    -- 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 (find_tycon env con) }
-      | otherwise = return Nothing
-
-    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),
-    -- or 'Nothing' if it is a pattern synonym or not in scope.
-    -- That's the parent to use for looking up record fields.
-    find_tycon env con_name
-      | isUnboundName con_name
-      = Just (mkUnboundName (setOccNameSpace tcName (getOccName con_name)))
-        -- If the data con is not in scope, return an unboundName tycon
-        -- That way the calls to lookupRecFieldOcc in rn_fld won't generate
-        -- an error cascade; see Trac #14307
-
-      | Just (AConLike (RealDataCon dc)) <- wiredInNameTyThing_maybe con_name
-      = Just (tyConName (dataConTyCon dc))
-        -- Special case for [], which is built-in syntax
-        -- and not in the GlobalRdrEnv (Trac #8448)
-
-      | Just gre <- lookupGRE_Name env con_name
-      = case gre_par gre of
-          ParentIs p -> Just p
-          _          -> Nothing   -- Can happen if the con_name
-                                  -- is for a pattern synonym
-
-      | otherwise = Nothing
-        -- Data constructor not lexically in scope at all
-        -- See Note [Disambiguation and Template Haskell]
-
     dup_flds :: [NE.NonEmpty RdrName]
         -- Each list represents a RdrName that occurred more than once
         -- (the list contains all occurrences)
@@ -713,21 +669,12 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
     (_, dup_flds) = removeDups compare (getFieldLbls flds)
 
 
-{- Note [Disambiguation and Template Haskell]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (Trac #12130)
-   module Foo where
-     import M
-     b = $(funny)
-
-   module M(funny) where
-     data T = MkT { x :: Int }
-     funny :: Q Exp
-     funny = [| MkT { x = 3 } |]
-
-When we splice, neither T nor MkT are lexically in scope, so find_tycon will
-fail.  But there is no need for disambiguation anyway, so we just return Nothing
--}
+-- NB: Consider this:
+--      module Foo where { data R = R { fld :: Int } }
+--      module Odd where { import Foo; fld x = x { fld = 3 } }
+-- Arguably this should work, because the reference to 'fld' is
+-- unambiguous because there is only one field id 'fld' in scope.
+-- But currently it's rejected.
 
 rnHsRecUpdFields
     :: [LHsRecUpdField GhcPs]
diff --git a/testsuite/tests/rename/should_compile/T14747.hs b/testsuite/tests/rename/should_compile/T14747.hs
new file mode 100644
index 0000000000..6dde0bdab9
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/T14747.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE PatternSynonyms, DisambiguateRecordFields #-}
+
+module T14747 where
+
+import T14747A
+
+pattern T{x} = [x]
+
+e = S { x = 42 }
diff --git a/testsuite/tests/rename/should_compile/T14747A.hs b/testsuite/tests/rename/should_compile/T14747A.hs
new file mode 100644
index 0000000000..a3b6e604e4
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/T14747A.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module T14747A where
+
+pattern S{x} = [x]
diff --git a/testsuite/tests/rename/should_compile/T15149.hs b/testsuite/tests/rename/should_compile/T15149.hs
new file mode 100644
index 0000000000..e2e77db9a1
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/T15149.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE DisambiguateRecordFields #-}
+module Main where
+import T15149B
+import T15149C
+main = do print (AnDouble{an=1}, AnInt{an=1})
diff --git a/testsuite/tests/rename/should_compile/T15149A.hs b/testsuite/tests/rename/should_compile/T15149A.hs
new file mode 100644
index 0000000000..09b9beb36f
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/T15149A.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE TypeFamilies #-}
+module T15149A where
+
+data family An c :: *
diff --git a/testsuite/tests/rename/should_compile/T15149B.hs b/testsuite/tests/rename/should_compile/T15149B.hs
new file mode 100644
index 0000000000..9a9508da08
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/T15149B.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE TypeFamilies #-}
+module T15149B where
+import T15149A
+data instance An Int = AnInt {an :: Int} deriving Show
diff --git a/testsuite/tests/rename/should_compile/T15149C.hs b/testsuite/tests/rename/should_compile/T15149C.hs
new file mode 100644
index 0000000000..ca1a7f88fb
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/T15149C.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE TypeFamilies #-}
+module T15149C where
+import T15149A
+data instance An Double = AnDouble {an :: Double} deriving Show
diff --git a/testsuite/tests/rename/should_compile/all.T b/testsuite/tests/rename/should_compile/all.T
index 1797c28854..7e31400715 100644
--- a/testsuite/tests/rename/should_compile/all.T
+++ b/testsuite/tests/rename/should_compile/all.T
@@ -154,3 +154,5 @@ test('T13132', normal, compile, [''])
 test('T13646', normal, compile, [''])
 test('LookupSub', [], multimod_compile, ['LookupSub', '-v0'])
 test('T14881', [], multimod_compile, ['T14881', '-W'])
+test('T14747', [], multimod_compile, ['T14747', '-v0'])
+test('T15149', [], multimod_compile, ['T15149', '-v0'])
diff --git a/testsuite/tests/rename/should_fail/T8448.stderr b/testsuite/tests/rename/should_fail/T8448.stderr
index e5834fbcaf..4b84290863 100644
--- a/testsuite/tests/rename/should_fail/T8448.stderr
+++ b/testsuite/tests/rename/should_fail/T8448.stderr
@@ -1,2 +1,6 @@
 
-T8448.hs:5:21: ‘r’ is not a (visible) field of constructor ‘[]’
+T8448.hs:5:17: error:
+    • Constructor ‘[]’ does not have field ‘r’
+    • In the first argument of ‘undefined’, namely ‘[] {r = x}’
+      In the expression: undefined [] {r = x}
+      In an equation for ‘f’: f x = undefined [] {r = x}