Initial addition of logging to ide-backend #296

ide-backend-common/IdeSession/Util/Logger.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module IdeSession.Util.Logger
+  ( LogFunc
+  , logDebug
+  , logInfo
+  , logWarn
+  , logError
+  , logOther
+  ) where
+
+import qualified Control.Monad.Logger as L
+import           Data.Text (Text)
+import           Language.Haskell.TH
+
+type LogFunc = L.Loc -> L.LogSource -> L.LogLevel -> L.LogStr -> IO ()
+
+logDebug :: Q Exp
+logDebug = [| \msg -> L.runLoggingT ($(L.logDebug) msg) $(varE (mkName "logFunc")) |]
+
+logInfo :: Q Exp
+logInfo = [| \msg -> L.runLoggingT ($(L.logInfo) msg) $(varE (mkName "logFunc")) |]
+
+logWarn :: Q Exp
+logWarn = [| \msg -> L.runLoggingT ($(L.logWarn) msg) $(varE (mkName "logFunc")) |]
+
+logError :: Q Exp
+logError = [| \msg -> L.runLoggingT ($(L.logError) msg) $(varE (mkName "logFunc")) |]
+
+logOther :: Text -> Q Exp
+logOther level = [| \msg -> L.runLoggingT $(L.logOther level) $(varE (mkName "logFunc")) |]

ide-backend-common/ide-backend-common.cabal

@@ -15,6 +15,7 @@ extra-source-files:   README.md
 library
   exposed-modules:    IdeSession.Util
                       IdeSession.Util.BlockingOps
+                      IdeSession.Util.Logger
                       IdeSession.Util.PrettyVal
                       IdeSession.GHC.API
                       IdeSession.GHC.Requests
@@ -59,7 +60,8 @@ library
                       transformers         >= 0.3     && < 0.5,
                       attoparsec           >= 0.10    && < 0.14,
                       template-haskell,
-                      pretty-show          >= 1.3     && < 1.7
+                      pretty-show          >= 1.3     && < 1.7,
+                      monad-logger
 
   -- GHC.Generics lived in `ghc-prim` for GHC 7.2 & GHC 7.4
   if impl(ghc < 7.6)

ide-backend/IdeSession.hs

@@ -111,8 +111,11 @@ module IdeSession (
     -- ** Starting and stopping
   , IdeSession -- Abstract
   , initSession
+  , initSessionWithCallbacks
   , SessionInitParams(..)
   , defaultSessionInitParams
+  , IdeCallbacks(..)
+  , defaultIdeCallbacks
   , shutdownSession
   , forceShutdownSession
   , restartSession
@@ -236,7 +239,7 @@ import IdeSession.GHC.API
 import IdeSession.GHC.Client
 import IdeSession.Query
 import IdeSession.RPC.Client (ExternalException (..))
-import IdeSession.State (IdeSession)
+import IdeSession.State (IdeSession, IdeCallbacks(..), defaultIdeCallbacks)
 import IdeSession.Types.Progress
 import IdeSession.Types.Public
 import IdeSession.Update

ide-backend/IdeSession/ExeCabalClient.hs

@@ -7,27 +7,21 @@ module IdeSession.ExeCabalClient (
 
 import System.Exit (ExitCode)
 
-import Distribution.Verbosity (normal)
-import Distribution.Simple.Program.Find (
-    ProgramSearchPath
-  , findProgramOnSearchPath
-  , ProgramSearchPathEntry(..)
-  )
-
 import IdeSession.Cabal
 import IdeSession.Config
 import IdeSession.GHC.API
-import IdeSession.RPC.Client (RpcServer, RpcConversation(..), forkRpcServer, rpcConversation, shutdown)
+import IdeSession.RPC.Client (RpcServer, RpcConversation(..), forkRpcServer, rpcConversation, shutdown, findProgram)
 import IdeSession.State
 import IdeSession.Types.Progress
 import IdeSession.Util
 
 -- | Invoke the executable that processes our custom functions that use
 -- the machinery of the cabal library.
-invokeExeCabal :: IdeStaticInfo -> ExeCabalRequest -> (Progress -> IO ())
+invokeExeCabal :: IdeStaticInfo -> IdeCallbacks -> ExeCabalRequest -> (Progress -> IO ())
                -> IO ExitCode
-invokeExeCabal ideStaticInfo@IdeStaticInfo{..} args callback = do
-  mLoc <- findProgramOnSearchPath normal searchPath ide_backend_exe_cabal
+invokeExeCabal ideStaticInfo@IdeStaticInfo{..} ideCallbacks args callback = do
+  let logFunc = ideCallbacksLogFunc ideCallbacks
+  mLoc <- findProgram logFunc searchPath ide_backend_exe_cabal
   case mLoc of
     Nothing ->
       fail $ "Could not find ide-backend-exe-cabal"

ide-backend/IdeSession/GHC/Client.hs

@@ -50,13 +50,7 @@ import IdeSession.Util
 import IdeSession.Util.BlockingOps
 import qualified IdeSession.Types.Public as Public
 
-import Distribution.Verbosity (normal)
 import Distribution.Simple (PackageDB(..), PackageDBStack)
-import Distribution.Simple.Program.Find ( -- From our patched cabal
-    ProgramSearchPath
-  , findProgramOnSearchPath
-  , ProgramSearchPathEntry(..)
-  )
 
 {------------------------------------------------------------------------------
   Starting and stopping the server
@@ -67,11 +61,13 @@ forkGhcServer :: [String]      -- ^ Initial ghc options
               -> [FilePath]    -- ^ Relative includes
               -> [String]      -- ^ RTS options
               -> IdeStaticInfo -- ^ Session setup info
+              -> IdeCallbacks  -- ^ Session callbacks
               -> IO (Either ExternalException (GhcServer, GhcVersion))
-forkGhcServer ghcOpts relIncls rtsOpts ideStaticInfo = do
+forkGhcServer ghcOpts relIncls rtsOpts ideStaticInfo ideCallbacks = do
+  let logFunc = ideCallbacksLogFunc ideCallbacks
   when configInProcess $
     fail "In-process ghc server not currently supported"
-  mLoc <- findProgramOnSearchPath normal searchPath ide_backend_server
+  mLoc <- findProgram logFunc searchPath ide_backend_server
   case mLoc of
     Nothing ->
       fail $ "Could not find ide-backend-server"

ide-backend/IdeSession/RPC/Client.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell, CPP, ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell, CPP, ScopedTypeVariables, OverloadedStrings #-}
 module IdeSession.RPC.Client (
     RpcServer
   , RpcConversation(..)
@@ -12,14 +12,20 @@ module IdeSession.RPC.Client (
   , illscopedConversationException
   , serverKilledException
   , getRpcExitCode
+  , findProgram
   ) where
 
 import Control.Concurrent.MVar (MVar, newMVar, tryTakeMVar)
 import Control.Monad (void, unless)
 import Data.Binary (Binary, encode, decode)
 import Data.IORef (writeIORef, readIORef, newIORef)
+import Data.List (intercalate)
+import Data.Maybe (catMaybes)
+import Data.Monoid ((<>))
+import qualified Data.Text as Text
 import Data.Typeable (Typeable)
 import Prelude hiding (take)
+import System.Environment (lookupEnv)
 import System.Exit (ExitCode)
 import System.IO (Handle, hClose)
 import System.IO.Temp (openTempFile)
@@ -37,8 +43,15 @@ import System.Process
 import System.Process.Internals (withProcessHandle, ProcessHandle__(..))
 import qualified Control.Exception as Ex
 import qualified System.Directory  as Dir
+import Distribution.Verbosity (normal)
+import Distribution.Simple.Program.Find (
+    findProgramOnSearchPath
+  , ProgramSearchPath
+  , ProgramSearchPathEntry(..)
+  )
 
 import IdeSession.Util.BlockingOps
+import IdeSession.Util.Logger
 import IdeSession.RPC.API
 import IdeSession.RPC.Stream
 
@@ -322,3 +335,16 @@ mapIOToExternal server p = Ex.catch p $ \ex -> do
     then Ex.throwIO (serverKilledException (Just ex))
     else Ex.throwIO (ExternalException merr (Just ex))
 
+findProgram :: LogFunc -> ProgramSearchPath -> FilePath -> IO (Maybe FilePath)
+findProgram logFunc searchPath prog = do
+    shownPath <- renderPath searchPath
+    $logInfo $ "Searching for " <> Text.pack prog <> " on this path: " <> Text.pack shownPath
+    mres <- findProgramOnSearchPath normal searchPath prog
+    $logInfo $ case mres of
+      Nothing -> "Failed to find " <> Text.pack prog
+      Just res -> "Found " <> Text.pack prog <> " - using this one: " <> Text.pack res
+    return mres
+  where
+    renderPath = fmap (intercalate ":" . catMaybes) . mapM pathEntryString
+    pathEntryString (ProgramSearchPathDir fp) = return (Just fp)
+    pathEntryString ProgramSearchPathDefault = lookupEnv "PATH"

ide-backend/IdeSession/State.hs

@@ -13,6 +13,7 @@ module IdeSession.State
   , ManagedFile
   , GhcServer(..)
   , RunActions(..)
+  , IdeCallbacks(..)
     -- * Accessors
   , ideLogicalTimestamp
   , ideComputed
@@ -38,6 +39,9 @@ module IdeSession.State
   -- * To allow for non-server environments
   , ideSourceDir
   , ideDataDir
+  -- * Callbacks
+  , defaultIdeCallbacks
+  , ideLogFunc
   ) where
 
 import Control.Concurrent (ThreadId)
@@ -54,6 +58,7 @@ import IdeSession.Strict.Container
 import IdeSession.Strict.MVar (StrictMVar)
 import IdeSession.Types.Private hiding (RunResult)
 import qualified IdeSession.Types.Public as Public
+import IdeSession.Util.Logger
 
 import System.FilePath ((</>))
 
@@ -98,6 +103,7 @@ data Computed = Computed {
 data IdeSession = IdeSession {
     ideStaticInfo :: IdeStaticInfo
   , ideState      :: StrictMVar IdeSessionState
+  , ideCallbacks  :: IdeCallbacks
   }
 
 data IdeStaticInfo = IdeStaticInfo {
@@ -213,6 +219,12 @@ data RunActions a = RunActions {
   , forceCancel :: IO ()
   }
 
+-- | Session callbacks.  Currently this just configures how logging is
+-- handled.
+data IdeCallbacks = IdeCallbacks
+  { ideCallbacksLogFunc :: LogFunc
+  }
+
 {------------------------------------------------------------------------------
   Accessors
 ------------------------------------------------------------------------------}
@@ -281,3 +293,24 @@ ideDataDir IdeStaticInfo{..} =
   case configLocalWorkingDir ideConfig of
     Just path -> path
     Nothing   -> ideSessionDir </> "data"
+
+{------------------------------------------------------------------------------
+  Callbacks
+------------------------------------------------------------------------------}
+
+-- | Default session configuration.
+--
+-- Use this instead of creating your own IdeCallbacks to be robust
+-- against extensions of IdeCallbacks.
+--
+-- >> defaultIdeCallbacks = IdeCallbacks
+-- >>  { ideCallbacksLogFunc = \_ _ _ _ -> return ()
+-- >>  }
+defaultIdeCallbacks :: IdeCallbacks
+defaultIdeCallbacks = IdeCallbacks
+  { ideCallbacksLogFunc = \_ _ _ _ -> return ()
+  }
+
+-- | Get the 'LogFunc' for use with the functions in "IdeSession.Util.Logger"
+ideLogFunc :: IdeSession -> LogFunc
+ideLogFunc = ideCallbacksLogFunc . ideCallbacks

ide-backend/IdeSession/Update.hs

@@ -1,10 +1,11 @@
-{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, ScopedTypeVariables, TemplateHaskell #-}
+{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, ScopedTypeVariables, TemplateHaskell, OverloadedStrings #-}
 -- | IDE session updates
 --
 -- We should only be using internal types here (explicit strictness/sharing)
 module IdeSession.Update (
     -- * Starting and stopping
     initSession
+  , initSessionWithCallbacks
   , SessionInitParams(..)
   , defaultSessionInitParams
   , shutdownSession
@@ -85,6 +86,7 @@ import IdeSession.Update.ExecuteSessionUpdate
 import IdeSession.Update.IdeSessionUpdate
 import IdeSession.Util
 import IdeSession.Util.BlockingOps
+import IdeSession.Util.Logger
 import qualified IdeSession.Query         as Query
 import qualified IdeSession.Strict.List   as List
 import qualified IdeSession.Strict.Map    as Map
@@ -181,7 +183,16 @@ writeMacros IdeStaticInfo{ideConfig = SessionConfig {..}, ..}
 -- Throws an exception if the configuration is invalid, or if GHC_PACKAGE_PATH
 -- is set.
 initSession :: SessionInitParams -> SessionConfig -> IO IdeSession
-initSession initParams@SessionInitParams{..} ideConfig@SessionConfig{..} = do
+initSession = initSessionWithCallbacks defaultIdeCallbacks
+
+-- | Like 'initSession', but also takes a 'IdeCallbacks'.
+--
+-- Since 0.10.0
+initSessionWithCallbacks :: IdeCallbacks -> SessionInitParams -> SessionConfig -> IO IdeSession
+initSessionWithCallbacks ideCallbacks initParams@SessionInitParams{..} ideConfig@SessionConfig{..} = do
+  let logFunc = ideCallbacksLogFunc ideCallbacks
+  --FIXME: add version info here.
+  $logInfo "Initializing ide-backend session"
   -- verifyConfig used to bail if GHC_PACKAGE_PATH was set.  Instead,
   -- we just unset it so that cabal invocations are happy.  It's up to
   -- the user of ide-backend to set 'configPackageDBStack' based on
@@ -191,14 +202,16 @@ initSession initParams@SessionInitParams{..} ideConfig@SessionConfig{..} = do
 
   configDirCanon <- Dir.canonicalizePath configDir
   ideSessionDir  <- createTempDirectory configDirCanon "session."
+  $logDebug $ "Session dir = " <> Text.pack ideSessionDir
   let ideDistDir = fromMaybe (ideSessionDir </> "dist/") sessionInitDistDir
+  $logDebug $ "Dist dir = " <> Text.pack ideDistDir
 
   let ideStaticInfo = IdeStaticInfo{..}
 
   -- Create the common subdirectories of session.nnnn so that we don't have to
   -- worry about creating these elsewhere
   case configLocalWorkingDir of
-    Just _  -> return ()
+    Just dir -> $logDebug $ "Local working dir = " <> Text.pack dir
     Nothing -> do
       Dir.createDirectoryIfMissing True (ideSourceDir  ideStaticInfo)
       Dir.createDirectoryIfMissing True (ideDataDir    ideStaticInfo)
@@ -212,6 +225,7 @@ initSession initParams@SessionInitParams{..} ideConfig@SessionConfig{..} = do
                            sessionInitRelativeIncludes
                            sessionInitRtsOpts
                            ideStaticInfo
+                           ideCallbacks
   let (state, server, version) = case mServer of
          Right (s, v) -> (IdeSessionIdle,         s,          v)
          Left e       -> (IdeSessionServerDied e, Ex.throw e, Ex.throw e)
@@ -326,14 +340,19 @@ data RestartResult =
 
 executeRestart :: SessionInitParams
                -> IdeStaticInfo
+               -> IdeCallbacks
                -> IdeIdleState
                -> IO RestartResult
-executeRestart initParams@SessionInitParams{..} staticInfo idleState = do
+executeRestart initParams@SessionInitParams{..} staticInfo ideCallbacks idleState = do
+  let logFunc = ideCallbacksLogFunc ideCallbacks
+  $logInfo "Restarting ide-backend-server"
   forceShutdownGhcServer $ _ideGhcServer idleState
   mServer <- forkGhcServer sessionInitGhcOptions
                            sessionInitRelativeIncludes
                            sessionInitRtsOpts
                            staticInfo
+                           ideCallbacks
+
   case mServer of
     Right (server, version) -> do
       execInitParams staticInfo initParams
@@ -384,14 +403,14 @@ updateSession :: IdeSession -> IdeSessionUpdate -> (Progress -> IO ()) -> IO ()
 updateSession = flip . updateSession'
 
 updateSession' :: IdeSession -> (Progress -> IO ()) -> IdeSessionUpdate -> IO ()
-updateSession' IdeSession{ideStaticInfo, ideState} callback = \update ->
+updateSession' IdeSession{ideStaticInfo, ideState, ideCallbacks} callback = \update ->
     $modifyStrictMVar_ ideState $ go False update
   where
     go :: Bool -> IdeSessionUpdate -> IdeSessionState -> IO IdeSessionState
     go justRestarted update (IdeSessionIdle idleState) =
       if not (requiresSessionRestart idleState update)
         then do
-          (idleState', mex) <- runSessionUpdate justRestarted update ideStaticInfo callback idleState
+          (idleState', mex) <- runSessionUpdate justRestarted update ideStaticInfo callback ideCallbacks idleState
           case mex of
             Nothing -> return $ IdeSessionIdle          idleState'
             Just ex -> return $ IdeSessionServerDied ex idleState'
@@ -412,7 +431,7 @@ updateSession' IdeSession{ideStaticInfo, ideState} callback = \update ->
       -- TODO: I wish I knew why this is necessary :(
       threadDelay 100000
 
-      restartResult <- executeRestart restartParams ideStaticInfo idleState
+      restartResult <- executeRestart restartParams ideStaticInfo ideCallbacks idleState
       case restartResult of
         ServerRestarted idleState' resetSession ->
           go True (resetSession <> update) (IdeSessionIdle idleState')