Opts

app/Command/Bundle.hs

@@ -1,11 +1,12 @@
 -- | Bundles compiled PureScript modules for the browser.
-module Command.Bundle (command) where
+module Command.Bundle (command, initSqlite) where
 
 import Prelude
 
 import System.Exit (exitFailure)
 import System.IO (stderr, hPutStrLn)
 import Options.Applicative qualified as Opts
+import Language.PureScript.Make.IdeCache (sqliteInit)
 
 app :: IO ()
 app = do
@@ -21,3 +22,9 @@ command :: Opts.Parser (IO ())
 command = run <$> (Opts.helper <*> pure ()) where
   run :: () -> IO ()
   run _ = app
+
+initSqlite :: Opts.Parser (IO ())
+initSqlite = run <$> (Opts.helper <*> pure ()) where
+  run :: () -> IO ()
+  run _ = do
+    sqliteInit "output"

app/Command/Compile.hs

@@ -24,6 +24,7 @@ import System.Exit (exitSuccess, exitFailure)
 import System.Directory (getCurrentDirectory)
 import System.IO (hPutStr, stderr, stdout)
 import System.IO.UTF8 (readUTF8FilesT)
+import Language.PureScript.Make.IdeCache (sqliteInit)
 
 data PSCMakeOptions = PSCMakeOptions
   { pscmInput        :: [FilePath]
@@ -56,6 +57,7 @@ printWarningsAndErrors verbose True files warnings errors = do
 
 compile :: PSCMakeOptions -> IO ()
 compile PSCMakeOptions{..} = do
+  sqliteInit "output"
   input <- toInputGlobs $ PSCGlobs
     { pscInputGlobs = pscmInput
     , pscInputGlobsFromFile = pscmInputFromFile

app/Command/Ide.hs

@@ -40,6 +40,8 @@ import System.Directory (doesDirectoryExist, getCurrentDirectory, setCurrentDire
 import System.FilePath ((</>))
 import System.IO (BufferMode(..), hClose, hFlush, hSetBuffering, hSetEncoding, utf8)
 import System.IO.Error (isEOFError)
+import Database.SQLite.Simple qualified as SQLite
+import Protolude qualified as D
 
 listenOnLocalhost :: Network.PortNumber -> IO Network.Socket
 listenOnLocalhost port = do
@@ -138,6 +140,7 @@ command = Opts.helper <*> subcommands where
       conf = IdeConfiguration
         { confLogLevel = logLevel
         , confOutputPath = outputPath
+        , sqliteFilePath = outputPath </> "cache.db"
         , confGlobs = globs
         , confGlobsFromFile = globsFromFile
         , confGlobsExclude = globsExcluded
@@ -148,6 +151,11 @@ command = Opts.helper <*> subcommands where
         { ideStateVar = ideState
         , ideConfiguration = conf
         , ideCacheDbTimestamp = ts
+        , query = \q -> SQLite.withConnection (outputPath </> "cache.db")
+             (\conn -> do
+              SQLite.execute_ conn "pragma busy_timeout = 30000;"
+              SQLite.query_ conn $ SQLite.Query q
+              )
         }
     startServer port env
 
@@ -189,6 +197,7 @@ startServer port env = Network.withSocketsDo $ do
       case accepted of
         Left err -> $(logError) err
         Right (cmd, h) -> do
+          -- traceM cmd
           case decodeT cmd of
             Right cmd' -> do
               let message duration =

app/Command/QuickBuild.hs

@@ -0,0 +1,248 @@
+-----------------------------------------------------------------------------
+--
+-- Module      : Main
+-- Description : The server accepting commands for psc-ide
+-- Copyright   : Christoph Hegemann 2016
+-- License     : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>
+-- Stability   : experimental
+--
+-- |
+-- The server accepting commands for psc-ide
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Command.QuickBuild (command) where
+
+import Protolude
+
+import Data.Aeson qualified as Aeson
+import Data.Set qualified as Set
+import Control.Concurrent.STM (newTVarIO)
+import "monad-logger" Control.Monad.Logger (MonadLogger, logDebug, logError, logInfo)
+import Data.IORef (newIORef)
+import Data.Text.IO qualified as T
+import Data.ByteString.Char8 qualified as BS8
+import Data.ByteString.Lazy.Char8 qualified as BSL8
+import GHC.IO.Exception (IOErrorType(..), IOException(..))
+import Language.PureScript.Ide (handleCommand)
+import Language.PureScript.Ide.Command (Command(..), commandName)
+import Language.PureScript.Ide.Util (decodeT, displayTimeSpec, encodeT, logPerf, runLogger)
+import Language.PureScript.Ide.Error (IdeError(..))
+import Language.PureScript.Ide.State (updateCacheTimestamp)
+import Language.PureScript.Ide.Types (Ide, IdeConfiguration(..), IdeEnvironment(..), IdeLogLevel(..), emptyIdeState)
+import Network.Socket qualified as Network
+import Options.Applicative qualified as Opts
+import SharedCLI qualified
+import System.Directory (doesDirectoryExist, getCurrentDirectory, setCurrentDirectory)
+import System.FilePath ((</>))
+import System.IO (BufferMode(..), hClose, hFlush, hSetBuffering, hSetEncoding, utf8)
+import System.IO.Error (isEOFError)
+import Database.SQLite.Simple qualified as SQLite
+import  Language.PureScript.Options as PO
+
+listenOnLocalhost :: Network.PortNumber -> IO Network.Socket
+listenOnLocalhost port = do
+  let hints = Network.defaultHints
+        { Network.addrFamily = Network.AF_INET
+        , Network.addrSocketType = Network.Stream
+        }
+  addr:_ <- Network.getAddrInfo (Just hints) (Just "127.0.0.1") (Just (show port))
+  bracketOnError
+    (Network.socket (Network.addrFamily addr) (Network.addrSocketType addr) (Network.addrProtocol addr))
+    Network.close
+    (\sock -> do
+      Network.setSocketOption sock Network.ReuseAddr 1
+      Network.bind sock (Network.addrAddress addr)
+      Network.listen sock Network.maxListenQueue
+      pure sock)
+
+data ServerOptions = ServerOptions
+  { _serverDirectory  :: Maybe FilePath
+  , _serverGlobs      :: [FilePath]
+  , _serverGlobsFromFile :: Maybe FilePath
+  , _serverGlobsExcluded :: [FilePath]
+  , _serverOutputPath :: FilePath
+  , _srcFile :: FilePath
+  , _serverPort       :: Network.PortNumber
+  , _serverLoglevel   :: IdeLogLevel
+  -- TODO(Christoph) Deprecated
+  , _serverEditorMode :: Bool
+  , _serverPolling    :: Bool
+  , _serverNoWatch    :: Bool
+
+  } deriving (Show)
+
+data ClientOptions = ClientOptions
+  { clientPort :: Network.PortNumber
+  }
+
+command :: Opts.Parser (IO ())
+command = Opts.helper <*> subcommands where
+  subcommands :: Opts.Parser (IO ())
+  subcommands = (Opts.subparser . fold)
+    [ Opts.command "server"
+        (Opts.info (fmap server serverOptions <**> Opts.helper)
+          (Opts.progDesc "Start a server process"))
+    ]
+
+  server :: ServerOptions -> IO ()
+  server opts'@(ServerOptions dir globs globsFromFile globsExcluded outputPath srcFile port logLevel editorMode polling noWatch) = do
+    when (logLevel == LogDebug || logLevel == LogAll)
+      (putText "Parsed Options:" *> print opts')
+    maybe (pure ()) setCurrentDirectory dir
+    ideState <- newTVarIO emptyIdeState
+    cwd <- getCurrentDirectory
+    let fullOutputPath = cwd </> outputPath
+
+
+    when noWatch
+      (putText "The --no-watch flag is deprecated and ignored. purs ide no longer uses a file system watcher, instead it relies on its clients to notify it about updates and checks timestamps to invalidate itself")
+
+    unlessM (doesDirectoryExist fullOutputPath) $ do
+      putText "Your output directory didn't exist. This usually means you didn't compile your project yet."
+      putText "psc-ide needs you to compile your project (for example by running pulp build)"
+
+    let
+      conf = IdeConfiguration
+        { confLogLevel = logLevel
+        , confOutputPath = outputPath
+        , sqliteFilePath = outputPath </> "cache.db"
+        , confGlobs = globs
+        , confGlobsFromFile = globsFromFile
+        , confGlobsExclude = globsExcluded
+        }
+    ts <- newIORef Nothing
+    let
+      env = IdeEnvironment
+        { ideStateVar = ideState
+        , ideConfiguration = conf
+        , ideCacheDbTimestamp = ts
+        , query = \q -> SQLite.withConnection (outputPath </> "cache.db")
+             (\conn -> SQLite.query_ conn $ SQLite.Query q)
+        }
+    startServer srcFile env
+
+  serverOptions :: Opts.Parser ServerOptions
+  serverOptions =
+    ServerOptions
+      <$> optional (Opts.strOption (Opts.long "directory" `mappend` Opts.short 'd'))
+      <*> many SharedCLI.inputFile
+      <*> SharedCLI.globInputFile
+      <*> many SharedCLI.excludeFiles
+      <*> Opts.strOption (Opts.long "output-directory" `mappend` Opts.value "output/")
+      <*> Opts.strOption (Opts.long "file" `mappend` Opts.value "output/")
+      <*> (fromIntegral <$>
+           Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer)))
+      <*> (parseLogLevel <$> Opts.strOption
+           (Opts.long "log-level"
+            `mappend` Opts.value ""
+            `mappend` Opts.help "One of \"debug\", \"perf\", \"all\" or \"none\""))
+      -- TODO(Christoph): Deprecated
+      <*> Opts.switch (Opts.long "editor-mode")
+      <*> Opts.switch (Opts.long "no-watch")
+      <*> Opts.switch (Opts.long "polling")
+
+  parseLogLevel :: Text -> IdeLogLevel
+  parseLogLevel s = case s of
+    "debug" -> LogDebug
+    "perf" -> LogPerf
+    "all" -> LogAll
+    "none" -> LogNone
+    _ -> LogDefault
+
+startServer :: FilePath -> IdeEnvironment -> IO ()
+startServer fp'' env = do
+  -- BSL8.putStrLn $ Aeson.encode fp''
+  runLogger (confLogLevel (ideConfiguration env)) (runReaderT (rebuildC fp'') env)
+  -- runLogger (confLogLevel (ideConfiguration env)) (runReaderT (forever (loop sock)) env)
+  where
+    rebuildC :: (Ide m, MonadLogger m) => FilePath -> m ()
+    rebuildC fp = do
+     runExceptT $ do
+      result <- handleCommand (RebuildSync fp Nothing (Set.fromList [PO.JS]))
+
+      -- liftIO $ BSL8.putStrLn $ Aeson.encode result 
+
+      return ()
+
+
+     return ()
+
+    loop :: (Ide m, MonadLogger m) => Network.Socket -> m ()
+    loop sock = do
+      accepted <- runExceptT (acceptCommand sock)
+      case accepted of
+        Left err -> $(logError) err
+        Right (cmd, h) -> do
+          case decodeT cmd of
+            Right cmd' -> do
+              let message duration =
+                    "Command "
+                      <> commandName cmd'
+                      <> " took "
+                      <> displayTimeSpec duration
+              logPerf message $ do
+                result <- runExceptT $ do
+                  updateCacheTimestamp >>= \case
+                    Nothing -> pure ()
+                    Just (before, after) -> do
+                      -- If the cache db file was changed outside of the IDE
+                      -- we trigger a reset before processing the command
+                      $(logInfo) ("cachedb was changed from: " <> show before <> ", to: " <> show after)
+                      unless (isLoadAll cmd') $
+                        void (handleCommand Reset *> handleCommand (LoadSync []))
+                  handleCommand cmd'
+                liftIO $ catchGoneHandle $ BSL8.hPutStrLn h $ case result of
+                  Right r  -> Aeson.encode r
+                  Left err -> Aeson.encode err
+              liftIO (hFlush stdout)
+            Left err -> do
+              let errMsg = "Parsing the command failed with:\n" <> err <> "\nCommand: " <> cmd
+              $(logError) errMsg
+              liftIO $ do
+                catchGoneHandle (T.hPutStrLn h (encodeT (GeneralError errMsg)))
+                hFlush stdout
+          liftIO $ catchGoneHandle (hClose h)
+
+isLoadAll :: Command -> Bool
+isLoadAll = \case
+  Load [] -> True
+  _ -> False
+
+catchGoneHandle :: IO () -> IO ()
+catchGoneHandle =
+  handle (\e -> case e of
+    IOError { ioe_type = ResourceVanished } ->
+      putText "[Error] psc-ide-server tried to interact with the handle, but the connection was already gone."
+    _ -> throwIO e)
+
+acceptCommand
+  :: (MonadIO m, MonadLogger m, MonadError Text m)
+  => Network.Socket
+  -> m (Text, Handle)
+acceptCommand sock = do
+  h <- acceptConnection
+  $(logDebug) "Accepted a connection"
+  cmd' <- liftIO (catchJust
+                  -- this means that the connection was
+                  -- terminated without receiving any input
+                  (\e -> if isEOFError e then Just () else Nothing)
+                  (Just <$> T.hGetLine h)
+                  (const (pure Nothing)))
+  case cmd' of
+    Nothing -> throwError "Connection was closed before any input arrived"
+    Just cmd -> do
+      $(logDebug) ("Received command: " <> cmd)
+      pure (cmd, h)
+  where
+   acceptConnection = liftIO $ do
+     -- Use low level accept to prevent accidental reverse name resolution
+     (s,_) <- Network.accept sock
+     h     <- Network.socketToHandle s ReadWriteMode
+     hSetEncoding h utf8
+     hSetBuffering h LineBuffering
+     pure h

app/Main.hs

@@ -8,6 +8,7 @@ import Command.Docs qualified as Docs
 import Command.Graph qualified as Graph
 import Command.Hierarchy qualified as Hierarchy
 import Command.Ide qualified as Ide
+import Command.QuickBuild qualified as QB
 import Command.Publish qualified as Publish
 import Command.REPL qualified as REPL
 import Control.Monad (join)
@@ -61,6 +62,9 @@ main = do
         [ Opts.command "bundle"
             (Opts.info Bundle.command
               (Opts.progDesc "This command was removed in v0.15.0. Run this command for migration information."))
+        , Opts.command "sqlite"
+            (Opts.info Bundle.initSqlite
+              (Opts.progDesc "Init sqlite"))
         , Opts.command "compile"
             (Opts.info Compile.command
               (Opts.progDesc "Compile PureScript source files"))
@@ -76,6 +80,9 @@ main = do
         , Opts.command "ide"
             (Opts.info Ide.command
               (Opts.progDesc "Start or query an IDE server process"))
+        , Opts.command "qb"
+            (Opts.info QB.command
+              (Opts.progDesc "Quick build module"))
         , Opts.command "publish"
             (Opts.info Publish.command
               (Opts.progDesc "Generates documentation packages for upload to Pursuit"))

profile-admin.txt

@@ -1,27 +1,27 @@
 'purs' 'compile' '--source-globs-file' '.spago/sources.txt' +RTS '-N' '-sprofile.txt' 
-1,881,065,351,416 bytes allocated in the heap
- 573,448,796,456 bytes copied during GC
-   6,854,605,176 bytes maximum residency (51 sample(s))
-      96,912,208 bytes maximum slop
-           19822 MiB total memory in use (0 MB lost due to fragmentation)
+ 765,357,373,648 bytes allocated in the heap
+ 360,583,388,216 bytes copied during GC
+   6,131,704,224 bytes maximum residency (40 sample(s))
+      59,567,712 bytes maximum slop
+           17666 MiB total memory in use (0 MB lost due to fragmentation)
 
                                      Tot time (elapsed)  Avg pause  Max pause
-  Gen  0     112618 colls, 112618 par   556.187s  189.050s     0.0017s    0.0491s
-  Gen  1        51 colls,    50 par   233.076s  122.893s     2.4097s    4.1721s
+  Gen  0     63238 colls, 63238 par   214.826s  86.156s     0.0014s    0.0344s
+  Gen  1        40 colls,    39 par   126.759s  24.613s     0.6153s    2.3480s
 
-  Parallel GC work balance: 72.00% (serial 0%, perfect 100%)
+  Parallel GC work balance: 62.83% (serial 0%, perfect 100%)
 
-  TASKS: 45 (1 bound, 44 peak workers (44 total), using -N10)
+  TASKS: 58 (1 bound, 57 peak workers (57 total), using -N10)
 
   SPARKS: 7516 (7516 converted, 0 overflowed, 0 dud, 0 GC'd, 0 fizzled)
 
-  INIT    time    0.000s  (  0.004s elapsed)
-  MUT     time  746.850s  (124.852s elapsed)
-  GC      time  789.263s  (311.943s elapsed)
-  EXIT    time    0.126s  (  0.007s elapsed)
-  Total   time  1536.239s  (436.806s elapsed)
+  INIT    time    0.000s  (  0.003s elapsed)
+  MUT     time  307.420s  ( 79.011s elapsed)
+  GC      time  341.586s  (110.770s elapsed)
+  EXIT    time    0.110s  (  0.004s elapsed)
+  Total   time  649.117s  (189.789s elapsed)
 
-  Alloc rate    2,518,666,039 bytes per MUT second
+  Alloc rate    2,489,613,396 bytes per MUT second
 
-  Productivity  48.6% of total user, 28.6% of total elapsed
+  Productivity  47.4% of total user, 41.6% of total elapsed