{-# LANGUAGE CPP               #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards   #-}

-- | CoreFiles let us serialize Core to a file in order to later recover it
-- without reparsing or retypechecking
module Development.IDE.GHC.CoreFile
  ( CoreFile(..)
  , codeGutsToCoreFile
  , typecheckCoreFile
  , readBinCoreFile
  , writeBinCoreFile
  , getImplicitBinds
  , occNamePrefixes) where

import           Control.Monad
import           Control.Monad.IO.Class
import           Data.Foldable
import           Data.IORef
import           Data.List                       (isPrefixOf)
import           Data.Maybe
import qualified Data.Text                       as T
import           Development.IDE.GHC.Compat
import qualified Development.IDE.GHC.Compat.Util as Util
import           GHC.Fingerprint
import           Prelude                         hiding (mod)

-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]

import           GHC.Core
import           GHC.CoreToIface
import           GHC.Iface.Binary
import           GHC.Iface.Env
import           GHC.Iface.Recomp.Binary         (fingerprintBinMem)
import           GHC.IfaceToCore
import           GHC.Types.Id.Make
import           GHC.Utils.Binary


import           GHC.Types.TypeEnv


-- | Initial ram buffer to allocate for writing interface files
initBinMemSize :: Int
initBinMemSize :: Int
initBinMemSize = Int
1024 forall a. Num a => a -> a -> a
* Int
1024

data CoreFile
  = CoreFile
  { CoreFile -> [TopIfaceBinding IfaceId]
cf_bindings   :: [TopIfaceBinding IfaceId]
  -- ^ The actual core file bindings, deserialized lazily
  , CoreFile -> Fingerprint
cf_iface_hash :: !Fingerprint
  }

-- | Like IfaceBinding, but lets us serialize internal names as well
data TopIfaceBinding v
  = TopIfaceNonRec v IfaceExpr
  | TopIfaceRec    [(v, IfaceExpr)]
  deriving (forall a b. a -> TopIfaceBinding b -> TopIfaceBinding a
forall a b. (a -> b) -> TopIfaceBinding a -> TopIfaceBinding b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> TopIfaceBinding b -> TopIfaceBinding a
$c<$ :: forall a b. a -> TopIfaceBinding b -> TopIfaceBinding a
fmap :: forall a b. (a -> b) -> TopIfaceBinding a -> TopIfaceBinding b
$cfmap :: forall a b. (a -> b) -> TopIfaceBinding a -> TopIfaceBinding b
Functor, forall a. Eq a => a -> TopIfaceBinding a -> Bool
forall a. Num a => TopIfaceBinding a -> a
forall a. Ord a => TopIfaceBinding a -> a
forall m. Monoid m => TopIfaceBinding m -> m
forall a. TopIfaceBinding a -> Bool
forall a. TopIfaceBinding a -> Int
forall a. TopIfaceBinding a -> [a]
forall a. (a -> a -> a) -> TopIfaceBinding a -> a
forall m a. Monoid m => (a -> m) -> TopIfaceBinding a -> m
forall b a. (b -> a -> b) -> b -> TopIfaceBinding a -> b
forall a b. (a -> b -> b) -> b -> TopIfaceBinding a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => TopIfaceBinding a -> a
$cproduct :: forall a. Num a => TopIfaceBinding a -> a
sum :: forall a. Num a => TopIfaceBinding a -> a
$csum :: forall a. Num a => TopIfaceBinding a -> a
minimum :: forall a. Ord a => TopIfaceBinding a -> a
$cminimum :: forall a. Ord a => TopIfaceBinding a -> a
maximum :: forall a. Ord a => TopIfaceBinding a -> a
$cmaximum :: forall a. Ord a => TopIfaceBinding a -> a
elem :: forall a. Eq a => a -> TopIfaceBinding a -> Bool
$celem :: forall a. Eq a => a -> TopIfaceBinding a -> Bool
length :: forall a. TopIfaceBinding a -> Int
$clength :: forall a. TopIfaceBinding a -> Int
null :: forall a. TopIfaceBinding a -> Bool
$cnull :: forall a. TopIfaceBinding a -> Bool
toList :: forall a. TopIfaceBinding a -> [a]
$ctoList :: forall a. TopIfaceBinding a -> [a]
foldl1 :: forall a. (a -> a -> a) -> TopIfaceBinding a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> TopIfaceBinding a -> a
foldr1 :: forall a. (a -> a -> a) -> TopIfaceBinding a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> TopIfaceBinding a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> TopIfaceBinding a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> TopIfaceBinding a -> b
foldl :: forall b a. (b -> a -> b) -> b -> TopIfaceBinding a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> TopIfaceBinding a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> TopIfaceBinding a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> TopIfaceBinding a -> b
foldr :: forall a b. (a -> b -> b) -> b -> TopIfaceBinding a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> TopIfaceBinding a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> TopIfaceBinding a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> TopIfaceBinding a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> TopIfaceBinding a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> TopIfaceBinding a -> m
fold :: forall m. Monoid m => TopIfaceBinding m -> m
$cfold :: forall m. Monoid m => TopIfaceBinding m -> m
Foldable, Functor TopIfaceBinding
Foldable TopIfaceBinding
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
TopIfaceBinding (m a) -> m (TopIfaceBinding a)
forall (f :: * -> *) a.
Applicative f =>
TopIfaceBinding (f a) -> f (TopIfaceBinding a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> TopIfaceBinding a -> m (TopIfaceBinding b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TopIfaceBinding a -> f (TopIfaceBinding b)
sequence :: forall (m :: * -> *) a.
Monad m =>
TopIfaceBinding (m a) -> m (TopIfaceBinding a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
TopIfaceBinding (m a) -> m (TopIfaceBinding a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> TopIfaceBinding a -> m (TopIfaceBinding b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> TopIfaceBinding a -> m (TopIfaceBinding b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
TopIfaceBinding (f a) -> f (TopIfaceBinding a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
TopIfaceBinding (f a) -> f (TopIfaceBinding a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TopIfaceBinding a -> f (TopIfaceBinding b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TopIfaceBinding a -> f (TopIfaceBinding b)
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_ :: BinHandle -> TopIfaceBinding IfaceId -> IO ()
put_ BinHandle
bh (TopIfaceNonRec IfaceId
d IfaceExpr
e) = do
    BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0
    forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh IfaceId
d
    forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh IfaceExpr
e
  put_ BinHandle
bh (TopIfaceRec [(IfaceId, IfaceExpr)]
vs) = do
    BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
    forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [(IfaceId, IfaceExpr)]
vs
  get :: BinHandle -> IO (TopIfaceBinding IfaceId)
get BinHandle
bh = do
    Word8
t <- BinHandle -> IO Word8
getByte BinHandle
bh
    case Word8
t of
      Word8
0 -> forall v. v -> IfaceExpr -> TopIfaceBinding v
TopIfaceNonRec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Binary a => BinHandle -> IO a
get BinHandle
bh forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
      Word8
1 -> forall v. [(v, IfaceExpr)] -> TopIfaceBinding v
TopIfaceRec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
      Word8
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"Binary TopIfaceBinding"

instance Binary CoreFile where
  put_ :: BinHandle -> CoreFile -> IO ()
put_ BinHandle
bh (CoreFile [TopIfaceBinding IfaceId]
core Fingerprint
fp) = forall a. Binary a => BinHandle -> a -> IO ()
lazyPut BinHandle
bh [TopIfaceBinding IfaceId]
core forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Fingerprint
fp
  get :: BinHandle -> IO CoreFile
get BinHandle
bh = [TopIfaceBinding IfaceId] -> Fingerprint -> CoreFile
CoreFile forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Binary a => BinHandle -> IO a
lazyGet BinHandle
bh forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Binary a => BinHandle -> IO a
get BinHandle
bh

readBinCoreFile
  :: NameCacheUpdater
  -> FilePath
  -> IO (CoreFile, Fingerprint)
readBinCoreFile :: NameCacheUpdater -> [Char] -> IO (CoreFile, Fingerprint)
readBinCoreFile NameCacheUpdater
name_cache [Char]
fat_hi_path = do
    BinHandle
bh <- [Char] -> IO BinHandle
readBinMem [Char]
fat_hi_path
    CoreFile
file <- forall a. Binary a => NameCacheUpdater -> BinHandle -> IO a
getWithUserData NameCacheUpdater
name_cache BinHandle
bh
    !Fingerprint
fp <- [Char] -> IO Fingerprint
Util.getFileHash [Char]
fat_hi_path
    forall (m :: * -> *) a. Monad m => a -> m a
return (CoreFile
file, Fingerprint
fp)

-- | Write a core file
writeBinCoreFile :: FilePath -> CoreFile -> IO Fingerprint
writeBinCoreFile :: [Char] -> CoreFile -> IO Fingerprint
writeBinCoreFile [Char]
core_path CoreFile
fat_iface = do
    BinHandle
bh <- Int -> IO BinHandle
openBinMem Int
initBinMemSize

    let quietTrace :: TraceBinIFace
quietTrace =
          TraceBinIFace
QuietBinIFace

    forall a. Binary a => TraceBinIFace -> BinHandle -> a -> IO ()
putWithUserData TraceBinIFace
quietTrace BinHandle
bh CoreFile
fat_iface

    -- And send the result to the file
    BinHandle -> [Char] -> IO ()
writeBinMem BinHandle
bh [Char]
core_path

    !Fingerprint
fp <- BinHandle -> IO Fingerprint
fingerprintBinMem BinHandle
bh
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Fingerprint
fp

-- Implicit binds aren't tidied, so we can't serialise them.
-- This isn't a problem however since we can regenerate them from the
-- original ModIface
codeGutsToCoreFile
  :: Fingerprint -- ^ Hash of the interface this was generated from
  -> CgGuts
  -> CoreFile
#if MIN_VERSION_ghc(9,5,0)
-- In GHC 9.6, implicit binds are tidied and part of core binds
codeGutsToCoreFile hash CgGuts{..} = CoreFile (map (toIfaceTopBind1 cg_module) cg_binds) hash
#else
codeGutsToCoreFile :: Fingerprint -> CgGuts -> CoreFile
codeGutsToCoreFile Fingerprint
hash CgGuts{[(ForeignSrcLang, [Char])]
[SptEntry]
CoreProgram
[TyCon]
[UnitId]
Maybe ModBreaks
ForeignStubs
Module
HpcInfo
cg_binds :: CgGuts -> CoreProgram
cg_dep_pkgs :: CgGuts -> [UnitId]
cg_foreign :: CgGuts -> ForeignStubs
cg_foreign_files :: CgGuts -> [(ForeignSrcLang, [Char])]
cg_hpc_info :: CgGuts -> HpcInfo
cg_modBreaks :: CgGuts -> Maybe ModBreaks
cg_module :: CgGuts -> Module
cg_spt_entries :: CgGuts -> [SptEntry]
cg_tycons :: CgGuts -> [TyCon]
cg_spt_entries :: [SptEntry]
cg_modBreaks :: Maybe ModBreaks
cg_hpc_info :: HpcInfo
cg_dep_pkgs :: [UnitId]
cg_foreign_files :: [(ForeignSrcLang, [Char])]
cg_foreign :: ForeignStubs
cg_binds :: CoreProgram
cg_tycons :: [TyCon]
cg_module :: Module
..} = [TopIfaceBinding IfaceId] -> Fingerprint -> CoreFile
CoreFile (forall a b. (a -> b) -> [a] -> [b]
map (Module -> Bind Id -> TopIfaceBinding IfaceId
toIfaceTopBind1 Module
cg_module) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter Bind Id -> Bool
isNotImplictBind CoreProgram
cg_binds) Fingerprint
hash

-- | Implicit binds can be generated from the interface and are not tidied,
-- so we must filter them out
isNotImplictBind :: CoreBind -> Bool
isNotImplictBind :: Bind Id -> Bool
isNotImplictBind Bind Id
bind = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Bool
isImplicitId) forall a b. (a -> b) -> a -> b
$ Bind Id -> [Id]
bindBindings Bind Id
bind

bindBindings :: CoreBind -> [Var]
bindBindings :: Bind Id -> [Id]
bindBindings (NonRec Id
b Expr Id
_) = [Id
b]
bindBindings (Rec [(Id, Expr Id)]
bnds)   = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Id, Expr Id)]
bnds
#endif

getImplicitBinds :: TyCon -> [CoreBind]
getImplicitBinds :: TyCon -> CoreProgram
getImplicitBinds TyCon
tc = CoreProgram
cls_binds forall a. [a] -> [a] -> [a]
++ TyCon -> CoreProgram
getTyConImplicitBinds TyCon
tc
  where
    cls_binds :: CoreProgram
cls_binds = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Class -> CoreProgram
getClassImplicitBinds (TyCon -> Maybe Class
tyConClass_maybe TyCon
tc)

getTyConImplicitBinds :: TyCon -> [CoreBind]
getTyConImplicitBinds :: TyCon -> CoreProgram
getTyConImplicitBinds TyCon
tc
  | TyCon -> Bool
isNewTyCon TyCon
tc = []  -- See Note [Compulsory newtype unfolding] in MkId
  | Bool
otherwise     = forall a b. (a -> b) -> [a] -> [b]
map Id -> Bind Id
get_defn (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DataCon -> Maybe Id
dataConWrapId_maybe (TyCon -> [DataCon]
tyConDataCons TyCon
tc))

getClassImplicitBinds :: Class -> [CoreBind]
getClassImplicitBinds :: Class -> CoreProgram
getClassImplicitBinds Class
cls
  = [ forall b. b -> Expr b -> Bind b
NonRec Id
op (Class -> Int -> Expr Id
mkDictSelRhs Class
cls Int
val_index)
    | (Id
op, Int
val_index) <- Class -> [Id]
classAllSelIds Class
cls forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
0..] ]

get_defn :: Id -> CoreBind
get_defn :: Id -> Bind Id
get_defn Id
identifier = forall b. b -> Expr b -> Bind b
NonRec Id
identifier (Unfolding -> Expr Id
unfoldingTemplate (Id -> Unfolding
realIdUnfolding Id
identifier))

toIfaceTopBndr1 :: Module -> Id -> IfaceId
toIfaceTopBndr1 :: Module -> Id -> IfaceId
toIfaceTopBndr1 Module
mod Id
identifier
  = IfaceTopBndr
-> IfaceType -> IfaceIdDetails -> IfaceIdInfo -> IfaceId
IfaceId (Module -> IfaceTopBndr -> IfaceTopBndr
mangleDeclName Module
mod forall a b. (a -> b) -> a -> b
$ forall a. NamedThing a => a -> IfaceTopBndr
getName Id
identifier)
            (Type -> IfaceType
toIfaceType (Id -> Type
idType Id
identifier))
            (IdDetails -> IfaceIdDetails
toIfaceIdDetails (Id -> IdDetails
idDetails Id
identifier))
            (IdInfo -> IfaceIdInfo
toIfaceIdInfo (HasDebugCallStack => Id -> IdInfo
idInfo Id
identifier))

toIfaceTopBind1 :: Module -> Bind Id -> TopIfaceBinding IfaceId
toIfaceTopBind1 :: Module -> Bind Id -> TopIfaceBinding IfaceId
toIfaceTopBind1 Module
mod (NonRec Id
b Expr Id
r) = forall v. v -> IfaceExpr -> TopIfaceBinding v
TopIfaceNonRec (Module -> Id -> IfaceId
toIfaceTopBndr1 Module
mod Id
b) (Expr Id -> IfaceExpr
toIfaceExpr Expr Id
r)
toIfaceTopBind1 Module
mod (Rec [(Id, Expr Id)]
prs)    = forall v. [(v, IfaceExpr)] -> TopIfaceBinding v
TopIfaceRec [(Module -> Id -> IfaceId
toIfaceTopBndr1 Module
mod Id
b, Expr Id -> IfaceExpr
toIfaceExpr Expr Id
r) | (Id
b,Expr Id
r) <- [(Id, Expr Id)]
prs]

typecheckCoreFile :: Module -> IORef TypeEnv -> CoreFile -> IfG CoreProgram
typecheckCoreFile :: Module -> IORef TypeEnv -> CoreFile -> IfG CoreProgram
typecheckCoreFile Module
this_mod IORef TypeEnv
type_var (CoreFile [TopIfaceBinding IfaceId]
prepd_binding Fingerprint
_) =
  forall a lcl.
Module -> SDoc -> IsBootInterface -> IfL a -> IfM lcl a
initIfaceLcl Module
this_mod ([Char] -> SDoc
text [Char]
"typecheckCoreFile") IsBootInterface
NotBoot forall a b. (a -> b) -> a -> b
$ do
    IORef TypeEnv -> [TopIfaceBinding IfaceId] -> IfL CoreProgram
tcTopIfaceBindings1 IORef TypeEnv
type_var [TopIfaceBinding IfaceId]
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 :: Module -> IfaceTopBndr -> IfaceTopBndr
mangleDeclName Module
mod IfaceTopBndr
name
  | IfaceTopBndr -> Bool
isExternalName IfaceTopBndr
name = IfaceTopBndr
name
  | Bool
otherwise = Unique -> Module -> OccName -> SrcSpan -> IfaceTopBndr
mkExternalName (IfaceTopBndr -> Unique
nameUnique IfaceTopBndr
name) (Module -> Module
mangleModule Module
mod) (IfaceTopBndr -> OccName
nameOccName IfaceTopBndr
name) (IfaceTopBndr -> SrcSpan
nameSrcSpan IfaceTopBndr
name)

-- | Mangle the module name too to avoid conflicts
mangleModule :: Module -> Module
mangleModule :: Module -> Module
mangleModule Module
mod = forall u. u -> ModuleName -> GenModule u
mkModule (forall unit. GenModule unit -> unit
moduleUnit Module
mod) ([Char] -> ModuleName
mkModuleName forall a b. (a -> b) -> a -> b
$ [Char]
"GHCIDEINTERNAL" forall a. [a] -> [a] -> [a]
++ ModuleName -> [Char]
moduleNameString (forall unit. GenModule unit -> ModuleName
moduleName Module
mod))

isGhcideModule :: Module -> Bool
isGhcideModule :: Module -> Bool
isGhcideModule Module
mod = [Char]
"GHCIDEINTERNAL" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` (ModuleName -> [Char]
moduleNameString forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> ModuleName
moduleName Module
mod)

-- Is this a fake external name that we need to make into an internal name?
isGhcideName :: Name -> Bool
isGhcideName :: IfaceTopBndr -> Bool
isGhcideName = Module -> Bool
isGhcideModule forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => IfaceTopBndr -> Module
nameModule

tcTopIfaceBindings1 :: IORef TypeEnv -> [TopIfaceBinding IfaceId]
          -> IfL [CoreBind]
tcTopIfaceBindings1 :: IORef TypeEnv -> [TopIfaceBinding IfaceId] -> IfL CoreProgram
tcTopIfaceBindings1 IORef TypeEnv
ty_var [TopIfaceBinding IfaceId]
ver_decls
   = do
     [TopIfaceBinding Id]
int <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ IfaceId -> IfL Id
tcIfaceId) [TopIfaceBinding IfaceId]
ver_decls
     let all_ids :: [Id]
all_ids = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [TopIfaceBinding Id]
int
     forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef TypeEnv
ty_var (forall a b c. (a -> b -> c) -> b -> a -> c
flip TypeEnv -> [TyThing] -> TypeEnv
extendTypeEnvList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Id -> TyThing
AnId [Id]
all_ids)
     forall a. [Id] -> IfL a -> IfL a
extendIfaceIdEnv [Id]
all_ids forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TopIfaceBinding Id -> IfL (Bind Id)
tc_iface_bindings [TopIfaceBinding Id]
int

tcIfaceId :: IfaceId -> IfL Id
tcIfaceId :: IfaceId -> IfL Id
tcIfaceId = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyThing -> Id
getIfaceId forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> IfaceId -> IfL TyThing
tcIfaceDecl Bool
False forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IfaceId -> IOEnv (Env IfGblEnv IfLclEnv) IfaceId
unmangle_decl_name
  where
    unmangle_decl_name :: IfaceId -> IOEnv (Env IfGblEnv IfLclEnv) IfaceId
unmangle_decl_name ifid :: IfaceId
ifid@IfaceId{ ifName :: IfaceId -> IfaceTopBndr
ifName = IfaceTopBndr
name }
    -- Check if the name is mangled
      | IfaceTopBndr -> Bool
isGhcideName IfaceTopBndr
name = do
        IfaceTopBndr
name' <- OccName -> IfL IfaceTopBndr
newIfaceName ([Char] -> OccName
mkVarOcc forall a b. (a -> b) -> a -> b
$ forall a. NamedThing a => a -> [Char]
getOccString IfaceTopBndr
name)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ IfaceId
ifid{ ifName :: IfaceTopBndr
ifName = IfaceTopBndr
name' }
      | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure IfaceId
ifid
    -- invariant: 'IfaceId' is always a 'IfaceId' constructor
    getIfaceId :: TyThing -> Id
getIfaceId (AnId Id
identifier) = Id
identifier
    getIfaceId TyThing
_                 = forall a. HasCallStack => [Char] -> a
error [Char]
"tcIfaceId: got non Id"

tc_iface_bindings :: TopIfaceBinding Id -> IfL CoreBind
tc_iface_bindings :: TopIfaceBinding Id -> IfL (Bind Id)
tc_iface_bindings (TopIfaceNonRec Id
v IfaceExpr
e) = do
  Expr Id
e' <- IfaceExpr -> IfL (Expr Id)
tcIfaceExpr IfaceExpr
e
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. b -> Expr b -> Bind b
NonRec Id
v Expr Id
e'
tc_iface_bindings (TopIfaceRec [(Id, IfaceExpr)]
vs) = do
  [(Id, Expr Id)]
vs' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Id
v, IfaceExpr
e) -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure Id
v forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IfaceExpr -> IfL (Expr Id)
tcIfaceExpr IfaceExpr
e) [(Id, IfaceExpr)]
vs
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. [(b, Expr b)] -> Bind b
Rec [(Id, Expr Id)]
vs'

-- | Prefixes that can occur in a GHC OccName
occNamePrefixes :: [T.Text]
occNamePrefixes :: [Text]
occNamePrefixes =
  [
    -- long ones
    Text
"$con2tag_"
  , Text
"$tag2con_"
  , Text
"$maxtag_"

  -- four chars
  , Text
"$sel:"
  , Text
"$tc'"

  -- three chars
  , Text
"$dm"
  , Text
"$co"
  , Text
"$tc"
  , Text
"$cp"
  , Text
"$fx"

  -- two chars
  , Text
"$W"
  , Text
"$w"
  , Text
"$m"
  , Text
"$b"
  , Text
"$c"
  , Text
"$d"
  , Text
"$i"
  , Text
"$s"
  , Text
"$f"
  , Text
"$r"
  , Text
"C:"
  , Text
"N:"
  , Text
"D:"
  , Text
"$p"
  , Text
"$L"
  , Text
"$f"
  , Text
"$t"
  , Text
"$c"
  , Text
"$m"
  ]