hsdev-0.3.4.0: src/HsDev/Tools/Ghc/Compat.hs

{-# LANGUAGE CPP, PackageImports #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module HsDev.Tools.Ghc.Compat (
	pkgDatabase,
	TcId,
	UnitId, InstalledUnitId, toInstalledUnitId,
	unitId, moduleUnitId, depends, getPackageDetails, patSynType, cleanupHandler, renderStyle,
	LogAction, setLogAction, addLogAction,
	languages, flags,
	recSelParent, recSelCtors,
	getFixity,
	unqualStyle,
	exposedModuleName,
	exprType,
	modSummaries,
	lookupModule,
	cleanTemps,
	mgArgTys, mgResTy,
	mkFunTy, mkFunTys
	) where

import qualified "ghc" BasicTypes
import qualified "ghc" DynFlags as GHC
import qualified "ghc" ErrUtils
import qualified "ghc" InteractiveEval as Eval
import qualified "ghc" GHC
import qualified "ghc" Module
import qualified "ghc" Name
import qualified "ghc" Packages as GHC
import qualified "ghc" PatSyn as GHC
import qualified "ghc" Pretty
import qualified "ghc" TyCoRep
import qualified "ghc" GhcPlugins as GHC
import "ghc" Outputable

#if __GLASGOW_HASKELL__ >= 810
import qualified "ghc-boot" GHC.Platform as GHC
#endif

#if __GLASGOW_HASKELL__ >= 804
import "ghc" FileCleanup (cleanTempDirs, cleanTempFiles)
#else
import "ghc" SysTools (cleanTempDirs, cleanTempFiles)
#endif

#if __GLASGOW_HASKELL__ >= 800
import Data.List (nub)
import qualified "ghc" IdInfo
import "ghc" TcRnDriver
#endif

#if __GLASGOW_HASKELL__ == 710
import "ghc" Exception (ExceptionMonad)
import Control.Monad.Reader
#endif

#if __GLASGOW_HASKELL__ <= 800
import qualified "ghc" GHC.PackageDb as GHC
#endif

pkgDatabase :: GHC.DynFlags -> Maybe [GHC.PackageConfig]
#if __GLASGOW_HASKELL__ >= 800
pkgDatabase = fmap (nub . concatMap snd) . GHC.pkgDatabase
#elif __GLASGOW_HASKELL__ == 710
pkgDatabase = GHC.pkgDatabase
#endif

#if __GLASGOW_HASKELL__ >= 804
type TcId = GHC.GhcTc
#else
type TcId = GHC.Id
#endif

#if __GLASGOW_HASKELL__ >= 800
type UnitId = Module.UnitId
#elif __GLASGOW_HASKELL__ == 710
type UnitId = Module.PackageKey
#endif

#if __GLASGOW_HASKELL__ >= 802
type InstalledUnitId = Module.InstalledUnitId
#else
type InstalledUnitId = UnitId
#endif

toInstalledUnitId :: UnitId -> InstalledUnitId
#if __GLASGOW_HASKELL__ >= 802
toInstalledUnitId = Module.toInstalledUnitId
#else
toInstalledUnitId = id
#endif

unitId :: GHC.PackageConfig -> InstalledUnitId
#if __GLASGOW_HASKELL__ >= 800
unitId = GHC.unitId
#elif __GLASGOW_HASKELL__ == 710
unitId = GHC.packageKey
#endif

moduleUnitId :: GHC.Module -> UnitId
#if __GLASGOW_HASKELL__ >= 800
moduleUnitId = GHC.moduleUnitId
#elif __GLASGOW_HASKELL__ == 710
moduleUnitId = GHC.modulePackageKey
#endif

depends :: GHC.DynFlags -> GHC.PackageConfig -> [InstalledUnitId]
#if __GLASGOW_HASKELL__ >= 800
depends _ = GHC.depends
#elif __GLASGOW_HASKELL__ == 710
depends df = map (GHC.resolveInstalledPackageId df) . GHC.depends
#endif

getPackageDetails :: GHC.DynFlags -> InstalledUnitId -> GHC.PackageConfig
#if __GLASGOW_HASKELL__ >= 802
getPackageDetails = GHC.getInstalledPackageDetails
#else
getPackageDetails = GHC.getPackageDetails
#endif

patSynType :: GHC.PatSyn -> GHC.Type
patSynType p = GHC.patSynInstResTy p (GHC.patSynArgs p)

#if __GLASGOW_HASKELL__ >= 800
cleanupHandler :: GHC.DynFlags -> m a -> m a
cleanupHandler _ = id
#elif __GLASGOW_HASKELL__ == 710
cleanupHandler :: (ExceptionMonad m) => GHC.DynFlags -> m a -> m a
cleanupHandler = GHC.defaultCleanupHandler
#endif

renderStyle :: Pretty.Mode -> Int -> Pretty.Doc -> String
#if __GLASGOW_HASKELL__ >= 800
renderStyle m cols = Pretty.renderStyle (Pretty.Style m cols 1.5)
#elif __GLASGOW_HASKELL__ == 710
renderStyle = Pretty.showDoc
#endif

type LogAction = GHC.DynFlags -> GHC.Severity -> GHC.SrcSpan -> ErrUtils.MsgDoc -> IO ()

setLogAction :: LogAction -> GHC.DynFlags -> GHC.DynFlags
setLogAction act fs = fs { GHC.log_action = act' } where
	act' :: GHC.LogAction
#if __GLASGOW_HASKELL__ >= 800
	act' df _ sev src _ msg = act df sev src msg
#elif __GLASGOW_HASKELL__ == 710
	act' df sev src _ msg = act df sev src msg
#endif

addLogAction :: LogAction -> GHC.DynFlags -> GHC.DynFlags
addLogAction act fs = fs { GHC.log_action = logBoth } where
	logBoth :: GHC.LogAction
#if __GLASGOW_HASKELL__ >= 800
	logBoth df wreason sev src style msg = do
		GHC.log_action fs df wreason sev src style msg
		GHC.log_action (setLogAction act fs) df wreason sev src style msg
#elif __GLASGOW_HASKELL__ == 710
	logBoth df sev src style ms = do
		GHC.log_action fs df sev src style msg
		GHC.log_action (setLogAction act fs) df sev src style msg
#endif

#if __GLASGOW_HASKELL__ == 710
instance (Monad m, GHC.HasDynFlags m) => GHC.HasDynFlags (ReaderT r m) where
	getDynFlags = lift GHC.getDynFlags
#endif

flags :: [String]
#if __GLASGOW_HASKELL__ >= 800
flags = concat [
	[option | (GHC.FlagSpec option _ _ _) <- GHC.fFlags],
	["warn-" ++ option | (GHC.FlagSpec option _ _ _) <- GHC.wWarningFlags],
	[option | (GHC.FlagSpec option _ _ _) <- GHC.fLangFlags]]
#elif __GLASGOW_HASKELL__ >= 710
flags = concat [
	[option | (GHC.FlagSpec option _ _ _) <- GHC.fFlags],
	[option | (GHC.FlagSpec option _ _ _) <- GHC.fWarningFlags],
	[option | (GHC.FlagSpec option _ _ _) <- GHC.fLangFlags]]
#elif __GLASGOW_HASKELL__ >= 704
flags = concat [
	[option | (option, _, _) <- GHC.fFlags],
	[option | (option, _, _) <- GHC.fWarningFlags],
	[option | (option, _, _) <- GHC.fLangFlags]]
#endif

#if __GLASGOW_HASKELL__ >= 800
recSelParent :: IdInfo.RecSelParent -> String
recSelParent (IdInfo.RecSelData p) = Name.getOccString p
recSelParent (IdInfo.RecSelPatSyn p) = Name.getOccString p
#else
recSelParent :: GHC.TyCon -> String
recSelParent = Name.getOccString
#endif

#if __GLASGOW_HASKELL__ >= 800
recSelCtors :: IdInfo.RecSelParent -> [String]
recSelCtors (IdInfo.RecSelData p) = map Name.getOccString (GHC.tyConDataCons p)
recSelCtors (IdInfo.RecSelPatSyn p) = [Name.getOccString p]
#else
recSelCtors :: GHC.TyCon -> [String]
recSelCtors = return . Name.getOccString
#endif

getFixity :: BasicTypes.Fixity -> (Int, BasicTypes.FixityDirection)
#if __GLASGOW_HASKELL__ >= 800
getFixity (BasicTypes.Fixity _ i d) = (i, d)
#else
getFixity (BasicTypes.Fixity i d) = (i, d)
#endif

languages :: [String]
#if __GLASGOW_HASKELL__ >= 810
languages = GHC.supportedLanguagesAndExtensions $ GHC.PlatformMini GHC.ArchUnknown GHC.OSUnknown
#else
languages = GHC.supportedLanguagesAndExtensions
#endif

unqualStyle :: GHC.DynFlags -> PprStyle
#if __GLASGOW_HASKELL__ >= 802
unqualStyle df = mkUserStyle df neverQualify AllTheWay
#else
unqualStyle _ = mkUserStyle neverQualify AllTheWay
#endif

#if __GLASGOW_HASKELL__ > 800
exposedModuleName :: (a, Maybe b) -> a
exposedModuleName = fst
#else
exposedModuleName :: GHC.ExposedModule unit mname -> mname
exposedModuleName = GHC.exposedName
#endif

exprType :: GHC.GhcMonad m => String -> m GHC.Type
#if __GLASGOW_HASKELL__ > 800
exprType = Eval.exprType TM_Inst
#else
exprType = Eval.exprType
#endif

modSummaries :: GHC.ModuleGraph -> [GHC.ModSummary]
#if __GLASGOW_HASKELL__ >= 804
modSummaries = GHC.mgModSummaries
#else
modSummaries = id
#endif

-- Lookup module everywhere
lookupModule :: GHC.DynFlags -> GHC.ModuleName -> [GHC.Module]
lookupModule d mn = case GHC.lookupModuleWithSuggestions d mn Nothing of
	GHC.LookupFound m' _ -> [m']
	GHC.LookupMultiple ms -> map fst ms
	GHC.LookupHidden ls rs -> map fst $ ls ++ rs
	GHC.LookupNotFound _ -> []
#if __GLASGOW_HASKELL__ >= 806
	GHC.LookupUnusable _ -> []
#endif

cleanTemps :: GHC.DynFlags -> IO ()
cleanTemps df = do
	cleanTempFiles df
	cleanTempDirs df

mgArgTys :: GHC.MatchGroup TcId (GHC.LHsExpr TcId) -> Maybe [GHC.Type]
#if __GLASGOW_HASKELL__ >= 806
mgArgTys (GHC.MG{GHC.mg_ext=ext}) = Just $ GHC.mg_arg_tys ext
mgArgTys _ = Nothing
#else
mgArgTys = Just . GHC.mg_arg_tys
#endif

mgResTy :: GHC.MatchGroup TcId (GHC.LHsExpr TcId) -> Maybe GHC.Type
#if __GLASGOW_HASKELL__ >= 806
mgResTy (GHC.MG{GHC.mg_ext=ext}) = Just $ GHC.mg_res_ty ext
mgResTy _ = Nothing
#else
mgResTy = Just . GHC.mg_res_ty
#endif

mkFunTy :: GHC.Type -> GHC.Type -> GHC.Type
#if __GLASGOW_HASKELL__ >= 810
mkFunTy = TyCoRep.mkVisFunTy
#else
mkFunTy = TyCoRep.mkFunTy
#endif

mkFunTys :: [GHC.Type] -> GHC.Type -> GHC.Type
#if __GLASGOW_HASKELL__ >= 810
mkFunTys = TyCoRep.mkVisFunTys
#else
mkFunTys = GHC.mkFunTys
#endif