Fix DFun renamingwip/names3

2 files changed, 20 insertions, 30 deletions

diff --git a/compiler/backpack/RnModIface.hs b/compiler/backpack/RnModIface.hs
index 371a65e105..a7f7c10f55 100644
--- a/compiler/backpack/RnModIface.hs
+++ b/compiler/backpack/RnModIface.hs
@@ -241,6 +241,18 @@ rnIfaceGlobal n = do
             let nsubst = mkNameShape (moduleName m) (mi_exports iface)
             return (substNameShape nsubst n)
 
+-- | Rename a DFun name. Here is where we ensure that DFuns have the correct
+-- module as described in Note [Bogus DFun renamings].
+rnIfaceDFun :: Name -> ShIfM Name
+rnIfaceDFun name = do
+    hmap <- getHoleSubst
+    dflags <- getDynFlags
+    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv
+    let m = renameHoleModule dflags hmap $ nameModule name
+    -- Doublecheck that this DFun was, indeed, locally defined.
+    MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m )
+    setNameModule (Just m) name
+
 -- PILES AND PILES OF BOILERPLATE
 
 -- | Rename an 'IfaceClsInst', with special handling for an associated
@@ -250,9 +262,6 @@ rnIfaceClsInst cls_inst = do
     n <- rnIfaceGlobal (ifInstCls cls_inst)
     tys <- mapM rnMaybeIfaceTyCon (ifInstTys cls_inst)
 
-    hmap <- getHoleSubst
-    dflags <- getDynFlags
-
     -- Note [Bogus DFun renamings]
     -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
     -- Every 'IfaceClsInst' is associated with a DFun; in fact, when
@@ -312,12 +321,7 @@ rnIfaceClsInst cls_inst = do
     --    are unique; for instantiation, the final interface never
     --    mentions DFuns since they are implicitly exported.)  The
     --    important thing is that it's consistent everywhere.
-
-    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv
-    let m = renameHoleModule dflags hmap $ nameModule (ifDFun cls_inst)
-    -- Doublecheck that this DFun was, indeed, locally defined.
-    MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m )
-    dfun <- setNameModule (Just m) (ifDFun cls_inst)
+    dfun <- rnIfaceDFun (ifDFun cls_inst)
     return cls_inst { ifInstCls = n
                     , ifInstTys = tys
                     , ifDFun = dfun
@@ -339,7 +343,9 @@ rnIfaceDecl' (fp, decl) = (,) fp <$> rnIfaceDecl decl
 
 rnIfaceDecl :: Rename IfaceDecl
 rnIfaceDecl d@IfaceId{} = do
-            name <- rnIfaceGlobal (ifName d)
+            name <- case ifIdDetails d of
+                      IfDFunId -> rnIfaceDFun (ifName d)
+                      _        -> rnIfaceGlobal (ifName d)
             ty <- rnIfaceType (ifType d)
             details <- rnIfaceIdDetails (ifIdDetails d)
             info <- rnIfaceIdInfo (ifIdInfo d)
@@ -464,6 +470,7 @@ rnIfaceConDecl d = do
              , ifConEqSpec = con_eq_spec
              , ifConCtxt = con_ctxt
              , ifConArgTys = con_arg_tys
+             , ifConFields = con_fields
              , ifConStricts = con_stricts
              }
 
diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs
index 581aa1f393..46bc0e9905 100644
--- a/compiler/iface/IfaceEnv.hs
+++ b/compiler/iface/IfaceEnv.hs
@@ -255,27 +255,10 @@ extendIfaceEnvs tcvs thing_inside
 ************************************************************************
 -}
 
+-- | Look up a top-level name from the current Iface module
 lookupIfaceTop :: OccName -> IfL Name
--- Look up a top-level name from the current Iface module
-lookupIfaceTop occ = do
-    lcl_env <- getLclEnv
-    -- NB: this is a semantic module, see
-    -- Note [Identity versus semantic module]
-    mod <- getIfModule
-    case if_nsubst lcl_env of
-        -- NOT substNameShape because 'getIfModule' returns the
-        -- renamed module (d'oh!)
-        Just nsubst ->
-            case lookupOccEnv (ns_map nsubst) occ of
-              Just n' ->
-                -- I thought this would be help but it turns out
-                -- n' doesn't have any useful information. Drat!
-                -- return (setNameLoc n' (nameSrcSpan n))
-                return n'
-              -- This case can occur when we encounter a DFun;
-              -- see Note [Bogus DFun renamings]
-              Nothing -> lookupOrig mod occ
-        _ -> lookupOrig mod occ
+lookupIfaceTop occ
+  = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }
 
 newIfaceName :: OccName -> IfL Name
 newIfaceName occ