9528dd5 · rowtype-yoga/purescript-native

psc-ide-server/Main.hs+21−9

compare with golang

unifiedsplit

@@ -30,6 +30,7 @@ import qualified Data.Text.IO as T

30import qualified Data.ByteString.Lazy.Char8 as BS8

31import Data.Version (showVersion)

32import Language.PureScript.Ide

33+import Language.PureScript.Ide.Command

33import Language.PureScript.Ide.Util

34import Language.PureScript.Ide.Util

34import Language.PureScript.Ide.Error

35import Language.PureScript.Ide.Error

35import Language.PureScript.Ide.Types

36import Language.PureScript.Ide.Types

@@ -45,7 +46,6 @@ import System.Info as SysInfo

45import System.FilePath

46import System.FilePath

46import System.IO hiding (putStrLn, print)

47import System.IO hiding (putStrLn, print)

47import System.IO.Error (isEOFError)

48import System.IO.Error (isEOFError)

48−

49import qualified Paths_purescript as Paths

50

51listenOnLocalhost :: PortNumber -> IO Socket

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

69 , optionsNoWatch :: Bool

70 , optionsPolling :: Bool

71 , optionsDebug :: Bool

72+ , optionsLoglevel :: IdeLogLevel

72 } deriving (Show)

73 } deriving (Show)

73

74

74main :: IO ()

75main :: IO ()

75main = do

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

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

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

78 maybe (pure ()) setCurrentDirectory dir

79 maybe (pure ()) setCurrentDirectory dir

79 ideState <- newTVarIO emptyIdeState

80 ideState <- newTVarIO emptyIdeState

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

88

89

89 unless noWatch $

90 unless noWatch $

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

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

91−

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

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

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

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

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

94 startServer port env

95 startServer port env

95 where

96 where

@@ -103,7 +104,17 @@ main = do

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

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

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

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

105 <*> Opts.switch (Opts.long "debug")

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

106 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+ "none" -> LogNone

117+ _ -> LogDefault

107 version = Opts.abortOption

118 version = Opts.abortOption

108 (InfoMsg (showVersion Paths.version))

119 (InfoMsg (showVersion Paths.version))

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

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

@@ -115,10 +126,8 @@ main = do

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

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

116startServer port env = withSocketsDo $ do

127startServer port env = withSocketsDo $ do

117 sock <- listenOnLocalhost port

128 sock <- listenOnLocalhost port

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

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

119 where

130 where

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

121−

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

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

123 loop sock = do

132 loop sock = do

124 accepted <- runExceptT $ acceptCommand sock

133 accepted <- runExceptT $ acceptCommand sock

@@ -127,7 +136,11 @@ startServer port env = withSocketsDo $ do

127 Right (cmd, h) -> do

136 Right (cmd, h) -> do

128 case decodeT cmd of

137 case decodeT cmd of

129 Just cmd' -> do

138 Just cmd' -> do

139+ let message duration =

140+ "Command " <> commandName cmd'

141+ <> " took "

142+ <> displayTimeSpec duration

130− result <- runExceptT (handleCommand cmd')

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

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

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

132 liftIO (hFlush stdout)

145 liftIO (hFlush stdout)

133 case result of

146 case result of

@@ -140,7 +153,6 @@ startServer port env = withSocketsDo $ do

140 hFlush stdout

153 hFlush stdout

141 liftIO (hClose h)

154 liftIO (hClose h)

142

155

143−

144acceptCommand :: (MonadIO m, MonadLogger m, MonadError Text m)

156acceptCommand :: (MonadIO m, MonadLogger m, MonadError Text m)

145 => Socket -> m (Text, Handle)

157 => Socket -> m (Text, Handle)

146acceptCommand sock = do

158acceptCommand sock = do

psc-ide-server/README.md+3−1

@@ -22,9 +22,11 @@ It supports the following options:

22- `--output-directory`: Specify where to look for compiled output inside your

23 project directory. Defaults to `output/`, relative to either the current

24 directory or the directory specified by `-d`.

25−- `--debug`: Enables some logging meant for debugging

25+<<<<<<< HEAD

26- `--polling`: Uses polling instead of file system events to watch the externs

27 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"

28- `--no-watch`: Disables the filewatcher

30- `--no-watch`: Disables the filewatcher

29- `--version`: Output psc-ide version

31- `--version`: Output psc-ide version

30

32

purescript.cabal+2−1

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

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

@@ -61,6 +61,21 @@ data Command

61 | Reset

62 | Quit

63

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+

64data ImportCommand

79data ImportCommand

65 = AddImplicitImport P.ModuleName

80 = AddImplicitImport P.ModuleName

66 | AddImportForIdentifier Text

81 | AddImportForIdentifier Text

src/Language/PureScript/Ide/Externs.hs+24−11

@@ -12,8 +12,8 @@

12-- Handles externs files for psc-ide

13-----------------------------------------------------------------------------

14

15−{-# LANGUAGE OverloadedStrings #-}

15+{-# LANGUAGE RecordWildCards #-}

16−{-# LANGUAGE RecordWildCards #-}

16+{-# LANGUAGE PackageImports #-}

17

18module Language.PureScript.Ide.Externs

19 ( readExternFile

@@ -23,25 +23,38 @@ module Language.PureScript.Ide.Externs

23

24import Protolude

25

26−import Control.Lens ((^.))

26+import Control.Lens ((^.))

27+import "monad-logger" Control.Monad.Logger

27−import Data.Aeson (decodeStrict)

28+import Data.Aeson (decodeStrict)

28−import qualified Data.ByteString as BS

29+import qualified Data.ByteString as BS

29−import Data.List (nub)

30−import qualified Data.Map as Map

30+import qualified Data.Map as Map

31+import Data.Version (showVersion)

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

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

32import Language.PureScript.Ide.Types

33import Language.PureScript.Ide.Types

33import Language.PureScript.Ide.Util

34import Language.PureScript.Ide.Util

34

35

35−import qualified Language.PureScript as P

36+import qualified Language.PureScript as P

36

37

37−readExternFile :: (MonadIO m, MonadError PscIdeError m) =>

38+readExternFile :: (MonadIO m, MonadError PscIdeError m, MonadLogger m) =>

38 FilePath -> m P.ExternsFile

39 FilePath -> m P.ExternsFile

39readExternFile fp = do

40readExternFile fp = do

40 parseResult <- liftIO (decodeStrict <$> BS.readFile fp)

41 parseResult <- liftIO (decodeStrict <$> BS.readFile fp)

41 case parseResult of

42 case parseResult of

43+ Nothing ->

44+ throwError (GeneralError

42− Nothing -> throwError . GeneralError $ "Parsing the extern at: " <> toS fp <> " failed"

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)

43 Just externs -> pure externs

53 Just externs -> pure externs

44

54

55+ where

56+ version = toS (showVersion P.version)

57+

45convertExterns :: P.ExternsFile -> (Module, [(P.ModuleName, P.DeclarationRef)])

58convertExterns :: P.ExternsFile -> (Module, [(P.ModuleName, P.DeclarationRef)])

46convertExterns ef =

59convertExterns ef =

47 ((P.efModuleName ef, decls), exportDecls)

60 ((P.efModuleName ef, decls), exportDecls)

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

55 declarations = mapMaybe convertDecl (P.efDeclarations ef)

68 declarations = mapMaybe convertDecl (P.efDeclarations ef)

56

69

57 typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration declarations)

70 typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration declarations)

58− cleanDeclarations = nub $ appEndo typeClassFilter declarations

71+ cleanDeclarations = ordNub (appEndo typeClassFilter declarations)

59

72

60removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration]

73removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration]

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

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

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

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

@@ -32,7 +32,6 @@ module Language.PureScript.Ide.State

32 , resolveOperatorsForModule

33 ) where

34

35−import qualified Prelude

36import Protolude

35import Protolude

37

36

38import Control.Concurrent.STM

37import Control.Concurrent.STM

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

46import Language.PureScript.Ide.SourceFile

45import Language.PureScript.Ide.SourceFile

47import Language.PureScript.Ide.Types

46import Language.PureScript.Ide.Types

48import Language.PureScript.Ide.Util

47import Language.PureScript.Ide.Util

49−import System.Clock

50

48

51-- | Resets all State inside psc-ide

49-- | Resets all State inside psc-ide

52resetIdeState :: Ide m => m ()

50resetIdeState :: Ide m => m ()

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

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

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

180populateStage2 = do

178populateStage2 = do

181 st <- ideStateVar <$> ask

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

188

182

189-- | STM version of populateStage2

183-- | STM version of populateStage2

190populateStage2STM :: TVar IdeState -> STM ()

184populateStage2STM :: TVar IdeState -> STM ()

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

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

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

198populateStage3 = do

192populateStage3 = do

199 st <- ideStateVar <$> ask

193 st <- ideStateVar <$> ask

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

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

201− start <- getTime Monotonic

202− results <- atomically (populateStage3STM st)

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

203− end <- getTime Monotonic

204− pure (Prelude.show (diffTimeSpec start end), results)

205 traverse_

196 traverse_

206 (logWarnN . prettyPrintReexportResult (runModuleNameT . fst))

197 (logWarnN . prettyPrintReexportResult (runModuleNameT . fst))

207 (filter reexportHasFailures results)

198 (filter reexportHasFailures results)

208− $(logDebug) $ "Finished populating Stage3 in " <> toS duration

209

199

210-- | STM version of populateStage3

200-- | STM version of populateStage3

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

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

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

@@ -12,9 +12,8 @@

12-- Type definitions for psc-ide

13-----------------------------------------------------------------------------

14

15−{-# LANGUAGE DeriveFoldable #-}

15+{-# LANGUAGE DeriveFoldable #-}

16−{-# LANGUAGE OverloadedStrings #-}

17−{-# LANGUAGE TemplateHaskell #-}

16+{-# LANGUAGE TemplateHaskell #-}

18

17

19module Language.PureScript.Ide.Types where

18module Language.PureScript.Ide.Types where

20

19

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

111 -- annotations found in a module

110 -- annotations found in a module

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

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

113

112

113+data IdeLogLevel = LogDebug | LogPerf | LogAll | LogDefault | LogNone

114+ deriving (Show, Eq)

115+

114data Configuration =

116data Configuration =

115 Configuration

117 Configuration

116 { confOutputPath :: FilePath

118 { confOutputPath :: FilePath

117− , confDebug :: Bool

119+ , confLogLevel :: IdeLogLevel

118 , confGlobs :: [FilePath]

120 , confGlobs :: [FilePath]

119 }

121 }

120

122

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

@@ -27,17 +27,20 @@ module Language.PureScript.Ide.Util

27 , valueOperatorAliasT

28 , typeOperatorAliasT

29 , module Language.PureScript.Ide.Conversions

30+ , module Language.PureScript.Ide.Logging

30 ) where

31 ) where

31

32

33+import Protolude hiding (decodeUtf8,

34+ encodeUtf8)

35+

32import Control.Lens ((^.))

36import Control.Lens ((^.))

33import Data.Aeson

37import Data.Aeson

34import qualified Data.Text as T

38import qualified Data.Text as T

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

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

36import qualified Language.PureScript as P

40import qualified Language.PureScript as P

37import Language.PureScript.Ide.Conversions

41import Language.PureScript.Ide.Conversions

42+import Language.PureScript.Ide.Logging

38import Language.PureScript.Ide.Types

43import Language.PureScript.Ide.Types

39−import Protolude hiding (decodeUtf8,

40− encodeUtf8)

41

44

42identifierFromIdeDeclaration :: IdeDeclaration -> Text

45identifierFromIdeDeclaration :: IdeDeclaration -> Text

43identifierFromIdeDeclaration d = case d of

46identifierFromIdeDeclaration d = case d of

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

@@ -22,6 +22,7 @@ import Control.Concurrent.STM

22import Language.PureScript.Ide.Externs

23import Language.PureScript.Ide.State

24import Language.PureScript.Ide.Types

25+import Language.PureScript.Ide.Util

25import System.FilePath

26import System.FilePath

26import System.FSNotify

27import System.FSNotify

27

28

@@ -31,7 +32,7 @@ reloadFile :: TVar IdeState -> Event -> IO ()

31reloadFile _ Removed{} = pure ()

32reloadFile _ Removed{} = pure ()

32reloadFile ref ev = do

33reloadFile ref ev = do

33 let fp = eventPath ev

34 let fp = eventPath ev

34− ef' <- runExceptT (readExternFile fp)

35+ ef' <- runLogger LogDefault (runExceptT (readExternFile fp))

35 case ef' of

36 case ef' of

36 Left _ -> pure ()

37 Left _ -> pure ()

37 Right ef -> do

38 Right ef -> do