module GHC.Vacuum.GHC.Internal (
GhcApiCfg(..)
,defaultGhcApiConfig
,withGhcApiCfg
,dynFlagsOn,dynFlagsOff
,defaultEnv,newEnv,myRunGhc
,CabalPkg(..)
,CabalPkgId
,CabalPkgVersion
,CabalModuleId
,CabalModule(..)
,cabalModulePkgId
,cabalModulePkgVersion
,cabalModuleModuleId
,preludeCM
,collectCabalModules
,cabalPkgToModules
,dataConInfoPtrToNames
) where
import GHC.Paths(libdir)
import GHC.Vacuum.GHC.Imports as Imports
import Distribution.Package(PackageName(..))
import Data.Char
import Data.Word
import Data.List
import Data.IORef
import Data.Array.IArray
import Control.Monad
import Foreign
import Data.List
import Data.Map(Map)
import Data.Set(Set)
import qualified Data.Set as S
import qualified Data.Map as M
import Data.Monoid(Monoid(..))
data GhcApiCfg = GhcApiCfg
{ghcApiLibDir :: FilePath
,ghcApiImports :: [CabalPkg]
,ghcApiDynFlagsOn :: [DynFlag]
,ghcApiDynFlagsOff :: [DynFlag]}
deriving(Eq,Ord,Read,Show)
deriving instance Ord DynFlag
deriving instance Read DynFlag
defaultGhcApiConfig :: GhcApiCfg
defaultGhcApiConfig = GhcApiCfg
{ghcApiLibDir = GHC.Paths.libdir
,ghcApiImports
= CabalPkg "base" [] ["Prelude"]
: collectCabalModules
[CabalModule "base" [] "Prelude"
,CabalModule "base" [] "Prelude"]
,ghcApiDynFlagsOn
= [Opt_TemplateHaskell
,Opt_QuasiQuotes
,Opt_ViewPatterns
,Opt_RankNTypes
,Opt_KindSignatures
,Opt_UnicodeSyntax
,Opt_MonomorphismRestriction
,Opt_PatternGuards
,Opt_ParallelListComp
,Opt_ImplicitParams
,Opt_BangPatterns]
,ghcApiDynFlagsOff
= [Opt_PrintBindResult
,Opt_PrintBindContents
,Opt_PrintEvldWithShow]}
withGhcApiCfg :: GhcApiCfg
-> (FilePath -> DynFlags -> [Module] -> o)
-> (DynFlags -> o)
withGhcApiCfg (GhcApiCfg
libdir
imports
ons offs) k dflags = k libdir
((dynFlagsOn ons
. dynFlagsOff offs) dflags)
(concatMap cabalPkgToModules imports)
dynFlagsOn :: [DynFlag] -> (DynFlags -> DynFlags)
dynFlagsOn = flip (foldl dopt_set)
dynFlagsOff :: [DynFlag] -> (DynFlags -> DynFlags)
dynFlagsOff = flip (foldl dopt_unset)
defaultEnv :: IO HscEnv
defaultEnv = newEnv defaultGhcApiConfig
(Just defaultDynFlags)
newEnv :: GhcApiCfg -> Maybe DynFlags -> IO HscEnv
newEnv cfg dflagsM
= let
initEnv :: HscEnv -> [Module] -> IO HscEnv
initEnv hsc modules = do
let dflags = hsc_dflags hsc
(dflags', preload) <- initPackages
(dflags{ghcLink=LinkInMemory})
let hsc' = hsc{hsc_dflags = dflags'}
myRunGhc hsc' (setContext [] modules)
return hsc'
newEnv' :: Maybe FilePath -> DynFlags -> IO HscEnv
newEnv' mb_top_dir dflags00 = do
initStaticOpts
dflags0 <- initDynFlags dflags00
dflags <- initSysTools mb_top_dir dflags0
hsc <- newHscEnv dflags
return hsc
in withGhcApiCfg cfg (\libdir dflags modules ->
do env <- newEnv' (Just libdir) dflags
env' <- initEnv env modules
return env')
(maybe defaultDynFlags id dflagsM)
myRunGhc :: HscEnv -> Ghc a -> IO a
myRunGhc hsc_env ghc = do
wref <- newIORef emptyBag
ref <- newIORef hsc_env
unGhc ghc (Session ref wref)
data CabalPkg = CabalPkg
{cabalPkgPkg :: CabalPkgId
,cabalPkgVersion :: CabalPkgVersion
,cabalPkgModules :: [CabalModuleId]}
deriving(Eq,Ord,Read,Show)
type CabalPkgId = String
type CabalPkgVersion = [Int]
type CabalModuleId = String
data CabalModule = CabalModule
CabalPkgId
CabalPkgVersion
CabalModuleId
deriving(Eq,Ord,Read,Show)
cabalModulePkgId :: CabalModule -> CabalPkgId
cabalModulePkgVersion :: CabalModule -> CabalPkgVersion
cabalModuleModuleId :: CabalModule -> CabalModuleId
cabalModulePkgId (CabalModule x _ _) = x
cabalModulePkgVersion (CabalModule _ x _) = x
cabalModuleModuleId (CabalModule _ _ x) = x
preludeCM :: CabalModule
preludeCM = CabalModule "base" [] "Prelude"
collectCabalModules :: [CabalModule] -> [CabalPkg]
collectCabalModules
= let f &&& g = \x -> (f x, g x)
keyify = cabalModulePkgId
&&& cabalModulePkgVersion
elemify = S.singleton . cabalModuleModuleId
toPkg ((pid,v),ms) = CabalPkg pid v (S.toList ms)
collect (<>) f g = M.toList . flip foldl' mempty
(\m a -> M.insertWith' (<>) (f a)
(g a) m)
in fmap toPkg . collect S.union keyify elemify
cabalPkgToModules :: CabalPkg -> [Module]
cabalPkgToModules (CabalPkg
pid
ver
mods) = fmap (mkModule
(mkPackageId
(PackageIdentifier
(PackageName pid)
(Version ver [])))
. mkModuleName) mods
dataConInfoPtrToNames :: Ptr () -> IO (String, String, String)
dataConInfoPtrToNames x = do
readIORef justToInitGhc
initStaticOpts
theString <- do
let ptr = castPtr x :: Ptr StgInfoTable
conDescAddress <- getConDescAddress ptr
peekArray0 0 conDescAddress
let (pkg, mod, occ) = parse theString
pkgFS = mkFastStringByteList pkg
modFS = mkFastStringByteList mod
occFS = mkFastStringByteList occ
occName = mkOccNameFS dataName occFS
modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS)
return ((packageIdString . modulePackageId) modName
,(moduleNameString . moduleName) modName
,occNameString occName)
justToInitGhc :: IORef HscEnv
justToInitGhc = unsafePerformIO (newIORef =<< defaultEnv)
getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
getConDescAddress ptr
| ghciTablesNextToCode = do
offsetToString <- peek (ptr `plusPtr` (negate wORD_SIZE))
return $ (ptr `plusPtr` stdInfoTableSizeB)
`plusPtr` (fromIntegral (offsetToString :: StgWord))
| otherwise = peek . intPtrToPtr
. (+ fromIntegral
stdInfoTableSizeB)
. ptrToIntPtr $ ptr
parse :: [Word8] -> ([Word8], [Word8], [Word8])
parse input = if not . all (>0) . fmap length $ [pkg,mod,occ]
then (error . concat)
["getConDescAddress:parse:"
,"(not . all (>0) . fmap le"
,"ngth $ [pkg,mod,occ]"]
else (pkg, mod, occ)
where
(pkg, rest1) = break (== fromIntegral (ord ':')) input
(mod, occ)
= (concat $ intersperse [dot] $ reverse modWords, occWord)
where
(modWords, occWord) = if (length rest1 < 1)
then error "getConDescAddress:parse:length rest1 < 1"
else parseModOcc [] (tail rest1)
dot = fromIntegral (ord '.')
parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
parseModOcc acc str
= case break (== dot) str of
(top, []) -> (acc, top)
(top, _:bot) -> parseModOcc (top : acc) bot