a9c525c · rowtype-yoga/purescript-native

psc-ide-server/Main.hs+19−11

compare with golang

unifiedsplit

@@ -41,7 +41,6 @@ import Network.Socket hiding (PortNumber, Type,

41 sClose)

42import Options.Applicative (ParseError (..))

43import qualified Options.Applicative as Opts

44−import System.Clock

45import System.Directory

44import System.Directory

46import System.Info as SysInfo

45import System.Info as SysInfo

47import System.FilePath

46import System.FilePath

@@ -70,11 +69,12 @@ data Options = Options

70 , optionsNoWatch :: Bool

69 , optionsNoWatch :: Bool

71 , optionsPolling :: Bool

70 , optionsPolling :: Bool

72 , optionsDebug :: Bool

71 , optionsDebug :: Bool

72+ , optionsLoglevel :: IdeLogLevel

73 } deriving (Show)

74

75main :: IO ()

76main = 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

78 when debug (putText "Parsed Options:" *> print opts')

79 maybe (pure ()) setCurrentDirectory dir

80 ideState <- newTVarIO emptyIdeState

@@ -89,8 +89,8 @@ main = do

89

90 unless noWatch $

91 void (forkFinally (watcher polling ideState fullOutputPath) print)

92−

92+ -- TODO: deprecate and get rid of `debug`

93− let conf = Configuration {confDebug = debug, confOutputPath = outputPath, confGlobs = globs}

93+ let conf = Configuration {confLogLevel = if debug then LogDebug else logLevel, confOutputPath = outputPath, confGlobs = globs}

94 env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf}

95 startServer port env

96 where

@@ -104,7 +104,16 @@ main = do

104 <*> Opts.switch (Opts.long "no-watch")

105 <*> flipIfWindows (Opts.switch (Opts.long "polling"))

106 <*> 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\""))

107 opts = Opts.info (version <*> Opts.helper <*> parser) mempty

111 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

108 version = Opts.abortOption

117 version = Opts.abortOption

109 (InfoMsg (showVersion Paths.version))

118 (InfoMsg (showVersion Paths.version))

110 (Opts.long "version" `mappend` Opts.help "Show the version number")

119 (Opts.long "version" `mappend` Opts.help "Show the version number")

@@ -116,10 +125,8 @@ main = do

116startServer :: PortNumber -> IdeEnvironment -> IO ()

125startServer :: PortNumber -> IdeEnvironment -> IO ()

117startServer port env = withSocketsDo $ do

126startServer port env = withSocketsDo $ do

118 sock <- listenOnLocalhost port

127 sock <- listenOnLocalhost port

119− runLogger (runReaderT (forever (loop sock)) env)

128+ runLogger (confLogLevel (ideConfiguration env)) (runReaderT (forever (loop sock)) env)

120 where

129 where

121− runLogger = runStdoutLoggingT . filterLogger (\_ _ -> confDebug (ideConfiguration env))

122−

123 loop :: (Ide m, MonadLogger m) => Socket -> m ()

130 loop :: (Ide m, MonadLogger m) => Socket -> m ()

124 loop sock = do

131 loop sock = do

125 accepted <- runExceptT $ acceptCommand sock

132 accepted <- runExceptT $ acceptCommand sock

@@ -128,10 +135,11 @@ startServer port env = withSocketsDo $ do

128 Right (cmd, h) -> do

135 Right (cmd, h) -> do

129 case decodeT cmd of

136 case decodeT cmd of

130 Just cmd' -> do

137 Just cmd' -> do

131− start <- liftIO (getTime Monotonic)

138+ let message duration =

132− result <- runExceptT (handleCommand cmd')

133− end <- liftIO (getTime Monotonic)

134− $(logDebug) ("Command " <> commandName cmd' <> " took " <> (displayTimeSpec (diffTimeSpec start end)))

139+ "Command " <> commandName cmd'

140+ <> " took "

141+ <> displayTimeSpec duration

142+ result <- logPerf message (runExceptT (handleCommand cmd'))

135 -- $(logDebug) ("Answer was: " <> T.pack (show result))

143 -- $(logDebug) ("Answer was: " <> T.pack (show result))

136 liftIO (hFlush stdout)

144 liftIO (hFlush stdout)

137 case result of

145 case result of

purescript.cabal+2−2

@@ -271,8 +271,9 @@ library

271 Language.PureScript.Ide.Conversions

272 Language.PureScript.Ide.Externs

273 Language.PureScript.Ide.Error

274− Language.PureScript.Ide.Imports

275 Language.PureScript.Ide.Filter

274 Language.PureScript.Ide.Filter

275+ Language.PureScript.Ide.Imports

276+ Language.PureScript.Ide.Logging

276 Language.PureScript.Ide.Matcher

277 Language.PureScript.Ide.Matcher

277 Language.PureScript.Ide.Pursuit

278 Language.PureScript.Ide.Pursuit

278 Language.PureScript.Ide.Rebuild

279 Language.PureScript.Ide.Rebuild

@@ -473,7 +474,6 @@ executable psc-ide-server

473 build-depends: base >=4 && <5,

474 build-depends: base >=4 && <5,

474 aeson >= 0.8 && < 1.0,

475 aeson >= 0.8 && < 1.0,

475 bytestring -any,

476 bytestring -any,

476− clock -any,

477 purescript -any,

478 base-compat >=0.6.0,

479 directory -any,

src/Language/PureScript/Ide.hs+2−4

@@ -186,11 +186,9 @@ loadModules moduleNames = do

186 -- Finally we kick off the worker with @async@ and return the number of

187 -- successfully parsed modules.

188 env <- ask

189− let runLogger =

190− runStdoutLoggingT

191− . filterLogger (\_ _ -> confDebug (ideConfiguration env))

189+ let ll = confLogLevel (ideConfiguration env)

192 -- populateStage2 and 3 return Unit for now, so it's fine to discard this

190 -- populateStage2 and 3 return Unit for now, so it's fine to discard this

193 -- result. We might want to block on this in a benchmarking situation.

191 -- 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)))

195 pure (TextResult ("Loaded " <> show (length efiles) <> " modules and "

193 pure (TextResult ("Loaded " <> show (length efiles) <> " modules and "

196 <> show (length allModules) <> " source files."))

194 <> show (length allModules) <> " source files."))

src/Language/PureScript/Ide/Externs.hs+1−2

@@ -26,7 +26,6 @@ import Protolude

26import Control.Lens ((^.))

27import Data.Aeson (decodeStrict)

28import qualified Data.ByteString as BS

29−import Data.List (nub)

30import qualified Data.Map as Map

29import qualified Data.Map as Map

31import Language.PureScript.Ide.Error (PscIdeError (..))

30import Language.PureScript.Ide.Error (PscIdeError (..))

32import Language.PureScript.Ide.Types

31import Language.PureScript.Ide.Types

@@ -55,7 +54,7 @@ convertExterns ef =

55 declarations = mapMaybe convertDecl (P.efDeclarations ef)

54 declarations = mapMaybe convertDecl (P.efDeclarations ef)

56

55

57 typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration declarations)

56 typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration declarations)

58− cleanDeclarations = nub $ appEndo typeClassFilter declarations

57+ cleanDeclarations = ordNub (appEndo typeClassFilter declarations)

59

58

60removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration]

59removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration]

61removeTypeDeclarationsForClass (IdeDeclTypeClass n) = Endo (filter notDuplicate)

60removeTypeDeclarationsForClass (IdeDeclTypeClass n) = Endo (filter notDuplicate)

src/Language/PureScript/Ide/Logging.hsnew file+36

@@ -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+1−1

@@ -116,7 +116,7 @@ extractSpans ss d = case d of

116 _ -> []

117 where

118 -- 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

120 -- declarations for non-typeclass members, which is why we can't handle them

121 -- in extractSpans.

122 extractSpans' ssP dP = case dP of

src/Language/PureScript/Ide/State.hs+4−13

@@ -45,7 +45,6 @@ import Language.PureScript.Ide.Reexports

45import Language.PureScript.Ide.SourceFile

46import Language.PureScript.Ide.Types

47import Language.PureScript.Ide.Util

48−import System.Clock

49

48

50-- | Resets all State inside psc-ide

49-- | Resets all State inside psc-ide

51resetIdeState :: Ide m => m ()

50resetIdeState :: Ide m => m ()

@@ -178,12 +177,8 @@ cachedRebuild = s3CachedRebuild <$> getStage3

178populateStage2 :: (Ide m, MonadLogger m) => m ()

177populateStage2 :: (Ide m, MonadLogger m) => m ()

179populateStage2 = do

178populateStage2 = do

180 st <- ideStateVar <$> ask

179 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)))

187

182

188-- | STM version of populateStage2

183-- | STM version of populateStage2

189populateStage2STM :: TVar IdeState -> STM ()

184populateStage2STM :: TVar IdeState -> STM ()

@@ -196,15 +191,11 @@ populateStage2STM ref = do

196populateStage3 :: (Ide m, MonadLogger m) => m ()

191populateStage3 :: (Ide m, MonadLogger m) => m ()

197populateStage3 = do

192populateStage3 = do

198 st <- ideStateVar <$> ask

193 st <- ideStateVar <$> ask

199− (duration, results) <- liftIO $ do

194+ let message duration = "Finished populating Stage3 in " <> displayTimeSpec duration

200− start <- getTime Monotonic

201− results <- atomically (populateStage3STM st)

195+ results <- logPerf message (liftIO (atomically (populateStage3STM st)))

202− end <- getTime Monotonic

203− pure (diffTimeSpec start end, results)

204 traverse_

196 traverse_

205 (logWarnN . prettyPrintReexportResult (runModuleNameT . fst))

197 (logWarnN . prettyPrintReexportResult (runModuleNameT . fst))

206 (filter reexportHasFailures results)

198 (filter reexportHasFailures results)

207− $(logDebug) $ "Finished populating Stage3 in " <> displayTimeSpec duration

208

199

209-- | STM version of populateStage3

200-- | STM version of populateStage3

210populateStage3STM :: TVar IdeState -> STM [ReexportResult Module]

201populateStage3STM :: TVar IdeState -> STM [ReexportResult Module]

src/Language/PureScript/Ide/Types.hs+4−1

@@ -111,10 +111,13 @@ newtype AstData a = AstData (Map P.ModuleName (DefinitionSites a, TypeAnnotation

111 -- annotations found in a module

112 deriving (Show, Eq, Ord, Functor, Foldable)

113

114+data IdeLogLevel = LogDebug | LogPerf | LogAll | LogNone

115+ deriving (Show, Eq)

116+

114data Configuration =

117data Configuration =

115 Configuration

118 Configuration

116 { confOutputPath :: FilePath

119 { confOutputPath :: FilePath

117− , confDebug :: Bool

120+ , confLogLevel :: IdeLogLevel

118 , confGlobs :: [FilePath]

121 , confGlobs :: [FilePath]

119 }

122 }

120

123

src/Language/PureScript/Ide/Util.hs+2−7

@@ -26,8 +26,8 @@ module Language.PureScript.Ide.Util

26 , withEmptyAnn

27 , valueOperatorAliasT

28 , typeOperatorAliasT

29− , displayTimeSpec

30 , module Language.PureScript.Ide.Conversions

29 , module Language.PureScript.Ide.Conversions

30+ , module Language.PureScript.Ide.Logging

31 ) where

32

33import Protolude hiding (decodeUtf8,

@@ -39,9 +39,8 @@ import qualified Data.Text as T

39import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)

40import qualified Language.PureScript as P

41import Language.PureScript.Ide.Conversions

42+import Language.PureScript.Ide.Logging

42import Language.PureScript.Ide.Types

43import Language.PureScript.Ide.Types

43−import System.Clock

44−import Text.Printf

45

44

46identifierFromIdeDeclaration :: IdeDeclaration -> Text

45identifierFromIdeDeclaration :: IdeDeclaration -> Text

47identifierFromIdeDeclaration d = case d of

46identifierFromIdeDeclaration d = case d of

@@ -115,7 +114,3 @@ unwrapPositioned x = x

115unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef

114unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef

116unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = unwrapPositionedRef x

115unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = unwrapPositionedRef x

117unwrapPositionedRef x = x

116unwrapPositionedRef x = x

118−

119−displayTimeSpec :: TimeSpec -> Text

120−displayTimeSpec ts =

121− T.pack (printf "%0.2f" (fromIntegral (toNanoSecs ts) / 1000000 :: Double)) <> "ms"