Sqlite

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/Ide.hs

@@ -40,6 +40,7 @@ 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
 
 listenOnLocalhost :: Network.PortNumber -> IO Network.Socket
 listenOnLocalhost port = do
@@ -138,6 +139,7 @@ command = Opts.helper <*> subcommands where
       conf = IdeConfiguration
         { confLogLevel = logLevel
         , confOutputPath = outputPath
+        , sqliteFilePath = outputPath </> "cache.db"
         , confGlobs = globs
         , confGlobsFromFile = globsFromFile
         , confGlobsExclude = globsExcluded
@@ -148,6 +150,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
 

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 <[email protected]>
+-- 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"))

purescript.cabal

@@ -81,6 +81,12 @@ common defaults
     -- Don’t warn if the monomorphism restriction is used
     -Wno-monomorphism-restriction
 
+    -Wno-unused-matches
+    -Wno-unused-local-binds
+    -Wno-unused-imports
+    -Wno-unused-top-binds
+    -Wno-redundant-constraints
+
     -- Remaining options don't come from the above blog post
     -Wno-missing-deriving-strategies
     -Wno-missing-export-lists
@@ -198,6 +204,7 @@ common defaults
     semigroups ==0.20.*,
     semialign >=1.2.0.1 && <1.3,
     sourcemap >=0.1.7 && <0.2,
+    sqlite-simple ==0.4.18.2,
     stm >=2.5.0.2 && <2.6,
     stringsearch >=0.3.6.6 && <0.4,
     template-haskell >=2.18.0.0 && <2.19,
@@ -267,6 +274,8 @@ library
     Language.PureScript.CST.Parser
     Language.PureScript.CST.Positions
     Language.PureScript.CST.Print
+    Language.PureScript.Ide.ToIde
+    Language.PureScript.Ide.ToI
     Language.PureScript.CST.Traversals
     Language.PureScript.CST.Traversals.Type
     Language.PureScript.CST.Types
@@ -336,6 +345,7 @@ library
     Language.PureScript.Make.Actions
     Language.PureScript.Make.BuildPlan
     Language.PureScript.Make.Cache
+    Language.PureScript.Make.IdeCache
     Language.PureScript.Make.Monad
     Language.PureScript.ModuleDependencies
     Language.PureScript.Names
@@ -422,6 +432,7 @@ executable purs
     Command.Graph
     Command.Hierarchy
     Command.Ide
+    Command.QuickBuild
     Command.Publish
     Command.REPL
     SharedCLI

src/Language/PureScript/AST/Declarations/ChainId.hs

@@ -7,14 +7,15 @@ import Prelude
 import Language.PureScript.AST.SourcePos qualified as Pos
 import Control.DeepSeq (NFData)
 import Codec.Serialise (Serialise)
+import Data.Aeson (ToJSON, FromJSON)
 
 -- |
 -- For a given instance chain, stores the chain's file name and
 -- the starting source pos of the first instance in the chain.
 -- This data is used to determine which instances are part of
 -- the same instance chain.
 newtype ChainId = ChainId (String, Pos.SourcePos)
-  deriving (Eq, Ord, Show, NFData, Serialise)
+  deriving (Eq, Ord, Show, NFData, Serialise, ToJSON, FromJSON)
 
 mkChainId :: String -> Pos.SourcePos -> ChainId
 mkChainId fileName startingSourcePos = ChainId (fileName, startingSourcePos)