{-# OPTIONS_GHC -Wno-missing-fields #-}
{-# LANGUAGE CPP #-}
module Development.IDE.GHC.Util(
lookupPackageConfig,
modifyDynFlags,
fakeDynFlags,
prettyPrint,
runGhcEnv,
textToStringBuffer,
moduleImportPaths
) where
import Config
import Data.List.Extra
#if __GLASGOW_HASKELL__ >= 806
import Fingerprint
#endif
import GHC
import GhcMonad
import GhcPlugins
import Data.IORef
import Control.Exception
import FileCleanup
import Platform
import qualified Data.Text as T
import StringBuffer
import System.FilePath
modifyDynFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m ()
modifyDynFlags f = do
newFlags <- f <$> getSessionDynFlags
modifySession $ \h ->
h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} }
lookupPackageConfig :: UnitId -> HscEnv -> Maybe PackageConfig
lookupPackageConfig unitId env =
lookupPackage' False pkgConfigMap unitId
where
pkgConfigMap =
getPackageConfigMap $ hsc_dflags env
textToStringBuffer :: T.Text -> StringBuffer
textToStringBuffer = stringToStringBuffer . T.unpack
prettyPrint :: Outputable a => a -> String
prettyPrint = showSDoc fakeDynFlags . ppr
runGhcEnv :: HscEnv -> Ghc a -> IO a
runGhcEnv env act = do
filesToClean <- newIORef emptyFilesToClean
dirsToClean <- newIORef mempty
let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean}
ref <- newIORef env{hsc_dflags=dflags}
unGhc act (Session ref) `finally` do
cleanTempFiles dflags
cleanTempDirs dflags
fakeDynFlags :: DynFlags
fakeDynFlags = defaultDynFlags settings mempty
where
settings = Settings
{ sTargetPlatform = platform
, sPlatformConstants = platformConstants
, sProgramName = "ghc"
, sProjectVersion = cProjectVersion
#if __GLASGOW_HASKELL__ >= 806
, sOpt_P_fingerprint = fingerprint0
#endif
}
platform = Platform
{ platformWordSize=8
, platformOS=OSUnknown
, platformUnregisterised=True
}
platformConstants = PlatformConstants
{ pc_DYNAMIC_BY_DEFAULT=False
, pc_WORD_SIZE=8
}
moduleImportPaths :: GHC.ParsedModule -> Maybe FilePath
moduleImportPaths pm
| rootModDir == "." = Just rootPathDir
| otherwise =
dropTrailingPathSeparator <$> stripSuffix (normalise rootModDir) (normalise rootPathDir)
where
ms = GHC.pm_mod_summary pm
file = GHC.ms_hspp_file ms
mod' = GHC.ms_mod ms
rootPathDir = takeDirectory file
rootModDir = takeDirectory . moduleNameSlashes . GHC.moduleName $ mod'