{-# 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
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 :: 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

    TraceBinIFace -> BinHandle -> CoreFile -> IO ()
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
    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 (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 (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] -> IOEnv (Env IfGblEnv IfLclEnv) IfaceId)
-> [Char] -> IOEnv (Env IfGblEnv IfLclEnv) IfaceId
forall a b. (a -> b) -> a -> b
$ [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"
  ]