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: 80cf21bdde938255e5736c4a35a74fecd9005029

exe/Main.hs

@@ -14,6 +14,7 @@ import HIE.Bios.Ghc.Check
 import HIE.Bios.Ghc.Gap as Gap
 import HIE.Bios.Internal.Debug
 import Paths_hie_bios
+import qualified Data.List.NonEmpty as NE
 
 ----------------------------------------------------------------
 
@@ -78,19 +79,24 @@ main = do
         _ -> do
           res <- forM files $ \fp -> do
                   res <- getCompilerOptions fp cradle
-                  case res of
-                      CradleFail (CradleError _deps _ex err) ->
-                        return $ "Failed to show flags for \""
-                                                  ++ fp
-                                                  ++ "\": " ++ show err
-                      CradleSuccess opts ->
-                        return $ unlines ["Options: " ++ show (componentOptions opts)
-                                        ,"ComponentDir: " ++ componentRoot opts
-                                        ,"Dependencies: " ++ show (componentDependencies opts) ]
-                      CradleNone -> return $ "No flags/None Cradle: component " ++ fp ++ " should not be loaded"
+                  pure $ printFlagsLoadResult fp res
+
           return (unlines res)
       ConfigInfo files -> configInfo files
       CradleInfo files -> cradleInfo files
       Root    -> rootInfo cradle
       Version -> return progVersion
     putStr res
+
+printFlagsLoadResult :: FilePath -> CradleLoadResult (NE.NonEmpty ComponentOptions) -> String
+printFlagsLoadResult fp = \case
+  CradleFail (CradleError _deps _ex err) ->
+    "Failed to show flags for \""
+                              ++ fp
+                              ++ "\": " ++ show err
+  CradleSuccess opts -> unlines $ NE.toList $ fmap showOpts opts
+  CradleNone -> "No flags/None Cradle: component " ++ fp ++ " should not be loaded"
+  where
+    showOpts opt = unlines ["Options: " ++ show (componentOptions opt)
+                    ,"ComponentDir: " ++ componentRoot opt
+                    ,"Dependencies: " ++ show (componentDependencies opt) ]

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(..))
@@ -54,13 +57,16 @@ import System.IO
 import Control.DeepSeq
 
 import Data.Conduit.Process
+import Data.List.NonEmpty (NonEmpty((:|)))
 import qualified Data.Conduit.Combinators as C
 import qualified Data.Conduit as C
 import qualified Data.Conduit.Text as C
 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"
@@ -130,15 +136,17 @@ addCradleDeps deps c =
     addActionDeps ca =
       ca { runCradle = \l fp ->
             runCradle ca l fp
-              >>= \case
-                CradleSuccess (ComponentOptions os' dir ds) ->
-                  pure $ CradleSuccess (ComponentOptions os' dir (ds `union` deps))
-                CradleFail err ->
-                  pure $ CradleFail
-                    (err { cradleErrorDependencies = cradleErrorDependencies err `union` deps })
-                CradleNone -> pure CradleNone
+              >>= pure . addStaticDeps
          }
 
+    addStaticDeps :: CradleLoadResult (NonEmpty ComponentOptions) -> CradleLoadResult (NonEmpty  ComponentOptions)
+    addStaticDeps (CradleSuccess ops) = CradleSuccess (fmap addDepsToOpts ops)
+    addStaticDeps (CradleFail err) = CradleFail (err { cradleErrorDependencies = cradleErrorDependencies err `union` deps })
+    addStaticDeps CradleNone = CradleNone
+
+    addDepsToOpts :: ComponentOptions -> ComponentOptions
+    addDepsToOpts (ComponentOptions os' dir ds) = (ComponentOptions os' dir (ds `union` deps))
+
 -- | 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
@@ -247,7 +255,7 @@ defaultCradle cur_dir =
     , cradleOptsProg = CradleAction
         { actionName = Types.Default
         , runCradle = \_ _ ->
-            return (CradleSuccess (ComponentOptions argDynamic cur_dir []))
+            return (CradleSuccess (ComponentOptions argDynamic cur_dir []:| []) )
         , runGhcCmd = runGhcCmdOnPath cur_dir
         }
     }
@@ -317,7 +325,7 @@ multiAction ::  forall b a
             -> [(FilePath, CradleConfig b)]
             -> LoggingFunction
             -> FilePath
-            -> IO (CradleLoadResult ComponentOptions)
+            -> IO (CradleLoadResult (NonEmpty ComponentOptions))
 multiAction buildCustomCradle cur_dir cs l cur_fp =
     selectCradle =<< canonicalizeCradles
 
@@ -356,7 +364,7 @@ directCradle wdir args =
     , cradleOptsProg = CradleAction
         { actionName = Types.Direct
         , runCradle = \_ _ ->
-            return (CradleSuccess (ComponentOptions (args ++ argDynamic) wdir []))
+            return $ CradleSuccess (ComponentOptions (args ++ argDynamic) wdir [] :| [])
         , runGhcCmd = runGhcCmdOnPath wdir
         }
     }
@@ -394,7 +402,7 @@ biosAction :: FilePath
            -> Maybe Callable
            -> LoggingFunction
            -> FilePath
-           -> IO (CradleLoadResult ComponentOptions)
+           -> IO (CradleLoadResult (NonEmpty ComponentOptions))
 biosAction wdir bios bios_deps l fp = do
   bios' <- callableToProcess bios (Just fp)
   (ex, _stdo, std, [(_, res),(_, mb_deps)]) <-
@@ -520,33 +528,64 @@ cabalBuildDir work_dir = do
   let dirHash = show (fingerprintString abs_work_dir)
   getCacheDir ("dist-"<>filter (not . isSpace) (takeBaseName abs_work_dir)<>"-"<>dirHash)
 
-cabalAction :: FilePath -> Maybe String -> LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions)
+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")
@@ -649,7 +688,7 @@ stackCradleDependencies wdir componentDir syaml = do
   return $ map normalise $
     cabalFiles ++ [relFp </> "package.yaml", stackYamlLocationOrDefault syaml]
 
-stackAction :: FilePath -> Maybe String -> StackYaml -> LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions)
+stackAction :: FilePath -> Maybe String -> StackYaml -> LoggingFunction -> FilePath -> IO (CradleLoadResult (NonEmpty ComponentOptions))
 stackAction work_dir mc syaml l _fp = do
   let ghcProcArgs = ("stack", stackYamlProcessArgs syaml <> ["exec", "ghc", "--"])
   -- Same wrapper works as with cabal
@@ -876,13 +915,13 @@ removeFileIfExists f = do
   yes <- doesFileExist f
   when yes (removeFile f)
 
-makeCradleResult :: (ExitCode, [String], FilePath, [String]) -> [FilePath] -> CradleLoadResult ComponentOptions
+makeCradleResult :: (ExitCode, [String], FilePath, [String]) -> [FilePath] -> CradleLoadResult (NonEmpty ComponentOptions)
 makeCradleResult (ex, err, componentDir, gopts) deps =
   case ex of
     ExitFailure _ -> CradleFail (CradleError deps ex err)
     _ ->
         let compOpts = ComponentOptions gopts componentDir deps
-        in CradleSuccess compOpts
+        in CradleSuccess (compOpts :| [])
 
 -- | Calls @ghc --print-libdir@, with just whatever's on the PATH.
 runGhcCmdOnPath :: FilePath -> [String] -> IO (CradleLoadResult String)

src/HIE/Bios/Flags.hs

@@ -2,22 +2,22 @@ module HIE.Bios.Flags (getCompilerOptions, getCompilerOptionsWithLogger, Logging
 
 import HIE.Bios.Types
 import HIE.Bios.Internal.Log
-
+import Data.List.NonEmpty (NonEmpty)
 
 -- | Initialize the 'DynFlags' relating to the compilation of a single
 -- file or GHC session according to the provided 'Cradle'.
 getCompilerOptions ::
     FilePath -- The file we are loading it because of
     -> Cradle a
-    -> IO (CradleLoadResult ComponentOptions)
+    -> IO (CradleLoadResult (NonEmpty ComponentOptions))
 getCompilerOptions =
   getCompilerOptionsWithLogger logm
 
 getCompilerOptionsWithLogger ::
   LoggingFunction
   -> FilePath
   -> Cradle a
-  -> IO (CradleLoadResult ComponentOptions)
+  -> IO (CradleLoadResult (NonEmpty ComponentOptions))
 getCompilerOptionsWithLogger l fp cradle =
   runCradle (cradleOptsProg cradle) l fp
 

src/HIE/Bios/Ghc/Api.hs

@@ -24,6 +24,7 @@ import Control.Monad.IO.Class
 import HIE.Bios.Types
 import HIE.Bios.Environment
 import HIE.Bios.Flags
+import Data.List.NonEmpty (NonEmpty)
 
 ----------------------------------------------------------------
 
@@ -32,8 +33,8 @@ initializeFlagsWithCradle ::
     GhcMonad m
     => 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 Gap.batchMsg)
+    -> m (CradleLoadResult (NonEmpty (m G.SuccessFlag, ComponentOptions)))
+initializeFlagsWithCradle = initializeFlagsWithCradleWithMessage (Just G.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@
@@ -43,9 +44,10 @@ initializeFlagsWithCradleWithMessage ::
   => Maybe G.Messager
   -> FilePath -- ^ The file we are loading the 'Cradle' because of
   -> Cradle a  -- ^ The cradle we want to load
-  -> m (CradleLoadResult (m G.SuccessFlag, ComponentOptions)) -- ^ Whether we actually loaded the cradle or not.
-initializeFlagsWithCradleWithMessage msg fp cradle =
-    fmap (initSessionWithMessage msg) <$> liftIO (getCompilerOptions fp cradle)
+  -> m (CradleLoadResult (NonEmpty (m G.SuccessFlag, ComponentOptions))) -- ^ Whether we actually loaded the cradle or not.
+initializeFlagsWithCradleWithMessage msg fp cradle = do
+    options <- liftIO (getCompilerOptions fp cradle)
+    pure $ fmap (fmap (initSessionWithMessage msg)) options
 
 -- | Actually perform the initialisation of the session. Initialising the session corresponds to
 -- parsing the command line flags, setting the targets for the session and then attempting to load