{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
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)
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]
, CoreFile -> Fingerprint
cf_iface_hash :: !Fingerprint
}
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)
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)
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
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
codeGutsToCoreFile
:: Fingerprint
-> CgGuts
-> CoreFile
#if MIN_VERSION_ghc(9,5,0)
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
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 = []
| 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
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)
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)
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 }
| 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: "
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'
occNamePrefixes :: [T.Text]
occNamePrefixes :: [Text]
occNamePrefixes =
[
Text
"$con2tag_"
, Text
"$tag2con_"
, Text
"$maxtag_"
, Text
"$sel:"
, Text
"$tc'"
, Text
"$dm"
, Text
"$co"
, Text
"$tc"
, Text
"$cp"
, Text
"$fx"
, 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"
]