{-# LANGUAGE CPP             #-}
{-# 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.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
import           GHC.Iface.Recomp.Binary         (fingerprintBinMem)
import           GHC.IfaceToCore
import           GHC.Types.Id.Make
import           GHC.Types.TypeEnv
import           GHC.Utils.Binary
import           Prelude                         hiding (mod)


-- | Initial ram buffer to allocate for writing interface files
initBinMemSize :: Int
initBinMemSize :: Int
initBinMemSize = Int
1024 Int -> Int -> Int
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 -> b) -> TopIfaceBinding a -> TopIfaceBinding b)
-> (forall a b. a -> TopIfaceBinding b -> TopIfaceBinding a)
-> Functor TopIfaceBinding
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
$cfmap :: forall a b. (a -> b) -> TopIfaceBinding a -> TopIfaceBinding b
fmap :: forall a b. (a -> b) -> TopIfaceBinding a -> TopIfaceBinding b
$c<$ :: forall a b. a -> TopIfaceBinding b -> TopIfaceBinding a
<$ :: forall a b. a -> TopIfaceBinding b -> TopIfaceBinding a
Functor, (forall m. Monoid m => TopIfaceBinding m -> m)
-> (forall m a. Monoid m => (a -> m) -> TopIfaceBinding a -> m)
-> (forall m a. Monoid m => (a -> m) -> TopIfaceBinding a -> m)
-> (forall a b. (a -> b -> b) -> b -> TopIfaceBinding a -> b)
-> (forall a b. (a -> b -> b) -> b -> TopIfaceBinding a -> b)
-> (forall b a. (b -> a -> b) -> b -> TopIfaceBinding a -> b)
-> (forall b a. (b -> a -> b) -> b -> TopIfaceBinding a -> b)
-> (forall a. (a -> a -> a) -> TopIfaceBinding a -> a)
-> (forall a. (a -> a -> a) -> TopIfaceBinding a -> a)
-> (forall a. TopIfaceBinding a -> [a])
-> (forall a. TopIfaceBinding a -> Bool)
-> (forall a. TopIfaceBinding a -> Int)
-> (forall a. Eq a => a -> TopIfaceBinding a -> Bool)
-> (forall a. Ord a => TopIfaceBinding a -> a)
-> (forall a. Ord a => TopIfaceBinding a -> a)
-> (forall a. Num a => TopIfaceBinding a -> a)
-> (forall a. Num a => TopIfaceBinding a -> a)
-> Foldable TopIfaceBinding
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
$cfold :: forall m. Monoid m => TopIfaceBinding m -> m
fold :: forall m. Monoid m => TopIfaceBinding m -> 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
foldMap' :: forall m a. Monoid m => (a -> m) -> TopIfaceBinding a -> m
$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
foldr' :: forall a b. (a -> b -> 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
foldl' :: forall b a. (b -> a -> b) -> b -> TopIfaceBinding a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> TopIfaceBinding a -> a
foldr1 :: forall a. (a -> a -> a) -> TopIfaceBinding a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> TopIfaceBinding a -> a
foldl1 :: forall a. (a -> a -> a) -> TopIfaceBinding a -> a
$ctoList :: forall a. TopIfaceBinding a -> [a]
toList :: forall a. TopIfaceBinding a -> [a]
$cnull :: forall a. TopIfaceBinding a -> Bool
null :: forall a. TopIfaceBinding a -> Bool
$clength :: forall a. TopIfaceBinding a -> Int
length :: forall a. TopIfaceBinding a -> Int
$celem :: forall a. Eq a => a -> TopIfaceBinding a -> Bool
elem :: forall a. Eq a => a -> TopIfaceBinding a -> Bool
$cmaximum :: forall a. Ord a => TopIfaceBinding a -> a
maximum :: forall a. Ord a => TopIfaceBinding a -> a
$cminimum :: forall a. Ord a => TopIfaceBinding a -> a
minimum :: forall a. Ord a => TopIfaceBinding a -> a
$csum :: forall a. Num a => TopIfaceBinding a -> a
sum :: forall a. Num a => TopIfaceBinding a -> a
$cproduct :: forall a. Num a => TopIfaceBinding a -> a
product :: forall a. Num a => TopIfaceBinding a -> a
Foldable, Functor TopIfaceBinding
Foldable TopIfaceBinding
(Functor TopIfaceBinding, Foldable TopIfaceBinding) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> TopIfaceBinding a -> f (TopIfaceBinding b))
-> (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 (m :: * -> *) a.
    Monad m =>
    TopIfaceBinding (m a) -> m (TopIfaceBinding a))
-> Traversable 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)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TopIfaceBinding a -> f (TopIfaceBinding b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TopIfaceBinding a -> f (TopIfaceBinding b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
TopIfaceBinding (f a) -> f (TopIfaceBinding a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
TopIfaceBinding (f a) -> f (TopIfaceBinding a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> TopIfaceBinding a -> m (TopIfaceBinding b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> TopIfaceBinding a -> m (TopIfaceBinding b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
TopIfaceBinding (m a) -> m (TopIfaceBinding a)
sequence :: forall (m :: * -> *) a.
Monad m =>
TopIfaceBinding (m a) -> m (TopIfaceBinding a)
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
    BinHandle -> IfaceId -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh IfaceId
d
    BinHandle -> IfaceExpr -> IO ()
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
    BinHandle -> [(IfaceId, IfaceExpr)] -> IO ()
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 -> IfaceId -> IfaceExpr -> TopIfaceBinding IfaceId
forall v. v -> IfaceExpr -> TopIfaceBinding v
TopIfaceNonRec (IfaceId -> IfaceExpr -> TopIfaceBinding IfaceId)
-> IO IfaceId -> IO (IfaceExpr -> TopIfaceBinding IfaceId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO IfaceId
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh IO (IfaceExpr -> TopIfaceBinding IfaceId)
-> IO IfaceExpr -> IO (TopIfaceBinding IfaceId)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO IfaceExpr
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
      Word8
1 -> [(IfaceId, IfaceExpr)] -> TopIfaceBinding IfaceId
forall v. [(v, IfaceExpr)] -> TopIfaceBinding v
TopIfaceRec ([(IfaceId, IfaceExpr)] -> TopIfaceBinding IfaceId)
-> IO [(IfaceId, IfaceExpr)] -> IO (TopIfaceBinding IfaceId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO [(IfaceId, IfaceExpr)]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
      Word8
_ -> [Char] -> IO (TopIfaceBinding IfaceId)
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) = BinHandle -> [TopIfaceBinding IfaceId] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
lazyPut BinHandle
bh [TopIfaceBinding IfaceId]
core IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> Fingerprint -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Fingerprint
fp
  get :: BinHandle -> IO CoreFile
get BinHandle
bh = [TopIfaceBinding IfaceId] -> Fingerprint -> CoreFile
CoreFile ([TopIfaceBinding IfaceId] -> Fingerprint -> CoreFile)
-> IO [TopIfaceBinding IfaceId] -> IO (Fingerprint -> CoreFile)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO [TopIfaceBinding IfaceId]
forall a. Binary a => BinHandle -> IO a
lazyGet BinHandle
bh IO (Fingerprint -> CoreFile) -> IO Fingerprint -> IO CoreFile
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO Fingerprint
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 <- NameCacheUpdater -> BinHandle -> IO CoreFile
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
    (CoreFile, Fingerprint) -> IO (CoreFile, Fingerprint)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreFile
file, Fingerprint
fp)

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

    let quietTrace :: TraceBinIFace
quietTrace =
          TraceBinIFace
QuietBinIFace

    TraceBinIFace -> BinHandle -> CoreFile -> IO ()
forall a. Binary a => TraceBinIFace -> BinHandle -> a -> IO ()
putWithUserData
      TraceBinIFace
quietTrace
#if MIN_VERSION_ghc(9,11,0)
      (Iface.flagsToIfCompression _dflags)
#endif
      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
    Fingerprint -> IO Fingerprint
forall a. a -> IO a
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 :: Fingerprint -> CgGuts -> CoreFile
codeGutsToCoreFile Fingerprint
hash CgGuts{[(ForeignSrcLang, [Char])]
[TyCon]
[CostCentre]
CoreProgram
[SptEntry]
Maybe ModBreaks
Set UnitId
Module
HpcInfo
ForeignStubs
cg_module :: Module
cg_tycons :: [TyCon]
cg_binds :: CoreProgram
cg_ccs :: [CostCentre]
cg_foreign :: ForeignStubs
cg_foreign_files :: [(ForeignSrcLang, [Char])]
cg_dep_pkgs :: Set UnitId
cg_hpc_info :: HpcInfo
cg_modBreaks :: Maybe ModBreaks
cg_spt_entries :: [SptEntry]
cg_module :: CgGuts -> Module
cg_tycons :: CgGuts -> [TyCon]
cg_binds :: CgGuts -> CoreProgram
cg_ccs :: CgGuts -> [CostCentre]
cg_foreign :: CgGuts -> ForeignStubs
cg_foreign_files :: CgGuts -> [(ForeignSrcLang, [Char])]
cg_dep_pkgs :: CgGuts -> Set UnitId
cg_hpc_info :: CgGuts -> HpcInfo
cg_modBreaks :: CgGuts -> Maybe ModBreaks
cg_spt_entries :: CgGuts -> [SptEntry]
..} = [TopIfaceBinding IfaceId] -> Fingerprint -> CoreFile
CoreFile ((Bind Id -> TopIfaceBinding IfaceId)
-> CoreProgram -> [TopIfaceBinding IfaceId]
forall a b. (a -> b) -> [a] -> [b]
map (Module -> Bind Id -> TopIfaceBinding IfaceId
toIfaceTopBind1 Module
cg_module) CoreProgram
cg_binds) Fingerprint
hash
#else
codeGutsToCoreFile hash CgGuts{..} = CoreFile (map (toIfaceTopBind1 cg_module) $ filter isNotImplictBind cg_binds) hash

-- | Implicit binds can be generated from the interface and are not tidied,
-- so we must filter them out
isNotImplictBind :: CoreBind -> Bool
isNotImplictBind bind = not . all isImplicitId $ bindBindings bind

bindBindings :: CoreBind -> [Var]
bindBindings (NonRec b _) = [b]
bindBindings (Rec bnds)   = map fst bnds
#endif

getImplicitBinds :: TyCon -> [CoreBind]
getImplicitBinds :: TyCon -> CoreProgram
getImplicitBinds TyCon
tc = CoreProgram
cls_binds CoreProgram -> CoreProgram -> CoreProgram
forall a. [a] -> [a] -> [a]
++ TyCon -> CoreProgram
getTyConImplicitBinds TyCon
tc
  where
    cls_binds :: CoreProgram
cls_binds = CoreProgram -> (Class -> CoreProgram) -> Maybe Class -> CoreProgram
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     = (Id -> Bind Id) -> [Id] -> CoreProgram
forall a b. (a -> b) -> [a] -> [b]
map Id -> Bind Id
get_defn ((DataCon -> Maybe Id) -> [DataCon] -> [Id]
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
  = [ Id -> Expr Id -> Bind Id
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 [Id] -> [Int] -> [(Id, Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
0..] ]

get_defn :: Id -> CoreBind
get_defn :: Id -> Bind Id
get_defn Id
identifier = Id -> Expr Id -> Bind Id
forall b. b -> Expr b -> Bind b
NonRec Id
identifier Expr Id
templ
  where
    templ :: Expr Id
templ = case Unfolding -> Maybe (Expr Id)
maybeUnfoldingTemplate (Id -> Unfolding
realIdUnfolding Id
identifier) of
              Maybe (Expr Id)
Nothing -> [Char] -> Expr Id
forall a. HasCallStack => [Char] -> a
error [Char]
"get_dfn: no unfolding template"
              Just Expr Id
x  -> Expr Id
x

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 (IfaceTopBndr -> IfaceTopBndr) -> IfaceTopBndr -> IfaceTopBndr
forall a b. (a -> b) -> a -> b
$ Id -> IfaceTopBndr
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 ((() :: Constraint) => Id -> IdInfo
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) = IfaceId -> IfaceExpr -> TopIfaceBinding IfaceId
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)    = [(IfaceId, IfaceExpr)] -> TopIfaceBinding IfaceId
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
_) =
  Module
-> SDoc -> IsBootInterface -> IfL CoreProgram -> IfG CoreProgram
forall a lcl.
Module -> SDoc -> IsBootInterface -> IfL a -> IfM lcl a
initIfaceLcl Module
this_mod ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"typecheckCoreFile") IsBootInterface
NotBoot (IfL CoreProgram -> IfG CoreProgram)
-> IfL CoreProgram -> IfG CoreProgram
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 = Unit -> ModuleName -> Module
forall u. u -> ModuleName -> GenModule u
mkModule (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod) ([Char] -> ModuleName
mkModuleName ([Char] -> ModuleName) -> [Char] -> ModuleName
forall a b. (a -> b) -> a -> b
$ [Char]
"GHCIDEINTERNAL" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ModuleName -> [Char]
moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod))

isGhcideModule :: Module -> Bool
isGhcideModule :: Module -> Bool
isGhcideModule Module
mod = [Char]
"GHCIDEINTERNAL" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` (ModuleName -> [Char]
moduleNameString (ModuleName -> [Char]) -> ModuleName -> [Char]
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
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 (Module -> Bool)
-> (IfaceTopBndr -> Module) -> IfaceTopBndr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() :: Constraint) => IfaceTopBndr -> Module
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 <- (TopIfaceBinding IfaceId
 -> IOEnv (Env IfGblEnv IfLclEnv) (TopIfaceBinding Id))
-> [TopIfaceBinding IfaceId]
-> IOEnv (Env IfGblEnv IfLclEnv) [TopIfaceBinding Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((IfaceId -> IOEnv (Env IfGblEnv IfLclEnv) Id)
-> TopIfaceBinding IfaceId
-> IOEnv (Env IfGblEnv IfLclEnv) (TopIfaceBinding Id)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TopIfaceBinding a -> f (TopIfaceBinding b)
traverse IfaceId -> IOEnv (Env IfGblEnv IfLclEnv) Id
tcIfaceId) [TopIfaceBinding IfaceId]
ver_decls
     let all_ids :: [Id]
all_ids = (TopIfaceBinding Id -> [Id]) -> [TopIfaceBinding Id] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TopIfaceBinding Id -> [Id]
forall a. TopIfaceBinding a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [TopIfaceBinding Id]
int
     IO () -> IOEnv (Env IfGblEnv IfLclEnv) ()
forall a. IO a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env IfGblEnv IfLclEnv) ())
-> IO () -> IOEnv (Env IfGblEnv IfLclEnv) ()
forall a b. (a -> b) -> a -> b
$ IORef TypeEnv -> (TypeEnv -> TypeEnv) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef TypeEnv
ty_var ((TypeEnv -> [TyThing] -> TypeEnv)
-> [TyThing] -> TypeEnv -> TypeEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip TypeEnv -> [TyThing] -> TypeEnv
extendTypeEnvList ([TyThing] -> TypeEnv -> TypeEnv)
-> [TyThing] -> TypeEnv -> TypeEnv
forall a b. (a -> b) -> a -> b
$ (Id -> TyThing) -> [Id] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map Id -> TyThing
AnId [Id]
all_ids)
     [Id] -> IfL CoreProgram -> IfL CoreProgram
forall a. [Id] -> IfL a -> IfL a
extendIfaceIdEnv [Id]
all_ids (IfL CoreProgram -> IfL CoreProgram)
-> IfL CoreProgram -> IfL CoreProgram
forall a b. (a -> b) -> a -> b
$ (TopIfaceBinding Id -> IOEnv (Env IfGblEnv IfLclEnv) (Bind Id))
-> [TopIfaceBinding Id] -> IfL CoreProgram
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TopIfaceBinding Id -> IOEnv (Env IfGblEnv IfLclEnv) (Bind Id)
tc_iface_bindings [TopIfaceBinding Id]
int

tcIfaceId :: IfaceId -> IfL Id
tcIfaceId :: IfaceId -> IOEnv (Env IfGblEnv IfLclEnv) Id
tcIfaceId = (TyThing -> Id)
-> IOEnv (Env IfGblEnv IfLclEnv) TyThing
-> IOEnv (Env IfGblEnv IfLclEnv) Id
forall a b.
(a -> b)
-> IOEnv (Env IfGblEnv IfLclEnv) a
-> IOEnv (Env IfGblEnv IfLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyThing -> Id
getIfaceId (IOEnv (Env IfGblEnv IfLclEnv) TyThing
 -> IOEnv (Env IfGblEnv IfLclEnv) Id)
-> (IfaceId -> IOEnv (Env IfGblEnv IfLclEnv) TyThing)
-> IfaceId
-> IOEnv (Env IfGblEnv IfLclEnv) Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> IfaceId -> IOEnv (Env IfGblEnv IfLclEnv) TyThing
tcIfaceDecl Bool
False (IfaceId -> IOEnv (Env IfGblEnv IfLclEnv) Id)
-> (IfaceId -> IOEnv (Env IfGblEnv IfLclEnv) IfaceId)
-> IfaceId
-> IOEnv (Env IfGblEnv IfLclEnv) Id
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 ([Char] -> OccName) -> [Char] -> OccName
forall a b. (a -> b) -> a -> b
$ IfaceTopBndr -> [Char]
forall a. NamedThing a => a -> [Char]
getOccString IfaceTopBndr
name)
        IfaceId -> IOEnv (Env IfGblEnv IfLclEnv) IfaceId
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IfaceId -> IOEnv (Env IfGblEnv IfLclEnv) IfaceId)
-> IfaceId -> IOEnv (Env IfGblEnv IfLclEnv) IfaceId
forall a b. (a -> b) -> a -> b
$ IfaceId
ifid{ ifName = name' }
      | Bool
otherwise = IfaceId -> IOEnv (Env IfGblEnv IfLclEnv) IfaceId
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IfaceId
ifid
    unmangle_decl_name IfaceId
_ifid = [Char] -> IOEnv (Env IfGblEnv IfLclEnv) IfaceId
forall a. HasCallStack => [Char] -> a
error [Char]
"tcIfaceId: got non IfaceId: "
    -- invariant: 'IfaceId' is always a 'IfaceId' constructor
    getIfaceId :: TyThing -> Id
getIfaceId (AnId Id
identifier) = Id
identifier
    getIfaceId TyThing
_                 = [Char] -> Id
forall a. HasCallStack => [Char] -> a
error [Char]
"tcIfaceId: got non Id"

tc_iface_bindings :: TopIfaceBinding Id -> IfL CoreBind
tc_iface_bindings :: TopIfaceBinding Id -> IOEnv (Env IfGblEnv IfLclEnv) (Bind Id)
tc_iface_bindings (TopIfaceNonRec Id
v IfaceExpr
e) = do
  Expr Id
e' <- IfaceExpr -> IfL (Expr Id)
tcIfaceExpr IfaceExpr
e
  Bind Id -> IOEnv (Env IfGblEnv IfLclEnv) (Bind Id)
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bind Id -> IOEnv (Env IfGblEnv IfLclEnv) (Bind Id))
-> Bind Id -> IOEnv (Env IfGblEnv IfLclEnv) (Bind Id)
forall a b. (a -> b) -> a -> b
$ Id -> Expr Id -> Bind Id
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' <- ((Id, IfaceExpr) -> IOEnv (Env IfGblEnv IfLclEnv) (Id, Expr Id))
-> [(Id, IfaceExpr)]
-> IOEnv (Env IfGblEnv IfLclEnv) [(Id, Expr Id)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\(Id
v, IfaceExpr
e) -> (Id
v,) (Expr Id -> (Id, Expr Id))
-> IfL (Expr Id) -> IOEnv (Env IfGblEnv IfLclEnv) (Id, Expr Id)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IfaceExpr -> IfL (Expr Id)
tcIfaceExpr IfaceExpr
e) [(Id, IfaceExpr)]
vs
  Bind Id -> IOEnv (Env IfGblEnv IfLclEnv) (Bind Id)
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bind Id -> IOEnv (Env IfGblEnv IfLclEnv) (Bind Id))
-> Bind Id -> IOEnv (Env IfGblEnv IfLclEnv) (Bind Id)
forall a b. (a -> b) -> a -> b
$ [(Id, Expr Id)] -> Bind Id
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"
  ]