Record full FieldLabel in ifConFields.

Summary:
The previous implementation tried to be "efficient" by
storing field names once in IfaceConDecls, and only just
enough information for us to reconstruct the FieldLabel.
But this came at a bit of code complexity cost.

This patch undos the optimization, instead storing a full
FieldLabel at each data constructor.  Consequently, this fixes
bugs #12699 and #13250.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: adamgundry, bgamari, austin

Subscribers: thomie

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

7 files changed, 66 insertions, 80 deletions

diff --git a/compiler/backpack/RnModIface.hs b/compiler/backpack/RnModIface.hs
index 1b11a0f900..d4af5cc4ab 100644
--- a/compiler/backpack/RnModIface.hs
+++ b/compiler/backpack/RnModIface.hs
@@ -509,11 +509,9 @@ rnIfaceTyConParent (IfDataInstance n tc args)
 rnIfaceTyConParent IfNoParent = pure IfNoParent
 
 rnIfaceConDecls :: Rename IfaceConDecls
-rnIfaceConDecls (IfDataTyCon ds b fs)
+rnIfaceConDecls (IfDataTyCon ds)
     = IfDataTyCon <$> mapM rnIfaceConDecl ds
-                  <*> return b
-                  <*> return fs
-rnIfaceConDecls (IfNewTyCon d b fs) = IfNewTyCon <$> rnIfaceConDecl d <*> return b <*> return fs
+rnIfaceConDecls (IfNewTyCon d) = IfNewTyCon <$> rnIfaceConDecl d
 rnIfaceConDecls (IfAbstractTyCon b) = pure (IfAbstractTyCon b)
 
 rnIfaceConDecl :: Rename IfaceConDecl
@@ -524,10 +522,7 @@ rnIfaceConDecl d = do
     con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d)
     con_ctxt <- mapM rnIfaceType (ifConCtxt d)
     con_arg_tys <- mapM rnIfaceType (ifConArgTys d)
-    -- TODO: It seems like we really should rename the field labels, but this
-    -- breaks due to tcIfaceDataCons projecting back to the field's OccName and
-    -- then looking up it up in the name cache. See #12699.
-    --con_fields <- mapM rnIfaceGlobal (ifConFields d)
+    con_fields <- mapM rnFieldLabel (ifConFields d)
     let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co
         rnIfaceBang bang = pure bang
     con_stricts <- mapM rnIfaceBang (ifConStricts d)
@@ -536,7 +531,7 @@ rnIfaceConDecl d = do
              , ifConEqSpec = con_eq_spec
              , ifConCtxt = con_ctxt
              , ifConArgTys = con_arg_tys
-             --, ifConFields = con_fields -- See TODO above
+             , ifConFields = con_fields
              , ifConStricts = con_stricts
              }
 
diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs
index 7150e228ba..5ed30c9998 100644
--- a/compiler/iface/IfaceSyn.hs
+++ b/compiler/iface/IfaceSyn.hs
@@ -27,7 +27,6 @@ module IfaceSyn (
 
         -- Misc
         ifaceDeclImplicitBndrs, visibleIfConDecls,
-        ifaceConDeclFields,
         ifaceDeclFingerprints,
 
         -- Free Names
@@ -70,7 +69,6 @@ import Lexeme (isLexSym)
 
 import Control.Monad
 import System.IO.Unsafe
-import Data.List (find)
 import Data.Maybe (isJust)
 
 infixl 3 &&&
@@ -209,15 +207,15 @@ data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars   :: [IfaceTvBndr]
                                      -- See Note [Storing compatibility] in CoAxiom
 
 data IfaceConDecls
-  = IfAbstractTyCon HowAbstract                   -- c.f TyCon.AbstractTyCon
-  | IfDataTyCon [IfaceConDecl] Bool [FieldLabelString] -- Data type decls
-  | IfNewTyCon  IfaceConDecl   Bool [FieldLabelString] -- Newtype decls
+  = IfAbstractTyCon HowAbstract     -- c.f TyCon.AbstractTyCon
+  | IfDataTyCon [IfaceConDecl] -- Data type decls
+  | IfNewTyCon  IfaceConDecl   -- Newtype decls
 
 -- For IfDataTyCon and IfNewTyCon we store:
 --  * the data constructor(s);
---  * a boolean indicating whether DuplicateRecordFields was enabled
---    at the definition site; and
---  * a list of field labels.
+-- The field labels are stored individually in the IfaceConDecl
+-- (there is some redundancy here, because a field label may occur
+-- in multiple IfaceConDecls and represent the same field label)
 
 data IfaceConDecl
   = IfCon {
@@ -235,7 +233,7 @@ data IfaceConDecl
         ifConEqSpec  :: IfaceEqSpec,        -- Equality constraints
         ifConCtxt    :: IfaceContext,       -- Non-stupid context
         ifConArgTys  :: [IfaceType],        -- Arg types
-        ifConFields  :: [IfaceTopBndr],     -- ...ditto... (field labels)
+        ifConFields  :: [FieldLabel],  -- ...ditto... (field labels)
         ifConStricts :: [IfaceBang],
           -- Empty (meaning all lazy),
           -- or 1-1 corresp with arg tys
@@ -370,18 +368,8 @@ See [http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoid
 
 visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
 visibleIfConDecls (IfAbstractTyCon {}) = []
-visibleIfConDecls (IfDataTyCon cs _ _) = cs
-visibleIfConDecls (IfNewTyCon c   _ _) = [c]
-
-ifaceConDeclFields :: IfaceConDecls -> [FieldLbl OccName]
-ifaceConDeclFields x = case x of
-    IfAbstractTyCon {}              -> []
-    IfDataTyCon cons is_over labels -> map (help cons  is_over) labels
-    IfNewTyCon  con  is_over labels -> map (help [con] is_over) labels
-  where
-    help (dc:_) is_over lbl =
-        mkFieldLabelOccs lbl (occName $ ifConName dc) is_over
-    help [] _ _ = error "ifaceConDeclFields: data type has no constructors!"
+visibleIfConDecls (IfDataTyCon cs) = cs
+visibleIfConDecls (IfNewTyCon c) = [c]
 
 ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName]
 --  *Excludes* the 'main' name, but *includes* the implicitly-bound names
@@ -398,8 +386,8 @@ ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName]
 ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons })
   = case cons of
       IfAbstractTyCon {}  -> []
-      IfNewTyCon  cd  _ _ -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd
-      IfDataTyCon cds _ _ -> concatMap ifaceConDeclImplicitBndrs cds
+      IfNewTyCon  cd  -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd
+      IfDataTyCon cds -> concatMap ifaceConDeclImplicitBndrs cds
 
 ifaceDeclImplicitBndrs (IfaceClass { ifCtxt = sc_ctxt
                                    , ifName = cls_tc_name
@@ -430,7 +418,8 @@ ifaceDeclImplicitBndrs (IfaceClass { ifCtxt = sc_ctxt
 ifaceDeclImplicitBndrs _ = []
 
 ifaceConDeclImplicitBndrs :: IfaceConDecl -> [OccName]
-ifaceConDeclImplicitBndrs (IfCon { ifConWrapper = has_wrapper, ifConName = con_name })
+ifaceConDeclImplicitBndrs (IfCon {
+        ifConWrapper = has_wrapper, ifConName = con_name })
   = [occName con_name, work_occ] ++ wrap_occs
   where
     con_occ = occName con_name
@@ -716,12 +705,11 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
     add_bars []     = Outputable.empty
     add_bars (c:cs) = sep ((equals <+> c) : map (vbar <+>) cs)
 
-    ok_con dc = showSub ss dc || any (showSub ss) (ifConFields dc)
+    ok_con dc = showSub ss dc || any (showSub ss . flSelector) (ifConFields dc)
 
     show_con dc
-      | ok_con dc = Just $ pprIfaceConDecl ss gadt_style fls tycon binders parent dc
+      | ok_con dc = Just $ pprIfaceConDecl ss gadt_style tycon binders parent dc
       | otherwise = Nothing
-    fls = ifaceConDeclFields condecls
 
     pp_nd = case condecls of
               IfAbstractTyCon how ->
@@ -942,12 +930,11 @@ isVanillaIfaceConDecl (IfCon { ifConExTvs  = ex_tvs
   = (null ex_tvs) && (null eq_spec) && (null ctxt)
 
 pprIfaceConDecl :: ShowSub -> Bool
-                -> [FieldLbl OccName]
                 -> IfaceTopBndr
                 -> [IfaceTyConBinder]
                 -> IfaceTyConParent
                 -> IfaceConDecl -> SDoc
-pprIfaceConDecl ss gadt_style fls tycon tc_binders parent
+pprIfaceConDecl ss gadt_style tycon tc_binders parent
         (IfCon { ifConName = name, ifConInfix = is_infix,
                  ifConExTvs = ex_tvs,
                  ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
@@ -995,18 +982,15 @@ pprIfaceConDecl ss gadt_style fls tycon tc_binders parent
     pp_field_args = braces $ sep $ punctuate comma $ ppr_trim $
                     zipWith maybe_show_label fields tys_w_strs
 
-    maybe_show_label :: IfaceTopBndr -> (IfaceBang, IfaceType) -> Maybe SDoc
-    maybe_show_label sel bty
+    maybe_show_label :: FieldLabel -> (IfaceBang, IfaceType) -> Maybe SDoc
+    maybe_show_label lbl bty
       | showSub ss sel =
-          Just (pprPrefixIfDeclBndr how_much lbl <+> dcolon <+> pprBangTy bty)
+          Just (pprPrefixIfDeclBndr how_much occ <+> dcolon <+> pprBangTy bty)
       | otherwise      =
           Nothing
       where
-        -- IfaceConDecl contains the name of the selector function, so
-        -- we have to look up the field label (in case
-        -- DuplicateRecordFields was used for the definition)
-        lbl = maybe (occName sel) (mkVarOccFS . flLabel)
-              $ find (\ fl -> flSelector fl == occName sel) fls
+        sel = flSelector lbl
+        occ = mkVarOccFS (flLabel lbl)
 
     mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc)
     -- See Note [Result type of a data family GADT]
@@ -1327,8 +1311,8 @@ freeNamesDM (Just (GenericDM ty)) = freeNamesIfType ty
 freeNamesDM _                     = emptyNameSet
 
 freeNamesIfConDecls :: IfaceConDecls -> NameSet
-freeNamesIfConDecls (IfDataTyCon c _ _) = fnList freeNamesIfConDecl c
-freeNamesIfConDecls (IfNewTyCon  c _ _) = freeNamesIfConDecl c
+freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c
+freeNamesIfConDecls (IfNewTyCon  c) = freeNamesIfConDecl c
 freeNamesIfConDecls _                   = emptyNameSet
 
 freeNamesIfConDecl :: IfaceConDecl -> NameSet
@@ -1336,6 +1320,7 @@ freeNamesIfConDecl c
   = freeNamesIfTyVarBndrs (ifConExTvs c) &&&
     freeNamesIfContext (ifConCtxt c) &&&
     fnList freeNamesIfType (ifConArgTys c) &&&
+    mkNameSet (map flSelector (ifConFields c)) &&&
     fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints
 
 freeNamesIfKind :: IfaceType -> NameSet
@@ -1733,14 +1718,14 @@ instance Binary IfaceAxBranch where
 
 instance Binary IfaceConDecls where
     put_ bh (IfAbstractTyCon d)   = putByte bh 0 >> put_ bh d
-    put_ bh (IfDataTyCon cs b fs) = putByte bh 1 >> put_ bh cs >> put_ bh b >> put_ bh fs
-    put_ bh (IfNewTyCon c b fs)   = putByte bh 2 >> put_ bh c >> put_ bh b >> put_ bh fs
+    put_ bh (IfDataTyCon cs) = putByte bh 1 >> put_ bh cs
+    put_ bh (IfNewTyCon c)   = putByte bh 2 >> put_ bh c
     get bh = do
         h <- getByte bh
         case h of
             0 -> liftM IfAbstractTyCon $ get bh
-            1 -> liftM3 IfDataTyCon (get bh) (get bh) (get bh)
-            2 -> liftM3 IfNewTyCon (get bh) (get bh) (get bh)
+            1 -> liftM IfDataTyCon (get bh)
+            2 -> liftM IfNewTyCon (get bh)
             _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls"
 
 instance Binary IfaceConDecl where
@@ -1753,7 +1738,7 @@ instance Binary IfaceConDecl where
         put_ bh a6
         put_ bh a7
         put_ bh (length a8)
-        mapM_ (putIfaceTopBndr bh) a8
+        mapM_ (put_ bh) a8
         put_ bh a9
         put_ bh a10
     get bh = do
@@ -1765,7 +1750,7 @@ instance Binary IfaceConDecl where
         a6 <- get bh
         a7 <- get bh
         n_fields <- get bh
-        a8 <- replicateM n_fields (getIfaceTopBndr bh)
+        a8 <- replicateM n_fields (get bh)
         a9 <- get bh
         a10 <- get bh
         return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index acf61a7066..dcb55ef2af 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -501,7 +501,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
                      , not (isHoleModule semantic_mod) = global_hash_fn name
                      | otherwise = return (snd (lookupOccEnv local_env (getOccName name)
                            `orElse` pprPanic "urk! lookup local fingerprint"
-                                       (ppr name)))
+                                       (ppr name $$ ppr local_env)))
                 -- This panic indicates that we got the dependency
                 -- analysis wrong, because we needed a fingerprint for
                 -- an entity that wasn't in the environment.  To debug
@@ -1589,7 +1589,7 @@ tyConToIfaceDecl env tycon
                   ifCType      = Nothing,
                   ifRoles      = tyConRoles tycon,
                   ifCtxt       = [],
-                  ifCons       = IfDataTyCon [] False [],
+                  ifCons       = IfDataTyCon [],
                   ifGadtSyntax = False,
                   ifParent     = IfNoParent })
   where
@@ -1623,10 +1623,10 @@ tyConToIfaceDecl env tycon
 
 
 
-    ifaceConDecls (NewTyCon { data_con = con })    flds = IfNewTyCon  (ifaceConDecl con) (ifaceOverloaded flds) (ifaceFields flds)
-    ifaceConDecls (DataTyCon { data_cons = cons }) flds = IfDataTyCon (map ifaceConDecl cons) (ifaceOverloaded flds) (ifaceFields flds)
-    ifaceConDecls (TupleTyCon { data_con = con })  _    = IfDataTyCon [ifaceConDecl con] False []
-    ifaceConDecls (SumTyCon { data_cons = cons })  flds = IfDataTyCon (map ifaceConDecl cons) (ifaceOverloaded flds) (ifaceFields flds)
+    ifaceConDecls (NewTyCon { data_con = con })    flds = IfNewTyCon  (ifaceConDecl con)
+    ifaceConDecls (DataTyCon { data_cons = cons }) flds = IfDataTyCon (map ifaceConDecl cons)
+    ifaceConDecls (TupleTyCon { data_con = con })  _    = IfDataTyCon [ifaceConDecl con]
+    ifaceConDecls (SumTyCon { data_cons = cons })  flds = IfDataTyCon (map ifaceConDecl cons)
     ifaceConDecls (AbstractTyCon distinct)         _    = IfAbstractTyCon distinct
         -- The AbstractTyCon case happens when a TyCon has been trimmed
         -- during tidying.
@@ -1643,7 +1643,7 @@ tyConToIfaceDecl env tycon
                     ifConEqSpec  = map (to_eq_spec . eqSpecPair) eq_spec,
                     ifConCtxt    = tidyToIfaceContext con_env2 theta,
                     ifConArgTys  = map (tidyToIfaceType con_env2) arg_tys,
-                    ifConFields  = map flSelector (dataConFieldLabels data_con),
+                    ifConFields  = dataConFieldLabels data_con,
                     ifConStricts = map (toIfaceBang con_env2)
                                        (dataConImplBangs data_con),
                     ifConSrcStricts = map toIfaceSrcBang
@@ -1669,7 +1669,6 @@ tyConToIfaceDecl env tycon
     ifaceOverloaded flds = case dFsEnvElts flds of
                              fl:_ -> flIsOverloaded fl
                              []   -> False
-    ifaceFields flds = map flLabel $ dFsEnvElts flds
 
 classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
 classToIfaceDecl env clas
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index a920945e16..5d41232cb2 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -805,21 +805,19 @@ tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyC
 tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
   = case if_cons of
         IfAbstractTyCon dis -> return (AbstractTyCon dis)
-        IfDataTyCon cons _ _ -> do  { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons)
-                                    ; data_cons  <- mapM (tc_con_decl field_lbls) cons
-                                    ; return (mkDataTyConRhs data_cons) }
-        IfNewTyCon  con  _ _ -> do  { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons)
-                                    ; data_con  <- tc_con_decl field_lbls con
-                                    ; mkNewTyConRhs tycon_name tycon data_con }
+        IfDataTyCon cons -> do  { data_cons  <- mapM tc_con_decl cons
+                                ; return (mkDataTyConRhs data_cons) }
+        IfNewTyCon  con  -> do  { data_con  <- tc_con_decl con
+                                ; mkNewTyConRhs tycon_name tycon data_con }
   where
     univ_tv_bndrs :: [TyVarBinder]
     univ_tv_bndrs = mkDataConUnivTyVarBinders tc_tybinders
 
-    tc_con_decl field_lbls (IfCon { ifConInfix = is_infix,
+    tc_con_decl (IfCon { ifConInfix = is_infix,
                          ifConExTvs = ex_bndrs,
                          ifConName = dc_name,
                          ifConCtxt = ctxt, ifConEqSpec = spec,
-                         ifConArgTys = args, ifConFields = my_lbls,
+                         ifConArgTys = args, ifConFields = lbl_names,
                          ifConStricts = if_stricts,
                          ifConSrcStricts = if_src_stricts})
      = -- Universally-quantified tyvars are shared with
@@ -841,16 +839,6 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
                         -- the type itself; hence inside forkM
                 ; return (eq_spec, theta, arg_tys, stricts) }
 
-        -- Look up the field labels for this constructor; note that
-        -- they should be in the same order as my_lbls!
-        ; let lbl_names = map find_lbl my_lbls
-              find_lbl x = case find (\ fl -> flSelector fl == x) field_lbls of
-                             Just fl -> fl
-                             Nothing -> pprPanic "TcIface.find_lbl" not_found
-                where
-                  not_found = text "missing:" <+> ppr (occName x)
-                           $$ text "known labels:" <+> ppr field_lbls
-
         -- Remember, tycon is the representation tycon
         ; let orig_res_ty = mkFamilyTyConApp tycon
                                 (substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec))
diff --git a/testsuite/tests/backpack/should_compile/T13250.bkp b/testsuite/tests/backpack/should_compile/T13250.bkp
new file mode 100644
index 0000000000..fb8098df44
--- /dev/null
+++ b/testsuite/tests/backpack/should_compile/T13250.bkp
@@ -0,0 +1,8 @@
+unit p where
+    signature A where
+        newtype F a = F { mkF :: a }
+unit q where
+    module A where
+        newtype F a = F { mkF :: a }
+unit r where
+    dependency p[A=q:A]
diff --git a/testsuite/tests/backpack/should_compile/T13250.stderr b/testsuite/tests/backpack/should_compile/T13250.stderr
new file mode 100644
index 0000000000..fc79c05623
--- /dev/null
+++ b/testsuite/tests/backpack/should_compile/T13250.stderr
@@ -0,0 +1,10 @@
+[1 of 3] Processing p
+  [1 of 1] Compiling A[sig]           ( p/A.hsig, nothing )
+[2 of 3] Processing q
+  Instantiating q
+  [1 of 1] Compiling A                ( q/A.hs, T13250.out/q/A.o )
+[3 of 3] Processing r
+  Instantiating r
+  [1 of 1] Including p[A=q:A]
+    Instantiating p[A=q:A]
+    [1 of 1] Compiling A[sig]           ( p/A.hsig, T13250.out/p/p-HVmFlcYSefiK5n1aDP1v7x/A.o )
diff --git a/testsuite/tests/backpack/should_compile/all.T b/testsuite/tests/backpack/should_compile/all.T
index 8f4ec3b982..96bc5e1862 100644
--- a/testsuite/tests/backpack/should_compile/all.T
+++ b/testsuite/tests/backpack/should_compile/all.T
@@ -47,4 +47,5 @@ test('bkp52', normal, backpack_compile, [''])
 
 test('T13149', expect_broken(13149), backpack_compile, [''])
 test('T13214', normal, backpack_compile, [''])
+test('T13250', normal, backpack_compile, [''])
 test('T13323', normal, backpack_compile, [''])