Skip to content

Commit a9c525c

Browse files
kritzcreekkritzcreek
committed
[psc-ide] more finegrained logging
1 parent 9ded0a3 commit a9c525c

File tree

9 files changed

+71
-41
lines changed

9 files changed

+71
-41
lines changed

‎psc-ide-server/Main.hs‎

Lines changed: 19 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -41,7 +41,6 @@ import Network.Socket hiding (PortNumber, Type,
4141
sClose)
4242
import Options.Applicative (ParseError (..))
4343
import qualified Options.Applicative as Opts
44-
import System.Clock
4544
import System.Directory
4645
import System.Info as SysInfo
4746
import System.FilePath
@@ -70,11 +69,12 @@ data Options = Options
7069
, optionsNoWatch :: Bool
7170
, optionsPolling :: Bool
7271
, optionsDebug :: Bool
72+
, optionsLoglevel :: IdeLogLevel
7373
} deriving (Show)
7474

7575
main :: IO ()
7676
main = do
77-
opts'@(Options dir globs outputPath port noWatch polling debug) <- Opts.execParser opts
77+
opts'@(Options dir globs outputPath port noWatch debug logLevel) <- Opts.execParser opts
7878
when debug (putText "Parsed Options:" *> print opts')
7979
maybe (pure ()) setCurrentDirectory dir
8080
ideState <- newTVarIO emptyIdeState
@@ -89,8 +89,8 @@ main = do
8989

9090
unless noWatch $
9191
void (forkFinally (watcher polling ideState fullOutputPath) print)
92-
93-
let conf = Configuration {confDebug = debug, confOutputPath = outputPath, confGlobs = globs}
92+
-- TODO: deprecate and get rid of `debug`
93+
let conf = Configuration {confLogLevel = if debug then LogDebug else logLevel, confOutputPath = outputPath, confGlobs = globs}
9494
env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf}
9595
startServer port env
9696
where
@@ -104,7 +104,16 @@ main = do
104104
<*> Opts.switch (Opts.long "no-watch")
105105
<*> flipIfWindows (Opts.switch (Opts.long "polling"))
106106
<*> Opts.switch (Opts.long "debug")
107+
<*> (parseLogLevel <$> Opts.strOption
108+
(Opts.long "log-level"
109+
<> Opts.value ""
110+
<> Opts.help "One of \"debug\", \"perf\" or \"all\""))
107111
opts = Opts.info (version <*> Opts.helper <*> parser) mempty
112+
parseLogLevel s = case s of
113+
"debug" -> LogDebug
114+
"perf" -> LogPerf
115+
"all" -> LogAll
116+
_ -> LogNone
108117
version = Opts.abortOption
109118
(InfoMsg (showVersion Paths.version))
110119
(Opts.long "version" `mappend` Opts.help "Show the version number")
@@ -116,10 +125,8 @@ main = do
116125
startServer :: PortNumber -> IdeEnvironment -> IO ()
117126
startServer port env = withSocketsDo $ do
118127
sock <- listenOnLocalhost port
119-
runLogger (runReaderT (forever (loop sock)) env)
128+
runLogger (confLogLevel (ideConfiguration env)) (runReaderT (forever (loop sock)) env)
120129
where
121-
runLogger = runStdoutLoggingT . filterLogger (\_ _ -> confDebug (ideConfiguration env))
122-
123130
loop :: (Ide m, MonadLogger m) => Socket -> m ()
124131
loop sock = do
125132
accepted <- runExceptT $ acceptCommand sock
@@ -128,10 +135,11 @@ startServer port env = withSocketsDo $ do
128135
Right (cmd, h) -> do
129136
case decodeT cmd of
130137
Just cmd' -> do
131-
start <- liftIO (getTime Monotonic)
132-
result <- runExceptT (handleCommand cmd')
133-
end <- liftIO (getTime Monotonic)
134-
$(logDebug) ("Command " <> commandName cmd' <> " took " <> (displayTimeSpec (diffTimeSpec start end)))
138+
let message duration =
139+
"Command " <> commandName cmd'
140+
<> " took "
141+
<> displayTimeSpec duration
142+
result <- logPerf message (runExceptT (handleCommand cmd'))
135143
-- $(logDebug) ("Answer was: " <> T.pack (show result))
136144
liftIO (hFlush stdout)
137145
case result of

‎purescript.cabal‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -271,8 +271,9 @@ library
271271
Language.PureScript.Ide.Conversions
272272
Language.PureScript.Ide.Externs
273273
Language.PureScript.Ide.Error
274-
Language.PureScript.Ide.Imports
275274
Language.PureScript.Ide.Filter
275+
Language.PureScript.Ide.Imports
276+
Language.PureScript.Ide.Logging
276277
Language.PureScript.Ide.Matcher
277278
Language.PureScript.Ide.Pursuit
278279
Language.PureScript.Ide.Rebuild
@@ -473,7 +474,6 @@ executable psc-ide-server
473474
build-depends: base >=4 && <5,
474475
aeson >= 0.8 && < 1.0,
475476
bytestring -any,
476-
clock -any,
477477
purescript -any,
478478
base-compat >=0.6.0,
479479
directory -any,

‎src/Language/PureScript/Ide.hs‎

Lines changed: 2 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -186,11 +186,9 @@ loadModules moduleNames = do
186186
-- Finally we kick off the worker with @async@ and return the number of
187187
-- successfully parsed modules.
188188
env <- ask
189-
let runLogger =
190-
runStdoutLoggingT
191-
. filterLogger (\_ _ -> confDebug (ideConfiguration env))
189+
let ll = confLogLevel (ideConfiguration env)
192190
-- populateStage2 and 3 return Unit for now, so it's fine to discard this
193191
-- result. We might want to block on this in a benchmarking situation.
194-
_ <- liftIO (async (runLogger (runReaderT (populateStage2 *> populateStage3) env)))
192+
_ <- liftIO (async (runLogger ll (runReaderT (populateStage2 *> populateStage3) env)))
195193
pure (TextResult ("Loaded " <> show (length efiles) <> " modules and "
196194
<> show (length allModules) <> " source files."))

‎src/Language/PureScript/Ide/Externs.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -26,7 +26,6 @@ import Protolude
2626
import Control.Lens ((^.))
2727
import Data.Aeson (decodeStrict)
2828
import qualified Data.ByteString as BS
29-
import Data.List (nub)
3029
import qualified Data.Map as Map
3130
import Language.PureScript.Ide.Error (PscIdeError (..))
3231
import Language.PureScript.Ide.Types
@@ -55,7 +54,7 @@ convertExterns ef =
5554
declarations = mapMaybe convertDecl (P.efDeclarations ef)
5655

5756
typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration declarations)
58-
cleanDeclarations = nub $ appEndo typeClassFilter declarations
57+
cleanDeclarations = ordNub (appEndo typeClassFilter declarations)
5958

6059
removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration]
6160
removeTypeDeclarationsForClass (IdeDeclTypeClass n) = Endo (filter notDuplicate)

‎src/Language/PureScript/Ide/Logging.hs‎

Lines changed: 36 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,36 @@
1+
{-# LANGUAGE PackageImports #-}
2+
3+
module Language.PureScript.Ide.Logging
4+
( runLogger
5+
, logPerf
6+
, displayTimeSpec
7+
) where
8+
9+
import Protolude
10+
11+
import "monad-logger" Control.Monad.Logger
12+
import qualified Data.Text as T
13+
import Language.PureScript.Ide.Types
14+
import System.Clock
15+
import Text.Printf
16+
17+
runLogger :: MonadIO m => IdeLogLevel -> LoggingT m a -> m a
18+
runLogger logLevel' =
19+
runStdoutLoggingT . filterLogger (\_ logLevel ->
20+
case logLevel' of
21+
LogAll -> True
22+
LogNone -> False
23+
LogDebug -> not (logLevel == LevelOther "perf")
24+
LogPerf -> logLevel == LevelOther "perf")
25+
26+
logPerf :: (MonadIO m, MonadLogger m) => (TimeSpec -> Text) -> m t -> m t
27+
logPerf format f = do
28+
start <- liftIO (getTime Monotonic)
29+
result <- f
30+
end <- liftIO (getTime Monotonic)
31+
logOtherN (LevelOther "perf") (format (diffTimeSpec start end))
32+
pure result
33+
34+
displayTimeSpec :: TimeSpec -> Text
35+
displayTimeSpec ts =
36+
T.pack (printf "%0.2f" (fromIntegral (toNanoSecs ts) / 1000000 :: Double)) <> "ms"

‎src/Language/PureScript/Ide/SourceFile.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -116,7 +116,7 @@ extractSpans ss d = case d of
116116
_ -> []
117117
where
118118
-- We need this special case to be able to also get the position info for
119-
-- typeclass member functions. Typedeclaratations would clash with value
119+
-- typeclass member functions. Typedeclarations would clash with value
120120
-- declarations for non-typeclass members, which is why we can't handle them
121121
-- in extractSpans.
122122
extractSpans' ssP dP = case dP of

‎src/Language/PureScript/Ide/State.hs‎

Lines changed: 4 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -45,7 +45,6 @@ import Language.PureScript.Ide.Reexports
4545
import Language.PureScript.Ide.SourceFile
4646
import Language.PureScript.Ide.Types
4747
import Language.PureScript.Ide.Util
48-
import System.Clock
4948

5049
-- | Resets all State inside psc-ide
5150
resetIdeState :: Ide m => m ()
@@ -178,12 +177,8 @@ cachedRebuild = s3CachedRebuild <$> getStage3
178177
populateStage2 :: (Ide m, MonadLogger m) => m ()
179178
populateStage2 = do
180179
st <- ideStateVar <$> ask
181-
duration <- liftIO $ do
182-
start <- getTime Monotonic
183-
atomically (populateStage2STM st)
184-
end <- getTime Monotonic
185-
pure (diffTimeSpec start end)
186-
$(logDebug) $ "Finished populating Stage2 in " <> displayTimeSpec duration
180+
let message duration = "Finished populating Stage2 in " <> displayTimeSpec duration
181+
logPerf message (liftIO (atomically (populateStage2STM st)))
187182

188183
-- | STM version of populateStage2
189184
populateStage2STM :: TVar IdeState -> STM ()
@@ -196,15 +191,11 @@ populateStage2STM ref = do
196191
populateStage3 :: (Ide m, MonadLogger m) => m ()
197192
populateStage3 = do
198193
st <- ideStateVar <$> ask
199-
(duration, results) <- liftIO $ do
200-
start <- getTime Monotonic
201-
results <- atomically (populateStage3STM st)
202-
end <- getTime Monotonic
203-
pure (diffTimeSpec start end, results)
194+
let message duration = "Finished populating Stage3 in " <> displayTimeSpec duration
195+
results <- logPerf message (liftIO (atomically (populateStage3STM st)))
204196
traverse_
205197
(logWarnN . prettyPrintReexportResult (runModuleNameT . fst))
206198
(filter reexportHasFailures results)
207-
$(logDebug) $ "Finished populating Stage3 in " <> displayTimeSpec duration
208199

209200
-- | STM version of populateStage3
210201
populateStage3STM :: TVar IdeState -> STM [ReexportResult Module]

‎src/Language/PureScript/Ide/Types.hs‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -111,10 +111,13 @@ newtype AstData a = AstData (Map P.ModuleName (DefinitionSites a, TypeAnnotation
111111
-- annotations found in a module
112112
deriving (Show, Eq, Ord, Functor, Foldable)
113113

114+
data IdeLogLevel = LogDebug | LogPerf | LogAll | LogNone
115+
deriving (Show, Eq)
116+
114117
data Configuration =
115118
Configuration
116119
{ confOutputPath :: FilePath
117-
, confDebug :: Bool
120+
, confLogLevel :: IdeLogLevel
118121
, confGlobs :: [FilePath]
119122
}
120123

‎src/Language/PureScript/Ide/Util.hs‎

Lines changed: 2 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -26,8 +26,8 @@ module Language.PureScript.Ide.Util
2626
, withEmptyAnn
2727
, valueOperatorAliasT
2828
, typeOperatorAliasT
29-
, displayTimeSpec
3029
, module Language.PureScript.Ide.Conversions
30+
, module Language.PureScript.Ide.Logging
3131
) where
3232

3333
import Protolude hiding (decodeUtf8,
@@ -39,9 +39,8 @@ import qualified Data.Text as T
3939
import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
4040
import qualified Language.PureScript as P
4141
import Language.PureScript.Ide.Conversions
42+
import Language.PureScript.Ide.Logging
4243
import Language.PureScript.Ide.Types
43-
import System.Clock
44-
import Text.Printf
4544

4645
identifierFromIdeDeclaration :: IdeDeclaration -> Text
4746
identifierFromIdeDeclaration d = case d of
@@ -115,7 +114,3 @@ unwrapPositioned x = x
115114
unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef
116115
unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = unwrapPositionedRef x
117116
unwrapPositionedRef x = x
118-
119-
displayTimeSpec :: TimeSpec -> Text
120-
displayTimeSpec ts =
121-
T.pack (printf "%0.2f" (fromIntegral (toNanoSecs ts) / 1000000 :: Double)) <> "ms"

0 commit comments

Comments
 (0)