Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit 0c73c2b

Browse files
Refactor CoreFile to use fat interface core type (#4700)
* Refactor CoreFile to use fat interface type * Update ghcide/src/Development/IDE/GHC/CoreFile.hs * Remove unused TopIfaceBinding type
1 parent f30030c commit 0c73c2b

File tree

1 file changed

+3
-97
lines changed

1 file changed

+3
-97
lines changed

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

Lines changed: 3 additions & 97 deletions
Original file line numberDiff line numberDiff line change
@@ -13,18 +13,14 @@ module Development.IDE.GHC.CoreFile
1313
) where
1414

1515
import Control.Monad
16-
import Control.Monad.IO.Class
17-
import Data.Foldable
1816
import Data.IORef
19-
import Data.List (isPrefixOf)
2017
import Data.Maybe
2118
import Development.IDE.GHC.Compat
2219
import qualified Development.IDE.GHC.Compat.Util as Util
2320
import GHC.Core
2421
import GHC.CoreToIface
2522
import GHC.Fingerprint
2623
import GHC.Iface.Binary
27-
import GHC.Iface.Env
2824
#if MIN_VERSION_ghc(9,11,0)
2925
import qualified GHC.Iface.Load as Iface
3026
#endif
@@ -42,38 +38,11 @@ initBinMemSize = 1024 * 1024
4238

4339
data CoreFile
4440
= CoreFile
45-
{ cf_bindings :: [TopIfaceBindingIfaceId]
41+
{ cf_bindings :: [IfaceBindingXIfaceMaybeRhsIfaceTopBndrInfo]
4642
-- ^ The actual core file bindings, deserialized lazily
4743
, cf_iface_hash :: !Fingerprint
4844
}
4945

50-
-- | Like IfaceBinding, but lets us serialize internal names as well
51-
data TopIfaceBinding v
52-
= TopIfaceNonRec v IfaceExpr
53-
| TopIfaceRec [(v, IfaceExpr)]
54-
deriving (Functor, Foldable, Traversable)
55-
56-
-- | GHC doesn't export 'tcIdDetails', 'tcIfaceInfo', or 'tcIfaceType',
57-
-- but it does export 'tcIfaceDecl'
58-
-- so we use `IfaceDecl` as a container for all of these
59-
-- invariant: 'IfaceId' is always a 'IfaceId' constructor
60-
type IfaceId = IfaceDecl
61-
62-
instance Binary (TopIfaceBinding IfaceId) where
63-
put_ bh (TopIfaceNonRec d e) = do
64-
putByte bh 0
65-
put_ bh d
66-
put_ bh e
67-
put_ bh (TopIfaceRec vs) = do
68-
putByte bh 1
69-
put_ bh vs
70-
get bh = do
71-
t <- getByte bh
72-
case t of
73-
0 -> TopIfaceNonRec <$> get bh <*> get bh
74-
1 -> TopIfaceRec <$> get bh
75-
_ -> error "Binary TopIfaceBinding"
76-
7746
instance Binary CoreFile where
7847
put_ bh (CoreFile core fp) = lazyPut bh core >> put_ bh fp
7948
get bh = CoreFile <$> lazyGet bh <*> get bh
@@ -118,7 +87,7 @@ codeGutsToCoreFile
11887
-> CgGuts
11988
-> CoreFile
12089
-- In GHC 9.6, implicit binds are tidied and part of core binds
121-
codeGutsToCoreFile hash CgGuts{..} = CoreFile (map (toIfaceTopBind1 cg_module) cg_binds) hash
90+
codeGutsToCoreFile hash CgGuts{..} = CoreFile (map toIfaceTopBind cg_binds) hash
12291

12392
getImplicitBinds :: TyCon -> [CoreBind]
12493
getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc
@@ -142,70 +111,7 @@ get_defn identifier = NonRec identifier templ
142111
Nothing -> error "get_dfn: no unfolding template"
143112
Just x -> x
144113

145-
toIfaceTopBndr1 :: Module -> Id -> IfaceId
146-
toIfaceTopBndr1 mod identifier
147-
= IfaceId (mangleDeclName mod $ getName identifier)
148-
(toIfaceType (idType identifier))
149-
(toIfaceIdDetails (idDetails identifier))
150-
(toIfaceIdInfo (idInfo identifier))
151-
152-
toIfaceTopBind1 :: Module -> Bind Id -> TopIfaceBinding IfaceId
153-
toIfaceTopBind1 mod (NonRec b r) = TopIfaceNonRec (toIfaceTopBndr1 mod b) (toIfaceExpr r)
154-
toIfaceTopBind1 mod (Rec prs) = TopIfaceRec [(toIfaceTopBndr1 mod b, toIfaceExpr r) | (b,r) <- prs]
155-
156114
typecheckCoreFile :: Module -> IORef TypeEnv -> CoreFile -> IfG CoreProgram
157115
typecheckCoreFile this_mod type_var (CoreFile prepd_binding _) =
158116
initIfaceLcl this_mod (text "typecheckCoreFile") NotBoot $ do
159-
tcTopIfaceBindings1 type_var prepd_binding
160-
161-
-- | Internal names can't be serialized, so we mange them
162-
-- to an external name and restore at deserialization time
163-
-- This is necessary because we rely on stuffing TopIfaceBindings into
164-
-- a IfaceId because we don't have access to 'tcIfaceType' etc..
165-
mangleDeclName :: Module -> Name -> Name
166-
mangleDeclName mod name
167-
| isExternalName name = name
168-
| otherwise = mkExternalName (nameUnique name) (mangleModule mod) (nameOccName name) (nameSrcSpan name)
169-
170-
-- | Mangle the module name too to avoid conflicts
171-
mangleModule :: Module -> Module
172-
mangleModule mod = mkModule (moduleUnit mod) (mkModuleName $ "GHCIDEINTERNAL" ++ moduleNameString (moduleName mod))
173-
174-
isGhcideModule :: Module -> Bool
175-
isGhcideModule mod = "GHCIDEINTERNAL" `isPrefixOf` (moduleNameString $ moduleName mod)
176-
177-
-- Is this a fake external name that we need to make into an internal name?
178-
isGhcideName :: Name -> Bool
179-
isGhcideName = isGhcideModule . nameModule
180-
181-
tcTopIfaceBindings1 :: IORef TypeEnv -> [TopIfaceBinding IfaceId]
182-
-> IfL [CoreBind]
183-
tcTopIfaceBindings1 ty_var ver_decls
184-
= do
185-
int <- mapM (traverse tcIfaceId) ver_decls
186-
let all_ids = concatMap toList int
187-
liftIO $ modifyIORef ty_var (flip extendTypeEnvList $ map AnId all_ids)
188-
extendIfaceIdEnv all_ids $ mapM tc_iface_bindings int
189-
190-
tcIfaceId :: IfaceId -> IfL Id
191-
tcIfaceId = fmap getIfaceId . tcIfaceDecl False <=< unmangle_decl_name
192-
where
193-
unmangle_decl_name ifid@IfaceId{ ifName = name }
194-
-- Check if the name is mangled
195-
| isGhcideName name = do
196-
name' <- newIfaceName (mkVarOcc $ getOccString name)
197-
pure $ ifid{ ifName = name' }
198-
| otherwise = pure ifid
199-
unmangle_decl_name _ifid = error "tcIfaceId: got non IfaceId: "
200-
-- invariant: 'IfaceId' is always a 'IfaceId' constructor
201-
getIfaceId (AnId identifier) = identifier
202-
getIfaceId _ = error "tcIfaceId: got non Id"
203-
204-
tc_iface_bindings :: TopIfaceBinding Id -> IfL CoreBind
205-
tc_iface_bindings (TopIfaceNonRec v e) = do
206-
e' <- tcIfaceExpr e
207-
pure $ NonRec v e'
208-
tc_iface_bindings (TopIfaceRec vs) = do
209-
vs' <- traverse (\(v, e) -> (v,) <$> tcIfaceExpr e) vs
210-
pure $ Rec vs'
211-
117+
tcTopIfaceBindings type_var prepd_binding

0 commit comments

Comments
(0)

AltStyle によって変換されたページ (->オリジナル) /