Move logging from hslogger to co-log

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

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

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

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

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

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)