Properly trim IdInfos of DFunIds and PatSyns in TidyPgm

Not doing this right caused #16608. We now properly trim IdInfos of
DFunIds and PatSyns.

Some further refactoring done by SPJ.

Two regression tests T16608_1 and T16608_2 added.

Fixes #16608

12 files changed, 184 insertions, 133 deletions

diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs
index fe296bf054..008a0771fa 100644
--- a/compiler/basicTypes/PatSyn.hs
+++ b/compiler/basicTypes/PatSyn.hs
@@ -19,7 +19,7 @@ module PatSyn (
         patSynInstArgTys, patSynInstResTy, patSynFieldLabels,
         patSynFieldType,
 
-        tidyPatSynIds, pprPatSynType
+        updatePatSynIds, pprPatSynType
     ) where
 
 #include "HsVersions.h"
@@ -417,8 +417,8 @@ patSynMatcher = psMatcher
 patSynBuilder :: PatSyn -> Maybe (Id, Bool)
 patSynBuilder = psBuilder
 
-tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
-tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder })
+updatePatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
+updatePatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder })
   = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder }
   where
     tidy_pr (id, dummy) = (tidy_fn id, dummy)
diff --git a/compiler/coreSyn/CoreTidy.hs b/compiler/coreSyn/CoreTidy.hs
index be5e6c1619..dfb031df7f 100644
--- a/compiler/coreSyn/CoreTidy.hs
+++ b/compiler/coreSyn/CoreTidy.hs
@@ -9,7 +9,7 @@ The code for *top-level* bindings is in TidyPgm.
 
 {-# LANGUAGE CPP #-}
 module CoreTidy (
-        tidyExpr, tidyVarOcc, tidyRule, tidyRules, tidyUnfolding
+        tidyExpr, tidyRule, tidyRules, tidyUnfolding
     ) where
 
 #include "HsVersions.h"
diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs
index 66cef76861..6c5cf6f9f0 100644
--- a/compiler/main/TidyPgm.hs
+++ b/compiler/main/TidyPgm.hs
@@ -7,7 +7,7 @@
 {-# LANGUAGE CPP, DeriveFunctor, ViewPatterns #-}
 
 module TidyPgm (
-       mkBootModDetailsTc, tidyProgram, globaliseAndTidyId
+       mkBootModDetailsTc, tidyProgram
    ) where
 
 #include "HsVersions.h"
@@ -39,13 +39,11 @@ import Id
 import MkId             ( mkDictSelRhs )
 import IdInfo
 import InstEnv
-import FamInstEnv
 import Type             ( tidyTopType )
 import Demand           ( appIsBottom, isTopSig, isBottomingSig )
 import BasicTypes
 import Name hiding (varName)
 import NameSet
-import NameEnv
 import NameCache
 import Avail
 import IfaceEnv
@@ -60,6 +58,7 @@ import HscTypes
 import Maybes
 import UniqSupply
 import Outputable
+import Util( filterOut )
 import qualified ErrUtils as Err
 
 import Control.Monad
@@ -149,65 +148,78 @@ mkBootModDetailsTc hsc_env
     Err.withTiming (pure dflags)
                    (text "CoreTidy"<+>brackets (ppr this_mod))
                    (const ()) $
-    do  { let { insts'     = map (tidyClsInstDFun globaliseAndTidyId) insts
-              ; pat_syns'  = map (tidyPatSynIds   globaliseAndTidyId) pat_syns
-              ; type_env1  = mkBootTypeEnv (availsToNameSet exports)
-                                           (typeEnvIds type_env) tcs fam_insts
-              ; type_env2  = extendTypeEnvWithPatSyns pat_syns' type_env1
-              ; dfun_ids   = map instanceDFunId insts'
-              ; type_env'  = extendTypeEnvWithIds type_env2 dfun_ids
-              }
-        ; return (ModDetails { md_types         = type_env'
-                             , md_insts         = insts'
-                             , md_fam_insts     = fam_insts
-                             , md_rules         = []
-                             , md_anns          = []
-                             , md_exports       = exports
-                             , md_complete_sigs = complete_sigs
-                             })
-        }
+    return (ModDetails { md_types         = type_env'
+                       , md_insts         = insts'
+                       , md_fam_insts     = fam_insts
+                       , md_rules         = []
+                       , md_anns          = []
+                       , md_exports       = exports
+                       , md_complete_sigs = complete_sigs
+                       })
   where
     dflags = hsc_dflags hsc_env
 
-mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv
-mkBootTypeEnv exports ids tcs fam_insts
-  = tidyTypeEnv True $
-       typeEnvFromEntities final_ids tcs fam_insts
-  where
-        -- Find the LocalIds in the type env that are exported
-        -- Make them into GlobalIds, and tidy their types
-        --
-        -- It's very important to remove the non-exported ones
-        -- because we don't tidy the OccNames, and if we don't remove
-        -- the non-exported ones we'll get many things with the
-        -- same name in the interface file, giving chaos.
-        --
-        -- Do make sure that we keep Ids that are already Global.
-        -- When typechecking an .hs-boot file, the Ids come through as
-        -- GlobalIds.
-    final_ids = [ (if isLocalId id then globaliseAndTidyId id
-                                   else id)
-                        `setIdUnfolding` BootUnfolding
-                | id <- ids
+    -- Find the LocalIds in the type env that are exported
+    -- Make them into GlobalIds, and tidy their types
+    --
+    -- It's very important to remove the non-exported ones
+    -- because we don't tidy the OccNames, and if we don't remove
+    -- the non-exported ones we'll get many things with the
+    -- same name in the interface file, giving chaos.
+    --
+    -- Do make sure that we keep Ids that are already Global.
+    -- When typechecking an .hs-boot file, the Ids come through as
+    -- GlobalIds.
+    final_ids = [ globaliseAndTidyBootId id
+                | id <- typeEnvIds type_env
                 , keep_it id ]
 
-        -- default methods have their export flag set, but everything
-        -- else doesn't (yet), because this is pre-desugaring, so we
-        -- must test both.
-    keep_it id = isExportedId id || idName id `elemNameSet` exports
-
+    final_tcs  = filterOut (isWiredInName . getName) tcs
+                 -- See Note [Drop wired-in things]
+    type_env1  = typeEnvFromEntities final_ids final_tcs fam_insts
+    insts'     = mkFinalClsInsts type_env1 insts
+    pat_syns'  = mkFinalPatSyns  type_env1 pat_syns
+    type_env'  = extendTypeEnvWithPatSyns pat_syns' type_env1
+
+    -- Default methods have their export flag set (isExportedId),
+    -- but everything else doesn't (yet), because this is
+    -- pre-desugaring, so we must test against the exports too.
+    keep_it id | isWiredInName id_name           = False
+                 -- See Note [Drop wired-in things]
+               | isExportedId id                 = True
+               | id_name `elemNameSet` exp_names = True
+               | otherwise                       = False
+               where
+                 id_name = idName id
+
+    exp_names = availsToNameSet exports
+
+lookupFinalId :: TypeEnv -> Id -> Id
+lookupFinalId type_env id
+  = case lookupTypeEnv type_env (idName id) of
+      Just (AnId id') -> id'
+      _ -> pprPanic "lookup_final_id" (ppr id)
+
+mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst]
+mkFinalClsInsts env = map (updateClsInstDFun (lookupFinalId env))
+
+mkFinalPatSyns :: TypeEnv -> [PatSyn] -> [PatSyn]
+mkFinalPatSyns env = map (updatePatSynIds (lookupFinalId env))
 
+extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv
+extendTypeEnvWithPatSyns tidy_patsyns type_env
+  = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ]
 
-globaliseAndTidyId :: Id -> Id
--- Takes a LocalId with an External Name,
+globaliseAndTidyBootId :: Id -> Id
+-- For a LocalId with an External Name,
 -- makes it into a GlobalId
 --     * unchanged Name (might be Internal or External)
 --     * unchanged details
---     * VanillaIdInfo (makes a conservative assumption about Caf-hood)
-globaliseAndTidyId id
-  = Id.setIdType (globaliseId id) tidy_type
-  where
-    tidy_type = tidyTopType (idType id)
+--     * VanillaIdInfo (makes a conservative assumption about Caf-hood and arity)
+--     * BootUnfolding (see Note [Inlining and hs-boot files] in ToIface)
+globaliseAndTidyBootId id
+  = globaliseId id `setIdType`      tidyTopType (idType id)
+                   `setIdUnfolding` BootUnfolding
 
 {-
 ************************************************************************
@@ -335,13 +347,7 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
     do  { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags
               ; expose_all = gopt Opt_ExposeAllUnfoldings  dflags
               ; print_unqual = mkPrintUnqualified dflags rdr_env
-              }
-
-        ; let { type_env = typeEnvFromEntities [] tcs fam_insts
-
-              ; implicit_binds
-                  = concatMap getClassImplicitBinds (typeEnvClasses type_env) ++
-                    concatMap getTyConImplicitBinds (typeEnvTyCons type_env)
+              ; implicit_binds = concatMap getImplicitBinds tcs
               }
 
         ; (unfold_env, tidy_occ_env)
@@ -353,30 +359,6 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
         ; (tidy_env, tidy_binds)
                  <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds
 
-        ; let { final_ids  = [ id | id <- bindersOfBinds tidy_binds,
-                                    isExternalName (idName id)]
-              ; type_env1  = extendTypeEnvWithIds type_env final_ids
-
-              ; tidy_cls_insts = map (tidyClsInstDFun (tidyVarOcc tidy_env)) cls_insts
-                -- A DFunId will have a binding in tidy_binds, and so will now be in
-                -- tidy_type_env, replete with IdInfo.  Its name will be unchanged since
-                -- it was born, but we want Global, IdInfo-rich (or not) DFunId in the
-                -- tidy_cls_insts.  Similarly the Ids inside a PatSyn.
-
-              ; tidy_rules = tidyRules tidy_env trimmed_rules
-                -- You might worry that the tidy_env contains IdInfo-rich stuff
-                -- and indeed it does, but if omit_prags is on, ext_rules is
-                -- empty
-
-                -- Tidy the Ids inside each PatSyn, very similarly to DFunIds
-                -- and then override the PatSyns in the type_env with the new tidy ones
-                -- This is really the only reason we keep mg_patsyns at all; otherwise
-                -- they could just stay in type_env
-              ; tidy_patsyns = map (tidyPatSynIds (tidyVarOcc tidy_env)) patsyns
-              ; type_env2    = extendTypeEnvWithPatSyns tidy_patsyns type_env1
-
-              ; tidy_type_env = tidyTypeEnv omit_prags type_env2
-              }
           -- See Note [Grand plan for static forms] in StaticPtrTable.
         ; (spt_entries, tidy_binds') <-
              sptCreateStaticBinds hsc_env mod tidy_binds
@@ -388,20 +370,44 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
                     HscInterpreted -> id
                     -- otherwise add a C stub to do so
                     _              -> (`appendStubC` spt_init_code)
-              }
 
-        ; let { -- See Note [Injecting implicit bindings]
+              -- The completed type environment is gotten from
+              --      a) the types and classes defined here (plus implicit things)
+              --      b) adding Ids with correct IdInfo, including unfoldings,
+              --              gotten from the bindings
+              -- From (b) we keep only those Ids with External names;
+              --          the CoreTidy pass makes sure these are all and only
+              --          the externally-accessible ones
+              -- This truncates the type environment to include only the
+              -- exported Ids and things needed from them, which saves space
+              --
+              -- See Note [Don't attempt to trim data types]
+              ; final_ids  = [ if omit_prags then trimId id else id
+                             | id <- bindersOfBinds tidy_binds
+                             , isExternalName (idName id)
+                             , not (isWiredInName (getName id))
+                             ]   -- See Note [Drop wired-in things]
+
+              ; final_tcs      = filterOut (isWiredInName . getName) tcs
+                                 -- See Note [Drop wired-in things]
+              ; type_env       = typeEnvFromEntities final_ids final_tcs fam_insts
+              ; tidy_cls_insts = mkFinalClsInsts type_env cls_insts
+              ; tidy_patsyns   = mkFinalPatSyns  type_env patsyns
+              ; tidy_type_env  = extendTypeEnvWithPatSyns tidy_patsyns type_env
+              ; tidy_rules     = tidyRules tidy_env trimmed_rules
+
+              ; -- See Note [Injecting implicit bindings]
                 all_tidy_binds = implicit_binds ++ tidy_binds'
 
               -- Get the TyCons to generate code for.  Careful!  We must use
-              -- the untidied TypeEnv here, because we need
+              -- the untidied TyCons here, because we need
               --  (a) implicit TyCons arising from types and classes defined
               --      in this module
               --  (b) wired-in TyCons, which are normally removed from the
               --      TypeEnv we put in the ModDetails
               --  (c) Constructors even if they are not exported (the
               --      tidied TypeEnv has trimmed these away)
-              ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
+              ; alg_tycons = filter isAlgTyCon tcs
               }
 
         ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules
@@ -444,46 +450,19 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
   where
     dflags = hsc_dflags hsc_env
 
-tidyTypeEnv :: Bool       -- Compiling without -O, so omit prags
-            -> TypeEnv -> TypeEnv
-
--- The completed type environment is gotten from
---      a) the types and classes defined here (plus implicit things)
---      b) adding Ids with correct IdInfo, including unfoldings,
---              gotten from the bindings
--- From (b) we keep only those Ids with External names;
---          the CoreTidy pass makes sure these are all and only
---          the externally-accessible ones
--- This truncates the type environment to include only the
--- exported Ids and things needed from them, which saves space
---
--- See Note [Don't attempt to trim data types]
-
-tidyTypeEnv omit_prags type_env
- = let
-        type_env1 = filterNameEnv (not . isWiredInName . getName) type_env
-          -- (1) remove wired-in things
-        type_env2 | omit_prags = mapNameEnv trimThing type_env1
-                  | otherwise  = type_env1
-          -- (2) trimmed if necessary
-    in
-    type_env2
-
 --------------------------
-trimThing :: TyThing -> TyThing
--- Trim off inessentials, for boot files and no -O
-trimThing (AnId id)
-   | not (isImplicitId id)
-   = AnId (id `setIdInfo` vanillaIdInfo)
+trimId :: Id -> Id
+trimId id
+  | not (isImplicitId id)
+  = id `setIdInfo` vanillaIdInfo
+  | otherwise
+  = id
 
-trimThing other_thing
-  = other_thing
+{- Note [Drop wired-in things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We never put wired-in TyCons or Ids in an interface file.
+They are wired-in, so the compiler knows about them already.
 
-extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv
-extendTypeEnvWithPatSyns tidy_patsyns type_env
-  = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ]
-
-{-
 Note [Don't attempt to trim data types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 For some time GHC tried to avoid exporting the data constructors
@@ -565,6 +544,11 @@ really just a code generation trick.... binding itself makes no sense.
 See Note [Data constructor workers] in CorePrep.
 -}
 
+getImplicitBinds :: TyCon -> [CoreBind]
+getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc
+  where
+    cls_binds = maybe [] getClassImplicitBinds (tyConClass_maybe tc)
+
 getTyConImplicitBinds :: TyCon -> [CoreBind]
 getTyConImplicitBinds tc
   | isNewTyCon tc = []  -- See Note [Compulsory newtype unfolding] in MkId
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 05d72d64ac..d13abf4e03 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -61,7 +61,6 @@ import RnExpr
 import RnUtils ( HsDocContext(..) )
 import RnFixity ( lookupFixityRn )
 import MkId
-import TidyPgm    ( globaliseAndTidyId )
 import TysWiredIn ( unitTy, mkListTy )
 import Plugins
 import DynFlags
@@ -2560,7 +2559,9 @@ tcRnDeclsi hsc_env local_decls
 externaliseAndTidyId :: Module -> Id -> TcM Id
 externaliseAndTidyId this_mod id
   = do { name' <- externaliseName this_mod (idName id)
-       ; return (globaliseAndTidyId (setIdName id name')) }
+       ; return $ globaliseId id
+                     `setIdName` name'
+                     `setIdType` tidyTopType (idType id) }
 
 
 {-
diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs
index debced8dba..13a0b30555 100644
--- a/compiler/types/InstEnv.hs
+++ b/compiler/types/InstEnv.hs
@@ -14,7 +14,7 @@ module InstEnv (
         OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
         ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances,
         instanceHead, instanceSig, mkLocalInstance, mkImportedInstance,
-        instanceDFunId, tidyClsInstDFun, instanceRoughTcs,
+        instanceDFunId, updateClsInstDFun, instanceRoughTcs,
         fuzzyClsInstCmp, orphNamesOfClsInst,
 
         InstEnvs(..), VisibleOrphanModules, InstEnv,
@@ -199,8 +199,8 @@ being equal to
 instanceDFunId :: ClsInst -> DFunId
 instanceDFunId = is_dfun
 
-tidyClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst
-tidyClsInstDFun tidy_dfun ispec
+updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst
+updateClsInstDFun tidy_dfun ispec
   = ispec { is_dfun = tidy_dfun (is_dfun ispec) }
 
 instanceRoughTcs :: ClsInst -> [Maybe Name]
diff --git a/testsuite/tests/driver/T16608/Makefile b/testsuite/tests/driver/T16608/Makefile
new file mode 100644
index 0000000000..f3a6fae9be
--- /dev/null
+++ b/testsuite/tests/driver/T16608/Makefile
@@ -0,0 +1,17 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+T16608_1:
+	'$(TEST_HC)' $(TEST_HC_OPTS) --make -O0 T16608_1.hs
+	./T16608_1
+	sed -i -e 's/{- . succ -}/. succ/' MyInteger.hs
+	'$(TEST_HC)' $(TEST_HC_OPTS) --make -O0 T16608_1.hs
+	./T16608_1
+
+T16608_2:
+	'$(TEST_HC)' $(TEST_HC_OPTS) --make -O0 T16608_2.hs
+	./T16608_2
+	sed -i -e 's/{- . succ -}/. succ/' MyInteger.hs
+	'$(TEST_HC)' $(TEST_HC_OPTS) --make -O0 T16608_2.hs
+	./T16608_2
diff --git a/testsuite/tests/driver/T16608/MyInteger.hs b/testsuite/tests/driver/T16608/MyInteger.hs
new file mode 100644
index 0000000000..a7c731ed8c
--- /dev/null
+++ b/testsuite/tests/driver/T16608/MyInteger.hs
@@ -0,0 +1,12 @@
+module MyInteger
+  ( MyInteger (MyInteger)
+  , ToMyInteger (toMyInteger)
+  ) where
+
+newtype MyInteger = MyInteger Integer
+
+class ToMyInteger a where
+  toMyInteger :: a -> MyInteger
+
+instance ToMyInteger Integer where
+  toMyInteger = MyInteger {- . succ -}
diff --git a/testsuite/tests/driver/T16608/T16608_1.hs b/testsuite/tests/driver/T16608/T16608_1.hs
new file mode 100644
index 0000000000..87a5000dab
--- /dev/null
+++ b/testsuite/tests/driver/T16608/T16608_1.hs
@@ -0,0 +1,11 @@
+module Main
+  ( main
+  ) where
+
+import MyInteger (MyInteger (MyInteger), toMyInteger)
+
+main :: IO ()
+main = do
+  let (MyInteger i) = toMyInteger (41 :: Integer)
+  print i
+
diff --git a/testsuite/tests/driver/T16608/T16608_1.stdout b/testsuite/tests/driver/T16608/T16608_1.stdout
new file mode 100644
index 0000000000..05c44cb5a8
--- /dev/null
+++ b/testsuite/tests/driver/T16608/T16608_1.stdout
@@ -0,0 +1,7 @@
+[1 of 2] Compiling MyInteger        ( MyInteger.hs, MyInteger.o )
+[2 of 2] Compiling Main             ( T16608_1.hs, T16608_1.o )
+Linking T16608_1 ...
+41
+[1 of 2] Compiling MyInteger        ( MyInteger.hs, MyInteger.o )
+Linking T16608_1 ...
+42
diff --git a/testsuite/tests/driver/T16608/T16608_2.hs b/testsuite/tests/driver/T16608/T16608_2.hs
new file mode 100644
index 0000000000..34eaddabf0
--- /dev/null
+++ b/testsuite/tests/driver/T16608/T16608_2.hs
@@ -0,0 +1,10 @@
+module Main
+  ( main
+  ) where
+
+import MyInteger (MyInteger (MyInteger), toMyInteger)
+
+main :: IO ()
+main = do
+  let (MyInteger i) = (id . toMyInteger) (41 :: Integer)
+  print i
diff --git a/testsuite/tests/driver/T16608/T16608_2.stdout b/testsuite/tests/driver/T16608/T16608_2.stdout
new file mode 100644
index 0000000000..9ca19a6dba
--- /dev/null
+++ b/testsuite/tests/driver/T16608/T16608_2.stdout
@@ -0,0 +1,7 @@
+[1 of 2] Compiling MyInteger        ( MyInteger.hs, MyInteger.o )
+[2 of 2] Compiling Main             ( T16608_2.hs, T16608_2.o )
+Linking T16608_2 ...
+41
+[1 of 2] Compiling MyInteger        ( MyInteger.hs, MyInteger.o )
+Linking T16608_2 ...
+42
diff --git a/testsuite/tests/driver/T16608/all.T b/testsuite/tests/driver/T16608/all.T
new file mode 100644
index 0000000000..5a1b8dc488
--- /dev/null
+++ b/testsuite/tests/driver/T16608/all.T
@@ -0,0 +1,2 @@
+test('T16608_1', [extra_files(['MyInteger.hs'])], makefile_test, [])
+test('T16608_2', [extra_files(['MyInteger.hs'])], makefile_test, [])