Timing

src/Server/Configuration.idr

@@ -57,6 +57,8 @@ record LSPConfiguration where
   longActionTimeout : Clock Duration
   ||| next id for requests to the server
   nextRequestId : Nat
+  ||| indent for duration
+  logDurationIndent : Nat
 
 ||| Server default configuration. Uses standard input and standard output for input/output.
 export
@@ -78,4 +80,5 @@ defaultConfig =
     , cachedHovers      = empty
     , longActionTimeout = makeDuration 5 0
     , nextRequestId     = 0
+    , logDurationIndent = 0
     }

src/Server/Log.idr

@@ -10,6 +10,8 @@ import Server.Utils
 import System.Directory
 import System.File
 import System.Path
+import System.Clock
+import Data.String.Extra
 
 %default total
 
@@ -61,6 +63,25 @@ export
 logShow : Ref LSPConf LSPConfiguration => Show a => Severity -> a -> Core ()
 logShow severity = logString severity . show
 
+export
+logDuration : Ref LSPConf LSPConfiguration => String -> Core a -> Core a
+logDuration desc action = do
+  logDurationIndent <- gets LSPConf logDurationIndent
+  let nano = 1000000000
+  logHandle <- gets LSPConf logHandle
+  startClock <- coreLift (clockTime Process)
+  let indent = replicate (logDurationIndent * 2) ' '
+  ignore $ coreLift $ fPutStrLn logHandle ("TIMING:  \{indent}\{desc} started")
+  modify LSPConf (record { logDurationIndent = logDurationIndent + 1 })
+  result <- action
+  modify LSPConf (record { logDurationIndent = logDurationIndent })
+  endClock <- coreLift (clockTime Process)
+  let duration = endClock `timeDifference` startClock
+  let nanoseconds = seconds duration * nano + nanoseconds duration
+  let milliseconds = nanoseconds `div` 1000000
+  ignore $ coreLift $ fPutStrLn logHandle ("TIMING:  \{indent}\{desc} took \{show milliseconds} ms")
+  pure result
+
 ||| Changes the log file location, if possible.
 export covering
 changeLogFile : Ref LSPConf LSPConfiguration => String -> Core ()

src/Server/Main.idr

@@ -65,21 +65,16 @@ parseHeaderPart h = do
     Just StartContent => pure $ Right Nothing
     Nothing => pure $ Right Nothing
 
-handleMessage : Ref LSPConf LSPConfiguration
-            => Ref Ctxt Defs
-            => Ref UST UState
-            => Ref Syn SyntaxInfo
-            => Ref MD Metadata
-            => Ref ROpts REPLOpts
-            => Core ()
-handleMessage = do
-  inputHandle <- gets LSPConf inputHandle
-  Right (Just l) <- parseHeaderPart inputHandle
-    | _ => sendUnknownResponseMessage parseError
-  Right msg <- coreLift $ fGetChars inputHandle l
-    | Left err => do
-      logShow Error (show err)
-      sendUnknownResponseMessage (internalError "Error while recovering the content part of a message")
+handleMessageString
+  :  Ref LSPConf LSPConfiguration
+  => Ref Ctxt Defs
+  => Ref UST UState
+  => Ref Syn SyntaxInfo
+  => Ref MD Metadata
+  => Ref ROpts REPLOpts
+  => String
+  -> Core ()
+handleMessageString msg = logDuration "handleMessageString" $ do
   logString Debug msg
   let Just msg = parse msg
     | _ => sendUnknownResponseMessage parseError
@@ -122,13 +117,32 @@ handleMessage = do
         | _ => sendUnknownResponseMessage (invalidRequest "Message does not have method or id")
       logString Warning "Ignoring response with id \{show idJSON}"
 
-runServer : Ref LSPConf LSPConfiguration
-         => Ref Ctxt Defs
-         => Ref UST UState
-         => Ref Syn SyntaxInfo
-         => Ref MD Metadata
-         => Ref ROpts REPLOpts
-         => Core ()
+handleMessage
+  : Ref LSPConf LSPConfiguration
+  => Ref Ctxt Defs
+  => Ref UST UState
+  => Ref Syn SyntaxInfo
+  => Ref MD Metadata
+  => Ref ROpts REPLOpts
+  => Core ()
+handleMessage = do
+  inputHandle <- gets LSPConf inputHandle
+  Right (Just l) <- parseHeaderPart inputHandle
+    | _ => sendUnknownResponseMessage parseError
+  Right msg <- coreLift $ fGetChars inputHandle l
+    | Left err => do
+      logShow Error (show err)
+      sendUnknownResponseMessage (internalError "Error while recovering the content part of a message")
+  handleMessageString msg
+
+runServer
+  :  Ref LSPConf LSPConfiguration
+  => Ref Ctxt Defs
+  => Ref UST UState
+  => Ref Syn SyntaxInfo
+  => Ref MD Metadata
+  => Ref ROpts REPLOpts
+  => Core ()
 runServer = do
   handleMessage
   runServer

src/Server/ProcessMessage.idr

@@ -80,7 +80,7 @@ loadURI : Ref LSPConf LSPConfiguration
        => Ref MD Metadata
        => Ref ROpts REPLOpts
        => InitializeParams -> URI -> Maybe Int -> Core (Either String ())
-loadURI conf uri version = do
+loadURI conf uri version = logDuration "loadURI \{uri.path}" $ do
   modify LSPConf (record {openFile = Just (uri, fromMaybe 0 version)})
   resetContext "(interactive)"
   let fpath = uri.path
@@ -101,8 +101,9 @@ loadURI conf uri version = do
                      logString Error msg
                      pure $ Left msg
   setSource res
-  errs <- buildDeps fname -- FIXME: the compiler always dumps the errors on stdout, requires
-                          --        a compiler change.
+  errs <- logDuration "buildDeps \{fname}" $ buildDeps fname
+  -- FIXME: the compiler always dumps the errors on stdout,
+  -- requires a compiler change.
   case errs of
     [] => pure ()
     (_::_) => modify LSPConf (record { errorFiles $= insert uri })
@@ -222,7 +223,8 @@ handleRequest Shutdown params = do
 handleRequest TextDocumentHover params = whenActiveRequest $ \conf => do
     False <- isDirty params.textDocument.uri
       | True => pure $ pure $ make $ MkNull
-    withURI conf params.textDocument.uri Nothing (pure $ pure $ make $ MkNull) $ do
+    withURI conf params.textDocument.uri Nothing (pure $ pure $ make $ MkNull) $
+    logDuration "Hover for loaded file \{params.textDocument.uri.path}" $ do
       Nothing <- gets LSPConf (map snd . head' . searchPos (cast params.position) . cachedHovers)
         | Just hover => do logString Debug "hover: found cached action"
                            pure $ pure $ make hover
@@ -260,7 +262,8 @@ handleRequest TextDocumentDefinition params = whenActiveRequest $ \conf => do
 handleRequest TextDocumentCodeAction params = whenActiveRequest $ \conf => do
     False <- isDirty params.textDocument.uri
       | True => pure $ pure $ make $ MkNull
-    withURI conf params.textDocument.uri Nothing (pure $ pure $ make $ MkNull) $ do
+    withURI conf params.textDocument.uri Nothing (pure $ pure $ make $ MkNull) $
+    logDuration "Code actions for loaded file \{params.textDocument.uri.path}" $ do
       quickfixActions <- map Just <$> gets LSPConf quickfixes
       exprSearchAction <- map Just <$> exprSearch params
       splitAction <- caseSplit params
@@ -289,7 +292,8 @@ handleRequest TextDocumentSignatureHelp params = whenActiveRequest $ \conf => do
 handleRequest TextDocumentDocumentSymbol params = whenActiveRequest $ \conf => do
     False <- isDirty params.textDocument.uri
       | True => pure $ pure $ make $ MkNull
-    withURI conf params.textDocument.uri Nothing (pure $ pure $ make $ MkNull) $ do
+    withURI conf params.textDocument.uri Nothing (pure $ pure $ make $ MkNull) $
+    logDuration "Document symbols for loaded file \{params.textDocument.uri.path}" $ do
       documentSymbolData <- documentSymbol params
       pure $ pure $ make documentSymbolData
 
@@ -307,7 +311,8 @@ handleRequest TextDocumentSemanticTokensFull params = whenActiveRequest $ \conf
       | True => pure $ Left (MkResponseError RequestCancelled "Document Dirty" JNull)
     False <- gets LSPConf (contains params.textDocument.uri . semanticTokensSentFiles)
       | True => pure $ Left (MkResponseError RequestCancelled "Semantic tokens already sent" JNull)
-    withURI conf params.textDocument.uri Nothing (pure $ Left (MkResponseError RequestCancelled "Document Errors" JNull)) $ do
+    withURI conf params.textDocument.uri Nothing (pure $ Left (MkResponseError RequestCancelled "Document Errors" JNull)) $
+    logDuration "Highlighing for loaded file \{params.textDocument.uri.path}" $ do
       md <- get MD
       src <- getSource
       let srcLines = forget $ lines src