WIP for cabal show-build-info

exe/Main.hs

@@ -15,6 +15,7 @@ import HIE.Bios
 import HIE.Bios.Ghc.Check
 import HIE.Bios.Internal.Debug
 import Paths_hie_bios
+import qualified Data.List.NonEmpty as NE
 
 ----------------------------------------------------------------
 
@@ -79,19 +80,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

src/HIE/Bios/Cabal/BuildInfo.hs

@@ -0,0 +1,53 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
+module HIE.Bios.Cabal.BuildInfo where
+
+import Data.Aeson
+import GHC.Generics
+
+decodeBuildInfoFile :: FilePath -> IO BuildInfo
+decodeBuildInfoFile fp = do
+    eitherDecodeFileStrict fp
+     >>= \case
+        Left err -> fail $ "Could not parse show-build-info file: " ++ err
+        Right buildInfos -> return buildInfos
+
+data BuildInfo = BuildInfo
+    { cabalVersion :: String
+    , compiler :: CompilerInfo
+    , components :: [ComponentInfo]
+    } deriving (Generic, Show)
+
+data CompilerInfo = CompilerInfo
+    { flavour :: String
+    , compilerId :: String
+    , path :: String
+    } deriving (Generic, Show)
+
+data ComponentInfo = ComponentInfo
+    { componentType :: String
+    , componentName :: String
+    , componentUnitId :: String
+    , componentCompilerArgs :: [String]
+    , componentModules :: [String]
+    , componentSrcFiles :: [FilePath]
+    , componentHsSrcDirs :: [FilePath]
+    , componentSrcDir :: FilePath
+    , componentCabalFile :: Maybe FilePath
+    } deriving (Generic, Show)
+
+instance ToJSON BuildInfo where
+  toEncoding = genericToEncoding defaultOptions
+instance FromJSON BuildInfo where
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '-' }
+
+instance ToJSON CompilerInfo where
+  toEncoding = genericToEncoding defaultOptions
+instance FromJSON CompilerInfo where
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '-' }
+
+instance ToJSON ComponentInfo where
+  toEncoding = genericToEncoding defaultOptions
+instance FromJSON ComponentInfo where
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 10 . camelTo2 '-' }
+

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
@@ -53,6 +55,7 @@ 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
@@ -61,6 +64,8 @@ import qualified Data.HashMap.Strict as Map
 import           Data.Maybe (fromMaybe, maybeToList)
 import           GHC.Fingerprint (fingerprintString)
 import DynFlags (dynamicGhc)
+import Data.Version
+import HIE.Bios.Cabal.BuildInfo
 
 hie_bios_output :: String
 hie_bios_output = "HIE_BIOS_OUTPUT"
@@ -130,15 +135,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 +254,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 +324,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 +363,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 +401,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 +527,53 @@ 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, 4]
+      then do
+        (ex, output, stde, []) <- readProcessWithOutputs [] l work_dir (proc "cabal" ["show-build-info", "--buildinfo-json-output", "info.json", "all"])
+        res <- decodeBuildInfoFile "info.json"
+        pure $ case components res of
+          [] -> CradleNone
+          (x:xs) -> CradleSuccess (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 -> ComponentOptions
+infoToOptions ComponentInfo {..} =
+    ComponentOptions
+      { componentRoot = componentSrcDir
+      , componentDependencies = maybeToList componentCabalFile
+      , componentOptions = componentCompilerArgs ++ componentModules ++ componentSrcFiles
+      }
 
 removeInteractive :: [String] -> [String]
 removeInteractive = filter (/= "--interactive")
@@ -649,7 +676,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 +903,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

@@ -15,10 +15,11 @@ import qualified GHC as G
 import qualified HscMain as G
 import qualified GhcMake as G
 
-import Control.Monad (void)
+import Control.Monad (void, forM)
 import HIE.Bios.Types
 import HIE.Bios.Environment
 import HIE.Bios.Flags
+import Data.List.NonEmpty (NonEmpty)
 
 ----------------------------------------------------------------
 
@@ -27,7 +28,7 @@ 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))
+    -> m (CradleLoadResult (NonEmpty (m G.SuccessFlag, ComponentOptions)))
 initializeFlagsWithCradle = initializeFlagsWithCradleWithMessage (Just G.batchMsg)
 
 -- | The same as 'initializeFlagsWithCradle' but with an additional argument to control
@@ -38,9 +39,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

src/HIE/Bios/Ghc/Check.hs

@@ -19,6 +19,9 @@ import qualified HIE.Bios.Ghc.Gap as Gap
 
 import qualified DynFlags as G
 import qualified GHC as G
+import qualified Data.List.NonEmpty as NE
+import Control.Monad (forM)
+import Control.Monad.Extra (concatForM)
 
 ----------------------------------------------------------------
 
@@ -28,19 +31,19 @@ checkSyntax :: Show a
             => Cradle a
             -> [FilePath]  -- ^ The target files.
             -> IO String
-checkSyntax _      []    = return ""
+checkSyntax _      []    = return []
 checkSyntax cradle files = do
     libDirRes <- getRuntimeGhcLibDir cradle
     handleRes libDirRes $ \libDir ->
       G.runGhcT (Just libDir) $ do
         Log.debugm $ "Cradle: " ++ show cradle
         res <- initializeFlagsWithCradle (head files) cradle
-        handleRes res $ \(ini, _) -> do
+        handleRes res $ \comps -> concatForM (NE.toList comps) $ \(ini, _) -> do
           _sf <- ini
           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"
 
 ----------------------------------------------------------------