diff --git a/cabal.project b/cabal.project index e6fdbadb..79f99662 100644 --- a/cabal.project +++ b/cabal.project @@ -1 +1,6 @@ packages: . + +source-repository-package + type: git + location: https://github.com/fendor/cabal-build-info + tag: 80cf21bdde938255e5736c4a35a74fecd9005029 diff --git a/hie-bios.cabal b/hie-bios.cabal index 88ac0889..9eb2db50 100644 --- a/hie-bios.cabal +++ b/hie-bios.cabal @@ -135,6 +135,7 @@ Library HIE.Bios.Flags HIE.Bios.Types HIE.Bios.Internal.Log + HIE.Bios.Cabal.BuildInfo HIE.Bios.Ghc.Api HIE.Bios.Ghc.Check HIE.Bios.Ghc.Doc @@ -170,7 +171,9 @@ Library hslogger >= 1.2 && < 1.4, file-embed >= 0.0.11 && < 1, conduit >= 1.3 && < 2, - conduit-extra >= 1.3 && < 2 + conduit-extra >= 1.3 && < 2, + aeson-combinators ^>= 0.0.5, + cabal-build-info ^>= 0.1 Executable hie-bios diff --git a/src/HIE/Bios/Cabal/BuildInfo.hs b/src/HIE/Bios/Cabal/BuildInfo.hs new file mode 100644 index 00000000..9ba91dce --- /dev/null +++ b/src/HIE/Bios/Cabal/BuildInfo.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module HIE.Bios.Cabal.BuildInfo where + +import qualified Data.Aeson.Combinators.Decode as ACD +import Data.Maybe +import Data.Either +import Cabal.BuildInfo +import Control.Monad +import System.FilePath +import Data.Foldable (foldr') +import System.Directory + +collectBuildInfo :: FilePath -> IO (Maybe BuildInfo) +collectBuildInfo builddir = do + let planJson = builddir "cache" "plan.json" + buildInfos <- ACD.decodeFileStrict buildInfoPathDecoder planJson + case buildInfos of + Nothing -> error "TODO: failed to decode plan.json" + Just bi -> do + existing <- filterM doesFileExist bi + realBuildInfos <- mapM decodeBuildInfoFile existing + case partitionEithers realBuildInfos of + (errs@(_:_), _) -> error $ "TODO: failed to build-info.json: " ++ unlines errs + (_, infos) -> pure $ merge infos + where + merge :: [BuildInfo] -> Maybe BuildInfo + merge [] = Nothing + merge (x:xs) = Just $ foldr' go x xs + + go :: BuildInfo -> BuildInfo -> BuildInfo + go b1 b2 = b1 { components = components b1 ++ components b2 } + +buildInfoPathDecoder :: ACD.Decoder [FilePath] +buildInfoPathDecoder = do + let buildInfoDecoder = ACD.maybe $ ACD.key "build-info" ACD.string + catMaybes <$> ACD.key "install-plan" (ACD.list buildInfoDecoder) diff --git a/src/HIE/Bios/Cradle.hs b/src/HIE/Bios/Cradle.hs index 64dc6c9a..78dbb2e7 100644 --- a/src/HIE/Bios/Cradle.hs +++ b/src/HIE/Bios/Cradle.hs @@ -2,6 +2,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module HIE.Bios.Cradle ( findCradle , loadCradle @@ -27,6 +29,7 @@ import qualified Data.Yaml as Yaml import Data.Void import Data.Char (isSpace) import Data.Bifunctor (first) +import Cabal.BuildInfo import System.Process import System.Exit import HIE.Bios.Types hiding (ActionName(..)) @@ -62,6 +65,8 @@ import qualified Data.Text as T import qualified Data.HashMap.Strict as Map import Data.Maybe (fromMaybe, maybeToList) import GHC.Fingerprint (fingerprintString) +import Data.Version +import HIE.Bios.Cabal.BuildInfo hie_bios_output :: String hie_bios_output = "HIE_BIOS_OUTPUT" @@ -523,33 +528,64 @@ cabalBuildDir work_dir = do let dirHash = show (fingerprintString abs_work_dir) getCacheDir ("dist-"<>filter (not . isSpace) (takeBaseName abs_work_dir)<>"-"<>dirHash) +getCabalVersion :: IO Version +getCabalVersion = (makeVersion . map (read . T.unpack) . T.splitOn "." . T.pack) <$> readProcess "cabal" ["--numeric-version"] "" + cabalAction :: FilePath -> Maybe String -> LoggingFunction -> FilePath -> IO (CradleLoadResult (NonEmpty ComponentOptions)) cabalAction work_dir mc l fp = do - wrapper_fp <- withCabalWrapperTool ("ghc", []) work_dir + ver <- getCabalVersion buildDir <- cabalBuildDir work_dir - let cab_args = ["--builddir="<>buildDir,"v2-repl", "--with-compiler", wrapper_fp, fromMaybe (fixTargetPath fp) mc] - (ex, output, stde, [(_,mb_args)]) <- - readProcessWithOutputs [hie_bios_output] l work_dir (proc "cabal" cab_args) - let args = fromMaybe [] mb_args - case processCabalWrapperArgs args of - Nothing -> do - -- Best effort. Assume the working directory is the - -- the root of the component, so we are right in trivial cases at least. - deps <- cabalCradleDependencies work_dir work_dir - pure $ CradleFail (CradleError deps ex - ["Failed to parse result of calling cabal" - , unlines output - , unlines stde - , unlines $ args]) - Just (componentDir, final_args) -> do - deps <- cabalCradleDependencies work_dir componentDir - pure $ makeCradleResult (ex, stde, componentDir, final_args) deps - where - -- Need to make relative on Windows, due to a Cabal bug with how it - -- parses file targets with a C: drive in it - fixTargetPath x - | isWindows && hasDrive x = makeRelative work_dir x - | otherwise = x + if ver >= makeVersion [3, 6] + then do + (ex, output, stde, []) <- readProcessWithOutputs [] l work_dir (proc "cabal" ["--builddir=" ++ buildDir, "build", "--enable-build-info", "-O0", "all"]) + + Just buildInfo <- collectBuildInfo buildDir + case components buildInfo of + [] -> pure CradleNone + (x:xs) -> fmap CradleSuccess $ sequenceA (infoToOptions x :| fmap infoToOptions xs) + else do + wrapper_fp <- withCabalWrapperTool ("ghc", []) work_dir + let cab_args = ["--builddir="<>buildDir,"v2-repl", "--with-compiler", wrapper_fp, fromMaybe (fixTargetPath fp) mc] + (ex, output, stde, [(_,mb_args)]) <- + readProcessWithOutputs [hie_bios_output] l work_dir (proc "cabal" cab_args) + let args = fromMaybe [] mb_args + case processCabalWrapperArgs args of + Nothing -> do + -- Best effort. Assume the working directory is the + -- the root of the component, so we are right in trivial cases at least. + deps <- cabalCradleDependencies work_dir work_dir + pure $ CradleFail (CradleError deps ex + ["Failed to parse result of calling cabal" + , unlines output + , unlines stde + , unlines $ args]) + Just (componentDir, final_args) -> do + deps <- cabalCradleDependencies work_dir componentDir + pure $ makeCradleResult (ex, stde, componentDir, final_args) deps + where + -- Need to make relative on Windows, due to a Cabal bug with how it + -- parses file targets with a C: drive in it + fixTargetPath x + | isWindows && hasDrive x = makeRelative work_dir x + | otherwise = x + +infoToOptions :: ComponentInfo -> IO ComponentOptions +infoToOptions ComponentInfo {..} = do + sourceFiles <- guessSourceFiles componentSrcFiles + pure $ ComponentOptions + { componentRoot = componentSrcDir + , componentDependencies = maybeToList componentCabalFile + , componentOptions = componentCompilerArgs ++ componentModules ++ sourceFiles + } + where + -- | Output from 'cabal show-build-info' doesn't tell us the full path for source files. + -- Guess the full path here. + guessSourceFiles s + | [l] <- componentHsSrcDirs = pure $ fmap (l ) s + | otherwise = do + let candidates = [ dir src | src <- s, dir <- componentHsSrcDirs] + filterM doesFileExist candidates + removeInteractive :: [String] -> [String] removeInteractive = filter (/= "--interactive")