Sqlite

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,8 @@ command = Opts.helper <*> subcommands where
         { ideStateVar = ideState
         , ideConfiguration = conf
         , ideCacheDbTimestamp = ts
+        , query = \q -> SQLite.withConnection (outputPath </> "cache.db")
+             (\conn -> SQLite.query_ conn $ SQLite.Query q)
         }
     startServer port env
 

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

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)

src/Language/PureScript/Docs/AsMarkdown.hs

@@ -3,6 +3,7 @@ module Language.PureScript.Docs.AsMarkdown
   , runDocs
   , moduleAsMarkdown
   , codeToString
+  , declAsMarkdown
   ) where
 
 import Prelude
@@ -17,8 +18,8 @@ import Data.Text qualified as T
 
 import Language.PureScript.Docs.RenderedCode (RenderedCode, RenderedCodeElement(..), outputWith)
 import Language.PureScript.Docs.Types (ChildDeclaration(..), ChildDeclarationInfo(..), Declaration(..), Module(..), ignorePackage)
-import Language.PureScript qualified as P
 import Language.PureScript.Docs.Render qualified as Render
+import Language.PureScript.Names qualified as P
 
 moduleAsMarkdown :: Module -> Docs
 moduleAsMarkdown Module{..} = do

src/Language/PureScript/Environment.hs

@@ -6,7 +6,7 @@ import GHC.Generics (Generic)
 import Control.DeepSeq (NFData)
 import Control.Monad (unless)
 import Codec.Serialise (Serialise)
-import Data.Aeson ((.=), (.:))
+import Data.Aeson ((.=), (.:), ToJSON, FromJSON)
 import Data.Aeson qualified as A
 import Data.Foldable (find, fold)
 import Data.Functor ((<&>))
@@ -267,6 +267,9 @@ data TypeKind
   -- ^ A scoped type variable
   deriving (Show, Eq, Generic)
 
+instance ToJSON TypeKind
+instance FromJSON TypeKind
+
 instance NFData TypeKind
 instance Serialise TypeKind
 

src/Language/PureScript/Errors/JSON.hs

@@ -7,8 +7,10 @@ import Prelude
 import Data.Aeson.TH qualified as A
 import Data.List.NonEmpty qualified as NEL
 import Data.Text (Text)
+import Language.PureScript.AST.SourcePos qualified as P
+import Language.PureScript.Errors qualified as P
+import Language.PureScript.Names qualified as P
 
-import Language.PureScript qualified as P
 
 data ErrorPosition = ErrorPosition
   { startLine :: Int

src/Language/PureScript/Externs.hs

@@ -39,6 +39,7 @@ import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionary
 import Language.PureScript.Types (SourceConstraint, SourceType, srcInstanceType)
 
 import Paths_purescript as Paths
+import Data.Aeson (ToJSON, FromJSON)
 
 -- | The data which will be serialized to an externs file
 data ExternsFile = ExternsFile
@@ -61,10 +62,11 @@ data ExternsFile = ExternsFile
   -- ^ List of type and value declaration
   , efSourceSpan :: SourceSpan
   -- ^ Source span for error reporting
-  } deriving (Show, Generic, NFData)
+  } deriving (Show, Generic, NFData, ToJSON, FromJSON)
 
 instance Serialise ExternsFile
 
+
 -- | A module import in an externs file
 data ExternsImport = ExternsImport
   {
@@ -77,6 +79,8 @@ data ExternsImport = ExternsImport
   } deriving (Show, Generic, NFData)
 
 instance Serialise ExternsImport
+instance ToJSON ExternsImport
+instance FromJSON ExternsImport
 
 -- | A fixity declaration in an externs file
 data ExternsFixity = ExternsFixity
@@ -92,6 +96,8 @@ data ExternsFixity = ExternsFixity
   } deriving (Show, Generic, NFData)
 
 instance Serialise ExternsFixity
+instance ToJSON ExternsFixity
+instance FromJSON ExternsFixity
 
 -- | A type fixity declaration in an externs file
 data ExternsTypeFixity = ExternsTypeFixity
@@ -104,7 +110,7 @@ data ExternsTypeFixity = ExternsTypeFixity
   , efTypeOperator :: OpName 'TypeOpName
   -- | The value the operator is an alias for
   , efTypeAlias :: Qualified (ProperName 'TypeName)
-  } deriving (Show, Generic, NFData)
+  } deriving (Show, Generic, NFData, ToJSON, FromJSON)
 
 instance Serialise ExternsTypeFixity
 
@@ -157,10 +163,11 @@ data ExternsDeclaration =
       , edInstanceNameSource      :: NameSource
       , edInstanceSourceSpan      :: SourceSpan
       }
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, ToJSON, FromJSON)
 
 instance Serialise ExternsDeclaration
 
+
 -- | Check whether the version in an externs file matches the currently running
 -- version.
 externsIsCurrentVersion :: ExternsFile -> Bool

src/Language/PureScript/Ide.hs

@@ -27,22 +27,40 @@ import Language.PureScript qualified as P
 import Language.PureScript.Glob (toInputGlobs, PSCGlobs(..))
 import Language.PureScript.Ide.CaseSplit qualified as CS
 import Language.PureScript.Ide.Command (Command(..), ImportCommand(..), ListType(..))
-import Language.PureScript.Ide.Completion (CompletionOptions, completionFromMatch, getCompletions, getExactCompletions, simpleExport)
+import Language.PureScript.Ide.Completion (CompletionOptions (coMaxResults), completionFromMatch, getCompletions, getExactCompletions, simpleExport)
 import Language.PureScript.Ide.Error (IdeError(..))
 import Language.PureScript.Ide.Externs (readExternFile)
-import Language.PureScript.Ide.Filter (Filter)
+import Language.PureScript.Ide.Filter qualified as F
 import Language.PureScript.Ide.Imports (parseImportsFromFile)
 import Language.PureScript.Ide.Imports.Actions (addImplicitImport, addImportForIdentifier, addQualifiedImport, answerRequest)
-import Language.PureScript.Ide.Matcher (Matcher)
+import Language.PureScript.Ide.Matcher (Matcher, Matcher' (..))
 import Language.PureScript.Ide.Prim (idePrimDeclarations)
 import Language.PureScript.Ide.Rebuild (rebuildFileAsync, rebuildFileSync)
 import Language.PureScript.Ide.SourceFile (parseModulesFromFiles)
-import Language.PureScript.Ide.State (getAllModules, getLoadedModulenames, insertExterns, insertModule, populateVolatileState, populateVolatileStateSync, resetIdeState)
-import Language.PureScript.Ide.Types (Annotation(..), Ide, IdeConfiguration(..), IdeDeclarationAnn(..), IdeEnvironment(..), Success(..))
+import Language.PureScript.Ide.State (getAllModules, getLoadedModulenames, insertExterns, insertModule, populateVolatileState, populateVolatileStateSync, resetIdeState, getSqliteFilePath, runQuery)
+import Language.PureScript.Ide.Types (Annotation(..), Ide, IdeConfiguration(..), IdeDeclarationAnn(..), IdeEnvironment(..), Success(..), Completion (..), toText, Match (..))
 import Language.PureScript.Ide.Util (discardAnn, identifierFromIdeDeclaration, namespaceForDeclaration, withEmptyAnn)
 import Language.PureScript.Ide.Usage (findUsages)
 import System.Directory (getCurrentDirectory, getDirectoryContents, doesDirectoryExist, doesFileExist)
 import System.FilePath ((</>), normalise)
+import Language.PureScript.Names (ModuleName(ModuleName))
+import Language.PureScript.AST.SourcePos (SourceSpan(SourceSpan))
+import Language.PureScript.Errors (SourcePos(..))
+import Database.SQLite.Simple qualified as SQLite
+import Language.PureScript (cacheDbFile, runModuleName)
+import Debug.Trace qualified as Debug
+import Data.Maybe (catMaybes)
+import Protolude (head)
+import Data.Foldable (find, Foldable (toList, foldMap))
+import Data.Text qualified
+import Data.Either (isLeft)
+import Codec.Serialise (deserialise)
+import Data.ByteString.Lazy qualified
+import Database.SQLite.Simple (Only(Only))
+import Database.SQLite.Simple.ToField (ToField(..))
+import Language.PureScript.Ide.Filter.Declaration (declarationTypeToText)
+import Data.ByteString.Lazy qualified as Lazy
+import Data.Aeson qualified as Aeson
 
 -- | Accepts a Command and runs it against psc-ide's State. This is the main
 -- entry point for the server.
@@ -53,39 +71,56 @@ handleCommand
 handleCommand c = case c of
   Load [] ->
     -- Clearing the State before populating it to avoid a space leak
-    resetIdeState *> findAvailableExterns >>= loadModulesAsync
+    pure $ TextResult "Done"
+    -- resetIdeState *> findAvailableExterns >>= loadModulesAsync
   Load modules ->
-    loadModulesAsync modules
+    pure $ TextResult "Done"
+    -- loadModulesAsync modules
   LoadSync [] ->
-    findAvailableExterns >>= loadModulesSync
+    pure $ TextResult "Done"
+    -- findAvailableExterns >>= loadModulesSync
   LoadSync modules ->
-    loadModulesSync modules
+    pure $ TextResult "Done"
+    -- loadModulesSync modules
   Type search filters currentModule ->
-    findType search filters currentModule
-  Complete filters matcher currentModule complOptions ->
-    findCompletions filters matcher currentModule complOptions
+    findDeclarations (F.Filter (Right $ F.Exact search) : filters) currentModule Nothing
+  Complete filters matcher currentModule complOptions -> do
+
+    findDeclarations (filters <> foldMap (\case 
+        Flex q -> [F.Filter (Right $ F.Prefix q)]
+        Distance q _ -> [F.Filter (Right $ F.Prefix q)]) matcher) currentModule (Just complOptions)
+    -- findCompletions' filters matcher currentModule complOptions
   List LoadedModules -> do
     logWarnN
       "Listing the loaded modules command is DEPRECATED, use the completion command and filter it to modules instead"
-    printModules
+    ModuleList . join <$> runQuery "select module_name from modules"
   List AvailableModules ->
-    listAvailableModules
+    ModuleList . join <$> runQuery "select module_name from modules"
   List (Imports fp) ->
     ImportList <$> parseImportsFromFile fp
   CaseSplit l b e wca t ->
     caseSplit l b e wca t
   AddClause l wca ->
     MultilineTextResult <$> CS.addClause l wca
   FindUsages moduleName ident namespace -> do
-    Map.lookup moduleName <$> getAllModules Nothing >>= \case
-      Nothing -> throwError (GeneralError "Module not found")
-      Just decls -> do
-        case find (\d -> namespaceForDeclaration (discardAnn d) == namespace
-                    && identifierFromIdeDeclaration (discardAnn d) == ident) decls of
-          Nothing -> throwError (GeneralError "Declaration not found")
-          Just declaration -> do
-            let sourceModule = fromMaybe moduleName (declaration & _idaAnnotation & _annExportedFrom)
-            UsagesResult . foldMap toList <$> findUsages (discardAnn declaration) sourceModule
+    r :: [Only Lazy.ByteString] <- runQuery $ unlines
+      [ "select distinct a.span"
+      , "from dependencies d join asts a on d.module_name = a.module_name"
+      , "where (d.dependency = '" <> runModuleName moduleName <> "' or d.module_name = '" <> runModuleName moduleName <> "') and a.name = '" <> ident <> "'"
+      ]
+
+    pure $ UsagesResult (mapMaybe (\(Only span) -> Aeson.decode span) r)
+
+
+    -- Map.lookup moduleName <$> getAllModules Nothing >>= \case
+    --   Nothing -> throwError (GeneralError "Module not found")
+    --   Just decls -> do
+    --     case find (\d -> namespaceForDeclaration (discardAnn d) == namespace
+    --                 && identifierFromIdeDeclaration (discardAnn d) == ident) decls of
+    --       Nothing -> throwError (GeneralError "Declaration not found")
+    --       Just declaration -> do
+    --         let sourceModule = fromMaybe moduleName (declaration & _idaAnnotation & _annExportedFrom)
+    --         UsagesResult . foldMap toList <$> findUsages (discardAnn declaration) sourceModule
   Import fp outfp _ (AddImplicitImport mn) -> do
     rs <- addImplicitImport fp mn
     answerRequest outfp rs
@@ -111,7 +146,7 @@ handleCommand c = case c of
 
 findCompletions
   :: Ide m
-  => [Filter]
+  => [F.Filter]
   -> Matcher IdeDeclarationAnn
   -> Maybe P.ModuleName
   -> CompletionOptions
@@ -121,34 +156,48 @@ findCompletions filters matcher currentModule complOptions = do
   let insertPrim = Map.union idePrimDeclarations
   pure (CompletionResult (getCompletions filters matcher complOptions (insertPrim modules)))
 
-findType
+findDeclarations
   :: Ide m
-  => Text
-  -> [Filter]
+  => [F.Filter]
   -> Maybe P.ModuleName
+  -> Maybe CompletionOptions
   -> m Success
-findType search filters currentModule = do
-  modules <- getAllModules currentModule
-  let insertPrim = Map.union idePrimDeclarations
-  pure (CompletionResult (getExactCompletions search filters (insertPrim modules)))
+findDeclarations filters currentModule completionOptions = do
+  rows :: [(Text, Lazy.ByteString)] <- runQuery $
+    "select module_name, declaration " <>
+    "from ide_declarations id " <>
+    (
+      mapMaybe (\case
+        F.Filter (Left modules) ->
+          Just $ "(exists (select 1 from exports e where id.module_name = e.defined_in and id.name = e.name and id.declaration_type = e.declaration_type and e.module_name in (" <>
+            T.intercalate "," (toList modules <&> runModuleName <&> \m -> "'" <> m <> "'") <>
+          "))" <>
+          " or " <> "id.module_name in (" <> T.intercalate "," (toList modules <&> runModuleName <&> \m -> "'" <> m <> "'") <> "))"
+        F.Filter (Right (F.Prefix f)) -> Just $ "id.name glob '" <> f <> "*'"
+        F.Filter (Right (F.Exact f)) -> Just $ "id.name glob '" <> f <> "'"
+        F.Filter (Right (F.Namespace namespaces)) ->
+          Just $ "id.namespace in (" <> T.intercalate "," (toList namespaces <&> \n -> "'" <> toText n <> "'") <> ")"
+        F.Filter (Right (F.DeclType dt)) ->
+          Just $ "id.namespace in (" <> T.intercalate "," (toList dt <&> \t -> "'" <> declarationTypeToText t <> "'") <> ")"
+        F.Filter _ -> Nothing)
+      filters
+      & \f -> if null f then " " else " where " <> T.intercalate " and " f
+      ) <>
+    foldMap (\maxResults -> " limit " <> show maxResults ) (coMaxResults =<< completionOptions)
 
-printModules :: Ide m => m Success
-printModules = ModuleList . map P.runModuleName <$> getLoadedModulenames
+  let matches = rows <&> \(m, decl) -> (Match (ModuleName m, deserialise decl), [])
+
+  pure $ CompletionResult $ completionFromMatch <$> matches
+
+sqliteFile :: Ide m => m FilePath
+sqliteFile = outputDirectory <&> ( </> "cache.db")
 
 outputDirectory :: Ide m => m FilePath
 outputDirectory = do
   outputPath <- confOutputPath . ideConfiguration <$> ask
   cwd <- liftIO getCurrentDirectory
   pure (cwd </> outputPath)
 
-listAvailableModules :: Ide m => m Success
-listAvailableModules = do
-  oDir <- outputDirectory
-  liftIO $ do
-    contents <- getDirectoryContents oDir
-    let cleaned = filter (`notElem` [".", ".."]) contents
-    return (ModuleList (map toS cleaned))
-
 caseSplit :: (Ide m, MonadError IdeError m) =>
   Text -> Int -> Int -> CS.WildcardAnnotations -> Text -> m Success
 caseSplit l b e csa t = do