diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,15 @@ # ChangeLog hie-bios +## 2022-07-26 - 0.10.0 + +* Apply Hlint suggestions [#354](https://github.com/haskell/hie-bios/pull/354) +* Cabal cradle: change error message on failure [#353](https://github.com/haskell/hie-bios/pull/353) +* Refactor parsing of hie.yaml files [#329](https://github.com/haskell/hie-bios/pull/329) +* Make sure we test the same versions as HLS [#346](https://github.com/haskell/hie-bios/pull/346) +* Move logging from hslogger to co-log [#347](https://github.com/haskell/hie-bios/pull/347) + * Demote process output to Debug severity [#348](https://github.com/haskell/hie-bios/pull/348) +* Fix typos [#342](https://github.com/haskell/hie-bios/pull/342) + ## 2022-03-07 - 0.9.1 * Ignore .ghci files while querying project GHC [#337](https://github.com/haskell/hie-bios/pull/337) diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,9 +1,12 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main where import Control.Monad ( forM ) +import qualified Colog.Core as L import Data.Version (showVersion) +import Data.Text.Prettyprint.Doc import Options.Applicative import System.Directory (getCurrentDirectory) import System.IO (stdout, hSetEncoding, utf8) @@ -66,18 +69,22 @@ Just yaml -> loadCradle yaml Nothing -> loadImplicitCradle (cwd "File.hs") + let + printLog (L.WithSeverity l sev) = "[" ++ show sev ++ "] " ++ show (pretty l) + logger :: forall a . Pretty a => L.LogAction IO (L.WithSeverity a) + logger = L.cmap printLog L.logStringStderr res <- case cmd of - Check targetFiles -> checkSyntax cradle targetFiles + Check targetFiles -> checkSyntax logger cradle targetFiles Debug files -> case files of - [] -> debugInfo (cradleRootDir cradle) cradle - fp -> debugInfo fp cradle + [] -> debugInfo logger (cradleRootDir cradle) cradle + fp -> debugInfo logger fp cradle Flags files -> case files of -- TODO force optparse to acquire one [] -> error "too few arguments" _ -> do res <- forM files $ \fp -> do - res <- getCompilerOptions fp cradle + res <- getCompilerOptions logger fp cradle case res of CradleFail (CradleError _deps _ex err) -> return $ "Failed to show flags for \"" diff --git a/hie-bios.cabal b/hie-bios.cabal --- a/hie-bios.cabal +++ b/hie-bios.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: hie-bios -Version: 0.9.1 +Version: 0.10.0 Author: Matthew Pickering Maintainer: Matthew Pickering License: BSD-3-Clause @@ -125,7 +125,7 @@ tests/projects/stack-with-yaml/stack-with-yaml.cabal tests/projects/stack-with-yaml/src/Lib.hs -tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1 || ==9.0.2 || ==9.2.1 +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.1 || ==9.0.2 || ==9.2.1 || ==9.2.1 Library Default-Language: Haskell2010 @@ -133,12 +133,12 @@ HS-Source-Dirs: src Exposed-Modules: HIE.Bios HIE.Bios.Config + HIE.Bios.Config.YAML HIE.Bios.Cradle HIE.Bios.Environment HIE.Bios.Internal.Debug HIE.Bios.Flags HIE.Bios.Types - HIE.Bios.Internal.Log HIE.Bios.Ghc.Api HIE.Bios.Ghc.Check HIE.Bios.Ghc.Doc @@ -153,6 +153,7 @@ aeson >= 1.4.5 && < 2.1, base16-bytestring >= 0.1.1 && < 1.1, bytestring >= 0.10.8 && < 0.12, + co-log-core ^>= 0.3.0, deepseq >= 1.4.3 && < 1.5, exceptions ^>= 0.10, containers >= 0.5.10 && < 0.7, @@ -161,6 +162,7 @@ filepath >= 1.4.1 && < 1.5, time >= 1.8.0 && < 1.13, extra >= 1.6.14 && < 1.8, + prettyprinter ^>= 1.7.0, process >= 1.6.1 && < 1.7, ghc >= 8.6.1 && < 9.3, transformers >= 0.5.2 && < 0.7, @@ -170,7 +172,6 @@ unordered-containers >= 0.2.9 && < 0.3, vector >= 0.12.0 && < 0.13, yaml >= 0.10.0 && < 0.12, - hslogger >= 1.2 && < 1.4, file-embed >= 0.0.11 && < 1, conduit >= 1.3 && < 2, conduit-extra >= 1.3 && < 2 @@ -183,11 +184,13 @@ GHC-Options: -Wall HS-Source-Dirs: exe Build-Depends: base >= 4.9 && < 5 + , co-log-core , directory , filepath , ghc , hie-bios , optparse-applicative + , prettyprinter test-suite parser-tests type: exitcode-stdio-1.0 diff --git a/src/HIE/Bios/Config.hs b/src/HIE/Bios/Config.hs --- a/src/HIE/Bios/Config.hs +++ b/src/HIE/Bios/Config.hs @@ -1,11 +1,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE CPP #-} -- | Logic and datatypes for parsing @hie.yaml@ files. module HIE.Bios.Config( readConfig, @@ -23,38 +19,16 @@ ) where import Control.Exception -import qualified Data.Text as T -import qualified Data.Vector as V -#if MIN_VERSION_aeson(2,0,0) -import Data.Aeson.Key (fromText) -import Data.Aeson.KeyMap (KeyMap) -import qualified Data.Aeson.KeyMap as Map -#else -import qualified Data.HashMap.Strict as Map -#endif -import Data.Maybe (mapMaybe) +import Data.Maybe (mapMaybe, fromMaybe) import Data.Monoid (Last(..)) -import Data.Foldable (foldrM) import Data.Aeson (JSONPath) import Data.Yaml import Data.Yaml.Internal (Warning(..)) +import HIE.Bios.Config.YAML (CradleConfigYAML) +import qualified HIE.Bios.Config.YAML as YAML -#if !MIN_VERSION_aeson(2,0,0) --- | Backwards compatible type-def for Key --- This used to be just a Text, but since aeson >= 2 --- this is an opaque datatype. -type Key = T.Text --- | Backwards compatible type-def for KeyMap --- This used to be just a HashMap, but since aeson >= 2 --- this is an opaque datatype. -type KeyMap v = Map.HashMap T.Text v --- | Create a Key from a Text. -fromText :: T.Text -> Key -fromText = id -#endif - -- | Configuration that can be used to load a 'Cradle'. -- A configuration has roughly the following form: -- @@ -140,10 +114,6 @@ | Other { otherConfig :: a, originalYamlValue :: Value } deriving (Eq, Functor) -instance FromJSON a => FromJSON (CradleType a) where - parseJSON (Object o) = parseCradleType o - parseJSON _ = fail "Not a known cradle type. Possible are: cabal, stack, bios, direct, default, none, multi" - instance Show (CradleType a) where show (Cabal comp) = "Cabal {component = " ++ show (cabalComponent comp) ++ "}" show (CabalMulti d a) = "CabalMulti {defaultCabal = " ++ show d ++ ", subCabalComponents = " ++ show a ++ "}" @@ -155,163 +125,50 @@ show (Multi a) = "Multi " ++ show a show (Other _ val) = "Other {originalYamlValue = " ++ show val ++ "}" -parseCradleType :: FromJSON a => Object -> Parser (CradleType a) -parseCradleType o - | Just val <- Map.lookup "cabal" o = parseCabal val - | Just val <- Map.lookup "stack" o = parseStack val --- | Just _val <- Map.lookup "bazel" o = return Bazel --- | Just _val <- Map.lookup "obelisk" o = return Obelisk - | Just val <- Map.lookup "bios" o = parseBios val - | Just val <- Map.lookup "direct" o = parseDirect val - | Just _val <- Map.lookup "none" o = return None - | Just val <- Map.lookup "multi" o = parseMulti val - | Just val <- Map.lookup "other" o = Other <$> parseJSON val <*> pure val -parseCradleType o = fail $ "Unknown cradle type: " ++ show o - -parseSingleOrMultiple - :: Monoid x - => (x -> CradleType a) - -> (x -> [(FilePath, x)] -> CradleType a) - -> (KeyMap Value -> Parser x) - -> Value - -> Parser (CradleType a) -parseSingleOrMultiple single multiple parse = doParse where - parseOne e - | Object v <- e - , Just (String prefix) <- Map.lookup "path" v - = (T.unpack prefix,) <$> parse (Map.delete "path" v) - | otherwise - = fail "Expected an object with a path key" - parseArray = foldrM (\v cs -> (: cs) <$> parseOne v) [] - doParse (Object v) - | Just (Array x) <- Map.lookup "components" v - = do - d <- parse (Map.delete "components" v) - xs <- parseArray x - return $ multiple d xs - | Just _ <- Map.lookup "components" v - = fail "Expected components to be an array of subcomponents" - | Nothing <- Map.lookup "components" v - = single <$> parse v - doParse (Array x) - = do - xs <- parseArray x - return $ multiple mempty xs - doParse Null = single <$> parse Map.empty - doParse _ = fail "Configuration is expected to be an object or an array of objects." - -parseStack :: Value -> Parser (CradleType a) -parseStack = parseSingleOrMultiple Stack StackMulti $ - \case x | Map.size x == 2 - , Just (String component) <- Map.lookup "component" x - , Just (String syaml) <- Map.lookup "stackYaml" x - -> return $ StackType (Just $ T.unpack component) (Just $ T.unpack syaml) - | Map.size x == 1, Just (String component) <- Map.lookup "component" x - -> return $ StackType (Just $ T.unpack component) Nothing - | Map.size x == 1, Just (String syaml) <- Map.lookup "stackYaml" x - -> return $ StackType Nothing (Just $ T.unpack syaml) - | Map.null x - -> return $ StackType Nothing Nothing - | otherwise - -> fail "Not a valid Stack configuration, following keys are allowed: component, stackYaml" - -parseCabal :: Value -> Parser (CradleType a) -parseCabal = parseSingleOrMultiple Cabal CabalMulti $ - \case x | Map.size x == 1, Just (String component) <- Map.lookup "component" x - -> return $ CabalType (Just $ T.unpack component) - | Map.null x - -> return $ CabalType Nothing - | otherwise - -> fail "Not a valid Cabal configuration, following keys are allowed: component" - -parseBios :: Value -> Parser (CradleType a) -parseBios (Object x) = - case biosCallable of - Just bc -> return $ Bios bc biosDepsCallable ghcPath - _ -> fail $ "Not a valid Bios Configuration type, following keys are allowed:" ++ - "program or shell, dependency-program or dependency-shell, with-ghc" - where - biosCallable = - exclusive - (stringTypeFromMap Program "program") - (stringTypeFromMap Command "shell") - biosDepsCallable = - exclusive - (stringTypeFromMap Program "dependency-program") - (stringTypeFromMap Command "dependency-shell") - ghcPath = - stringTypeFromMap id "with-ghc" - - exclusive :: Maybe a -> Maybe a -> Maybe a - exclusive (Just _) (Just _) = Nothing - exclusive l Nothing = l - exclusive Nothing r = r - stringTypeFromMap :: (String -> t) -> T.Text -> Maybe t - stringTypeFromMap constructor name = constructor <$> (intoString =<< Map.lookup (fromText name) x) - intoString :: Value -> Maybe String - intoString (String s) = Just (T.unpack s) - intoString _ = Nothing - -parseBios _ = fail "Bios Configuration is expected to be an object." - -parseDirect :: Value -> Parser (CradleType a) -parseDirect (Object x) - | Map.size x == 1 - , Just (Array v) <- Map.lookup "arguments" x - = return $ Direct [T.unpack s | String s <- V.toList v] - - | otherwise - = fail "Not a valid Direct Configuration type, following keys are allowed: arguments" -parseDirect _ = fail "Direct Configuration is expected to be an object." - -parseMulti :: FromJSON a => Value -> Parser (CradleType a) -parseMulti (Array x) - = Multi <$> mapM parsePath (V.toList x) -parseMulti _ = fail "Multi Configuration is expected to be an array." - -parsePath :: FromJSON a => Value -> Parser (FilePath, CradleConfig a) -parsePath (Object v) - | Just (String path) <- Map.lookup "path" v - , Just c <- Map.lookup "config" v - = (T.unpack path,) <$> parseJSON c -parsePath o = fail ("Multi component is expected to be an object." ++ show o) - -instance FromJSON a => FromJSON (CradleConfig a) where - parseJSON (Object val) = do - crd <- val .: "cradle" - crdDeps <- case Map.size val of - 1 -> return [] - 2 -> val .: "dependencies" - _ -> fail "Unknown key, following keys are allowed: cradle, dependencies" - - return $ CradleConfig { cradleType = crd - , cradleDependencies = crdDeps - } - - parseJSON _ = fail "Expected a cradle: key containing the preferences, possible values: cradle, dependencies" - +readConfig :: FromJSON a => FilePath -> IO (Config a) +readConfig fp = do + result <- decodeFileWithWarnings fp + fmap fromYAMLConfig $ either throwIO failOnAnyDuplicate result + where + failOnAnyDuplicate :: ([Warning], CradleConfigYAML a) -> IO (CradleConfigYAML a) + failOnAnyDuplicate (warnings, config) = do + _ <- case mapMaybe failOnDuplicate warnings of + dups@(_:_) -> throwIO $ InvalidYaml $ Just $ YamlException + $ "Duplicate keys are not allowed, found: " ++ show dups + _ -> return () + return config + -- future proofing in case more warnings are added + failOnDuplicate :: Warning -> Maybe JSONPath + failOnDuplicate (DuplicateKey a) = Just a -instance FromJSON a => FromJSON (Config a) where - parseJSON o = Config <$> parseJSON o +fromYAMLConfig :: CradleConfigYAML a -> Config a +fromYAMLConfig cradleYAML = Config $ CradleConfig (fromMaybe [] $ YAML.dependencies cradleYAML) + (toCradleType $ YAML.cradle cradleYAML) +toCradleType :: YAML.CradleComponent a -> CradleType a +toCradleType (YAML.Multi cpts) = + Multi $ (\(YAML.MultiSubComponent fp' cfg) -> (fp', cradle $ fromYAMLConfig cfg)) <$> cpts +toCradleType (YAML.Stack (YAML.StackConfig yaml cpts)) = + case cpts of + YAML.NoComponent -> Stack $ StackType Nothing yaml + (YAML.SingleComponent c) -> Stack $ StackType (Just c) yaml + (YAML.ManyComponents cs) -> StackMulti (StackType Nothing yaml) + ((\(YAML.StackComponent fp' c cYAML) -> + (fp', StackType (Just c) cYAML)) <$> cs) +toCradleType (YAML.Cabal (YAML.CabalConfig cpts)) = + case cpts of + YAML.NoComponent -> Cabal $ CabalType Nothing + (YAML.SingleComponent c) -> Cabal $ CabalType (Just c) + (YAML.ManyComponents cs) -> CabalMulti (CabalType Nothing) + ((\(YAML.CabalComponent fp' c) -> (fp', CabalType (Just c))) <$> cs) +toCradleType (YAML.Direct cfg) = Direct (YAML.arguments cfg) +toCradleType (YAML.Bios cfg) = Bios (toCallable $ YAML.callable cfg) + (toCallable <$> YAML.depsCallable cfg) + (YAML.ghcPath cfg) +toCradleType (YAML.None _) = None +toCradleType (YAML.Other cfg) = Other (YAML.otherConfig cfg) + (YAML.originalYamlValue cfg) --- | Decode given file to a 'Config a' value. --- Type variable 'a' can be used to extend the 'hie.yaml' file format --- to extend configuration in the user-library. --- If the contents of the file is not a valid 'Config a', --- an 'Control.Exception.IOException' is thrown. -readConfig :: FromJSON a => FilePath -> IO (Config a) -readConfig fp = do - result <- decodeFileWithWarnings fp - either throwIO failOnAnyDuplicate result - where - failOnAnyDuplicate :: ([Warning], Config a) -> IO (Config a) - failOnAnyDuplicate (warnings, config) = do - _ <- case mapMaybe failOnDuplicate warnings of - dups@(_:_) -> throwIO $ InvalidYaml $ Just $ YamlException - $ "Duplicate keys are not allowed, found: " ++ show dups - _ -> return () - return config - -- future proofing in case more warnings are added - failOnDuplicate :: Warning -> Maybe JSONPath - failOnDuplicate (DuplicateKey a) = Just a +toCallable :: YAML.Callable -> Callable +toCallable (YAML.Program p) = Program p +toCallable (YAML.Shell c) = Command c diff --git a/src/HIE/Bios/Config/YAML.hs b/src/HIE/Bios/Config/YAML.hs new file mode 100644 --- /dev/null +++ b/src/HIE/Bios/Config/YAML.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Datatypes for parsing @hie.yaml@ files +module HIE.Bios.Config.YAML + ( CradleConfigYAML(..) + , CradleComponent(..) + , MultiSubComponent(..) + , CabalConfig(..) + , CabalComponent(..) + , StackConfig(..) + , StackComponent(..) + , DirectConfig(..) + , BiosConfig(..) + , NoneConfig(..) + , OtherConfig(..) + , OneOrManyComponents(..) + , Callable(..) + ) where + +import Control.Applicative ((<|>)) +import Data.Aeson +import Data.Aeson.KeyMap (keys) +import Data.Aeson.Types (Object, Parser, Value (Null), + typeMismatch) +import qualified Data.Char as C (toLower) +import Data.List ((\\)) +import GHC.Generics (Generic) + +checkObjectKeys :: [Key] -> Object -> Parser () +checkObjectKeys allowedKeys obj = + let extraKeys = keys obj \\ allowedKeys + in case extraKeys of + [] -> pure () + _ -> fail $ mconcat [ "Unexpected keys " + , show extraKeys + , ", keys allowed: " + , show allowedKeys + ] + +data CradleConfigYAML a + = CradleConfigYAML { cradle :: CradleComponent a + , dependencies :: Maybe [FilePath] + } deriving (Generic, FromJSON) + +data CradleComponent a + = Multi [MultiSubComponent a] + | Cabal CabalConfig + | Stack StackConfig + | Direct DirectConfig + | Bios BiosConfig + | None NoneConfig + | Other (OtherConfig a) + deriving (Generic) + +instance FromJSON a => FromJSON (CradleComponent a) where + parseJSON = let opts = defaultOptions { constructorTagModifier = fmap C.toLower + , sumEncoding = ObjectWithSingleField + } + in genericParseJSON opts + +data NoneConfig = NoneConfig + +data OtherConfig a + = OtherConfig { otherConfig :: a + , originalYamlValue :: Value + } + +instance FromJSON a => FromJSON (OtherConfig a) where + parseJSON v = OtherConfig + <$> parseJSON v + <*> pure v + +instance FromJSON NoneConfig where + parseJSON Null = pure NoneConfig + parseJSON v = typeMismatch "NoneConfig" v + +data MultiSubComponent a + = MultiSubComponent { path :: FilePath + , config :: CradleConfigYAML a + } deriving (Generic, FromJSON) + +data CabalConfig + = CabalConfig { cabalComponents :: OneOrManyComponents CabalComponent } + +instance FromJSON CabalConfig where + parseJSON v@(Array _) = CabalConfig . ManyComponents <$> parseJSON v + parseJSON v@(Object obj) = (checkObjectKeys ["component", "components"] obj) *> (CabalConfig <$> parseJSON v) + parseJSON Null = pure $ CabalConfig NoComponent + parseJSON v = typeMismatch "CabalConfig" v + +data CabalComponent + = CabalComponent { cabalPath :: FilePath + , cabalComponent :: String + } + +instance FromJSON CabalComponent where + parseJSON = + let parseCabalComponent obj = checkObjectKeys ["path", "component"] obj + *> (CabalComponent + <$> obj .: "path" + <*> obj .: "component") + in withObject "CabalComponent" parseCabalComponent + +data StackConfig + = StackConfig { stackYaml :: Maybe FilePath + , stackComponents :: OneOrManyComponents StackComponent + } + +data StackComponent + = StackComponent { stackPath :: FilePath + , stackComponent :: String + , stackComponentYAML :: Maybe String + } + +instance FromJSON StackConfig where + parseJSON v@(Array _) = StackConfig Nothing . ManyComponents <$> parseJSON v + parseJSON v@(Object obj) = (checkObjectKeys ["component", "components", "stackYaml"] obj) + *> (StackConfig + <$> obj .:? "stackYaml" + <*> parseJSON v + ) + parseJSON Null = pure $ StackConfig Nothing NoComponent + parseJSON v = typeMismatch "StackConfig" v + +instance FromJSON StackComponent where + parseJSON = + let parseStackComponent obj = (checkObjectKeys ["path", "component", "stackYaml"] obj) + *> (StackComponent + <$> obj .: "path" + <*> obj .: "component" + <*> obj .:? "stackYaml") + in withObject "StackComponent" parseStackComponent + +data OneOrManyComponents component + = SingleComponent String + | ManyComponents [component] + | NoComponent + +instance FromJSON component => FromJSON (OneOrManyComponents component) where + parseJSON = + let parseComponents o = (parseSingleComponent o <|> parseSubComponents o <|> pure NoComponent) + parseSingleComponent o = SingleComponent <$> o .: "component" + parseSubComponents o = ManyComponents <$> o .: "components" + in withObject "Components" parseComponents + +data DirectConfig + = DirectConfig { arguments :: [String] } + deriving (Generic, FromJSON) + +data BiosConfig = + BiosConfig { callable :: Callable + , depsCallable :: Maybe Callable + , ghcPath :: Maybe FilePath + } + +instance FromJSON BiosConfig where + parseJSON = withObject "BiosConfig" parseBiosConfig + +data Callable + = Program FilePath + | Shell String + +parseBiosConfig :: Object -> Parser BiosConfig +parseBiosConfig obj = + let parseCallable o = (Program <$> o .: "program") <|> (Shell <$> o .: "shell") + parseDepsCallable o = (Just . Program <$> o .: "dependency-program") + <|> (Just . Shell <$> o .: "dependency-shell") + <|> (pure Nothing) + parse o = BiosConfig <$> parseCallable o + <*> parseDepsCallable o + <*> (o .:? "with-ghc") + check = checkObjectKeys ["program", "shell", "dependency-program", "dependency-shell", "with-ghc"] + in check obj *> parse obj diff --git a/src/HIE/Bios/Cradle.hs b/src/HIE/Bios/Cradle.hs --- a/src/HIE/Bios/Cradle.hs +++ b/src/HIE/Bios/Cradle.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -32,6 +31,7 @@ import Data.Char (isSpace) import System.Exit import System.Directory hiding (findFile) +import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&)) import Control.Monad import Control.Monad.Extra (unlessM) import Control.Monad.Trans.Cont @@ -346,13 +346,14 @@ None -> True _ -> False -multiAction :: forall b a - . (b -> Cradle a) - -> FilePath - -> [(FilePath, CradleConfig b)] - -> LoggingFunction - -> FilePath - -> IO (CradleLoadResult ComponentOptions) +multiAction + :: forall b a + . (b -> Cradle a) + -> FilePath + -> [(FilePath, CradleConfig b)] + -> LogAction IO (WithSeverity Log) + -> FilePath + -> IO (CradleLoadResult ComponentOptions) multiAction buildCustomCradle cur_dir cs l cur_fp = selectCradle =<< canonicalizeCradles @@ -415,7 +416,7 @@ biosWorkDir :: FilePath -> MaybeT IO FilePath biosWorkDir = findFileUpwards (".hie-bios" ==) -biosDepsAction :: LoggingFunction -> FilePath -> Maybe Callable -> FilePath -> IO [FilePath] +biosDepsAction :: LogAction IO (WithSeverity Log) -> FilePath -> Maybe Callable -> FilePath -> IO [FilePath] biosDepsAction l wdir (Just biosDepsCall) fp = do biosDeps' <- callableToProcess biosDepsCall (Just fp) (ex, sout, serr, [(_, args)]) <- readProcessWithOutputs [hie_bios_output] l wdir biosDeps' @@ -424,12 +425,13 @@ ExitSuccess -> return $ fromMaybe [] args biosDepsAction _ _ Nothing _ = return [] -biosAction :: FilePath - -> Callable - -> Maybe Callable - -> LoggingFunction - -> FilePath - -> IO (CradleLoadResult ComponentOptions) +biosAction + :: FilePath + -> Callable + -> Maybe Callable + -> LogAction IO (WithSeverity Log) + -> FilePath + -> IO (CradleLoadResult ComponentOptions) biosAction wdir bios bios_deps l fp = do bios' <- callableToProcess bios (Just fp) (ex, _stdo, std, [(_, res),(_, mb_deps)]) <- @@ -689,15 +691,38 @@ "" pure (trimEnd exe, trimEnd libdir) -cabalAction :: FilePath -> Maybe String -> LoggingFunction -> FilePath -> CradleLoadResultT IO ComponentOptions +cabalAction + :: FilePath + -> Maybe String + -> LogAction IO (WithSeverity Log) + -> FilePath + -> CradleLoadResultT IO ComponentOptions cabalAction workDir mc l fp = do - cabalProc <- cabalProcess workDir "v2-repl" [fromMaybe (fixTargetPath fp) mc] `modCradleError` \err -> do + let + cabalCommand = "v2-repl" + cabalArgs = [fromMaybe (fixTargetPath fp) mc] + + cabalProc <- cabalProcess workDir cabalCommand cabalArgs `modCradleError` \err -> do deps <- cabalCradleDependencies workDir workDir pure $ err { cradleErrorDependencies = cradleErrorDependencies err ++ deps } (ex, output, stde, [(_, maybeArgs)]) <- liftIO $ readProcessWithOutputs [hie_bios_output] l workDir cabalProc - let args = fromMaybe [] maybeArgs + + let errorDetails = + ["Failed command: " <> prettyCmdSpec (cmdspec cabalProc) + , unlines output + , unlines stde + , unlines $ args + , "Process Environment:"] + <> prettyProcessEnv cabalProc + + when (ex /= ExitSuccess) $ do + deps <- liftIO $ cabalCradleDependencies workDir workDir + let cmd = show (["cabal", cabalCommand] <> cabalArgs) + let errorMsg = "Failed to run " <> cmd <> " in directory \"" <> workDir <> "\". Consult the logs for full command and error." + throwCE (CradleError deps ex ([errorMsg] <> errorDetails)) + case processCabalWrapperArgs args of Nothing -> do -- Provide some dependencies an IDE can look for to trigger a reload. @@ -705,13 +730,7 @@ -- root of the component, so we are right in trivial cases at least. deps <- liftIO $ cabalCradleDependencies workDir workDir throwCE (CradleError deps ex $ - [ "Failed to parse result of calling cabal" - , "Failed command: " <> prettyCmdSpec (cmdspec cabalProc) - , unlines output - , unlines stde - , unlines $ args - , "Process Environment:"] - <> prettyProcessEnv cabalProc) + (["Failed to parse result of calling cabal" ] <> errorDetails)) Just (componentDir, final_args) -> do deps <- liftIO $ cabalCradleDependencies workDir componentDir CradleLoadResultT $ pure $ makeCradleResult (ex, stde, componentDir, final_args) deps @@ -822,7 +841,13 @@ return $ map normalise $ cabalFiles ++ [relFp "package.yaml", stackYamlLocationOrDefault syaml] -stackAction :: FilePath -> Maybe String -> StackYaml -> LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions) +stackAction + :: FilePath + -> Maybe String + -> StackYaml + -> LogAction IO (WithSeverity Log) + -> FilePath + -> IO (CradleLoadResult ComponentOptions) stackAction workDir mc syaml l _fp = do let ghcProcArgs = ("stack", stackYamlProcessArgs syaml <> ["exec", "ghc", "--"]) -- Same wrapper works as with cabal @@ -999,7 +1024,7 @@ -- * The process is executed in the given directory. readProcessWithOutputs :: Outputs -- ^ Names of the outputs produced by this process - -> LoggingFunction -- ^ Output of the process is streamed into this function. + -> LogAction IO (WithSeverity Log) -- ^ Output of the process is emitted as logs. -> FilePath -- ^ Working directory. Process is executed in this directory. -> CreateProcess -- ^ Parameters for the process to be executed. -> IO (ExitCode, [String], [String], [(OutputName, Maybe [String])]) @@ -1013,7 +1038,7 @@ -- Windows line endings are not converted so you have to filter out `'r` characters let loggingConduit = C.decodeUtf8 C..| C.lines C..| C.filterE (/= '\r') - C..| C.map T.unpack C..| C.iterM l C..| C.sinkList + C..| C.map T.unpack C..| C.iterM (\msg -> l <& LogProcessOutput msg `WithSeverity` Debug) C..| C.sinkList (ex, stdo, stde) <- liftIO $ sourceProcessWithStreams process mempty loggingConduit loggingConduit res <- forM output_files $ \(name,path) -> diff --git a/src/HIE/Bios/Flags.hs b/src/HIE/Bios/Flags.hs --- a/src/HIE/Bios/Flags.hs +++ b/src/HIE/Bios/Flags.hs @@ -1,25 +1,15 @@ -module HIE.Bios.Flags (getCompilerOptions, getCompilerOptionsWithLogger, LoggingFunction) where +module HIE.Bios.Flags (getCompilerOptions) where import HIE.Bios.Types -import HIE.Bios.Internal.Log +import qualified Colog.Core as L +import Data.Text.Prettyprint.Doc -- | 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) -getCompilerOptions = - getCompilerOptionsWithLogger logm - -getCompilerOptionsWithLogger :: - LoggingFunction - -> FilePath +getCompilerOptions + :: L.LogAction IO (L.WithSeverity Log) + -> FilePath -- The file we are loading it because of -> Cradle a -> IO (CradleLoadResult ComponentOptions) -getCompilerOptionsWithLogger l fp cradle = - runCradle (cradleOptsProg cradle) l fp - - ----------------------------------------------------------------- +getCompilerOptions l fp cradle = runCradle (cradleOptsProg cradle) l fp diff --git a/src/HIE/Bios/Ghc/Api.hs b/src/HIE/Bios/Ghc/Api.hs --- a/src/HIE/Bios/Ghc/Api.hs +++ b/src/HIE/Bios/Ghc/Api.hs @@ -21,6 +21,7 @@ import qualified HIE.Bios.Ghc.Gap as Gap import Control.Monad (void) import Control.Monad.IO.Class +import Colog.Core (LogAction (..), WithSeverity (..)) import HIE.Bios.Types import HIE.Bios.Environment import HIE.Bios.Flags @@ -30,22 +31,24 @@ -- | Initialize a GHC session by loading a given file into a given cradle. initializeFlagsWithCradle :: GhcMonad m - => FilePath -- ^ The file we are loading the 'Cradle' because of + => LogAction IO (WithSeverity Log) + -> 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) +initializeFlagsWithCradle l = initializeFlagsWithCradleWithMessage l (Just Gap.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@ -- the module loading progress is displayed in the UI by using a progress notification. initializeFlagsWithCradleWithMessage :: GhcMonad m - => Maybe G.Messager + => LogAction IO (WithSeverity Log) + -> 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) +initializeFlagsWithCradleWithMessage l msg fp cradle = + fmap (initSessionWithMessage msg) <$> liftIO (getCompilerOptions l fp cradle) -- | 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 diff --git a/src/HIE/Bios/Ghc/Check.hs b/src/HIE/Bios/Ghc/Check.hs --- a/src/HIE/Bios/Ghc/Check.hs +++ b/src/HIE/Bios/Ghc/Check.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExistentialQuantification #-} module HIE.Bios.Ghc.Check ( checkSyntax , check @@ -14,37 +17,49 @@ #endif import Control.Exception +import Control.Monad.IO.Class +import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&), cmap) +import Data.Text.Prettyprint.Doc -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 HIE.Bios.Types hiding (Log (..)) +import qualified HIE.Bios.Types as T +import qualified HIE.Bios.Ghc.Load as Load +import HIE.Bios.Environment import System.IO.Unsafe (unsafePerformIO) import qualified HIE.Bios.Ghc.Gap as Gap +data Log = + LoadLog Load.Log + | LogAny T.Log + | forall a . Show a => LogCradle (Cradle a) +instance Pretty Log where + pretty (LoadLog l) = pretty l + pretty (LogAny l) = pretty l + pretty (LogCradle c) = "Cradle:" <+> viaShow c + ---------------------------------------------------------------- -- | Checking syntax of a target file using GHC. -- Warnings and errors are returned. checkSyntax :: Show a - => Cradle a + => LogAction IO (WithSeverity Log) + -> Cradle a -> [FilePath] -- ^ The target files. -> IO String -checkSyntax _ [] = return "" -checkSyntax cradle files = do +checkSyntax _ _ [] = return "" +checkSyntax logger cradle files = do libDirRes <- getRuntimeGhcLibDir cradle handleRes libDirRes $ \libDir -> G.runGhcT (Just libDir) $ do - Log.debugm $ "Cradle: " ++ show cradle - res <- initializeFlagsWithCradle (head files) cradle + liftIO $ logger <& LogCradle cradle `WithSeverity` Info + res <- initializeFlagsWithCradle (cmap (fmap LogAny) logger) (head files) cradle handleRes res $ \(ini, _) -> do _sf <- ini - either id id <$> check files + either id id <$> check logger files where handleRes (CradleSuccess x) f = f x handleRes (CradleFail ce) _f = liftIO $ throwIO ce @@ -55,11 +70,12 @@ -- | Checking syntax of a target file using GHC. -- Warnings and errors are returned. check :: (GhcMonad m) - => [FilePath] -- ^ The target files. + => LogAction IO (WithSeverity Log) + -> [FilePath] -- ^ The target files. -> m (Either String String) -check fileNames = do +check logger fileNames = do libDir <- G.topDir <$> G.getDynFlags - withLogger (setAllWarningFlags libDir) $ setTargetFiles (map dup fileNames) + withLogger (setAllWarningFlags libDir) $ Load.setTargetFiles (cmap (fmap LoadLog) logger) (map dup fileNames) dup :: a -> (a, a) dup x = (x, x) diff --git a/src/HIE/Bios/Ghc/Load.hs b/src/HIE/Bios/Ghc/Load.hs --- a/src/HIE/Bios/Ghc/Load.hs +++ b/src/HIE/Bios/Ghc/Load.hs @@ -1,14 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} -- | Convenience functions for loading a file into a GHC API session -module HIE.Bios.Ghc.Load ( loadFileWithMessage, loadFile, setTargetFiles, setTargetFilesWithMessage) where +module HIE.Bios.Ghc.Load ( loadFileWithMessage, loadFile, setTargetFiles, setTargetFilesWithMessage, Log (..)) where +import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&)) import Control.Monad (forM, void) import Control.Monad.IO.Class import Data.List import Data.Time.Clock +import Data.Text.Prettyprint.Doc import Data.IORef import GHC @@ -23,8 +26,24 @@ #endif import qualified HIE.Bios.Ghc.Gap as Gap -import qualified HIE.Bios.Internal.Log as Log +data Log = + LogLoaded FilePath FilePath + | LogTypechecked [TypecheckedModule] + | LogInitPlugins Int [ModuleName] + | LogSetTargets [(FilePath, FilePath)] + | LogModGraph ModuleGraph + +instance Pretty Log where + pretty (LogLoaded fp1 fp2) = "Loaded" <+> viaShow fp1 <+> "-" <+> viaShow fp2 + pretty (LogTypechecked tcs) = "Typechecked modules for:" <+> (cat $ map (viaShow . get_fp) tcs) + pretty (LogInitPlugins n ns) = "Loaded" <+> viaShow n <+> "plugins, specified" <+> viaShow (length ns) + pretty (LogSetTargets ts) = "Set targets:" <+> viaShow ts + pretty (LogModGraph mod_graph) = "ModGraph:" <+> viaShow (map ms_location $ Gap.mgModSummaries mod_graph) + +get_fp :: TypecheckedModule -> Maybe FilePath +get_fp = ml_hs_file . ms_location . pm_mod_summary . tm_parsed_module + -- | Load a target into the GHC session. -- -- The target is represented as a tuple. The tuple consists of the @@ -38,19 +57,19 @@ -- together with all the typechecked modules that had to be loaded -- in order to typecheck the given target. loadFileWithMessage :: GhcMonad m - => Maybe G.Messager -- ^ Optional messager hook + => LogAction IO (WithSeverity Log) + -> Maybe G.Messager -- ^ Optional messager hook -- to log messages produced by GHC. -> (FilePath, FilePath) -- ^ Target file to load. -> m (Maybe TypecheckedModule, [TypecheckedModule]) -- ^ Typechecked module and modules that had to -- be loaded for the target. -loadFileWithMessage msg file = do +loadFileWithMessage logger msg file = do -- STEP 1: Load the file into the session, using collectASTs to also retrieve -- typechecked and parsed modules. - (_, tcs) <- collectASTs $ (setTargetFilesWithMessage msg [file]) - Log.debugm $ "loaded " ++ fst file ++ " - " ++ snd file - let get_fp = ml_hs_file . ms_location . pm_mod_summary . tm_parsed_module - Log.debugm $ "Typechecked modules for: " ++ (unlines $ map (show . get_fp) tcs) + (_, tcs) <- collectASTs logger $ (setTargetFilesWithMessage logger msg [file]) + liftIO $ logger <& LogLoaded (fst file) (snd file) `WithSeverity` Debug + liftIO $ logger <& LogTypechecked tcs `WithSeverity` Debug -- Find the specific module in the list of returned typechecked modules if it exists. let findMod [] = Nothing findMod (x:xs) = case get_fp x of @@ -71,19 +90,24 @@ -- together with all the typechecked modules that had to be loaded -- in order to typecheck the given target. loadFile :: (GhcMonad m) - => (FilePath, FilePath) -- ^ Target file to load. + => LogAction IO (WithSeverity Log) + -> (FilePath, FilePath) -- ^ Target file to load. -> m (Maybe TypecheckedModule, [TypecheckedModule]) -- ^ Typechecked module and modules that had to -- be loaded for the target. -loadFile = loadFileWithMessage (Just G.batchMsg) +loadFile logger = loadFileWithMessage logger (Just G.batchMsg) -- | Set the files as targets and load them. This will reset GHC's targets so only the modules you -- set as targets and its dependencies will be loaded or reloaded. -- Produced diagnostics will be printed similar to the normal output of GHC. -- To configure this, use 'setTargetFilesWithMessage'. -setTargetFiles :: GhcMonad m => [(FilePath, FilePath)] -> m () -setTargetFiles = setTargetFilesWithMessage (Just G.batchMsg) +setTargetFiles + :: GhcMonad m + => LogAction IO (WithSeverity Log) + -> [(FilePath, FilePath)] + -> m () +setTargetFiles logger = setTargetFilesWithMessage logger (Just G.batchMsg) msTargetIs :: ModSummary -> Target -> Bool msTargetIs ms t = case targetId t of @@ -102,25 +126,34 @@ -- | Set the files as targets and load them. This will reset GHC's targets so only the modules you -- set as targets and its dependencies will be loaded or reloaded. -setTargetFilesWithMessage :: (GhcMonad m) => Maybe G.Messager -> [(FilePath, FilePath)] -> m () -setTargetFilesWithMessage msg files = do +setTargetFilesWithMessage + :: (GhcMonad m) + => LogAction IO (WithSeverity Log) + -> Maybe G.Messager + -> [(FilePath, FilePath)] + -> m () +setTargetFilesWithMessage logger msg files = do targets <- forM files guessTargetMapped - Log.debugm $ "setTargets: " ++ show files + liftIO $ logger <& LogSetTargets files `WithSeverity` Debug G.setTargets targets mod_graph <- updateTime targets =<< depanal [] False - Log.debugm $ "modGraph: " ++ show (map ms_location $ Gap.mgModSummaries mod_graph) + liftIO $ logger <& LogModGraph mod_graph `WithSeverity` Debug void $ G.load' LoadAllTargets msg mod_graph -- | Add a hook to record the contents of any 'TypecheckedModule's which are produced -- during compilation. -collectASTs :: (GhcMonad m) => m a -> m (a, [TypecheckedModule]) -collectASTs action = do +collectASTs + :: (GhcMonad m) + => LogAction IO (WithSeverity Log) + -> m a + -> m (a, [TypecheckedModule]) +collectASTs logger action = do ref1 <- liftIO $ newIORef [] -- Modify session is much faster than `setSessionDynFlags`. - Gap.modifySession $ Gap.setFrontEndHooks (Just (astHook ref1)) + Gap.modifySession $ Gap.setFrontEndHooks (Just (astHook logger ref1)) res <- action tcs <- liftIO $ readIORef ref1 - -- Unset the hook so that we don't retain the reference ot the IORef so it can be gced. + -- Unset the hook so that we don't retain the reference to the IORef so it can be GCed. -- This stops the typechecked modules being retained in some cases. liftIO $ writeIORef ref1 [] Gap.modifySession $ Gap.setFrontEndHooks Nothing @@ -128,22 +161,28 @@ return (res, tcs) -- | This hook overwrites the default frontend action of GHC. -astHook :: IORef [TypecheckedModule] -> ModSummary -> Gap.Hsc Gap.FrontendResult -astHook tc_ref ms = ghcInHsc $ do - p <- G.parseModule =<< initializePluginsGhc ms +astHook + :: LogAction IO (WithSeverity Log) + -> IORef [TypecheckedModule] + -> ModSummary + -> Gap.Hsc Gap.FrontendResult +astHook logger tc_ref ms = ghcInHsc $ do + p <- G.parseModule =<< initializePluginsGhc logger ms tcm <- G.typecheckModule p let tcg_env = fst (tm_internals_ tcm) liftIO $ modifyIORef tc_ref (tcm :) return $ Gap.FrontendTypecheck tcg_env -initializePluginsGhc :: ModSummary -> Ghc ModSummary -initializePluginsGhc ms = do +initializePluginsGhc + :: GhcMonad m + => LogAction IO (WithSeverity Log) + -> ModSummary + -> m ModSummary +initializePluginsGhc logger ms = do hsc_env <- getSession (pluginsLoaded, pluginNames, newMs) <- liftIO $ Gap.initializePluginsForModSummary hsc_env ms - Log.debugm ("init-plugins(loaded):" ++ show pluginsLoaded) - Log.debugm ("init-plugins(specified):" ++ show (length pluginNames)) + liftIO $ logger <& LogInitPlugins pluginsLoaded pluginNames `WithSeverity` Debug return newMs - ghcInHsc :: Ghc a -> Gap.Hsc a ghcInHsc gm = do diff --git a/src/HIE/Bios/Internal/Debug.hs b/src/HIE/Bios/Internal/Debug.hs --- a/src/HIE/Bios/Internal/Debug.hs +++ b/src/HIE/Bios/Internal/Debug.hs @@ -2,6 +2,7 @@ module HIE.Bios.Internal.Debug (debugInfo, rootInfo, configInfo, cradleInfo) where import Control.Monad +import Colog.Core (LogAction (..), WithSeverity (..)) import Data.Void import qualified Data.Char as Char @@ -24,11 +25,12 @@ -- -- Otherwise, shows the error message and exit-code. debugInfo :: Show a - => FilePath + => LogAction IO (WithSeverity Log) + -> FilePath -> Cradle a -> IO String -debugInfo fp cradle = unlines <$> do - res <- getCompilerOptions fp cradle +debugInfo logger fp cradle = unlines <$> do + res <- getCompilerOptions logger fp cradle canonFp <- canonicalizePath fp conf <- findConfig canonFp crdl <- findCradle' canonFp diff --git a/src/HIE/Bios/Internal/Log.hs b/src/HIE/Bios/Internal/Log.hs deleted file mode 100644 --- a/src/HIE/Bios/Internal/Log.hs +++ /dev/null @@ -1,16 +0,0 @@ -module HIE.Bios.Internal.Log where - -import Control.Monad.IO.Class -import System.Log.Logger - -logm :: MonadIO m => String -> m () -logm s = liftIO $ infoM "hie-bios" s - -debugm :: MonadIO m => String -> m () -debugm s = liftIO $ debugM "hie-bios" s - -warningm :: MonadIO m => String -> m () -warningm s = liftIO $ warningM "hie-bios" s - -errorm :: MonadIO m => String -> m () -errorm s = liftIO $ errorM "hie-bios" s diff --git a/src/HIE/Bios/Types.hs b/src/HIE/Bios/Types.hs --- a/src/HIE/Bios/Types.hs +++ b/src/HIE/Bios/Types.hs @@ -1,16 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} module HIE.Bios.Types where import System.Exit +import qualified Colog.Core as L import Control.Exception ( Exception ) import Control.Monad import Control.Monad.IO.Class @@ -18,7 +13,9 @@ #if MIN_VERSION_base(4,9,0) import qualified Control.Monad.Fail as Fail #endif +import Data.Text.Prettyprint.Doc + data BIOSVerbosity = Silent | Verbose ---------------------------------------------------------------- @@ -40,8 +37,6 @@ , cradleOptsProg :: CradleAction a } deriving (Show, Functor) -type LoggingFunction = String -> IO () - data ActionName a = Stack | Cabal @@ -53,10 +48,19 @@ | Other a deriving (Show, Eq, Ord, Functor) +data Log = + LogAny String + | LogProcessOutput String + deriving Show + +instance Pretty Log where + pretty (LogAny s) = pretty s + pretty (LogProcessOutput s) = pretty s + data CradleAction a = CradleAction { actionName :: ActionName a -- ^ Name of the action. - , runCradle :: LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions) + , runCradle :: L.LogAction IO (L.WithSeverity Log) -> 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 @@ -138,7 +142,7 @@ #endif instance MonadTrans CradleLoadResultT where - lift = CradleLoadResultT . liftM CradleSuccess + lift = CradleLoadResultT . fmap CradleSuccess {-# INLINE lift #-} instance (MonadIO m) => MonadIO (CradleLoadResultT m) where diff --git a/tests/BiosTests.hs b/tests/BiosTests.hs --- a/tests/BiosTests.hs +++ b/tests/BiosTests.hs @@ -75,7 +75,7 @@ crdl <- initialiseCradle isMultiCradle (addTrailingPathSeparator tmpdir) step step "Load module A" withCurrentDirectory (cradleRootDir crdl) $ do - runCradle (cradleOptsProg crdl) (const (pure ())) "./a/A.hs" + runCradle (cradleOptsProg crdl) mempty "./a/A.hs" >>= \case CradleSuccess r -> componentOptions r `shouldMatchList` ["a"] <> argDynamic @@ -90,7 +90,7 @@ unlessM (doesFileExist "./b/A.hs") $ assertFailure "Test invariant broken, this file must exist." - runCradle (cradleOptsProg crdl) (const (pure ())) "./b/A.hs" + runCradle (cradleOptsProg crdl) mempty "./b/A.hs" >>= \case CradleSuccess r -> componentOptions r `shouldMatchList` ["b"] <> argDynamic @@ -105,7 +105,7 @@ unlessM (doesFileExist "./c/A.hs") $ assertFailure "Test invariant broken, this file must exist." - runCradle (cradleOptsProg crdl) (const (pure ())) "./c/A.hs" + runCradle (cradleOptsProg crdl) mempty "./c/A.hs" >>= \case CradleNone -> pure () _ -> assertFailure "Cradle loaded symlink" @@ -308,23 +308,27 @@ withCurrentDirectory (cradleRootDir crd) $ G.runGhc (Just libDir) $ do let relFp = makeRelative (cradleRootDir crd) a_fp - res <- initializeFlagsWithCradleWithMessage (Just (\_ n _ _ -> step (show n))) relFp crd + liftIO (step "Cradle load") + res <- initializeFlagsWithCradle mempty relFp crd handleCradleResult res $ \(ini, _) -> do liftIO (step "Initial module load") sf <- ini case sf of -- Test resetting the targets - Succeeded -> setTargetFilesWithMessage (Just (\_ n _ _ -> step (show n))) [(a_fp, a_fp)] + Succeeded -> do + liftIO (step "Set target files") + setTargetFiles mempty [(a_fp, a_fp)] Failed -> liftIO $ assertFailure "Module loading failed" testLoadFileCradleFail :: Cradle a -> FilePath -> (CradleError -> Assertion) -> (String -> IO ()) -> IO () testLoadFileCradleFail crd a_fp cradleErrorExpectation step = do + step "Loading cradle" -- don't spin up a ghc session, just run the opts program manually since -- we're not guaranteed to be able to get the ghc libdir if the cradle is -- failing withCurrentDirectory (cradleRootDir crd) $ do let relFp = makeRelative (cradleRootDir crd) a_fp - res <- runCradle (cradleOptsProg crd) (step . show) relFp + res <- runCradle (cradleOptsProg crd) mempty relFp case res of CradleSuccess _ -> liftIO $ assertFailure "Cradle loaded successfully" CradleNone -> liftIO $ assertFailure "Unexpected none-Cradle" @@ -341,7 +345,7 @@ withCurrentDirectory (cradleRootDir crd) $ G.runGhc (Just libDir) $ do let relFp = makeRelative (cradleRootDir crd) a_fp - res <- initializeFlagsWithCradleWithMessage (Just (\_ n _ _ -> step (show n))) relFp crd + res <- initializeFlagsWithCradleWithMessage mempty (Just (\_ n _ _ -> step (show n))) relFp crd handleCradleResult res $ \(_, options) -> liftIO $ dependencyPred (componentDependencies options) diff --git a/tests/ParserTests.hs b/tests/ParserTests.hs --- a/tests/ParserTests.hs +++ b/tests/ParserTests.hs @@ -81,6 +81,7 @@ , (".", CradleConfig [] None) ])) assertParserFails "keys-not-unique-fails.yaml" invalidYamlException + assertParser "cabal-empty-config.yaml" (noDeps (Cabal $ CabalType Nothing)) assertParser :: FilePath -> Config Void -> Assertion assertParser fp cc = do diff --git a/tests/configs/cabal-empty-config.yaml b/tests/configs/cabal-empty-config.yaml new file mode 100644 --- /dev/null +++ b/tests/configs/cabal-empty-config.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: