From e38460491f7c3ae0ef1648a43ca4f80a5f435aab Mon Sep 17 00:00:00 2001 From: seastian Date: Thu, 26 Sep 2024 09:21:28 +0200 Subject: [PATCH] wip --- src/Language/PureScript/Ide.hs | 32 ++++++++++++------- src/Language/PureScript/Make/IdeCache.hs | 40 ++++++++++++++++++++++-- 2 files changed, 58 insertions(+), 14 deletions(-) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 3b874a7995..3eb92f3145 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -60,6 +60,7 @@ 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. @@ -99,15 +100,24 @@ handleCommand c = case c of 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 a.span" + , "from dependencies d join asts a on d.module_name = a.module_name" + , "where d.dependency = '" <> 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 @@ -168,8 +178,8 @@ findDeclarations filters currentModule completionOptions = do foldMap (\maxResults -> " limit " <> show maxResults ) (coMaxResults =<< completionOptions) let matches = rows <&> \(m, decl) -> (Match (ModuleName m, deserialise decl), []) - - pure $ CompletionResult $ completionFromMatch <$> matches + + pure $ CompletionResult $ completionFromMatch <$> matches sqliteFile :: Ide m => m FilePath sqliteFile = outputDirectory <&> ( "cache.db") diff --git a/src/Language/PureScript/Make/IdeCache.hs b/src/Language/PureScript/Make/IdeCache.hs index 4126791844..a95e65d3f2 100644 --- a/src/Language/PureScript/Make/IdeCache.hs +++ b/src/Language/PureScript/Make/IdeCache.hs @@ -9,7 +9,7 @@ import Codec.Serialise qualified as Serialise import Control.Concurrent (threadDelay) import Control.Exception (try) import System.FilePath ((), takeDirectory) -import Language.PureScript.Names (runModuleName, ProperName (runProperName), runIdent) +import Language.PureScript.Names (runModuleName, ProperName (runProperName), runIdent, disqualify, Ident (..)) import Language.PureScript.Externs (ExternsFile(..), ExternsImport(..)) import Data.Foldable (for_) import Control.Monad.IO.Class (MonadIO (liftIO)) @@ -31,14 +31,34 @@ import Language.PureScript.Docs.AsMarkdown (codeToString, declAsMarkdown, runDoc import Codec.Serialise (serialise) import Data.Aeson (encode) import Debug.Trace qualified as Debug -import Language.PureScript.AST.Declarations (Module) +import Language.PureScript.AST.Declarations (Module, Expr (Var), getModuleDeclarations) import Language.PureScript.Ide.Filter.Declaration (DeclarationType (..)) import Data.Aeson qualified as Aeson +import Language.PureScript.AST.Traversals (everywhereOnValuesM) +import Protolude (identity) sqliteExtern :: (MonadIO m) => FilePath -> Module -> Docs.Module -> ExternsFile -> m () sqliteExtern outputDir m docs extern = liftIO $ do conn <- SQLite.open db + -- Debug.traceM $ show m + + let (doDecl, _, _) = everywhereOnValuesM (pure . identity) (\expr -> case expr of + Var ss i -> do + let iv = disqualify i + case iv of + Ident t -> do + withRetry $ SQLite.executeNamed conn + "insert into asts (module_name, name, span) values (:module_name, :name, :span)" + [ ":module_name" := runModuleName ( efModuleName extern ) + , ":name" := t + , ":span" := Aeson.encode ss + ] + _ -> pure () + pure expr + _ -> pure expr + ) (pure . identity) + withRetry $ SQLite.execute_ conn "pragma foreign_keys = ON;" withRetry $ SQLite.executeNamed conn @@ -46,6 +66,7 @@ sqliteExtern outputDir m docs extern = liftIO $ do [ ":module_name" := runModuleName ( efModuleName extern ) ] + withRetry $ SQLite.executeNamed conn "insert into modules (module_name, comment, extern, dec) values (:module_name, :docs, :extern, :dec)" [ ":module_name" := runModuleName ( efModuleName extern ) @@ -54,6 +75,8 @@ sqliteExtern outputDir m docs extern = liftIO $ do , ":dec" := show ( efExports extern ) ] + for_ (getModuleDeclarations m) (\d -> doDecl d) + for_ (efImports extern) (\i -> do withRetry $ SQLite.executeNamed conn "insert into dependencies (module_name, dependency) values (:module_name, :dependency)" [ ":module_name" := runModuleName (efModuleName extern ) @@ -191,10 +214,21 @@ sqliteInit outputDir = liftIO $ do , ")" ] + withRetry $ SQLite.execute_ conn $ SQLite.Query $ Text.pack $ unlines + [ "create table if not exists asts (" + , " module_name text references modules(module_name) on delete cascade," + , " name text not null," + , " span text" + , ")" + ] + withRetry $ SQLite.execute_ conn "create index if not exists dm on declarations(module_name)" withRetry $ SQLite.execute_ conn "create index if not exists dn on declarations(name);" + + withRetry $ SQLite.execute_ conn "create index if not exists asts_module_name_idx on asts(module_name);" + withRetry $ SQLite.execute_ conn "create index if not exists asts_name_idx on asts(name);" - withRetry $ SQLite.execute_ conn "create table if not exists ide_declarations (module_name text, name text, namespace text, declaration_type text, span blob, declaration blob)" + withRetry $ SQLite.execute_ conn "create table if not exists ide_declarations (module_name text references modules(module_name) on delete cascade, name text, namespace text, declaration_type text, span blob, declaration blob)" SQLite.close conn where db = outputDir "cache.db"