Add explicit type for LoadResults

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)
@@ -14,7 +15,6 @@ 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
 
 ----------------------------------------------------------------
 
@@ -77,6 +77,7 @@ 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
                   pure $ printFlagsLoadResult fp res
@@ -88,15 +89,15 @@ main = do
       Version -> return progVersion
     putStr res
 
-printFlagsLoadResult :: FilePath -> CradleLoadResult (NE.NonEmpty ComponentOptions) -> String
+printFlagsLoadResult :: FilePath -> CradleLoadResult LoadResult -> 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
+    "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) ]
+    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

@@ -54,7 +54,6 @@ 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
@@ -134,7 +133,7 @@ addCradleDeps deps c =
               >>= pure . addStaticDeps
          }
 
-    addStaticDeps :: CradleLoadResult (NonEmpty ComponentOptions) -> CradleLoadResult (NonEmpty  ComponentOptions)
+    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
@@ -250,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
         }
     }
@@ -320,7 +319,7 @@ multiAction ::  forall b a
             -> [(FilePath, CradleConfig b)]
             -> LoggingFunction
             -> FilePath
-            -> IO (CradleLoadResult (NonEmpty ComponentOptions))
+            -> IO (CradleLoadResult LoadResult)
 multiAction buildCustomCradle cur_dir cs l cur_fp =
     selectCradle =<< canonicalizeCradles
 
@@ -359,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
         }
     }
@@ -397,7 +396,7 @@ biosAction :: FilePath
            -> Maybe Callable
            -> LoggingFunction
            -> FilePath
-           -> IO (CradleLoadResult (NonEmpty ComponentOptions))
+           -> IO (CradleLoadResult LoadResult)
 biosAction wdir bios bios_deps l fp = do
   bios' <- callableToProcess bios (Just fp)
   (ex, _stdo, std, [(_, res),(_, mb_deps)]) <-
@@ -523,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 (NonEmpty 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
@@ -652,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 (NonEmpty 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
@@ -879,13 +878,13 @@ removeFileIfExists f = do
   yes <- doesFileExist f
   when yes (removeFile f)
 
-makeCradleResult :: (ExitCode, [String], FilePath, [String]) -> [FilePath] -> CradleLoadResult (NonEmpty 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

@@ -2,22 +2,21 @@ 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 (NonEmpty ComponentOptions))
+    -> IO (CradleLoadResult LoadResult)
 getCompilerOptions =
   getCompilerOptionsWithLogger logm
 
 getCompilerOptionsWithLogger ::
   LoggingFunction
   -> FilePath
   -> Cradle a
-  -> IO (CradleLoadResult (NonEmpty ComponentOptions))
+  -> IO (CradleLoadResult LoadResult)
 getCompilerOptionsWithLogger l fp cradle =
   runCradle (cradleOptsProg cradle) l fp
 

src/HIE/Bios/Ghc/Api.hs

@@ -24,7 +24,6 @@ import Control.Monad.IO.Class
 import HIE.Bios.Types
 import HIE.Bios.Environment
 import HIE.Bios.Flags
-import Data.List.NonEmpty (NonEmpty)
 
 ----------------------------------------------------------------
 
@@ -33,7 +32,7 @@ initializeFlagsWithCradle ::
     GhcMonad m
     => FilePath -- ^ The file we are loading the 'Cradle' because of
     -> Cradle a   -- ^ The cradle we want to load
-    -> m (CradleLoadResult (NonEmpty (m G.SuccessFlag, ComponentOptions)))
+    -> m (CradleLoadResult (LoadResult' (m G.SuccessFlag, ComponentOptions)))
 initializeFlagsWithCradle = initializeFlagsWithCradleWithMessage (Just G.batchMsg)
 
 -- | The same as 'initializeFlagsWithCradle' but with an additional argument to control
@@ -44,7 +43,7 @@ initializeFlagsWithCradleWithMessage ::
   => Maybe G.Messager
   -> FilePath -- ^ The file we are loading the 'Cradle' because of
   -> Cradle a  -- ^ The cradle we want to load
-  -> m (CradleLoadResult (NonEmpty (m G.SuccessFlag, ComponentOptions))) -- ^ Whether we actually loaded the cradle or not.
+  -> 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

src/HIE/Bios/Ghc/Check.hs

@@ -17,7 +17,7 @@ import Control.Exception
 import Control.Monad.Extra (concatForM)
 import Control.Monad.IO.Class
 
-import qualified Data.List.NonEmpty as NE
+import qualified Data.Foldable as F
 
 import HIE.Bios.Environment
 import HIE.Bios.Ghc.Api
@@ -45,7 +45,7 @@ checkSyntax cradle files = do
       G.runGhcT (Just libDir) $ do
         Log.debugm $ "Cradle: " ++ show cradle
         res <- initializeFlagsWithCradle (head files) cradle
-        handleRes res $ \comps -> concatForM (NE.toList comps) $ \(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
 
@@ -12,7 +13,6 @@ import HIE.Bios.Types
 import HIE.Bios.Flags
 
 import System.Directory
-import qualified Data.List.NonEmpty as NE
 
 ----------------------------------------------------------------
 
@@ -35,18 +35,18 @@ debugInfo fp cradle = unlines <$> do
     crdl <- findCradle' canonFp
     ghcLibDir <- getRuntimeGhcLibDir cradle
     ghcVer <- getRuntimeGhcVersion cradle
-    let printOptions (ComponentOptions gopts croot deps) =
+    let printCradleData =
           [ "Root directory:        " ++ rootDir
-          , "Component directory:   " ++ croot
-          , "GHC options:           " ++ unwords (map quoteIfNeeded gopts)
+          , "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 $ concatMap printOptions (NE.toList opts)
+      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
@@ -60,6 +60,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,15 +1,16 @@
 {-# 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 )
-import           Data.List.NonEmpty             ( NonEmpty )
 
 ----------------------------------------------------------------
 
@@ -43,21 +44,59 @@ 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 (NonEmpty 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', 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.