{-# OPTIONS_GHC -Wno-missing-fields #-}
{-# LANGUAGE CPP #-}
module Development.IDE.GHC.Util(
lookupPackageConfig,
modifyDynFlags,
fakeDynFlags,
prettyPrint,
runGhcEnv,
textToStringBuffer,
moduleImportPaths,
HscEnvEq, hscEnv, newHscEnvEq
) where
import Config
import Data.List.Extra
#if __GLASGOW_HASKELL__ >= 806
import Fingerprint
#endif
import GHC
import GhcMonad
import GhcPlugins hiding (Unique)
import Data.IORef
import Control.Exception
import FileCleanup
import Platform
import Data.Unique
import Development.Shake.Classes
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'
-- | An HscEnv with equality.
data HscEnvEq = HscEnvEq Unique HscEnv
hscEnv :: HscEnvEq -> HscEnv
hscEnv (HscEnvEq _ x) = x
newHscEnvEq :: HscEnv -> IO HscEnvEq
newHscEnvEq e = do u <- newUnique; return $ HscEnvEq u e
instance Show HscEnvEq where
show (HscEnvEq a _) = "HscEnvEq " ++ show (hashUnique a)
instance Eq HscEnvEq where
HscEnvEq a _ == HscEnvEq b _ = a == b
instance NFData HscEnvEq where
rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` ()