hie-bios 0.7.5 → 0.7.6

raw patch · 15 files changed

+723/−330 lines, 15 filesdep +exceptionsdep ~ghcdep ~timedep ~transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: exceptions

Dependency ranges changed: ghc, time, transformers

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• exe/Main.hs +2/−3
• hie-bios.cabal +6/−4
• src/HIE/Bios/Config.hs +5/−16
• src/HIE/Bios/Cradle.hs +39/−18
• src/HIE/Bios/Environment.hs +37/−123
• src/HIE/Bios/Ghc/Api.hs +11/−6
• src/HIE/Bios/Ghc/Check.hs +11/−4
• src/HIE/Bios/Ghc/Doc.hs +17/−4
• src/HIE/Bios/Ghc/Gap.hs +419/−47
• src/HIE/Bios/Ghc/Load.hs +26/−32
• src/HIE/Bios/Ghc/Logger.hs +71/−23
• src/HIE/Bios/Types.hs +22/−1
• tests/BiosTests.hs +48/−48
• tests/ParserTests.hs +1/−1

@@ -1,5 +1,13 @@ # ChangeLog hie-bios +## 2021-08-30 - 0.7.6++* Don't look for NIX_GHC_LIBDIR as it is redundant [#294](https://github.com/mpickering/hie-bios/pull/294)+* Add compatbility for GHC 9.0 and 9.2 [#300](https://github.com/mpickering/hie-bios/pull/300)+  * Add CPP statements for IncludeSpecs [#307](https://github.com/mpickering/hie-bios/pull/307)+* Refactor implicit config discovery [#291](https://github.com/mpickering/hie-bios/pull/291)+* Log stderr of stack to display more informative error messages to users. [#254](https://github.com/mpickering/hie-bios/pull/254)+ ## 2021-03-21 - 0.7.5  ### Bug Fixes

@@ -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 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] }

@@ -1,6 +1,6 @@ Cabal-Version:          2.2 Name:                   hie-bios-Version:                0.7.5+Version:                0.7.6 Author:                 Matthew Pickering <matthewtpickering@gmail.com> Maintainer:             Matthew Pickering <matthewtpickering@gmail.com> License:                BSD-3-Clause@@ -150,15 +150,17 @@                         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,+                        time                 >= 1.8.0 && < 1.13,                         extra                >= 1.6.14 && < 1.8,+                        exceptions,                         process              >= 1.6.1 && < 1.7,-                        ghc                  >= 8.4.1 && < 8.11,-                        transformers         >= 0.5.2 && < 0.6,+                        ghc                  >= 8.4.1 && < 9.3,+                        transformers         >= 0.5.2 && < 0.7,                         temporary            >= 1.2 && < 1.4,                         text                 >= 1.2.3 && < 1.3,                         unix-compat          >= 0.5.1 && < 0.6,

@@ -26,23 +26,12 @@ import qualified Data.Vector as V import qualified Data.HashMap.Strict as Map import           Data.Maybe (mapMaybe)-import           Data.Semigroup+import           Data.Monoid (Last(..)) import           Data.Foldable (foldrM) import           Data.Aeson (JSONPath) import           Data.Yaml import           Data.Yaml.Internal (Warning(..)) -type MLast a = Maybe (Last a)--viewLast :: MLast a -> Maybe a-viewLast (Just l) = Just $ getLast l-viewLast Nothing = Nothing--pattern MLast :: Maybe a -> MLast a-pattern MLast m <- (viewLast -> m) where-    MLast (Just l) = Just $ Last l-    MLast Nothing = Nothing- -- | Configuration that can be used to load a 'Cradle'. -- A configuration has roughly the following form: --@@ -70,7 +59,7 @@     deriving (Show, Eq)  data CabalType-    = CabalType_ { _cabalComponent :: !(MLast String) }+    = CabalType_ { _cabalComponent :: !(Last String) }     deriving (Eq)  instance Semigroup CabalType where@@ -80,14 +69,14 @@     mempty = CabalType_ mempty  pattern CabalType :: Maybe String -> CabalType-pattern CabalType { cabalComponent } = CabalType_ (MLast cabalComponent)+pattern CabalType { cabalComponent } = CabalType_ (Last cabalComponent) {-# COMPLETE CabalType #-}  instance Show CabalType where   show = show . Cabal  data StackType-    = StackType_ { _stackComponent :: !(MLast String) , _stackYaml :: !(MLast String) }+    = StackType_ { _stackComponent :: !(Last String) , _stackYaml :: !(Last String) }     deriving (Eq)  instance Semigroup StackType where@@ -97,7 +86,7 @@     mempty = StackType_ mempty mempty  pattern StackType :: Maybe String -> Maybe String -> StackType-pattern StackType { stackComponent, stackYaml } = StackType_ (MLast stackComponent) (MLast stackYaml)+pattern StackType { stackComponent, stackYaml } = StackType_ (Last stackComponent) (Last stackYaml) {-# COMPLETE StackType #-}  instance Show StackType where

@@ -27,12 +27,14 @@ import qualified Data.Yaml as Yaml import Data.Void import Data.Char (isSpace)+import Data.Bifunctor (first) import System.Process import System.Exit 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@@ -60,7 +62,6 @@ 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"@@ -142,21 +143,37 @@                 CradleNone -> pure CradleNone          } +-- | Try to infer an appropriate implicit cradle type from stuff we can find in the enclosing directories:+--   * If a .hie-bios file is found, we can treat this as a @Bios@ cradle+--   * If a stack.yaml file is found, we can treat this as a @Stack@ cradle+--   * If a cabal.project or an xyz.cabal file is found, we can treat this as a @Cabal@ cradle+inferCradleType :: FilePath -> MaybeT IO (CradleType a, FilePath)+inferCradleType fp =+       maybeItsBios+   <|> maybeItsStack+   <|> maybeItsCabal+-- <|> maybeItsObelisk+-- <|> maybeItsObelisk -implicitConfig :: FilePath -> MaybeT IO (CradleConfig a, FilePath)-implicitConfig fp = do-  (crdType, wdir) <- implicitConfig' fp-  return (CradleConfig [] crdType, wdir)+  where+  maybeItsBios = (\wdir -> (Bios (Program $ wdir </> ".hie-bios") Nothing Nothing, wdir)) <$> biosWorkDir fp -implicitConfig' :: FilePath -> MaybeT IO (CradleType a, FilePath)-implicitConfig' fp = (\wdir ->-         (Bios (Program $ wdir </> ".hie-bios") Nothing Nothing, wdir)) <$> biosWorkDir fp-  --   <|> (Obelisk,) <$> obeliskWorkDir fp-  --   <|> (Bazel,) <$> rulesHaskellWorkDir fp-     <|> (stackExecutable >> (Stack $ StackType Nothing Nothing,) <$> stackWorkDir fp)-     <|> ((Cabal $ CabalType Nothing,) <$> cabalWorkDir fp)+  maybeItsStack = stackExecutable >> (Stack $ StackType Nothing Nothing,) <$> stackWorkDir fp +  maybeItsCabal = (Cabal $ CabalType Nothing,) <$> cabalWorkDir fp +  -- maybeItsObelisk = (Obelisk,) <$> obeliskWorkDir fp++  -- maybeItsBazel = (Bazel,) <$> rulesHaskellWorkDir fp+++-- | Wraps up the cradle inferred by @inferCradleType@ as a @CradleConfig@ with no dependencies+implicitConfig :: FilePath -> MaybeT IO (CradleConfig a, FilePath)+implicitConfig = (fmap . first) (CradleConfig noDeps) . inferCradleType+  where+  noDeps :: [FilePath]+  noDeps = []+ yamlConfig :: FilePath ->  MaybeT IO FilePath yamlConfig fp = do   configDir <- yamlConfigDirectory fp@@ -174,12 +191,12 @@ configFileName = "hie.yaml"  -- | Pass '-dynamic' flag when GHC is built with dynamic linking.--- +-- -- Append flag to options of 'defaultCradle' and 'directCradle' if GHC is dynmically linked, -- 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 ]  --------------------------------------------------------------- @@ -608,10 +625,14 @@     , cradleOptsProg   = CradleAction         { actionName = Types.Stack         , runCradle = stackAction wdir mc syaml-        , runGhcCmd = \args ->-            readProcessWithCwd wdir "stack"-              (stackYamlProcessArgs syaml <> ["exec", "--silent", "ghc", "--"] <> args)-              ""+        , runGhcCmd = \args -> do+            -- Setup stack silently, since stack might print stuff to stdout in some cases (e.g. on Win)+            -- Issue 242 from HLS: https://github.com/haskell/haskell-language-server/issues/242+            stackSetup <- readProcessWithCwd wdir "stack" (stackYamlProcessArgs syaml <> ["setup", "--silent"]) ""+            stackSetup `bindIO` \_ ->+              readProcessWithCwd wdir "stack"+                (stackYamlProcessArgs syaml <> ["exec", "ghc", "--"] <> args)+                ""         }     } 

@@ -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.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 @@         $ 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'  ----------------------------------------------------------------@@ -66,19 +64,12 @@  -- | @getRuntimeGhcLibDir cradle@ will give you the ghc libDir: -- __do not__ use 'runGhcCmd' directly.--- This will also perform additional lookups and fallbacks to try and get a--- reliable library directory.--- It tries this specific order of paths: ----- 1. the @NIX_GHC_LIBDIR@ if it is set--- 2. calling 'runCradleGhc' on the provided cradle+--+-- Obtains libdir by calling 'runCradleGhc' on the provided cradle. getRuntimeGhcLibDir :: Cradle a                     -> IO (CradleLoadResult FilePath)-getRuntimeGhcLibDir cradle = do-  maybeNixLibDir <- lookupEnv "NIX_GHC_LIBDIR"-  case maybeNixLibDir of-    Just ld -> pure (CradleSuccess ld)-    Nothing -> fmap (fmap trim) $+getRuntimeGhcLibDir cradle = fmap (fmap trim) $       runGhcCmd (cradleOptsProg cradle) ["--print-libdir"]  -- | Gets the version of ghc used when compiling the cradle. It is based off of@@ -123,25 +114,24 @@ -- 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.@@ -149,113 +139,37 @@ -- 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 leftovers = map G.unLoc leftovers' ++ 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 (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 <suffix> 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  -- -------------------------------------------------------- 

@@ -7,15 +7,20 @@   , 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 @@     => 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 @@ 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

@@ -1,11 +1,20 @@+{-# 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 import HIE.Bios.Ghc.Logger@@ -17,8 +26,6 @@ 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 @@           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"  ----------------------------------------------------------------

@@ -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

@@ -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 -#if __GLASGOW_HASKELL__ >= 804-import DynFlags (WarningFlag)-import qualified EnumSet as E (EnumSet, empty)-import GHC (mgModSummaries, mapMG)+ghcVersion :: String+ghcVersion = VERSION_ghc++#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,14 @@  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))+#if __GLASGOW_HASKELL__ >= 902+          (map f $ G.includePathsQuoteImplicit (includePaths df))+#endif #else       map f (includePaths df) #endif@@ -117,7 +276,11 @@ 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 +294,234 @@ 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 <suffix> 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

@@ -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 -import Data.Time.Clock+#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 qualified HIE.Bios.Ghc.Gap as Gap import qualified HIE.Bios.Internal.Log as Log @@ -113,55 +115,47 @@ -- 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

@@ -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 @@     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,14 +72,26 @@ 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 ++ ----------------------------------------------------------------  -- | Converting 'SourceError' to 'String'.@@ -65,25 +99,38 @@   (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 @@ 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

@@ -3,6 +3,8 @@ {-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-} module HIE.Bios.Types where  import           System.Exit@@ -74,7 +76,26 @@   = CradleSuccess r -- ^ The cradle succeeded and returned these options.   | CradleFail CradleError -- ^ We tried to load the cradle and it failed.   | CradleNone -- ^ No attempt was made to load the cradle.-  deriving (Functor, Show, Eq)+ deriving (Functor, Foldable, Traversable, Show, Eq)+++instance Applicative CradleLoadResult where+  pure = CradleSuccess+  CradleSuccess a <*> CradleSuccess b = CradleSuccess (a b)+  CradleFail err <*> _ = CradleFail err+  _ <*> CradleFail err = CradleFail err+  _ <*> _ = CradleNone++instance Monad CradleLoadResult where+  return = pure+  CradleSuccess r >>= k = k r+  CradleFail err >>= _ = CradleFail err+  CradleNone >>= _ = CradleNone++bindIO :: CradleLoadResult a -> (a -> IO (CradleLoadResult b)) -> IO (CradleLoadResult b)+bindIO  (CradleSuccess r) k = k r+bindIO (CradleFail err) _ = return $ CradleFail err+bindIO CradleNone _ = return CradleNone   data CradleError = CradleError

@@ -26,10 +26,10 @@ 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@@ -95,44 +95,43 @@       , testGroup "Loading tests"         $ linuxExlusiveTestCases         ++-           [ testCaseSteps "failing-cabal" $ testDirectoryFail isCabalCradle "./tests/projects/failing-cabal" "MyLib.hs"-              (\CradleError {..} -> do-                  cradleErrorExitCode `shouldBe` ExitFailure 1-                  cradleErrorDependencies `shouldMatchList` ["failing-cabal.cabal", "cabal.project", "cabal.project.local"])-           , testCaseSteps "failing-bios" $ testDirectoryFail isBiosCradle "./tests/projects/failing-bios" "B.hs"-              (\CradleError {..} -> do-                  cradleErrorExitCode `shouldBe` ExitFailure 1-                  cradleErrorDependencies `shouldMatchList` ["hie.yaml"])-           , testCaseSteps "failing-bios-ghc" $ testGetGhcVersionFail isBiosCradle "./tests/projects/failing-bios-ghc" "B.hs"-              (\CradleError {..} -> do-                  cradleErrorExitCode `shouldBe` ExitSuccess-                  cradleErrorDependencies `shouldMatchList` []-                  length cradleErrorStderr `shouldBe` 1-                  head cradleErrorStderr `shouldStartWith` "Couldn't execute myGhc")-           , testCaseSteps "simple-bios-shell" $ testDirectory isBiosCradle "./tests/projects/simple-bios-shell" "B.hs"-           , testCaseSteps "simple-bios-shell-deps" $ testLoadCradleDependencies isBiosCradle "./tests/projects/simple-bios-shell" "B.hs" (assertEqual "dependencies" ["hie.yaml"])-           , testCaseSteps "simple-cabal" $ testDirectory isCabalCradle "./tests/projects/simple-cabal" "B.hs"-           , testCaseSteps "simple-direct" $ testDirectory isDirectCradle "./tests/projects/simple-direct" "B.hs"-           , testCaseSteps "nested-cabal" $ testLoadCradleDependencies isCabalCradle "./tests/projects/nested-cabal" "sub-comp/Lib.hs"-              (\deps -> deps `shouldMatchList` ["sub-comp" </> "sub-comp.cabal", "cabal.project", "cabal.project.local"]-              )-           , testCaseSteps "nested-cabal2" $ testLoadCradleDependencies isCabalCradle "./tests/projects/nested-cabal" "MyLib.hs"-              (\deps -> deps `shouldMatchList` ["nested-cabal.cabal", "cabal.project", "cabal.project.local"]-              )-           , testCaseSteps "multi-direct" {- tests if both components can be loaded -}-                         $  testDirectory isMultiCradle "./tests/projects/multi-direct" "A.hs"-                         >> testDirectory isMultiCradle "./tests/projects/multi-direct" "B.hs"-           , testCaseSteps "multi-cabal" {- tests if both components can be loaded -}-                         $  testDirectory isCabalCradle "./tests/projects/multi-cabal" "app/Main.hs"-                         >> testDirectory isCabalCradle "./tests/projects/multi-cabal" "src/Lib.hs"-           , testCaseSteps "monorepo-cabal" {- issue https://github.com/mpickering/hie-bios/issues/200 -}-                         $  testDirectory isCabalCradle "./tests/projects/monorepo-cabal" "A/Main.hs"-                         >> testDirectory isCabalCradle "./tests/projects/monorepo-cabal" "B/MyLib.hs"-           ]+          [ testCaseSteps "failing-cabal" $ testDirectoryFail isCabalCradle "./tests/projects/failing-cabal" "MyLib.hs"+            (\CradleError {..} -> do+                cradleErrorExitCode `shouldBe` ExitFailure 1+                cradleErrorDependencies `shouldMatchList` ["failing-cabal.cabal", "cabal.project", "cabal.project.local"])+          , testCaseSteps "failing-bios" $ testDirectoryFail isBiosCradle "./tests/projects/failing-bios" "B.hs"+            (\CradleError {..} -> do+                cradleErrorExitCode `shouldBe` ExitFailure 1+                cradleErrorDependencies `shouldMatchList` ["hie.yaml"])+          , testCaseSteps "failing-bios-ghc" $ testGetGhcVersionFail isBiosCradle "./tests/projects/failing-bios-ghc" "B.hs"+            (\CradleError {..} -> do+                cradleErrorExitCode `shouldBe` ExitSuccess+                cradleErrorDependencies `shouldMatchList` []+                length cradleErrorStderr `shouldBe` 1+                head cradleErrorStderr `shouldStartWith` "Couldn't execute myGhc")+          , testCaseSteps "simple-bios-shell" $ testDirectory isBiosCradle "./tests/projects/simple-bios-shell" "B.hs"+          , testCaseSteps "simple-bios-shell-deps" $ testLoadCradleDependencies isBiosCradle "./tests/projects/simple-bios-shell" "B.hs" (assertEqual "dependencies" ["hie.yaml"])+          , testCaseSteps "simple-cabal" $ testDirectory isCabalCradle "./tests/projects/simple-cabal" "B.hs"+          , testCaseSteps "simple-direct" $ testDirectory isDirectCradle "./tests/projects/simple-direct" "B.hs"+          , testCaseSteps "nested-cabal" $ testLoadCradleDependencies isCabalCradle "./tests/projects/nested-cabal" "sub-comp/Lib.hs"+            (\deps -> deps `shouldMatchList` ["sub-comp" </> "sub-comp.cabal", "cabal.project", "cabal.project.local"]+            )+          , testCaseSteps "nested-cabal2" $ testLoadCradleDependencies isCabalCradle "./tests/projects/nested-cabal" "MyLib.hs"+            (\deps -> deps `shouldMatchList` ["nested-cabal.cabal", "cabal.project", "cabal.project.local"]+            )+          , testCaseSteps "multi-direct" {- tests if both components can be loaded -}+                        $  testDirectory isMultiCradle "./tests/projects/multi-direct" "A.hs"+                        >> testDirectory isMultiCradle "./tests/projects/multi-direct" "B.hs"+          , testCaseSteps "multi-cabal" {- tests if both components can be loaded -}+                        $  testDirectory isCabalCradle "./tests/projects/multi-cabal" "app/Main.hs"+                        >> testDirectory isCabalCradle "./tests/projects/multi-cabal" "src/Lib.hs"+          , testCaseSteps "monorepo-cabal" {- issue https://github.com/mpickering/hie-bios/issues/200 -}+                        $  testDirectory isCabalCradle "./tests/projects/monorepo-cabal" "A/Main.hs"+                        >> testDirectory isCabalCradle "./tests/projects/monorepo-cabal" "B/MyLib.hs" -- TODO: Remove once stack and ghc-8.10.1 play well -- https://github.com/bubba/hie-bios/runs/811271872?check_suite_focus=true #if __GLASGOW_HASKELL__ < 810-       ++ [ expectFailBecause "stack repl does not fail on an invalid cabal file" $+          , expectFailBecause "stack repl does not fail on an invalid cabal file" $               testCaseSteps "failing-stack" $ testDirectoryFail isStackCradle "./tests/projects/failing-stack" "src/Lib.hs"                 (\CradleError {..} -> do                     cradleErrorExitCode `shouldBe` ExitFailure 1@@ -141,8 +140,7 @@           , testCaseSteps "multi-stack" {- tests if both components can be loaded -}                         $  testDirectory isStackCradle "./tests/projects/multi-stack" "app/Main.hs"                         >> testDirectory isStackCradle "./tests/projects/multi-stack" "src/Lib.hs"-          , expectFailBecause "stack repl set the component directory to the root directory" $-              testCaseSteps "nested-stack" $ testLoadCradleDependencies isStackCradle "./tests/projects/nested-stack" "sub-comp/Lib.hs"+          , testCaseSteps "nested-stack" $ testLoadCradleDependencies isStackCradle "./tests/projects/nested-stack" "sub-comp/Lib.hs"                 (\deps -> deps `shouldMatchList`                   ["sub-comp" </> "sub-comp.cabal", "sub-comp" </> "package.yaml", "stack.yaml"]                 )@@ -161,8 +159,8 @@           testCaseSteps "space stack"                         $  testDirectory isStackCradle "./tests/projects/space stack" "A.hs"                         >> testDirectory isStackCradle "./tests/projects/space stack" "B.hs"-          ] #endif+        ]       , testGroup "Implicit cradle tests" $         [ testCaseSteps "implicit-cabal" $             testImplicitCradle "./tests/projects/implicit-cabal" "Main.hs" Cabal@@ -375,18 +373,20 @@  stackYamlResolver :: String stackYamlResolver =-#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)))-  "nightly-2020-06-25"+#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)))+  "nightly-2021-08-22" -- GHC 9.0.1+#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)))+  "lts-18.6" -- GHC 8.10.4 #elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)))-  "lts-15.10"+  "lts-16.31" -- GHC 8.8.4 #elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,6,5,0)))-  "lts-14.17"+  "lts-14.27" -- GHC 8.6.5 #elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,6,4,0)))-  "lts-13.19"+  "lts-13.19" -- GHC 8.6.4 #elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,4,0)))-  "lts-12.26"+  "lts-12.26" -- GHC 8.4.4 #elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)))-  "lts-12.26"+  "lts-12.14" -- GHC 8.4.3 #elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)))-  "lts-11.22"+  "lts-11.22" -- GHC 8.2.2 #endif

@@ -13,7 +13,7 @@ import Control.Applicative ( (<|>) ) import Control.Exception -configDir :: FilePath+configDir :: FilePah configDir = "tests/configs"  main :: IO ()