initial contravariant logging style for HLS wrapper

Author: eddiemundo

exe/Wrapper.hs

@@ -9,12 +9,12 @@ import           Control.Exception            (SomeException, catch, throwIO)
 import           Control.Monad.Extra
 import           Data.Default
 import           Data.Foldable
+import           Data.Text                    (Text)
 import qualified Data.Text                    as Text
 import           Data.Void
 import qualified Development.IDE.Session      as Session
-import           Development.IDE.Types.Logger (LogMessage, Recorder,
-                                               logException, logInfo,
-                                               withLogMessageRecorder)
+import           Development.IDE.Types.Logger (Recorder, cmap, logWith,
+                                               withDefaultTextRecorder)
 import qualified HIE.Bios.Environment         as HieBios
 import           HIE.Bios.Types
 import           Ide.Arguments
@@ -23,10 +23,56 @@ import           System.Directory
 import           System.Environment
 import           System.Exit
 import           System.FilePath
-import           System.IO
 import           System.Info
 import           System.Process
 
+data Log
+  = LogProgram { name :: !String, arguments :: ![String], version :: !String }
+  -- logInfo recorder $ "Run entered for haskell-language-server-wrapper(" <> Text.pack progName <> ") "
+  --                    <> Text.pack hlsVersion
+  -- logInfo recorder $ "Arguments: " <> (Text.pack . show) args
+  | LogCurrentDirectory !FilePath
+  -- logInfo recorder $ "Current directory: " <> Text.pack d
+  | LogOs !String
+  -- logInfo recorder $ "Operating system: " <> Text.pack os
+  | LogCradle !(Cradle Void)
+  -- logInfo recorder $ "Cradle directory: " <> Text.pack (cradleRootDir cradle)
+  -- logInfo recorder $ "Cradle type: " <> (Text.pack . show) (actionName (cradleOptsProg cradle))
+  | LogBuildTools !ProgramsOfInterest
+  -- logInfo recorder ""
+  -- logInfo recorder "Tool versions found on the $PATH"
+  -- logInfo recorder $ Text.pack $ showProgramVersionOfInterest programsOfInterest
+  -- logInfo recorder ""
+  | LogGhcVersion LogGhcVersionMessage
+  -- logInfo recorder "Consulting the cradle to get project GHC version..."
+  | LogExeCandidates ![Text]
+  -- logInfo recorder $ "haskell-language-server exe candidates: " <> (Text.pack . show) candidates
+  | LogExeNotFound
+  -- logInfo recorder $ "Cannot find any haskell-language-server exe, looked for: " <> Text.intercalate ", " candidates
+  | LogExeFound !FilePath
+  -- logInfo recorder $ "Launching haskell-language-server exe at:" <> Text.pack e
+  | LogException !SomeException
+  | LogHieYamlFound { initialPath :: !FilePath, path :: !FilePath }
+  -- hPutStrLn stderr $ "Found \"" ++ yaml ++ "\" for \"" ++ initialFp ++ "\""
+  | LogHieYamlNotFound
+  -- hPutStrLn stderr "No 'hie.yaml' found. Try to discover the project type!"
+  | LogHieBios !String
+  deriving Show
+
+data LogGhcVersionMessage
+  = LogGhcVersionCradleSuccess !String
+  -- logInfo recorder $ "Project GHC version: " <> Text.pack ghcVersion
+  | LogGhcVersionCradleFail !CradleError
+  -- die $ "Failed to get project GHC version:" ++ show error
+  | LogGhcVersionCradleNone
+  -- die "Failed get project GHC version, since we have a none cradle"
+  | LogGhcVersionToolNotFound !FilePath
+  -- die $ "Cradle requires " ++ exe ++ " but couldn't find it" ++ "\n"
+  --  ++ show cradle
+  deriving Show
+
+logToText :: Log -> Text
+logToText = Text.pack . show
 -- ---------------------------------------------------------------------
 
 main :: IO ()
@@ -39,7 +85,8 @@ main = do
         Ghcide GhcideArguments{ argsLogFile } -> argsLogFile
         _                                     -> Nothing
 
-  withLogMessageRecorder logFilePath $ \recorder ->
+  withDefaultTextRecorder logFilePath $ \textRecorder -> do
+    let logRecorder = cmap logToText textRecorder
     catch
       (do
         hlsVer <- haskellLanguageServerVersion
@@ -57,69 +104,64 @@ main = do
                 putStrLn haskellLanguageServerNumericVersion
 
             BiosMode PrintCradleType ->
-                print =<< findProjectCradle recorder
+                print =<< findProjectCradle mempty
 
-            _ -> launchHaskellLanguageServer recorder args
+            _ -> launchHaskellLanguageServer logRecorder args
       )
-      (\e -> logException recorder (e :: SomeException) *> throwIO e)
+      (\e -> logWith logRecorder (LogException e) *> throwIO e)
 
-launchHaskellLanguageServer :: Recorder LogMessage -> Arguments -> IO ()
+launchHaskellLanguageServer :: Recorder Log -> Arguments -> IO ()
 launchHaskellLanguageServer recorder parsedArgs = do
+  let ghcVersionRecorder = cmap LogGhcVersion recorder
+
   case parsedArgs of
     Ghcide GhcideArguments{..} -> whenJust argsCwd setCurrentDirectory
     _                          -> pure ()
 
   d <- getCurrentDirectory
+  logWith recorder $ LogCurrentDirectory d
 
   -- search for the project cradle type
   cradle <- findProjectCradle recorder
+  logWith recorder $ LogCradle cradle
 
   -- Get the root directory from the cradle
   setCurrentDirectory $ cradleRootDir cradle
 
   case parsedArgs of
     Ghcide GhcideArguments{..} ->
-      when argsProjectGhcVersion $ getRuntimeGhcVersion' cradle >>= putStrLn >> exitSuccess
+      when argsProjectGhcVersion $ getRuntimeGhcVersion' ghcVersionRecorder cradle >>= putStrLn >> exitSuccess
     _ -> pure ()
 
   progName <- getProgName
-  logInfo recorder $ "Run entered for haskell-language-server-wrapper(" <> Text.pack progName <> ") "
-                     <> Text.pack hlsVersion
-  logInfo recorder $ "Current directory: " <> Text.pack d
-  logInfo recorder $ "Operating system: " <> Text.pack os
   args <- getArgs
-  logInfo recorder $ "Arguments: " <> (Text.pack . show) args
-  logInfo recorder $ "Cradle directory: " <> Text.pack (cradleRootDir cradle)
-  logInfo recorder $ "Cradle type: " <> (Text.pack . show) (actionName (cradleOptsProg cradle))
+  logWith recorder $ LogProgram progName args hlsVersion
+  logWith recorder $ LogOs os
   programsOfInterest <- findProgramVersions
-  logInfo recorder ""
-  logInfo recorder "Tool versions found on the $PATH"
-  logInfo recorder $ Text.pack $ showProgramVersionOfInterest programsOfInterest
-  logInfo recorder ""
+  logWith recorder $ LogBuildTools programsOfInterest
   -- Get the ghc version -- this might fail!
-  logInfo recorder "Consulting the cradle to get project GHC version..."
-  ghcVersion <- getRuntimeGhcVersion' cradle
-  logInfo recorder $ "Project GHC version: " <> Text.pack ghcVersion
+  ghcVersion <- getRuntimeGhcVersion' ghcVersionRecorder cradle
 
   let
     hlsBin = "haskell-language-server-" <> Text.pack ghcVersion
     candidates' = [hlsBin, "haskell-language-server"]
     candidates = map (<> Text.pack exeExtension) candidates'
 
-  logInfo recorder $ "haskell-language-server exe candidates: " <> (Text.pack . show) candidates
+  logWith recorder $ LogExeCandidates candidates
 
   mexes <- traverse (findExecutable . Text.unpack) candidates
 
   case asum mexes of
-    Nothing -> logInfo recorder $ "Cannot find any haskell-language-server exe, looked for: " <> Text.intercalate ", " candidates
+    Nothing ->
+      logWith recorder LogExeNotFound
     Just e -> do
-      logInfo recorder $ "Launching haskell-language-server exe at:" <> Text.pack e
+      logWith recorder $ LogExeFound e
       callProcess e args
 
 -- | Version of 'getRuntimeGhcVersion' that dies if we can't get it, and also
 -- checks to see if the tool is missing if it is one of
-getRuntimeGhcVersion' :: Show a => Cradle a -> IO String
-getRuntimeGhcVersion' cradle = do
+getRuntimeGhcVersion' :: Recorder LogGhcVersionMessage -> Cradle a -> IO String
+getRuntimeGhcVersion' recorder cradle = do
 
   -- See if the tool is installed
   case actionName (cradleOptsProg cradle) of
@@ -132,19 +174,24 @@ getRuntimeGhcVersion' cradle = do
   ghcVersionRes <- HieBios.getRuntimeGhcVersion cradle
   case ghcVersionRes of
     CradleSuccess ver -> do
+      logWith recorder $ LogGhcVersionCradleSuccess ver
       return ver
-    CradleFail error -> die $ "Failed to get project GHC version:" ++ show error
-    CradleNone -> die "Failed get project GHC version, since we have a none cradle"
+    CradleFail error -> do
+      logWith recorder $ LogGhcVersionCradleFail error
+      exitFailure
+    CradleNone -> do
+      logWith recorder LogGhcVersionCradleNone
+      exitFailure
   where
     checkToolExists exe = do
       exists <- findExecutable exe
       case exists of
         Just _ -> pure ()
-        Nothing ->
-          die $ "Cradle requires " ++ exe ++ " but couldn't find it" ++ "\n"
-           ++ show cradle
+        Nothing -> do
+          logWith recorder $ LogGhcVersionToolNotFound exe
+          exitFailure
 
-findProjectCradle :: Recorder LogMessage -> IO (Cradle Void)
+findProjectCradle :: Recorder Log -> IO (Cradle Void)
 findProjectCradle recorder = do
   d <- getCurrentDirectory
 
@@ -153,7 +200,7 @@ findProjectCradle recorder = do
 
   -- Some log messages
   case hieYaml of
-    Just yaml -> hPutStrLn stderr $ "Found \"" ++ yaml ++ "\" for \"" ++ initialFp ++ "\""
-    Nothing -> hPutStrLn stderr "No 'hie.yaml' found. Try to discover the project type!"
+    Just yaml -> logWith recorder $ LogHieYamlFound initialFp yaml
+    Nothing   -> logWith recorder LogHieYamlNotFound
 
-  Session.loadCradle def recorder hieYaml d
+  Session.loadCradle def (cmap LogHieBios recorder) hieYaml d

ghcide/session-loader/Development/IDE/Session.hs

@@ -103,7 +103,7 @@ data SessionLoadingOptions = SessionLoadingOptions
   -- | Load the cradle with an optional 'hie.yaml' location.
   -- If a 'hie.yaml' is given, use it to load the cradle.
   -- Otherwise, use the provided project root directory to determine the cradle type.
-  , loadCradle             :: Recorder LogMessage -> Maybe FilePath -> FilePath -> IO (HieBios.Cradle Void)
+  , loadCradle             :: Recorder String -> Maybe FilePath -> FilePath -> IO (HieBios.Cradle Void)
   -- | Given the project name and a set of command line flags,
   --   return the path for storing generated GHC artifacts,
   --   or 'Nothing' to respect the cradle setting
@@ -136,7 +136,7 @@ instance Default SessionLoadingOptions where
 -- using the provided root directory for discovering the project.
 -- The implicit config uses different heuristics to determine the type
 -- of the project that may or may not be accurate.
-loadWithImplicitCradle :: Recorder LogMessage
+loadWithImplicitCradle :: Recorder String
                           -> Maybe FilePath
                           -- ^ Optional 'hie.yaml' location. Will be used if given.
                           -> FilePath
@@ -147,13 +147,13 @@ loadWithImplicitCradle recorder mHieYaml rootDir = do
   cradle@Cradle{ cradleOptsProg = cradleOptsProg@CradleAction{ runCradle } } <- case mHieYaml of
     Just yaml -> HieBios.loadCradle yaml
     Nothing   -> loadImplicitHieCradle $ addTrailingPathSeparator rootDir
-  let runCradleWithLogger = \_ -> runCradle (logDebug recorder . ("hie-bios - " <>) . T.pack)
+  let runCradleWithLogger = \_ -> runCradle (logWith recorder)
   pure cradle{ cradleOptsProg = cradleOptsProg{ runCradle = runCradleWithLogger } }
 
 getInitialGhcLibDirDefault :: Recorder LogMessage -> FilePath -> IO (Maybe LibDir)
 getInitialGhcLibDirDefault logger rootDir = do
   hieYaml <- findCradle def rootDir
-  cradle <- loadCradle def logger hieYaml rootDir
+  cradle <- loadCradle def mempty hieYaml rootDir
   logDebug logger $ T.pack $ "setInitialDynFlags cradle: " ++ show cradle
   libDirRes <- getRuntimeGhcLibDir cradle
   case libDirRes of
@@ -520,7 +520,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
            when (isNothing hieYaml) $
              logWarning recorder $ implicitCradleWarning lfp
 
-           cradle <- loadCradle recorder hieYaml dir
+           cradle <- loadCradle (cmap LogHieBios recorder) hieYaml dir
            lfp <- flip makeRelative cfp <$> getCurrentDirectory
 
            when optTesting $ mRunLspT lspEnv $

ghcide/src/Development/IDE/Types/Logger.hs

@@ -15,9 +15,10 @@ module Development.IDE.Types.Logger
   , threadSafeTextStderrRecorder
   , withTextFileRecorder
   , makeDefaultStderrRecorder
+  , withDefaultTextRecorder
   , withLogMessageRecorder
   , withMinPriority
-  , logPriority, logException, logError, logWarning, logInfo, logDebug, logTelemetry
+  , logWith, logPriority, logException, logError, logWarning, logInfo, logDebug, logTelemetry
   , noopRecorder, noLogging
   , cmap, cmapIO, cfilter
   ) where
@@ -56,6 +57,7 @@ data Priority
 
 data LogMessage =
   LogOther LogOtherMessage
+  | LogHieBios !String
 
 data LogOtherMessage = LogOtherMessage
   { stack    :: !CallStack
@@ -71,6 +73,9 @@ data Recorder msg = Recorder
   , tracer :: forall a m. (HasCallStack, MonadUnliftIO m) => msg -> m a -> m a
   }
 
+logWith :: (HasCallStack, MonadIO m) => Recorder msg -> msg -> m ()
+logWith recorder msg = withFrozenCallStack $ logger recorder msg
+
 instance Semigroup (Recorder msg) where
   (<>) Recorder{ logger = logger1, tracer = tracer1 } Recorder{ logger = logger2, tracer = tracer2 } =
     Recorder
@@ -134,12 +139,26 @@ threadSafeTextStderrRecorder = do
     , tracer = \msg action -> withRunInIO $ \runInIO -> withLock lock $ runInIO (tracer msg action)
     }
 
-withTextFileRecorder :: FilePath -> (Recorder Text -> IO a) -> IO a
-withTextFileRecorder path action = withFile path AppendMode $ action . textHandleRecorder
+makeThreadSafeTextStderrRecorder :: MonadIO m => m (Recorder Text)
+makeThreadSafeTextStderrRecorder = do
+  liftIO threadSafeTextStderrRecorder
+
+withTextFileRecorder :: MonadUnliftIO m => FilePath -> (Recorder Text -> m a) -> m a
+withTextFileRecorder path action = withRunInIO $ \runInIO -> withFile path AppendMode $ \handle ->
+  runInIO (action (textHandleRecorder handle))
 
 withMinPriority :: Priority -> Recorder LogMessage -> Recorder LogMessage
 withMinPriority minPriority recorder = cfilter (\(LogOther LogOtherMessage{priority}) -> priority >= minPriority) recorder
 
+-- | if no file path given use stderr, else use stderr and file
+withDefaultTextRecorder :: MonadUnliftIO m => Maybe FilePath -> (Recorder Text -> m a) -> m a
+withDefaultTextRecorder path action = do
+  textStderrRecorder <- makeThreadSafeTextStderrRecorder
+  case path of
+    Nothing -> action textStderrRecorder
+    Just path -> withTextFileRecorder path $ \textFileRecorder ->
+      action (textStderrRecorder <> textFileRecorder)
+
 -- | if no file path use stderr recorder, else use stderr and file recorder
 withLogMessageRecorder :: Maybe FilePath -> (Recorder LogMessage -> IO a) -> IO a
 withLogMessageRecorder path action = do

src/Ide/Main.hs

@@ -62,7 +62,7 @@ defaultMain recorder args idePlugins = do
         BiosMode PrintCradleType -> do
             dir <- IO.getCurrentDirectory
             hieYaml <- Session.findCradle def dir
-            cradle <- Session.loadCradle def recorder hieYaml dir
+            cradle <- Session.loadCradle def mempty hieYaml dir
             print cradle
 
         Ghcide ghcideArgs -> do

src/Ide/Version.hs

@@ -39,6 +39,7 @@ data ProgramsOfInterest = ProgramsOfInterest
   , stackVersion :: Maybe Version
   , ghcVersion   :: Maybe Version
   }
+  deriving Show
 
 showProgramVersionOfInterest :: ProgramsOfInterest -> String
 showProgramVersionOfInterest ProgramsOfInterest {..} =