diff --git a/ghcide/src/Development/IDE/GHC/CoreFile.hs b/ghcide/src/Development/IDE/GHC/CoreFile.hs index 99b7328770..8061f22058 100644 --- a/ghcide/src/Development/IDE/GHC/CoreFile.hs +++ b/ghcide/src/Development/IDE/GHC/CoreFile.hs @@ -13,10 +13,7 @@ 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 @@ -24,7 +21,6 @@ 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