diff --git a/exe/Main.hs b/exe/Main.hs index 2c64e188..8724c727 100644 --- a/exe/Main.hs +++ b/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) + ] diff --git a/src/HIE/Bios.hs b/src/HIE/Bios.hs index 27136f7b..7d4494c4 100644 --- a/src/HIE/Bios.hs +++ b/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 \ No newline at end of file +import HIE.Bios.Ghc.Load diff --git a/src/HIE/Bios/Cradle.hs b/src/HIE/Bios/Cradle.hs index 64dc6c9a..a7e5d67a 100644 --- a/src/HIE/Bios/Cradle.hs +++ b/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) diff --git a/src/HIE/Bios/Flags.hs b/src/HIE/Bios/Flags.hs index 730d1f9e..a6b2267b 100644 --- a/src/HIE/Bios/Flags.hs +++ b/src/HIE/Bios/Flags.hs @@ -2,14 +2,13 @@ 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 @@ -17,7 +16,7 @@ getCompilerOptionsWithLogger :: LoggingFunction -> FilePath -> Cradle a - -> IO (CradleLoadResult (NonEmpty ComponentOptions)) + -> IO (CradleLoadResult LoadResult) getCompilerOptionsWithLogger l fp cradle = runCradle (cradleOptsProg cradle) l fp diff --git a/src/HIE/Bios/Ghc/Api.hs b/src/HIE/Bios/Ghc/Api.hs index ff0913d8..447296d6 100644 --- a/src/HIE/Bios/Ghc/Api.hs +++ b/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 diff --git a/src/HIE/Bios/Ghc/Check.hs b/src/HIE/Bios/Ghc/Check.hs index 5c82e352..1d61b57d 100644 --- a/src/HIE/Bios/Ghc/Check.hs +++ b/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 diff --git a/src/HIE/Bios/Internal/Debug.hs b/src/HIE/Bios/Internal/Debug.hs index 4f09e748..ca8fdd1d 100644 --- a/src/HIE/Bios/Internal/Debug.hs +++ b/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. diff --git a/src/HIE/Bios/Types.hs b/src/HIE/Bios/Types.hs index 57468688..151defbd 100644 --- a/src/HIE/Bios/Types.hs +++ b/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. diff --git a/tests/BiosTests.hs b/tests/BiosTests.hs index 27d22d0a..955a8fb1 100644 --- a/tests/BiosTests.hs +++ b/tests/BiosTests.hs @@ -27,7 +27,6 @@ import System.IO.Temp import System.Exit (ExitCode(ExitSuccess, ExitFailure)) import Control.Monad.Extra (unlessM) import qualified HIE.Bios.Ghc.Gap as Gap -import Data.List.NonEmpty (NonEmpty((:|))) argDynamic :: [String] argDynamic = ["-dynamic" | Gap.hostIsDynamic] @@ -60,7 +59,7 @@ main = do withCurrentDirectory (cradleRootDir crdl) $ do runCradle (cradleOptsProg crdl) (const (pure ())) "./a/A.hs" >>= \case - CradleSuccess (r :| []) -> + CradleSuccess (Main r) -> componentOptions r `shouldMatchList` ["a"] <> argDynamic _ -> expectationFailure "Cradle could not be loaded" @@ -75,7 +74,7 @@ main = do runCradle (cradleOptsProg crdl) (const (pure ())) "./b/A.hs" >>= \case - CradleSuccess (r :| []) -> + CradleSuccess (Main r) -> componentOptions r `shouldMatchList` ["b"] <> argDynamic _ -> expectationFailure "Cradle could not be loaded" @@ -264,7 +263,7 @@ testLoadFile crd a_fp step = do G.runGhc (Just libDir) $ do let relFp = makeRelative (cradleRootDir crd) a_fp res <- initializeFlagsWithCradleWithMessage (Just (\_ n _ _ -> step (show n))) relFp crd - handleCradleResult res $ \((ini, _) :| []) -> do + handleCradleResult res $ \(Main (ini, _)) -> do liftIO (step "Initial module load") sf <- ini case sf of @@ -297,7 +296,7 @@ testLoadCradleDependencies cradlePred rootDir file dependencyPred step = G.runGhc (Just libDir) $ do let relFp = makeRelative (cradleRootDir crd) a_fp res <- initializeFlagsWithCradleWithMessage (Just (\_ n _ _ -> step (show n))) relFp crd - handleCradleResult res $ \((_, options) :| []) -> + handleCradleResult res $ \(Main (_, options)) -> liftIO $ dependencyPred (componentDependencies options) handleCradleResult :: MonadIO m => CradleLoadResult a -> (a -> m ()) -> m ()