From ddf50f5ba57666d1917177a21e7e1e336883305f Mon Sep 17 00:00:00 2001 From: fendor Date: Thu, 29 Jul 2021 13:43:31 +0200 Subject: [PATCH] Add compatbility for GHC 9.0 and 9.2 (#300) * Make hie-bios compile with GHC-HEAD * Adapt hie-bios to compile with GHC HEAD * Add allow-newer to get a build plan * Bump up ghc upper bound * Update ghc head to 9.0 * Use ghc-api-compat head * Adjust some defs to 9.0.1 * Add ghc-api-compat to exe component * Remove updated libraries * Fix some definitions * Add compatibility for GHC 9.2 Co-authored-by: jneira (cherry picked from commit 3703788b30b08435b4fd7d7c3ffceaa16a8b6b8f) --- .github/workflows/haskell.yml | 2 +- exe/Main.hs | 5 +- hie-bios.cabal | 4 +- hie.yaml.back | 10 + src/HIE/Bios/Cradle.hs | 4 +- src/HIE/Bios/Environment.hs | 149 +++-------- src/HIE/Bios/Ghc/Api.hs | 17 +- src/HIE/Bios/Ghc/Check.hs | 15 +- src/HIE/Bios/Ghc/Doc.hs | 21 +- src/HIE/Bios/Ghc/Gap.hs | 463 ++++++++++++++++++++++++++++++---- src/HIE/Bios/Ghc/Load.hs | 58 ++--- src/HIE/Bios/Ghc/Logger.hs | 94 +++++-- src/HIE/Bios/Types.hs | 2 +- tests/BiosTests.hs | 5 +- 14 files changed, 609 insertions(+), 240 deletions(-) create mode 100644 hie.yaml.back diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 20ddff88c..16489912d 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -8,7 +8,7 @@ jobs: strategy: fail-fast: false matrix: - ghc: ['8.10.1', '8.8.3', '8.6.5', '8.4.4'] + ghc: ['9.0.1', '8.10.4', '8.8.4', '8.6.5', '8.4.4'] os: [ubuntu-latest, macOS-latest, windows-latest] exclude: - os: windows-latest diff --git a/exe/Main.hs b/exe/Main.hs index c46a1bda6..860b0ab90 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -2,8 +2,6 @@ module Main where -import Config (cProjectVersion) - import Control.Monad ( forM ) import Data.Version (showVersion) import Options.Applicative @@ -13,13 +11,14 @@ import System.FilePath( () ) import HIE.Bios import HIE.Bios.Ghc.Check +import HIE.Bios.Ghc.Gap as Gap import HIE.Bios.Internal.Debug import Paths_hie_bios ---------------------------------------------------------------- progVersion :: String -progVersion = "hie-bios version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n" +progVersion = "hie-bios version " ++ showVersion version ++ " compiled by GHC " ++ Gap.ghcVersion ++ "\n" data Command = Check { checkTargetFiles :: [FilePath] } diff --git a/hie-bios.cabal b/hie-bios.cabal index 8c298d558..27f4d5d24 100644 --- a/hie-bios.cabal +++ b/hie-bios.cabal @@ -150,14 +150,16 @@ Library base16-bytestring >= 0.1.1 && < 1.1, bytestring >= 0.10.8 && < 0.12, deepseq >= 1.4.3 && < 1.5, + exceptions ^>= 0.10, containers >= 0.5.10 && < 0.7, cryptohash-sha1 >= 0.11.100 && < 0.12, directory >= 1.3.0 && < 1.4, filepath >= 1.4.1 && < 1.5, time >= 1.8.0 && < 1.12, extra >= 1.6.14 && < 1.8, + exceptions, process >= 1.6.1 && < 1.7, - ghc >= 8.4.1 && < 8.11, + ghc >= 8.4.1 && < 9.3, transformers >= 0.5.2 && < 0.6, temporary >= 1.2 && < 1.4, text >= 1.2.3 && < 1.3, diff --git a/hie.yaml.back b/hie.yaml.back new file mode 100644 index 000000000..3a0e7c90f --- /dev/null +++ b/hie.yaml.back @@ -0,0 +1,10 @@ +cradle: + cabal: + - path: "./src" + component: "lib:hie-bios" + - path: "./tests/BiosTests.hs" + component: "test:bios-tests" + - path: "./tests/ParserTests.hs" + component: "test:parser-tests" + - path: "./exe" + component: "exe:hie-bios" diff --git a/src/HIE/Bios/Cradle.hs b/src/HIE/Bios/Cradle.hs index 2a70c5528..55734ef55 100644 --- a/src/HIE/Bios/Cradle.hs +++ b/src/HIE/Bios/Cradle.hs @@ -34,6 +34,7 @@ import HIE.Bios.Types hiding (ActionName(..)) import qualified HIE.Bios.Types as Types import HIE.Bios.Config import HIE.Bios.Environment (getCacheDir) +import qualified HIE.Bios.Ghc.Gap as Gap import System.Directory hiding (findFile) import Control.Monad.Trans.Cont import Control.Monad.Trans.Maybe @@ -61,7 +62,6 @@ import qualified Data.Text as T import qualified Data.HashMap.Strict as Map import Data.Maybe (fromMaybe, maybeToList) import GHC.Fingerprint (fingerprintString) -import DynFlags (dynamicGhc) hie_bios_output :: String hie_bios_output = "HIE_BIOS_OUTPUT" @@ -196,7 +196,7 @@ configFileName = "hie.yaml" -- because unlike the case of using build tools, which means '-dynamic' can be set via -- '.cabal' or 'package.yaml', users have to create an explicit hie.yaml to pass this flag. argDynamic :: [String] -argDynamic = ["-dynamic" | dynamicGhc] +argDynamic = ["-dynamic" | Gap.hostIsDynamic ] --------------------------------------------------------------- diff --git a/src/HIE/Bios/Environment.hs b/src/HIE/Bios/Environment.hs index 8b8c70271..e106c8e80 100644 --- a/src/HIE/Bios/Environment.hs +++ b/src/HIE/Bios/Environment.hs @@ -1,15 +1,12 @@ {-# LANGUAGE RecordWildCards, CPP #-} module HIE.Bios.Environment (initSession, getRuntimeGhcLibDir, getRuntimeGhcVersion, makeDynFlagsAbsolute, makeTargetsAbsolute, getCacheDir, addCmdOpts) where -import CoreMonad (liftIO) import GHC (GhcMonad) import qualified GHC as G -import qualified DriverPhases as G -import qualified Util as G -import DynFlags import Control.Applicative import Control.Monad (void) +import Control.Monad.IO.Class import System.Directory import System.FilePath @@ -21,8 +18,9 @@ import Data.ByteString.Base16 import Data.List import Data.Char (isSpace) import Text.ParserCombinators.ReadP hiding (optional) + import HIE.Bios.Types -import HIE.Bios.Ghc.Gap +import qualified HIE.Bios.Ghc.Gap as Gap -- | Start a GHC session and set some sensible options for tooling to use. -- Creates a folder in the cache directory to cache interface files to make @@ -44,13 +42,13 @@ initSession ComponentOptions {..} = do $ setIgnoreInterfacePragmas -- Ignore any non-essential information in interface files such as unfoldings changing. $ writeInterfaceFiles (Just cache_dir) -- Write interface files to the cache $ setVerbosity 0 -- Set verbosity to zero just in case the user specified `-vx` in the options. - $ (if dynamicGhc then updateWays . addWay' WayDyn else id) -- Add dynamic way if GHC is built with dynamic linking - $ setLinkerOptions df'' -- Set `-fno-code` to avoid generating object files, unless we have to. + $ Gap.setWayDynamicIfHostIsDynamic -- Add dynamic way if GHC is built with dynamic linking + $ setLinkerOptions df'' -- Set `-fno-code` to avoid generating object files, unless we have to. ) let targets' = makeTargetsAbsolute componentRoot targets -- Unset the default log action to avoid output going to stdout. - unsetLogAction + Gap.unsetLogAction return targets' ---------------------------------------------------------------- @@ -116,25 +114,24 @@ getCacheDir fp = do -- we don't want to generate object code so we compile to bytecode -- (HscInterpreted) which implies LinkInMemory -- HscInterpreted -setLinkerOptions :: DynFlags -> DynFlags -setLinkerOptions df = df { - ghcLink = LinkInMemory - , hscTarget = HscNothing - , ghcMode = CompManager +setLinkerOptions :: G.DynFlags -> G.DynFlags +setLinkerOptions df = Gap.setNoCode $ df { + G.ghcLink = G.LinkInMemory + , G.ghcMode = G.CompManager } -setIgnoreInterfacePragmas :: DynFlags -> DynFlags -setIgnoreInterfacePragmas df = gopt_set df Opt_IgnoreInterfacePragmas +setIgnoreInterfacePragmas :: G.DynFlags -> G.DynFlags +setIgnoreInterfacePragmas df = Gap.gopt_set df G.Opt_IgnoreInterfacePragmas -setVerbosity :: Int -> DynFlags -> DynFlags -setVerbosity n df = df { verbosity = n } +setVerbosity :: Int -> G.DynFlags -> G.DynFlags +setVerbosity n df = df { G.verbosity = n } -writeInterfaceFiles :: Maybe FilePath -> DynFlags -> DynFlags +writeInterfaceFiles :: Maybe FilePath -> G.DynFlags -> G.DynFlags writeInterfaceFiles Nothing df = df -writeInterfaceFiles (Just hi_dir) df = setHiDir hi_dir (gopt_set df Opt_WriteInterface) +writeInterfaceFiles (Just hi_dir) df = setHiDir hi_dir (Gap.gopt_set df G.Opt_WriteInterface) -setHiDir :: FilePath -> DynFlags -> DynFlags -setHiDir f d = d { hiDir = Just f} +setHiDir :: FilePath -> G.DynFlags -> G.DynFlags +setHiDir f d = d { G.hiDir = Just f} -- | Interpret and set the specific command line options. @@ -142,113 +139,37 @@ setHiDir f d = d { hiDir = Just f} -- It would be good to move this code into a library module so we can just use it -- rather than copy it. addCmdOpts :: (GhcMonad m) - => [String] -> DynFlags -> m (DynFlags, [G.Target]) + => [String] -> G.DynFlags -> m (G.DynFlags, [G.Target]) addCmdOpts cmdOpts df1 = do - (df2, leftovers', _warns) <- G.parseDynamicFlags df1 (map G.noLoc cmdOpts) + logger <- Gap.getLogger <$> G.getSession + (df2, leftovers', _warns) <- Gap.parseDynamicFlags logger df1 (map G.noLoc cmdOpts) -- parse targets from ghci-scripts. Only extract targets that have been ":add"'ed. - additionalTargets <- concat <$> mapM (liftIO . getTargetsFromGhciScript) (ghciScripts df2) + additionalTargets <- concat <$> mapM (liftIO . getTargetsFromGhciScript) (G.ghciScripts df2) -- leftovers contains all Targets from the command line - let leftovers = leftovers' ++ map G.noLoc additionalTargets - - let - -- To simplify the handling of filepaths, we normalise all filepaths right - -- away. Note the asymmetry of FilePath.normalise: - -- Linux: p/q -> p/q; p\q -> p\q - -- Windows: p/q -> p\q; p\q -> p\q - -- #12674: Filenames starting with a hypen get normalised from ./-foo.hs - -- to -foo.hs. We have to re-prepend the current directory. - normalise_hyp fp - | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp - | otherwise = nfp - where -#if defined(mingw32_HOST_OS) - strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp -#else - strt_dot_sl = "./" `isPrefixOf` fp -#endif - cur_dir = '.' : [pathSeparator] - nfp = normalise fp - normal_fileish_paths = map (normalise_hyp . G.unLoc) leftovers - let - (srcs, objs) = partition_args normal_fileish_paths [] [] - df3 = df2 { ldInputs = map (FileOption "") objs ++ ldInputs df2 } - ts <- mapM (uncurry G.guessTarget) srcs + let leftovers = map G.unLoc leftovers' ++ additionalTargets + + let (df3, srcs, _objs) = Gap.parseTargetFiles df2 leftovers + ts <- mapM (uncurry Gap.guessTarget) srcs return (df3, ts) - -- TODO: Need to handle these as well - -- Ideally it requires refactoring to work in GHCi monad rather than - -- Ghc monad and then can just use newDynFlags. - {- - liftIO $ G.handleFlagWarnings idflags1 warns - when (not $ null leftovers) - (throwGhcException . CmdLineError - $ "Some flags have not been recognized: " - ++ (concat . intersperse ", " $ map unLoc leftovers)) - when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do - liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set" - -} -- | Make filepaths in the given 'DynFlags' absolute. -- This makes the 'DynFlags' independent of the current working directory. -makeDynFlagsAbsolute :: FilePath -> DynFlags -> DynFlags +makeDynFlagsAbsolute :: FilePath -> G.DynFlags -> G.DynFlags makeDynFlagsAbsolute work_dir df = - mapOverIncludePaths (work_dir ) + Gap.mapOverIncludePaths makeAbs $ df - { importPaths = map (work_dir ) (importPaths df) - , packageDBFlags = - let makePackageDbAbsolute (PackageDB pkgConfRef) = PackageDB - $ case pkgConfRef of - PkgConfFile fp -> PkgConfFile (work_dir fp) - conf -> conf - makePackageDbAbsolute db = db - in map makePackageDbAbsolute (packageDBFlags df) + { G.importPaths = map makeAbs (G.importPaths df) + , G.packageDBFlags = + map (Gap.overPkgDbRef makeAbs) (G.packageDBFlags df) } - --- partition_args, along with some of the other code in this file, --- was copied from ghc/Main.hs --- ----------------------------------------------------------------------------- --- Splitting arguments into source files and object files. This is where we --- interpret the -x option, and attach a (Maybe Phase) to each source --- file indicating the phase specified by the -x option in force, if any. -partition_args :: [String] -> [(String, Maybe G.Phase)] -> [String] - -> ([(String, Maybe G.Phase)], [String]) -partition_args [] srcs objs = (reverse srcs, reverse objs) -partition_args ("-x":suff:args) srcs objs - | "none" <- suff = partition_args args srcs objs - | G.StopLn <- phase = partition_args args srcs (slurp ++ objs) - | otherwise = partition_args rest (these_srcs ++ srcs) objs - where phase = G.startPhase suff - (slurp,rest) = break (== "-x") args - these_srcs = zip slurp (repeat (Just phase)) -partition_args (arg:args) srcs objs - | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs - | otherwise = partition_args args srcs (arg:objs) - - {- - We split out the object files (.o, .dll) and add them - to ldInputs for use by the linker. - The following things should be considered compilation manager inputs: - - haskell source files (strings ending in .hs, .lhs or other - haskellish extension), - - module names (not forgetting hierarchical module names), - - things beginning with '-' are flags that were not recognised by - the flag parser, and we want them to generate errors later in - checkOptions, so we class them as source files (#5921) - - and finally we consider everything without an extension to be - a comp manager input, as shorthand for a .hs or .lhs filename. - Everything else is considered to be a linker object, and passed - straight through to the linker. - -} -looks_like_an_input :: String -> Bool -looks_like_an_input m = G.isSourceFilename m - || G.looksLikeModuleName m - || "-" `isPrefixOf` m - || not (hasExtension m) + where + makeAbs = (work_dir ) -- -------------------------------------------------------- -disableOptimisation :: DynFlags -> DynFlags -disableOptimisation df = updOptLevel 0 df +disableOptimisation :: G.DynFlags -> G.DynFlags +disableOptimisation df = Gap.updOptLevel 0 df -- -------------------------------------------------------- diff --git a/src/HIE/Bios/Ghc/Api.hs b/src/HIE/Bios/Ghc/Api.hs index 487e62d83..072ce34e7 100644 --- a/src/HIE/Bios/Ghc/Api.hs +++ b/src/HIE/Bios/Ghc/Api.hs @@ -7,15 +7,20 @@ module HIE.Bios.Ghc.Api ( , withDynFlags ) where -import CoreMonad (liftIO) -import GHC (LoadHowMuch(..), GhcMonad) -import DynFlags - +import GHC (LoadHowMuch(..), DynFlags, GhcMonad) import qualified GHC as G + +#if __GLASGOW_HASKELL__ >= 900 +import qualified GHC.Driver.Main as G +import qualified GHC.Driver.Make as G +#else import qualified HscMain as G import qualified GhcMake as G +#endif +import qualified HIE.Bios.Ghc.Gap as Gap import Control.Monad (void) +import Control.Monad.IO.Class import HIE.Bios.Types import HIE.Bios.Environment import HIE.Bios.Flags @@ -28,7 +33,7 @@ initializeFlagsWithCradle :: => FilePath -- ^ The file we are loading the 'Cradle' because of -> Cradle a -- ^ The cradle we want to load -> m (CradleLoadResult (m G.SuccessFlag, ComponentOptions)) -initializeFlagsWithCradle = initializeFlagsWithCradleWithMessage (Just G.batchMsg) +initializeFlagsWithCradle = initializeFlagsWithCradleWithMessage (Just Gap.batchMsg) -- | The same as 'initializeFlagsWithCradle' but with an additional argument to control -- how the loading progress messages are displayed to the user. In @haskell-ide-engine@ @@ -61,7 +66,7 @@ initSessionWithMessage msg compOpts = (do withDynFlags :: (GhcMonad m) => (DynFlags -> DynFlags) -> m a -> m a -withDynFlags setFlag body = G.gbracket setup teardown (\_ -> body) +withDynFlags setFlag body = Gap.bracket setup teardown (\_ -> body) where setup = do dflag <- G.getSessionDynFlags diff --git a/src/HIE/Bios/Ghc/Check.hs b/src/HIE/Bios/Ghc/Check.hs index 6bd33a7cd..4242ad01b 100644 --- a/src/HIE/Bios/Ghc/Check.hs +++ b/src/HIE/Bios/Ghc/Check.hs @@ -1,10 +1,19 @@ +{-# LANGUAGE CPP #-} module HIE.Bios.Ghc.Check ( checkSyntax , check ) where import GHC (DynFlags(..), GhcMonad) -import Exception +import qualified GHC as G + +#if __GLASGOW_HASKELL__ >= 900 +import qualified GHC.Driver.Session as G +#else +import qualified DynFlags as G +#endif + +import Control.Exception import HIE.Bios.Environment import HIE.Bios.Ghc.Api @@ -17,8 +26,6 @@ import Control.Monad.IO.Class import System.IO.Unsafe (unsafePerformIO) import qualified HIE.Bios.Ghc.Gap as Gap -import qualified DynFlags as G -import qualified GHC as G ---------------------------------------------------------------- @@ -40,7 +47,7 @@ checkSyntax cradle files = do either id id <$> check files where handleRes (CradleSuccess x) f = f x - handleRes (CradleFail ce) _f = liftIO $ throwIO ce + handleRes (CradleFail ce) _f = liftIO $ throwIO ce handleRes CradleNone _f = return "None cradle" ---------------------------------------------------------------- diff --git a/src/HIE/Bios/Ghc/Doc.hs b/src/HIE/Bios/Ghc/Doc.hs index faaf9a9ac..122da6da6 100644 --- a/src/HIE/Bios/Ghc/Doc.hs +++ b/src/HIE/Bios/Ghc/Doc.hs @@ -1,17 +1,30 @@ +{-# LANGUAGE CPP #-} -- | Pretty printer utilities module HIE.Bios.Ghc.Doc where + import GHC (DynFlags, getPrintUnqual, pprCols, GhcMonad) -import Outputable (PprStyle, SDoc, withPprStyleDoc, neverQualify) + +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Driver.Session (initSDocContext) +import GHC.Utils.Outputable (PprStyle, SDoc, runSDoc, neverQualify, ) +import GHC.Utils.Ppr (Mode(..), Doc, Style(..), renderStyle, style) +#else +import Outputable (PprStyle, SDoc, runSDoc, neverQualify, initSDocContext) import Pretty (Mode(..), Doc, Style(..), renderStyle, style) +#endif -import HIE.Bios.Ghc.Gap (makeUserStyle) +import HIE.Bios.Ghc.Gap (makeUserStyle, pageMode, oneLineMode) showPage :: DynFlags -> PprStyle -> SDoc -> String -showPage dflag stl = showDocWith dflag PageMode . withPprStyleDoc dflag stl +showPage dflag stl sdoc = showDocWith dflag pageMode $ runSDoc sdoc scontext + where + scontext = initSDocContext dflag stl showOneLine :: DynFlags -> PprStyle -> SDoc -> String -showOneLine dflag stl = showDocWith dflag OneLineMode . withPprStyleDoc dflag stl +showOneLine dflag stl sdoc = showDocWith dflag oneLineMode $ runSDoc sdoc scontext + where + scontext = initSDocContext dflag stl getStyle :: (GhcMonad m) => DynFlags -> m PprStyle getStyle dflags = makeUserStyle dflags <$> getPrintUnqual diff --git a/src/HIE/Bios/Ghc/Gap.hs b/src/HIE/Bios/Ghc/Gap.hs index 0078daf83..dd025bb6c 100644 --- a/src/HIE/Bios/Ghc/Gap.hs +++ b/src/HIE/Bios/Ghc/Gap.hs @@ -1,73 +1,229 @@ -{-# LANGUAGE FlexibleInstances, CPP #-} +{-# LANGUAGE FlexibleInstances, CPP, PatternSynonyms #-} -- | All the CPP for GHC version compability should live in this module. module HIE.Bios.Ghc.Gap ( - WarnFlags + ghcVersion + -- * Warnings, Doc Compat + , WarnFlags , emptyWarnFlags , makeUserStyle - , getModuleName - , getTyThing - , fixInfo + , PprStyle + -- * Argument parsing + , HIE.Bios.Ghc.Gap.parseTargetFiles + -- * Ghc Monad + , G.modifySession + , G.reflectGhc + , G.Session(..) + -- * Hsc Monad + , getHscEnv + -- * Driver compat + , batchMsg + -- * HscEnv Compat + , set_hsc_dflags + , overPkgDbRef + , HIE.Bios.Ghc.Gap.guessTarget + , setNoCode , getModSummaries , mapOverIncludePaths + , HIE.Bios.Ghc.Gap.getLogger + -- * AST compat + , pattern HIE.Bios.Ghc.Gap.RealSrcSpan , LExpression , LBinding , LPattern , inTypes , outType + -- * Exceptions + , catch + , bracket + , handle + -- * Doc Gap functions + , pageMode + , oneLineMode + -- * DynFlags compat + , initializePluginsForModSummary + , setFrontEndHooks + , updOptLevel + , setWayDynamicIfHostIsDynamic + , HIE.Bios.Ghc.Gap.gopt_set + , HIE.Bios.Ghc.Gap.parseDynamicFlags + -- * Platform constants + , hostIsDynamic + -- * misc + , getModuleName + , getTyThing + , fixInfo + , Tc.FrontendResult(..) + , Hsc , mapMG , mgModSummaries - , numLoadedPlugins - , initializePlugins , unsetLogAction ) where -import DynFlags (DynFlags, includePaths) -import GHC(LHsBind, LHsExpr, LPat, Type, ModSummary, ModuleGraph, HscEnv, setLogAction, GhcMonad) -import Outputable (PrintUnqualified, PprStyle, Depth(AllTheWay), mkUserStyle) +import Control.Monad.IO.Class +import qualified Control.Monad.Catch as E + +import GHC +import qualified GHC as G + +#if __GLASGOW_HASKELL__ >= 804 && __GLASGOW_HASKELL__ < 900 +import Data.List +import System.FilePath + +import DynFlags (LogAction, WarningFlag, updOptLevel, Way(WayDyn), updateWays, addWay') +import qualified DynFlags as G +import qualified Exception as G + +import Outputable (PprStyle, Depth(AllTheWay), mkUserStyle) +import HscMain (getHscEnv, batchMsg) +import HscTypes (Hsc, HscEnv(..)) +import qualified HscTypes as G +import qualified EnumSet as E (EnumSet, empty) +import qualified Pretty as Ppr +import qualified TcRnTypes as Tc +import Hooks (Hooks(hscFrontendHook)) +import qualified CmdLineParser as CmdLine +import DriverPhases as G +import Util as G +import qualified GhcMonad as G #if __GLASGOW_HASKELL__ >= 808 import qualified DynamicLoading (initializePlugins) import qualified Plugins (plugins) #endif +#if __GLASGOW_HASKELL__ >= 806 && __GLASGOW_HASKELL__ < 810 +import HsExtension (GhcTc) +import HsExpr (MatchGroup, MatchGroupTc(..)) +#elif __GLASGOW_HASKELL__ >= 804 && __GLASGOW_HASKELL__ < 810 +import HsExtension (GhcTc) +import HsExpr (MatchGroup) +#endif +#endif +---------------------------------------------------------------- +---------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 902 +import GHC.Core.Multiplicity (irrelevantMult) +import GHC.Data.EnumSet as E +import GHC.Driver.CmdLine as CmdLine +import GHC.Driver.Env as G +import GHC.Driver.Session as G +import GHC.Driver.Hooks +import GHC.Driver.Main +import GHC.Driver.Monad as G +import qualified GHC.Driver.Plugins as Plugins +import GHC.Platform.Ways (Way(WayDyn)) +import qualified GHC.Platform.Ways as Platform +import qualified GHC.Runtime.Loader as DynamicLoading (initializePlugins) +import qualified GHC.Tc.Types as Tc +import GHC.Utils.Logger +import GHC.Utils.Outputable +import qualified GHC.Utils.Ppr as Ppr +#elif __GLASGOW_HASKELL__ >= 900 +import Data.List +import System.FilePath +import GHC.Core.Multiplicity (irrelevantMult) +import GHC.Data.EnumSet as E +import GHC.Driver.CmdLine as CmdLine +import GHC.Driver.Types as G +import GHC.Driver.Session as G +import GHC.Driver.Hooks +import GHC.Driver.Main +import GHC.Driver.Monad as G +import GHC.Driver.Phases as G +import GHC.Utils.Misc as G +import qualified GHC.Driver.Plugins as Plugins +import GHC.Driver.Ways (Way(WayDyn)) +import qualified GHC.Driver.Ways as Platform +import qualified GHC.Runtime.Loader as DynamicLoading (initializePlugins) +import qualified GHC.Tc.Types as Tc +import GHC.Utils.Outputable +import qualified GHC.Utils.Ppr as Ppr +#endif ----------------------------------------------------------------- ----------------------------------------------------------------- +ghcVersion :: String +ghcVersion = VERSION_ghc -#if __GLASGOW_HASKELL__ >= 804 -import DynFlags (WarningFlag) -import qualified EnumSet as E (EnumSet, empty) -import GHC (mgModSummaries, mapMG) +#if __GLASGOW_HASKELL__ >= 900 +bracket :: E.MonadMask m => m a -> (a -> m c) -> (a -> m b) -> m b +bracket = + E.bracket +#else +bracket :: G.ExceptionMonad m => m a -> (a -> m c) -> (a -> m b) -> m b +bracket = + G.gbracket #endif -#if __GLASGOW_HASKELL__ >= 806 -import DynFlags (IncludeSpecs(..)) +#if __GLASGOW_HASKELL__ >= 900 +handle :: (E.MonadCatch m, E.Exception e) => (e -> m a) -> m a -> m a +handle = E.handle +#else +handle :: (G.ExceptionMonad m, E.Exception e) => (e -> m a) -> m a -> m a +handle = G.ghandle #endif #if __GLASGOW_HASKELL__ >= 810 -import GHC.Hs.Extension (GhcTc) -import GHC.Hs.Expr (MatchGroup, MatchGroupTc(..), mg_ext) -#elif __GLASGOW_HASKELL__ >= 806 -import HsExtension (GhcTc) -import HsExpr (MatchGroup, MatchGroupTc(..)) -import GHC (mg_ext) -#elif __GLASGOW_HASKELL__ >= 804 -import HsExtension (GhcTc) -import HsExpr (MatchGroup) -import GHC (mg_res_ty, mg_arg_tys) +catch :: (E.MonadCatch m, E.Exception e) => m a -> (e -> m a) -> m a +catch = + E.catch #else -import HsExtension (GhcTc) -import HsExpr (MatchGroup) +catch :: (G.ExceptionMonad m, E.Exception e) => m a -> (e -> m a) -> m a +catch = + G.gcatch #endif ---------------------------------------------------------------- + +pattern RealSrcSpan :: G.RealSrcSpan -> G.SrcSpan +#if __GLASGOW_HASKELL__ >= 900 +pattern RealSrcSpan t <- G.RealSrcSpan t _ +#else +pattern RealSrcSpan t <- G.RealSrcSpan t +#endif + +---------------------------------------------------------------- + +setNoCode :: DynFlags -> DynFlags +#if __GLASGOW_HASKELL__ >= 901 +setNoCode d = d { G.backend = G.NoBackend } +#else +setNoCode d = d { G.hscTarget = G.HscNothing } +#endif + +---------------------------------------------------------------- + +set_hsc_dflags :: DynFlags -> HscEnv -> HscEnv +set_hsc_dflags dflags hsc_env = hsc_env { G.hsc_dflags = dflags } + +overPkgDbRef :: (FilePath -> FilePath) -> G.PackageDBFlag -> G.PackageDBFlag +overPkgDbRef f (G.PackageDB pkgConfRef) = G.PackageDB + $ case pkgConfRef of +#if __GLASGOW_HASKELL__ >= 900 + G.PkgDbPath fp -> G.PkgDbPath (f fp) +#else + G.PkgConfFile fp -> G.PkgConfFile (f fp) +#endif + conf -> conf +overPkgDbRef _f db = db + +---------------------------------------------------------------- + +guessTarget :: GhcMonad m => String -> Maybe G.Phase -> m G.Target +#if __GLASGOW_HASKELL__ >= 901 +guessTarget a b = G.guessTarget a b +#else +guessTarget a b = G.guessTarget a b +#endif + ---------------------------------------------------------------- makeUserStyle :: DynFlags -> PrintUnqualified -> PprStyle -#if __GLASGOW_HASKELL__ >= 804 +#if __GLASGOW_HASKELL__ >= 900 +makeUserStyle _dflags style = mkUserStyle style AllTheWay +#elif __GLASGOW_HASKELL__ >= 804 makeUserStyle dflags style = mkUserStyle dflags style AllTheWay #endif @@ -99,11 +255,11 @@ fixInfo (t,f,cs,fs,_) = (t,f,cs,fs) mapOverIncludePaths :: (FilePath -> FilePath) -> DynFlags -> DynFlags mapOverIncludePaths f df = df - { includePaths = + { includePaths = #if __GLASGOW_HASKELL__ > 804 - IncludeSpecs - (map f $ includePathsQuote (includePaths df)) - (map f $ includePathsGlobal (includePaths df)) + G.IncludeSpecs + (map f $ G.includePathsQuote (includePaths df)) + (map f $ G.includePathsGlobal (includePaths df)) #else map f (includePaths df) #endif @@ -117,7 +273,11 @@ type LBinding = LHsBind GhcTc type LPattern = LPat GhcTc inTypes :: MatchGroup GhcTc LExpression -> [Type] +#if __GLASGOW_HASKELL__ >= 900 +inTypes = map irrelevantMult . mg_arg_tys . mg_ext +#else inTypes = mg_arg_tys . mg_ext +#endif outType :: MatchGroup GhcTc LExpression -> Type outType = mg_res_ty . mg_ext #elif __GLASGOW_HASKELL__ >= 804 @@ -131,25 +291,234 @@ outType :: MatchGroup GhcTc LExpression -> Type outType = mg_res_ty #endif -numLoadedPlugins :: DynFlags -> Int -#if __GLASGOW_HASKELL__ >= 808 +unsetLogAction :: GhcMonad m => m () +unsetLogAction = do +#if __GLASGOW_HASKELL__ >= 902 + hsc_env <- getSession + logger <- liftIO $ initLogger + let env = hsc_env { hsc_logger = pushLogHook (const noopLogger) logger } + setSession env +#else + setLogAction noopLogger +#if __GLASGOW_HASKELL__ < 806 + (\_df -> return ()) +#endif +#endif + +noopLogger :: LogAction +#if __GLASGOW_HASKELL__ >= 900 +noopLogger = (\_df _wr _s _ss _m -> return ()) +#else +noopLogger = (\_df _wr _s _ss _pp _m -> return ()) +#endif + +-- -------------------------------------------------------- +-- Doc Compat functions +-- -------------------------------------------------------- + +pageMode :: Ppr.Mode +pageMode = +#if __GLASGOW_HASKELL__ >= 902 + Ppr.PageMode True +#else + Ppr.PageMode +#endif + +oneLineMode :: Ppr.Mode +oneLineMode = Ppr.OneLineMode + +-- -------------------------------------------------------- +-- DynFlags Compat functions +-- -------------------------------------------------------- + +numLoadedPlugins :: HscEnv -> Int +#if __GLASGOW_HASKELL__ >= 902 numLoadedPlugins = length . Plugins.plugins +#elif __GLASGOW_HASKELL__ >= 808 +numLoadedPlugins = length . Plugins.plugins . hsc_dflags #else -- Plugins are loaded just as they are used numLoadedPlugins _ = 0 #endif -initializePlugins :: HscEnv -> DynFlags -> IO DynFlags -#if __GLASGOW_HASKELL__ >= 808 -initializePlugins = DynamicLoading.initializePlugins +initializePluginsForModSummary :: HscEnv -> ModSummary -> IO (Int, [G.ModuleName], ModSummary) +initializePluginsForModSummary hsc_env' mod_summary = do +#if __GLASGOW_HASKELL__ >= 902 + hsc_env <- DynamicLoading.initializePlugins hsc_env' + pure ( numLoadedPlugins hsc_env + , pluginModNames $ hsc_dflags hsc_env + , mod_summary + ) +#elif __GLASGOW_HASKELL__ >= 808 + let dynFlags' = G.ms_hspp_opts mod_summary + dynFlags <- DynamicLoading.initializePlugins hsc_env' dynFlags' + pure ( numLoadedPlugins $ set_hsc_dflags dynFlags hsc_env' + , G.pluginModNames dynFlags + , mod_summary { G.ms_hspp_opts = dynFlags } + ) #else --- In earlier versions of GHC plugins are just loaded before they are used. -initializePlugins _ df = return df + -- In earlier versions of GHC plugins are just loaded before they are used. + return (numLoadedPlugins hsc_env', G.pluginModNames $ hsc_dflags hsc_env', mod_summary) #endif -unsetLogAction :: GhcMonad m => m () -unsetLogAction = - setLogAction (\_df _wr _s _ss _pp _m -> return ()) -#if __GLASGOW_HASKELL__ < 806 - (\_df -> return ()) + +setFrontEndHooks :: Maybe (ModSummary -> G.Hsc Tc.FrontendResult) -> HscEnv -> HscEnv +setFrontEndHooks frontendHook env = +#if __GLASGOW_HASKELL__ >= 902 + env + { hsc_hooks = hooks + { hscFrontendHook = frontendHook + } + } + where + hooks = hsc_hooks env +#else + env + { G.hsc_dflags = flags + { G.hooks = oldhooks + { hscFrontendHook = frontendHook + } + } + } + where + flags = hsc_dflags env + oldhooks = G.hooks flags +#endif + +#if __GLASGOW_HASKELL__ < 902 +type Logger = () +#endif + +getLogger :: HscEnv -> Logger +getLogger = +#if __GLASGOW_HASKELL__ >= 902 + hsc_logger +#else + const () +#endif + +gopt_set :: DynFlags -> G.GeneralFlag -> DynFlags +gopt_set = G.gopt_set + +setWayDynamicIfHostIsDynamic :: DynFlags -> DynFlags +setWayDynamicIfHostIsDynamic = + if hostIsDynamic + then + updateWays . addWay' WayDyn + else + id + +#if __GLASGOW_HASKELL__ >= 900 +updateWays :: DynFlags -> DynFlags +updateWays = id + +#if __GLASGOW_HASKELL__ >= 902 +-- Copied from GHC, do we need that? +addWay' :: Way -> DynFlags -> DynFlags +addWay' w dflags0 = + let platform = targetPlatform dflags0 + dflags1 = dflags0 { targetWays_ = Platform.addWay w (targetWays_ dflags0) } + dflags2 = foldr setGeneralFlag' dflags1 + (Platform.wayGeneralFlags platform w) + dflags3 = foldr unSetGeneralFlag' dflags2 + (Platform.wayUnsetGeneralFlags platform w) + in dflags3 +#endif +#endif + +parseDynamicFlags :: MonadIO m + => Logger + -> DynFlags + -> [G.Located String] + -> m (DynFlags, [G.Located String], [CmdLine.Warn]) +#if __GLASGOW_HASKELL__ >= 902 +parseDynamicFlags = G.parseDynamicFlags +#else +parseDynamicFlags _ = G.parseDynamicFlags +#endif + +parseTargetFiles :: DynFlags -> [String] -> (DynFlags, [(String, Maybe G.Phase)], [String]) +#if __GLASGOW_HASKELL__ >= 902 +parseTargetFiles = G.parseTargetFiles +#else +parseTargetFiles dflags0 fileish_args = + let + -- To simplify the handling of filepaths, we normalise all filepaths right + -- away. Note the asymmetry of FilePath.normalise: + -- Linux: p/q -> p/q; p\q -> p\q + -- Windows: p/q -> p\q; p\q -> p\q + -- #12674: Filenames starting with a hypen get normalised from ./-foo.hs + -- to -foo.hs. We have to re-prepend the current directory. + normalise_hyp fp + | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp + | otherwise = nfp + where +#if defined(mingw32_HOST_OS) + strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp +#else + strt_dot_sl = "./" `isPrefixOf` fp +#endif + cur_dir = '.' : [pathSeparator] + nfp = normalise fp + normal_fileish_paths = map normalise_hyp fileish_args + + (srcs, objs) = partition_args normal_fileish_paths [] [] + df1 = dflags0 { G.ldInputs = map (G.FileOption "") objs ++ G.ldInputs dflags0 } + in + (df1, srcs, objs) +#endif + + +#if __GLASGOW_HASKELL__ < 902 +partition_args :: [String] -> [(String, Maybe G.Phase)] -> [String] + -> ([(String, Maybe G.Phase)], [String]) +-- partition_args, along with some of the other code in this file, +-- was copied from ghc/Main.hs +-- ----------------------------------------------------------------------------- +-- Splitting arguments into source files and object files. This is where we +-- interpret the -x option, and attach a (Maybe Phase) to each source +-- file indicating the phase specified by the -x option in force, if any. +partition_args [] srcs objs = (reverse srcs, reverse objs) +partition_args ("-x":suff:args) srcs objs + | "none" <- suff = partition_args args srcs objs + | G.StopLn <- phase = partition_args args srcs (slurp ++ objs) + | otherwise = partition_args rest (these_srcs ++ srcs) objs + where phase = G.startPhase suff + (slurp,rest) = break (== "-x") args + these_srcs = zip slurp (repeat (Just phase)) +partition_args (arg:args) srcs objs + | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs + | otherwise = partition_args args srcs (arg:objs) + + {- + We split out the object files (.o, .dll) and add them + to ldInputs for use by the linker. + The following things should be considered compilation manager inputs: + - haskell source files (strings ending in .hs, .lhs or other + haskellish extension), + - module names (not forgetting hierarchical module names), + - things beginning with '-' are flags that were not recognised by + the flag parser, and we want them to generate errors later in + checkOptions, so we class them as source files (#5921) + - and finally we consider everything without an extension to be + a comp manager input, as shorthand for a .hs or .lhs filename. + Everything else is considered to be a linker object, and passed + straight through to the linker. + -} +looks_like_an_input :: String -> Bool +looks_like_an_input m = G.isSourceFilename m + || G.looksLikeModuleName m + || "-" `isPrefixOf` m + || not (hasExtension m) +#endif + +-- -------------------------------------------------------- +-- Platform constants +-- -------------------------------------------------------- + +hostIsDynamic :: Bool +#if __GLASGOW_HASKELL__ >= 900 +hostIsDynamic = Platform.hostIsDynamic +#else +hostIsDynamic = G.dynamicGhc #endif \ No newline at end of file diff --git a/src/HIE/Bios/Ghc/Load.hs b/src/HIE/Bios/Ghc/Load.hs index 0c8149691..ae4103f8a 100644 --- a/src/HIE/Bios/Ghc/Load.hs +++ b/src/HIE/Bios/Ghc/Load.hs @@ -3,23 +3,25 @@ -- | Convenience functions for loading a file into a GHC API session module HIE.Bios.Ghc.Load ( loadFileWithMessage, loadFile, setTargetFiles, setTargetFilesWithMessage) where -import GHC -import qualified GHC as G -import qualified GhcMake as G -import qualified HscMain as G -import HscTypes + +import Control.Monad (forM, void) import Control.Monad.IO.Class +import Data.List +import Data.Time.Clock import Data.IORef -import Hooks -import TcRnTypes (FrontendResult(..)) -import Control.Monad (forM, void) -import GhcMonad -import HscMain -import Data.List +import GHC +import qualified GHC as G + +#if __GLASGOW_HASKELL__ >= 900 +import qualified GHC.Driver.Main as G +import qualified GHC.Driver.Make as G +#else +import qualified GhcMake as G +import qualified HscMain as G +#endif -import Data.Time.Clock import qualified HIE.Bios.Ghc.Gap as Gap import qualified HIE.Bios.Internal.Log as Log @@ -113,55 +115,47 @@ setTargetFilesWithMessage msg files = do -- during compilation. collectASTs :: (GhcMonad m) => m a -> m (a, [TypecheckedModule]) collectASTs action = do - dflags0 <- getSessionDynFlags ref1 <- liftIO $ newIORef [] - let dflags1 = dflags0 { hooks = (hooks dflags0) - { hscFrontendHook = Just (astHook ref1) } - } -- Modify session is much faster than `setSessionDynFlags`. - modifySession $ \h -> h{ hsc_dflags = dflags1 } + Gap.modifySession $ Gap.setFrontEndHooks (Just (astHook ref1)) res <- action tcs <- liftIO $ readIORef ref1 -- Unset the hook so that we don't retain the reference ot the IORef so it can be gced. -- This stops the typechecked modules being retained in some cases. liftIO $ writeIORef ref1 [] - dflags_old <- getSessionDynFlags - let dflags2 = dflags1 { hooks = (hooks dflags_old) - { hscFrontendHook = Nothing } - } - modifySession $ \h -> h{ hsc_dflags = dflags2 } + Gap.modifySession $ Gap.setFrontEndHooks Nothing return (res, tcs) -- | This hook overwrites the default frontend action of GHC. -astHook :: IORef [TypecheckedModule] -> ModSummary -> Hsc FrontendResult +astHook :: IORef [TypecheckedModule] -> ModSummary -> Gap.Hsc Gap.FrontendResult astHook tc_ref ms = ghcInHsc $ do p <- G.parseModule =<< initializePluginsGhc ms tcm <- G.typecheckModule p let tcg_env = fst (tm_internals_ tcm) liftIO $ modifyIORef tc_ref (tcm :) - return $ FrontendTypecheck tcg_env + return $ Gap.FrontendTypecheck tcg_env initializePluginsGhc :: ModSummary -> Ghc ModSummary initializePluginsGhc ms = do hsc_env <- getSession - df <- liftIO $ Gap.initializePlugins hsc_env (ms_hspp_opts ms) - Log.debugm ("init-plugins(loaded):" ++ show (Gap.numLoadedPlugins df)) - Log.debugm ("init-plugins(specified):" ++ show (length $ pluginModNames df)) - return (ms { ms_hspp_opts = df }) + (pluginsLoaded, pluginNames, newMs) <- liftIO $ Gap.initializePluginsForModSummary hsc_env ms + Log.debugm ("init-plugins(loaded):" ++ show pluginsLoaded) + Log.debugm ("init-plugins(specified):" ++ show (length pluginNames)) + return newMs -ghcInHsc :: Ghc a -> Hsc a +ghcInHsc :: Ghc a -> Gap.Hsc a ghcInHsc gm = do - hsc_session <- getHscEnv + hsc_session <- Gap.getHscEnv session <- liftIO $ newIORef hsc_session - liftIO $ reflectGhc gm (Session session) + liftIO $ Gap.reflectGhc gm (Gap.Session session) -- | A variant of 'guessTarget' which after guessing the target for a filepath, overwrites the -- target file to be a temporary file. guessTargetMapped :: (GhcMonad m) => (FilePath, FilePath) -> m Target guessTargetMapped (orig_file_name, mapped_file_name) = do - t <- G.guessTarget orig_file_name Nothing + t <- Gap.guessTarget orig_file_name Nothing return (setTargetFilename mapped_file_name t) setTargetFilename :: FilePath -> Target -> Target diff --git a/src/HIE/Bios/Ghc/Logger.hs b/src/HIE/Bios/Ghc/Logger.hs index d55ac292e..35fcdf7a6 100644 --- a/src/HIE/Bios/Ghc/Logger.hs +++ b/src/HIE/Bios/Ghc/Logger.hs @@ -1,26 +1,44 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, CPP #-} module HIE.Bios.Ghc.Logger ( withLogger ) where +import GHC (DynFlags(..), SrcSpan(..), GhcMonad, getSessionDynFlags) +import qualified GHC as G +import Control.Monad.IO.Class + +#if __GLASGOW_HASKELL__ >= 902 +import GHC.Data.Bag +import GHC.Data.FastString (unpackFS) +import GHC.Driver.Session (dopt, DumpFlag(Opt_D_dump_splices)) +import GHC.Types.SourceError +import GHC.Utils.Error +import GHC.Utils.Logger +#elif __GLASGOW_HASKELL__ >= 900 +import GHC.Data.Bag +import GHC.Data.FastString (unpackFS) +import GHC.Driver.Session (dopt, DumpFlag(Opt_D_dump_splices), LogAction) +import GHC.Driver.Types (SourceError, srcErrorMessages) +import GHC.Utils.Error +import GHC.Utils.Outputable (SDoc) +#else import Bag (Bag, bagToList) -import CoreMonad (liftIO) import DynFlags (LogAction, dopt, DumpFlag(Opt_D_dump_splices)) import ErrUtils -import Exception (ghandle) import FastString (unpackFS) -import GHC (DynFlags(..), SrcSpan(..), GhcMonad) -import qualified GHC as G import HscTypes (SourceError, srcErrorMessages) -import Outputable (PprStyle, SDoc) +import Outputable (SDoc) +#endif import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) import Data.Maybe (fromMaybe) + import System.FilePath (normalise) import HIE.Bios.Ghc.Doc (showPage, getStyle) import HIE.Bios.Ghc.Api (withDynFlags) +import qualified HIE.Bios.Ghc.Gap as Gap ---------------------------------------------------------------- @@ -37,8 +55,12 @@ readAndClearLogRef (LogRef ref) = do writeIORef ref id return $! unlines (b []) -appendLogRef :: DynFlags -> LogRef -> LogAction -appendLogRef df (LogRef ref) _ _ sev src style msg = do +appendLogRef :: DynFlags -> Gap.PprStyle -> LogRef -> LogAction +appendLogRef df style (LogRef ref) _ _ sev src +#if __GLASGOW_HASKELL__ < 900 + _style +#endif + msg = do let !l = ppMsg src sev df style msg modifyIORef ref (\b -> b . (l:)) @@ -50,13 +72,25 @@ appendLogRef df (LogRef ref) _ _ sev src style msg = do withLogger :: (GhcMonad m) => (DynFlags -> DynFlags) -> m () -> m (Either String String) -withLogger setDF body = ghandle sourceError $ do +withLogger setDF body = Gap.handle sourceError $ do logref <- liftIO newLogRef - withDynFlags (setLogger logref . setDF) $ do + dflags <- getSessionDynFlags + style <- getStyle dflags +#if __GLASGOW_HASKELL__ >= 902 + G.pushLogHookM (const $ appendLogRef dflags style logref) + let setLogger _ df = df +#else + let setLogger logref_ df = df { log_action = appendLogRef df style logref_ } +#endif + r <- withDynFlags (setLogger logref . setDF) $ do body liftIO $ Right <$> readAndClearLogRef logref - where - setLogger logref df = df { log_action = appendLogRef df logref } +#if __GLASGOW_HASKELL__ >= 902 + G.popLogHookM +#endif + pure r + + ---------------------------------------------------------------- @@ -65,25 +99,38 @@ sourceError :: (GhcMonad m) => SourceError -> m (Either String String) sourceError err = do - dflag <- G.getSessionDynFlags + dflag <- getSessionDynFlags style <- getStyle dflag let ret = unlines . errBagToStrList dflag style . srcErrorMessages $ err return (Left ret) -errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String] +#if __GLASGOW_HASKELL__ >= 902 +errBagToStrList :: DynFlags -> Gap.PprStyle -> Bag (MsgEnvelope DecoratedSDoc) -> [String] +errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList + + +ppErrMsg :: DynFlags -> Gap.PprStyle -> MsgEnvelope DecoratedSDoc -> String +ppErrMsg dflag style err = ppMsg spn SevError dflag style msg -- ++ ext + where + spn = errMsgSpan err + msg = pprLocMsgEnvelope err + -- fixme +#else +errBagToStrList :: DynFlags -> Gap.PprStyle -> Bag ErrMsg -> [String] errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList ---------------------------------------------------------------- -ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String +ppErrMsg :: DynFlags -> Gap.PprStyle -> ErrMsg -> String ppErrMsg dflag style err = ppMsg spn SevError dflag style msg -- ++ ext where spn = errMsgSpan err msg = pprLocErrMsg err -- fixme -- ext = showPage dflag style (pprLocErrMsg $ errMsgReason err) +#endif -ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String +ppMsg :: SrcSpan -> G.Severity-> DynFlags -> Gap.PprStyle -> SDoc -> String ppMsg spn sev dflag style msg = prefix ++ cts where cts = showPage dflag style msg @@ -99,20 +146,21 @@ ppMsg spn sev dflag style msg = prefix ++ cts checkErrorPrefix :: String checkErrorPrefix = "Dummy:0:0:Error:" -showSeverityCaption :: Severity -> String -showSeverityCaption SevWarning = "Warning: " +showSeverityCaption :: G.Severity -> String +showSeverityCaption G.SevWarning = "Warning: " showSeverityCaption _ = "" getSrcFile :: SrcSpan -> Maybe String -getSrcFile (G.RealSrcSpan spn) = Just . unpackFS . G.srcSpanFile $ spn +getSrcFile (Gap.RealSrcSpan spn) = Just . unpackFS . G.srcSpanFile $ spn getSrcFile _ = Nothing isDumpSplices :: DynFlags -> Bool isDumpSplices dflag = dopt Opt_D_dump_splices dflag getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int) -getSrcSpan (RealSrcSpan spn) = Just ( G.srcSpanStartLine spn - , G.srcSpanStartCol spn - , G.srcSpanEndLine spn - , G.srcSpanEndCol spn) +getSrcSpan (Gap.RealSrcSpan spn) = + Just ( G.srcSpanStartLine spn + , G.srcSpanStartCol spn + , G.srcSpanEndLine spn + , G.srcSpanEndCol spn) getSrcSpan _ = Nothing diff --git a/src/HIE/Bios/Types.hs b/src/HIE/Bios/Types.hs index a46ef89cf..c5050ba74 100644 --- a/src/HIE/Bios/Types.hs +++ b/src/HIE/Bios/Types.hs @@ -87,7 +87,7 @@ instance Applicative CradleLoadResult where _ <*> _ = CradleNone instance Monad CradleLoadResult where - return = CradleSuccess + return = pure CradleSuccess r >>= k = k r CradleFail err >>= _ = CradleFail err CradleNone >>= _ = CradleNone diff --git a/tests/BiosTests.hs b/tests/BiosTests.hs index 4c2bb08a2..c752bb2ee 100644 --- a/tests/BiosTests.hs +++ b/tests/BiosTests.hs @@ -26,10 +26,11 @@ import System.Info.Extra ( isWindows ) import System.IO.Temp import System.Exit (ExitCode(ExitSuccess, ExitFailure)) import Control.Monad.Extra (unlessM) -import DynFlags (dynamicGhc) + +import qualified HIE.Bios.Ghc.Gap as Gap argDynamic :: [String] -argDynamic = ["-dynamic" | dynamicGhc] +argDynamic = ["-dynamic" | Gap.hostIsDynamic] main :: IO () main = do