WIP for cabal show-build-info

cabal.project

@@ -1 +1,6 @@
 packages: .
+
+source-repository-package
+    type: git
+    location: https://github.com/fendor/cabal-build-info
+    tag: d28c94d08d6fb8996225bfc127ebcc6e7e80e46a

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

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)

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")