Draft: Change API to emit multiple ComponentOptions if available

exe/Main.hs

@@ -3,6 +3,7 @@
 module Main where
 
 import Control.Monad ( forM )
+import qualified Data.Foldable as F
 import Data.Version (showVersion)
 import Options.Applicative
 import System.Directory (getCurrentDirectory)
@@ -76,21 +77,27 @@ main = do
         -- TODO force optparse to acquire one
         [] -> error "too few arguments"
         _ -> do
+          -- TODO: might print identical information multiple times
           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 LoadResult -> String
+printFlagsLoadResult fp = \case
+  CradleFail (CradleError _deps _ex err) ->
+    "Failed to show flags for \"" ++ fp ++ "\": " ++ show err
+  CradleSuccess opts -> unlines $ F.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)
+      ]

src/HIE/Bios.hs

@@ -11,6 +11,8 @@ module HIE.Bios (
   -- * Find and load a Cradle
     Cradle(..)
   , CradleLoadResult(..)
+  , LoadResult
+  , LoadResult'(..)
   , CradleError(..)
   , findCradle
   , loadCradle
@@ -30,4 +32,4 @@ import HIE.Bios.Cradle
 import HIE.Bios.Types
 import HIE.Bios.Flags
 import HIE.Bios.Environment
-import HIE.Bios.Ghc.Load
+import HIE.Bios.Ghc.Load

src/HIE/Bios/Cradle.hs

@@ -130,15 +130,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 LoadResult -> CradleLoadResult LoadResult
+    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 +249,7 @@ defaultCradle cur_dir =
     , cradleOptsProg = CradleAction
         { actionName = Types.Default
         , runCradle = \_ _ ->
-            return (CradleSuccess (ComponentOptions argDynamic cur_dir []))
+            return (CradleSuccess (mkSimpleLoadResult $ ComponentOptions argDynamic cur_dir []) )
         , runGhcCmd = runGhcCmdOnPath cur_dir
         }
     }
@@ -317,7 +319,7 @@ multiAction ::  forall b a
             -> [(FilePath, CradleConfig b)]
             -> LoggingFunction
             -> FilePath
-            -> IO (CradleLoadResult ComponentOptions)
+            -> IO (CradleLoadResult LoadResult)
 multiAction buildCustomCradle cur_dir cs l cur_fp =
     selectCradle =<< canonicalizeCradles
 
@@ -356,7 +358,7 @@ directCradle wdir args =
     , cradleOptsProg = CradleAction
         { actionName = Types.Direct
         , runCradle = \_ _ ->
-            return (CradleSuccess (ComponentOptions (args ++ argDynamic) wdir []))
+            return $ CradleSuccess (mkSimpleLoadResult $ ComponentOptions (args ++ argDynamic) wdir [])
         , runGhcCmd = runGhcCmdOnPath wdir
         }
     }
@@ -394,7 +396,7 @@ biosAction :: FilePath
            -> Maybe Callable
            -> LoggingFunction
            -> FilePath
-           -> IO (CradleLoadResult ComponentOptions)
+           -> IO (CradleLoadResult LoadResult)
 biosAction wdir bios bios_deps l fp = do
   bios' <- callableToProcess bios (Just fp)
   (ex, _stdo, std, [(_, res),(_, mb_deps)]) <-
@@ -520,7 +522,7 @@ 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)
+cabalAction :: FilePath -> Maybe String -> LoggingFunction -> FilePath -> IO (CradleLoadResult LoadResult)
 cabalAction work_dir mc l fp = do
     wrapper_fp <- withCabalWrapperTool ("ghc", []) work_dir
     buildDir <- cabalBuildDir work_dir
@@ -649,7 +651,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 LoadResult)
 stackAction work_dir mc syaml l _fp = do
   let ghcProcArgs = ("stack", stackYamlProcessArgs syaml <> ["exec", "ghc", "--"])
   -- Same wrapper works as with cabal
@@ -876,13 +878,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 LoadResult
 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 (mkSimpleLoadResult compOpts)
 
 -- | Calls @ghc --print-libdir@, with just whatever's on the PATH.
 runGhcCmdOnPath :: FilePath -> [String] -> IO (CradleLoadResult String)

src/HIE/Bios/Flags.hs

@@ -3,21 +3,20 @@ module HIE.Bios.Flags (getCompilerOptions, getCompilerOptionsWithLogger, Logging
 import HIE.Bios.Types
 import HIE.Bios.Internal.Log
 
-
 -- | 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 LoadResult)
 getCompilerOptions =
   getCompilerOptionsWithLogger logm
 
 getCompilerOptionsWithLogger ::
   LoggingFunction
   -> FilePath
   -> Cradle a
-  -> IO (CradleLoadResult ComponentOptions)
+  -> IO (CradleLoadResult LoadResult)
 getCompilerOptionsWithLogger l fp cradle =
   runCradle (cradleOptsProg cradle) l fp
 

src/HIE/Bios/Ghc/Api.hs

@@ -32,8 +32,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 (LoadResult' (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 +43,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 (LoadResult' (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

@@ -14,14 +14,17 @@ import qualified DynFlags as G
 #endif
 
 import Control.Exception
+import Control.Monad.Extra (concatForM)
+import Control.Monad.IO.Class
+
+import qualified Data.Foldable as F
 
 import HIE.Bios.Environment
 import HIE.Bios.Ghc.Api
 import HIE.Bios.Ghc.Logger
 import qualified HIE.Bios.Internal.Log as Log
 import HIE.Bios.Types
 import HIE.Bios.Ghc.Load
-import Control.Monad.IO.Class
 
 import System.IO.Unsafe (unsafePerformIO)
 import qualified HIE.Bios.Ghc.Gap as Gap
@@ -35,14 +38,14 @@ 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 (F.toList comps) $ \(ini, _) -> do
           _sf <- ini
           either id id <$> check files
   where

src/HIE/Bios/Internal/Debug.hs

@@ -3,6 +3,7 @@ module HIE.Bios.Internal.Debug (debugInfo, rootInfo, configInfo, cradleInfo) whe
 
 import Control.Monad
 import Data.Void
+import Data.Foldable
 
 import qualified Data.Char as Char
 
@@ -34,23 +35,24 @@ debugInfo fp cradle = unlines <$> do
     crdl <- findCradle' canonFp
     ghcLibDir <- getRuntimeGhcLibDir cradle
     ghcVer <- getRuntimeGhcVersion cradle
-    case res of
-      CradleSuccess (ComponentOptions gopts croot deps) -> do
-        return [
-            "Root directory:        " ++ rootDir
-          , "Component directory:   " ++ croot
-          , "GHC options:           " ++ unwords (map quoteIfNeeded gopts)
+    let printCradleData =
+          [ "Root directory:        " ++ rootDir
+          , "Cradle:                " ++ crdl
           , "GHC library directory: " ++ show ghcLibDir
           , "GHC version:           " ++ show ghcVer
           , "Config Location:       " ++ conf
-          , "Cradle:                " ++ crdl
-          , "Dependencies:          " ++ unwords deps
           ]
+    case res of
+      CradleSuccess opts ->
+        return $
+          -- TODO: 'toList' might swallow main component as it might be Nothing
+          printCradleData ++ (concatMap printComponentOptions (toList opts))
       CradleFail (CradleError deps ext stderr) ->
-        return ["Cradle failed to load"
-               , "Deps: " ++ show deps
-               , "Exit Code: " ++ show ext
-               , "Stderr: " ++ unlines stderr]
+        return
+          [ "Cradle failed to load"
+          , "Deps: " ++ show deps
+          , "Exit Code: " ++ show ext
+          , "Stderr: " ++ unlines stderr]
       CradleNone ->
         return ["No cradle"]
   where
@@ -59,6 +61,12 @@ debugInfo fp cradle = unlines <$> do
       | any Char.isSpace option = "\"" ++ option ++ "\""
       | otherwise = option
 
+    printComponentOptions (ComponentOptions gopts croot deps) =
+      [ "Component directory:   " ++ croot
+      , "GHC options:           " ++ unwords (map quoteIfNeeded gopts)
+      , "Dependencies:          " ++ unwords deps
+      ]
+
 ----------------------------------------------------------------
 
 -- | Get the root directory of the given Cradle.

src/HIE/Bios/Types.hs

@@ -1,17 +1,17 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE DeriveFunctor #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
-
 {-# LANGUAGE DeriveFoldable #-}
 {-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 module HIE.Bios.Types where
 
 import           System.Exit
 import           Control.Exception              ( Exception )
 
-data BIOSVerbosity = Silent | Verbose
-
 ----------------------------------------------------------------
 
 -- | The environment of a single 'Cradle'.
@@ -44,21 +44,60 @@ data ActionName a
   | Other a
   deriving (Show, Eq, Ord, Functor)
 
-data CradleAction a = CradleAction {
-                        actionName    :: ActionName a
-                      -- ^ Name of the action.
-                      , runCradle     :: LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions)
-                      -- ^ Options to compile the given file with.
-                      , runGhcCmd :: [String] -> IO (CradleLoadResult String)
-                      -- ^ Executes the @ghc@ binary that is usually used to
-                      -- build the cradle. E.g. for a cabal cradle this should be
-                      -- equivalent to @cabal exec ghc -- args@
-                      }
+data CradleAction a = CradleAction
+  { actionName    :: ActionName a
+  -- ^ Name of the action.
+  , runCradle     :: LoggingFunction -> FilePath -> IO (CradleLoadResult LoadResult)
+  -- ^ Options to compile the given file with.
+  --
+  -- The given FilePath /must/ be part of 'LoadResult.loadResultComponent' if
+  -- the loading operation succeeds.
+  , runGhcCmd :: [String] -> IO (CradleLoadResult String)
+  -- ^ Executes the @ghc@ binary that is usually used to
+  -- build the cradle. E.g. for a cabal cradle this should be
+  -- equivalent to @cabal exec ghc -- args@
+  }
   deriving (Functor)
 
 instance Show a => Show (CradleAction a) where
   show CradleAction { actionName = name } = "CradleAction: " ++ show name
 
+type LoadResult = LoadResult' ComponentOptions
+
+-- | Record for expressing successful loading.
+-- Can express partial success.
+data LoadResult' a = LoadResult
+  { loadResultComponent :: Maybe a
+  -- ^ Component options for the FilePath that produced this 'LoadResult'.
+  -- See 'CradleAction.runCradle' for information on how to produce a 'LoadResult'.
+  --
+  -- This field can be 'Nothing' to indicate that loading partially failed/succeeded.
+  , loadResultDependencies :: [a]
+  -- ^ Direct or indirect dependencies from the component from above.
+  -- Indirect means that it is not required that 'ComponentOptions' in this list
+  -- are required dependencies of 'loadResultComponent'. It is specifically allowed
+  -- to list 'ComponentOptions' that have no relation with 'loadResultComponent'.
+  --
+  -- Example:
+  --
+  -- Assume we load an executable component, then its options must be located
+  -- in 'loadResultComponent' and its local dependencies in 'loadResultDependencies',
+  -- but additionally it is possible to list other executable component's
+  -- options in 'loadResultDependencies'.
+  } deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+-- | Create a simple LoadResult from a single 'ComponentOptions' record.
+-- Sets the 'ComponentOptions' as 'loadResultComponent'.
+mkSimpleLoadResult :: ComponentOptions -> LoadResult
+mkSimpleLoadResult opts = LoadResult
+  { loadResultComponent = Just opts
+  , loadResultDependencies = []
+  }
+
+-- | Helper to access the main component if there is one.
+pattern Main :: a -> LoadResult' a
+pattern Main opts <- (loadResultComponent -> Just opts)
+
 -- | Result of an attempt to set up a GHC session for a 'Cradle'.
 -- This is the go-to error handling mechanism. When possible, this
 -- should be preferred over throwing exceptions.