Refactor CoreFile to use fat interface core type

ghcide/src/Development/IDE/GHC/CoreFile.hs

@@ -13,18 +13,14 @@ module Development.IDE.GHC.CoreFile
   ) where
 
 import           Control.Monad
-import           Control.Monad.IO.Class
-import           Data.Foldable
 import           Data.IORef
-import           Data.List                       (isPrefixOf)
 import           Data.Maybe
 import           Development.IDE.GHC.Compat
 import qualified Development.IDE.GHC.Compat.Util as Util
 import           GHC.Core
 import           GHC.CoreToIface
 import           GHC.Fingerprint
 import           GHC.Iface.Binary
-import           GHC.Iface.Env
 #if MIN_VERSION_ghc(9,11,0)
 import qualified GHC.Iface.Load                  as Iface
 #endif
@@ -42,38 +38,11 @@ initBinMemSize = 1024 * 1024
 
 data CoreFile
   = CoreFile
-  { cf_bindings   :: [TopIfaceBinding IfaceId]
+  { cf_bindings   :: [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
   -- ^ The actual core file bindings, deserialized lazily
   , cf_iface_hash :: !Fingerprint
   }
 
--- | Like IfaceBinding, but lets us serialize internal names as well
-data TopIfaceBinding v
-  = TopIfaceNonRec v IfaceExpr
-  | TopIfaceRec    [(v, IfaceExpr)]
-  deriving (Functor, Foldable, Traversable)
-
--- | GHC doesn't export 'tcIdDetails', 'tcIfaceInfo', or 'tcIfaceType',
--- but it does export 'tcIfaceDecl'
--- so we use `IfaceDecl` as a container for all of these
--- invariant: 'IfaceId' is always a 'IfaceId' constructor
-type IfaceId = IfaceDecl
-
-instance Binary (TopIfaceBinding IfaceId) where
-  put_ bh (TopIfaceNonRec d e) = do
-    putByte bh 0
-    put_ bh d
-    put_ bh e
-  put_ bh (TopIfaceRec vs) = do
-    putByte bh 1
-    put_ bh vs
-  get bh = do
-    t <- getByte bh
-    case t of
-      0 -> TopIfaceNonRec <$> get bh <*> get bh
-      1 -> TopIfaceRec <$> get bh
-      _ -> error "Binary TopIfaceBinding"
-
 instance Binary CoreFile where
   put_ bh (CoreFile core fp) = lazyPut bh core >> put_ bh fp
   get bh = CoreFile <$> lazyGet bh <*> get bh
@@ -118,7 +87,7 @@ codeGutsToCoreFile
   -> CgGuts
   -> CoreFile
 -- In GHC 9.6, implicit binds are tidied and part of core binds
-codeGutsToCoreFile hash CgGuts{..} = CoreFile (map (toIfaceTopBind1 cg_module) cg_binds) hash
+codeGutsToCoreFile hash CgGuts{..} = CoreFile (map toIfaceTopBind cg_binds) hash
 
 getImplicitBinds :: TyCon -> [CoreBind]
 getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc
@@ -142,70 +111,7 @@ get_defn identifier = NonRec identifier templ
               Nothing -> error "get_dfn: no unfolding template"
               Just x  -> x
 
-toIfaceTopBndr1 :: Module -> Id -> IfaceId
-toIfaceTopBndr1 mod identifier
-  = IfaceId (mangleDeclName mod $ getName identifier)
-            (toIfaceType (idType identifier))
-            (toIfaceIdDetails (idDetails identifier))
-            (toIfaceIdInfo (idInfo identifier))
-
-toIfaceTopBind1 :: Module -> Bind Id -> TopIfaceBinding IfaceId
-toIfaceTopBind1 mod (NonRec b r) = TopIfaceNonRec (toIfaceTopBndr1 mod b) (toIfaceExpr r)
-toIfaceTopBind1 mod (Rec prs)    = TopIfaceRec [(toIfaceTopBndr1 mod b, toIfaceExpr r) | (b,r) <- prs]
-
 typecheckCoreFile :: Module -> IORef TypeEnv -> CoreFile -> IfG CoreProgram
 typecheckCoreFile this_mod type_var (CoreFile prepd_binding _) =
   initIfaceLcl this_mod (text "typecheckCoreFile") NotBoot $ do
-    tcTopIfaceBindings1 type_var prepd_binding
-
--- | Internal names can't be serialized, so we mange them
--- to an external name and restore at deserialization time
--- This is necessary because we rely on stuffing TopIfaceBindings into
--- a IfaceId because we don't have access to 'tcIfaceType' etc..
-mangleDeclName :: Module -> Name -> Name
-mangleDeclName mod name
-  | isExternalName name = name
-  | otherwise = mkExternalName (nameUnique name) (mangleModule mod) (nameOccName name) (nameSrcSpan name)
-
--- | Mangle the module name too to avoid conflicts
-mangleModule :: Module -> Module
-mangleModule mod = mkModule (moduleUnit mod) (mkModuleName $ "GHCIDEINTERNAL" ++ moduleNameString (moduleName mod))
-
-isGhcideModule :: Module -> Bool
-isGhcideModule mod = "GHCIDEINTERNAL" `isPrefixOf` (moduleNameString $ moduleName mod)
-
--- Is this a fake external name that we need to make into an internal name?
-isGhcideName :: Name -> Bool
-isGhcideName = isGhcideModule . nameModule
-
-tcTopIfaceBindings1 :: IORef TypeEnv -> [TopIfaceBinding IfaceId]
-          -> IfL [CoreBind]
-tcTopIfaceBindings1 ty_var ver_decls
-   = do
-     int <- mapM (traverse tcIfaceId) ver_decls
-     let all_ids = concatMap toList int
-     liftIO $ modifyIORef ty_var (flip extendTypeEnvList $ map AnId all_ids)
-     extendIfaceIdEnv all_ids $ mapM tc_iface_bindings int
-
-tcIfaceId :: IfaceId -> IfL Id
-tcIfaceId = fmap getIfaceId . tcIfaceDecl False <=< unmangle_decl_name
-  where
-    unmangle_decl_name ifid@IfaceId{ ifName = name }
-    -- Check if the name is mangled
-      | isGhcideName name = do
-        name' <- newIfaceName (mkVarOcc $ getOccString name)
-        pure $ ifid{ ifName = name' }
-      | otherwise = pure ifid
-    unmangle_decl_name _ifid = error "tcIfaceId: got non IfaceId: "
-    -- invariant: 'IfaceId' is always a 'IfaceId' constructor
-    getIfaceId (AnId identifier) = identifier
-    getIfaceId _                 = error "tcIfaceId: got non Id"
-
-tc_iface_bindings :: TopIfaceBinding Id -> IfL CoreBind
-tc_iface_bindings (TopIfaceNonRec v e) = do
-  e' <- tcIfaceExpr e
-  pure $ NonRec v e'
-tc_iface_bindings (TopIfaceRec vs) = do
-  vs' <- traverse (\(v, e) -> (v,) <$> tcIfaceExpr e) vs
-  pure $ Rec vs'
-
+    tcTopIfaceBindings type_var prepd_binding