Skip to content

Commit 9528dd5

Browse files
kritzcreekkritzcreek
authored
Merge pull request purescript#2467 from kRITZCREEK/psc-ide-diagnostics
[psc-ide] Better logging and diagnostics
2 parents ad6fd47 + 7cb2c29 commit 9528dd5

File tree

12 files changed

+122
-48
lines changed

12 files changed

+122
-48
lines changed

‎psc-ide-server/Main.hs‎

Lines changed: 21 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,7 @@ import qualified Data.Text.IO as T
3030
import qualified Data.ByteString.Lazy.Char8 as BS8
3131
import Data.Version (showVersion)
3232
import Language.PureScript.Ide
33+
import Language.PureScript.Ide.Command
3334
import Language.PureScript.Ide.Util
3435
import Language.PureScript.Ide.Error
3536
import Language.PureScript.Ide.Types
@@ -45,7 +46,6 @@ import System.Info as SysInfo
4546
import System.FilePath
4647
import System.IO hiding (putStrLn, print)
4748
import System.IO.Error (isEOFError)
48-
4949
import qualified Paths_purescript as Paths
5050

5151
listenOnLocalhost :: PortNumber -> IO Socket
@@ -69,11 +69,12 @@ data Options = Options
6969
, optionsNoWatch :: Bool
7070
, optionsPolling :: Bool
7171
, optionsDebug :: Bool
72+
, optionsLoglevel :: IdeLogLevel
7273
} deriving (Show)
7374

7475
main :: IO ()
7576
main = do
76-
opts'@(Options dir globs outputPath port noWatch polling debug) <- Opts.execParser opts
77+
opts'@(Options dir globs outputPath port noWatch polling debug logLevel) <- Opts.execParser opts
7778
when debug (putText "Parsed Options:" *> print opts')
7879
maybe (pure ()) setCurrentDirectory dir
7980
ideState <- newTVarIO emptyIdeState
@@ -88,8 +89,8 @@ main = do
8889

8990
unless noWatch $
9091
void (forkFinally (watcher polling ideState fullOutputPath) print)
91-
92-
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}
9394
env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf}
9495
startServer port env
9596
where
@@ -103,7 +104,17 @@ main = do
103104
<*> Opts.switch (Opts.long "no-watch")
104105
<*> flipIfWindows (Opts.switch (Opts.long "polling"))
105106
<*> Opts.switch (Opts.long "debug")
107+
<*> (parseLogLevel <$> Opts.strOption
108+
(Opts.long "log-level"
109+
`mappend` Opts.value ""
110+
`mappend` Opts.help "One of \"debug\", \"perf\", \"all\" or \"none\""))
106111
opts = Opts.info (version <*> Opts.helper <*> parser) mempty
112+
parseLogLevel s = case s of
113+
"debug" -> LogDebug
114+
"perf" -> LogPerf
115+
"all" -> LogAll
116+
"none" -> LogNone
117+
_ -> LogDefault
107118
version = Opts.abortOption
108119
(InfoMsg (showVersion Paths.version))
109120
(Opts.long "version" `mappend` Opts.help "Show the version number")
@@ -115,10 +126,8 @@ main = do
115126
startServer :: PortNumber -> IdeEnvironment -> IO ()
116127
startServer port env = withSocketsDo $ do
117128
sock <- listenOnLocalhost port
118-
runLogger (runReaderT (forever (loop sock)) env)
129+
runLogger (confLogLevel (ideConfiguration env)) (runReaderT (forever (loop sock)) env)
119130
where
120-
runLogger = runStdoutLoggingT . filterLogger (\_ _ -> confDebug (ideConfiguration env))
121-
122131
loop :: (Ide m, MonadLogger m) => Socket -> m ()
123132
loop sock = do
124133
accepted <- runExceptT $ acceptCommand sock
@@ -127,7 +136,11 @@ startServer port env = withSocketsDo $ do
127136
Right (cmd, h) -> do
128137
case decodeT cmd of
129138
Just cmd' -> do
130-
result <- runExceptT (handleCommand cmd')
139+
let message duration =
140+
"Command " <> commandName cmd'
141+
<> " took "
142+
<> displayTimeSpec duration
143+
result <- logPerf message (runExceptT (handleCommand cmd'))
131144
-- $(logDebug) ("Answer was: " <> T.pack (show result))
132145
liftIO (hFlush stdout)
133146
case result of
@@ -140,7 +153,6 @@ startServer port env = withSocketsDo $ do
140153
hFlush stdout
141154
liftIO (hClose h)
142155

143-
144156
acceptCommand :: (MonadIO m, MonadLogger m, MonadError Text m)
145157
=> Socket -> m (Text, Handle)
146158
acceptCommand sock = do

‎psc-ide-server/README.md‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -22,9 +22,11 @@ It supports the following options:
2222
- `--output-directory`: Specify where to look for compiled output inside your
2323
project directory. Defaults to `output/`, relative to either the current
2424
directory or the directory specified by `-d`.
25-
- `--debug`: Enables some logging meant for debugging
25+
<<<<<<< HEAD
2626
- `--polling`: Uses polling instead of file system events to watch the externs
2727
files. This flag is reversed on Windows and polling is the default.
28+
- `--debug`: DEPRECATED: use --log-level="debug"
29+
- `--log-level`: Can be set to one of "all", "none", "debug" and "perf"
2830
- `--no-watch`: Disables the filewatcher
2931
- `--version`: Output psc-ide version
3032

‎purescript.cabal‎

Lines changed: 2 additions & 1 deletion
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

‎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/Command.hs‎

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -61,6 +61,21 @@ data Command
6161
| Reset
6262
| Quit
6363

64+
commandName :: Command -> Text
65+
commandName c = case c of
66+
Load{} -> "Load"
67+
Type{} -> "Type"
68+
Complete{} -> "Complete"
69+
Pursuit{} -> "Pursuit"
70+
CaseSplit{} -> "CaseSplit"
71+
AddClause{} -> "AddClause"
72+
Import{} -> "Import"
73+
List{} -> "List"
74+
Rebuild{} -> "Rebuild"
75+
Cwd{} -> "Cwd"
76+
Reset{} -> "Reset"
77+
Quit{} -> "Quit"
78+
6479
data ImportCommand
6580
= AddImplicitImport P.ModuleName
6681
| AddImportForIdentifier Text

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

Lines changed: 24 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -12,8 +12,8 @@
1212
-- Handles externs files for psc-ide
1313
-----------------------------------------------------------------------------
1414

15-
{-# LANGUAGE OverloadedStrings #-}
16-
{-# LANGUAGE RecordWildCards #-}
15+
{-# LANGUAGE RecordWildCards #-}
16+
{-# LANGUAGE PackageImports #-}
1717

1818
module Language.PureScript.Ide.Externs
1919
( readExternFile
@@ -23,25 +23,38 @@ module Language.PureScript.Ide.Externs
2323

2424
import Protolude
2525

26-
import Control.Lens ((^.))
27-
import Data.Aeson (decodeStrict)
28-
import qualified Data.ByteString as BS
29-
import Data.List (nub)
30-
import qualified Data.Map as Map
26+
import Control.Lens ((^.))
27+
import "monad-logger" Control.Monad.Logger
28+
import Data.Aeson (decodeStrict)
29+
import qualified Data.ByteString as BS
30+
import qualified Data.Map as Map
31+
import Data.Version (showVersion)
3132
import Language.PureScript.Ide.Error (PscIdeError (..))
3233
import Language.PureScript.Ide.Types
3334
import Language.PureScript.Ide.Util
3435

35-
import qualified Language.PureScript as P
36+
import qualified Language.PureScript as P
3637

37-
readExternFile :: (MonadIO m, MonadError PscIdeError m) =>
38+
readExternFile :: (MonadIO m, MonadError PscIdeError m, MonadLogger m) =>
3839
FilePath -> m P.ExternsFile
3940
readExternFile fp = do
4041
parseResult <- liftIO (decodeStrict <$> BS.readFile fp)
4142
case parseResult of
42-
Nothing -> throwError . GeneralError $ "Parsing the extern at: " <> toS fp <> " failed"
43+
Nothing ->
44+
throwError (GeneralError
45+
("Parsing the extern at: " <> toS fp <> " failed"))
46+
Just externs
47+
| P.efVersion externs /= version -> do
48+
let errMsg = "Version mismatch for the externs at: " <> toS fp
49+
<> " Expected: " <> version
50+
<> " Found: " <> P.efVersion externs
51+
logErrorN errMsg
52+
throwError (GeneralError errMsg)
4353
Just externs -> pure externs
4454

55+
where
56+
version = toS (showVersion P.version)
57+
4558
convertExterns :: P.ExternsFile -> (Module, [(P.ModuleName, P.DeclarationRef)])
4659
convertExterns ef =
4760
((P.efModuleName ef, decls), exportDecls)
@@ -55,7 +68,7 @@ convertExterns ef =
5568
declarations = mapMaybe convertDecl (P.efDeclarations ef)
5669

5770
typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration declarations)
58-
cleanDeclarations = nub $ appEndo typeClassFilter declarations
71+
cleanDeclarations = ordNub (appEndo typeClassFilter declarations)
5972

6073
removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration]
6174
removeTypeDeclarationsForClass (IdeDeclTypeClass n) = Endo (filter notDuplicate)

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

Lines changed: 37 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,37 @@
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+
LogDefault -> not (logLevel == LevelOther "perf" || logLevel == LevelDebug)
23+
LogNone -> False
24+
LogDebug -> not (logLevel == LevelOther "perf")
25+
LogPerf -> logLevel == LevelOther "perf")
26+
27+
logPerf :: (MonadIO m, MonadLogger m) => (TimeSpec -> Text) -> m t -> m t
28+
logPerf format f = do
29+
start <- liftIO (getTime Monotonic)
30+
result <- f
31+
end <- liftIO (getTime Monotonic)
32+
logOtherN (LevelOther "perf") (format (diffTimeSpec start end))
33+
pure result
34+
35+
displayTimeSpec :: TimeSpec -> Text
36+
displayTimeSpec ts =
37+
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 & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -32,7 +32,6 @@ module Language.PureScript.Ide.State
3232
, resolveOperatorsForModule
3333
) where
3434

35-
import qualified Prelude
3635
import Protolude
3736

3837
import Control.Concurrent.STM
@@ -46,7 +45,6 @@ import Language.PureScript.Ide.Reexports
4645
import Language.PureScript.Ide.SourceFile
4746
import Language.PureScript.Ide.Types
4847
import Language.PureScript.Ide.Util
49-
import System.Clock
5048

5149
-- | Resets all State inside psc-ide
5250
resetIdeState :: Ide m => m ()
@@ -179,12 +177,8 @@ cachedRebuild = s3CachedRebuild <$> getStage3
179177
populateStage2 :: (Ide m, MonadLogger m) => m ()
180178
populateStage2 = do
181179
st <- ideStateVar <$> ask
182-
duration <- liftIO $ do
183-
start <- getTime Monotonic
184-
atomically (populateStage2STM st)
185-
end <- getTime Monotonic
186-
pure (Prelude.show (diffTimeSpec start end))
187-
$(logDebug) $ "Finished populating Stage2 in " <> toS duration
180+
let message duration = "Finished populating Stage2 in " <> displayTimeSpec duration
181+
logPerf message (liftIO (atomically (populateStage2STM st)))
188182

189183
-- | STM version of populateStage2
190184
populateStage2STM :: TVar IdeState -> STM ()
@@ -197,15 +191,11 @@ populateStage2STM ref = do
197191
populateStage3 :: (Ide m, MonadLogger m) => m ()
198192
populateStage3 = do
199193
st <- ideStateVar <$> ask
200-
(duration, results) <- liftIO $ do
201-
start <- getTime Monotonic
202-
results <- atomically (populateStage3STM st)
203-
end <- getTime Monotonic
204-
pure (Prelude.show (diffTimeSpec start end), results)
194+
let message duration = "Finished populating Stage3 in " <> displayTimeSpec duration
195+
results <- logPerf message (liftIO (atomically (populateStage3STM st)))
205196
traverse_
206197
(logWarnN . prettyPrintReexportResult (runModuleNameT . fst))
207198
(filter reexportHasFailures results)
208-
$(logDebug) $ "Finished populating Stage3 in " <> toS duration
209199

210200
-- | STM version of populateStage3
211201
populateStage3STM :: TVar IdeState -> STM [ReexportResult Module]

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

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -12,9 +12,8 @@
1212
-- Type definitions for psc-ide
1313
-----------------------------------------------------------------------------
1414

15-
{-# LANGUAGE DeriveFoldable #-}
16-
{-# LANGUAGE OverloadedStrings #-}
17-
{-# LANGUAGE TemplateHaskell #-}
15+
{-# LANGUAGE DeriveFoldable #-}
16+
{-# LANGUAGE TemplateHaskell #-}
1817

1918
module Language.PureScript.Ide.Types where
2019

@@ -111,10 +110,13 @@ newtype AstData a = AstData (Map P.ModuleName (DefinitionSites a, TypeAnnotation
111110
-- annotations found in a module
112111
deriving (Show, Eq, Ord, Functor, Foldable)
113112

113+
data IdeLogLevel = LogDebug | LogPerf | LogAll | LogDefault | LogNone
114+
deriving (Show, Eq)
115+
114116
data Configuration =
115117
Configuration
116118
{ confOutputPath :: FilePath
117-
, confDebug :: Bool
119+
, confLogLevel :: IdeLogLevel
118120
, confGlobs :: [FilePath]
119121
}
120122

0 commit comments

Comments
 (0)