diff --git a/exe/Main.hs b/exe/Main.hs index 3f71cc0a9..505ffeb7e 100644 --- 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 @@ main = do 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 index 6eddc3ded..99d493815 100644 --- a/hie-bios.cabal +++ b/hie-bios.cabal @@ -138,7 +138,6 @@ Library 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 +152,7 @@ Library 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 +161,7 @@ Library 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 +171,6 @@ Library 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 +183,13 @@ Executable hie-bios 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/Cradle.hs b/src/HIE/Bios/Cradle.hs index 5d90c111c..6d7f44a19 100644 --- a/src/HIE/Bios/Cradle.hs +++ b/src/HIE/Bios/Cradle.hs @@ -32,6 +32,7 @@ import Data.Void 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 +347,14 @@ multiCradle buildCustomCradle cur_dir cs = 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 +417,7 @@ biosCradle wdir biosCall biosDepsCall mbGhc = 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 +426,13 @@ biosDepsAction l wdir (Just biosDepsCall) fp = do 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,7 +692,12 @@ cabalGhcDirs workDir = do "" 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 deps <- cabalCradleDependencies workDir workDir @@ -822,7 +830,13 @@ stackCradleDependencies wdir componentDir syaml = do return $ map normalise $ cabalFiles ++ [relFp "package.yaml", stackYamlLocationOrDefault syaml] -stackAction :: FilePath -> Maybe String -> StackYaml -> LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions) +stackAction + :: FilePath + -> Maybe String + -> StackYaml + -> 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 +1013,7 @@ type OutputName = String -- * 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 +1027,7 @@ readProcessWithOutputs outputNames l workDir cp = flip runContT return $ do -- 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 <& LogAny msg `WithSeverity` Info) 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 index 6acbee74d..530b59201 100644 --- 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 index 072ce34e7..56dac0217 100644 --- a/src/HIE/Bios/Ghc/Api.hs +++ b/src/HIE/Bios/Ghc/Api.hs @@ -21,6 +21,7 @@ import qualified GhcMake as G 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 @@ import HIE.Bios.Flags -- | 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 index 4242ad01b..29635daa4 100644 --- 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 @@ import qualified DynFlags as G #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 @@ checkSyntax cradle files = do -- | 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 index 30e963dc0..426d6400b 100644 --- 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,7 +26,23 @@ import qualified HscMain as G #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. -- @@ -38,19 +57,19 @@ import qualified HIE.Bios.Internal.Log as Log -- 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 @@ loadFileWithMessage msg file = do -- 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,22 +126,31 @@ updateTime ts graph = liftIO $ do -- | 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 to the IORef so it can be GCed. @@ -128,23 +161,29 @@ collectASTs action = do 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 hsc_session <- Gap.getHscEnv diff --git a/src/HIE/Bios/Internal/Debug.hs b/src/HIE/Bios/Internal/Debug.hs index 173e99de5..c2f86da3a 100644 --- 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 @@ import System.Directory -- -- 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 index 15e660c1e..000000000 --- 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 index 515847c81..c6e7f1223 100644 --- a/src/HIE/Bios/Types.hs +++ b/src/HIE/Bios/Types.hs @@ -11,6 +11,7 @@ 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,6 +19,8 @@ import Control.Monad.Trans.Class #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 +43,6 @@ data Cradle a = Cradle { , cradleOptsProg :: CradleAction a } deriving (Show, Functor) -type LoggingFunction = String -> IO () - data ActionName a = Stack | Cabal @@ -53,10 +54,16 @@ data ActionName a | Other a deriving (Show, Eq, Ord, Functor) +data Log = LogAny String + deriving Show + +instance Pretty Log where + pretty (LogAny 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 diff --git a/tests/BiosTests.hs b/tests/BiosTests.hs index b98b30140..52bd77838 100644 --- a/tests/BiosTests.hs +++ b/tests/BiosTests.hs @@ -75,7 +75,7 @@ main = do 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 @@ main = do 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 @@ main = do 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 @@ testLoadFile crd a_fp step = do 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 @@ testLoadCradleDependencies cradlePred rootDir file dependencyPred step = 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)