hie-bios 0.9.1 → 0.10.0

raw patch · 16 files changed

+449/−326 lines, 16 filesdep +co-log-coredep +prettyprinterdep −hsloggerdep ~aesonPVP ok

version bump matches the API change (PVP)

Dependencies added: co-log-core, prettyprinter

Dependencies removed: hslogger

Dependency ranges changed: aeson

API changes (from Hackage documentation)

Files

• ChangeLog.md +10/−0
• exe/Main.hs +11/−4
• hie-bios.cabal +7/−4
• src/HIE/Bios/Config.hs +47/−190
• src/HIE/Bios/Config/YAML.hs +176/−0
• src/HIE/Bios/Cradle.hs +53/−28
• src/HIE/Bios/Flags.hs +7/−17
• src/HIE/Bios/Ghc/Api.hs +8/−5
• src/HIE/Bios/Ghc/Check.hs +30/−14
• src/HIE/Bios/Ghc/Load.hs +67/−28
• src/HIE/Bios/Internal/Debug.hs +5/−3
• src/HIE/Bios/Internal/Log.hs +0/−16
• src/HIE/Bios/Types.hs +14/−10
• tests/BiosTests.hs +11/−7
• tests/ParserTests.hs +1/−0
• tests/configs/cabal-empty-config.yaml +2/−0

@@ -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)

@@ -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 \""

@@ -1,6 +1,6 @@ Cabal-Version:          2.2 Name:                   hie-bios-Version:                0.9.1+Version:                0.10.0 Author:                 Matthew Pickering <matthewtpickering@gmail.com> Maintainer:             Matthew Pickering <matthewtpickering@gmail.com> 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

@@ -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

@@ -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

@@ -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) ->

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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) 

@@ -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

@@ -0,0 +1,2 @@+cradle:+  cabal: