From 0a198c00d025b8cfb3c3864d334cea4196bb6656 Mon Sep 17 00:00:00 2001 From: seastian Date: Sat, 14 Sep 2024 16:21:36 +0200 Subject: [PATCH 01/38] add sqlite dep --- purescript.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/purescript.cabal b/purescript.cabal index 0d32ce4814..cccaf7c01a 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -198,6 +198,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, From 4a274843339ec0b123a119669fe145143c4350bd Mon Sep 17 00:00:00 2001 From: seastian Date: Sat, 14 Sep 2024 16:22:37 +0200 Subject: [PATCH 02/38] save stuff on sqlite wip add column to json store extern on db whatever to json unique constraint externs log perf rebuild fast rebuild comment out load add indexes fix query fix query completions refactor refactor convertdcl concer add completions drp import wip save comment docs externs refactor imports more sqlitepath on env wip wip wip --- app/Command/Ide.hs | 1 + purescript.cabal | 7 ++ .../PureScript/AST/Declarations/ChainId.hs | 3 +- src/Language/PureScript/Docs/AsMarkdown.hs | 3 +- src/Language/PureScript/Environment.hs | 5 +- src/Language/PureScript/Errors/JSON.hs | 4 +- src/Language/PureScript/Externs.hs | 13 +- src/Language/PureScript/Ide.hs | 118 ++++++++++++++++-- src/Language/PureScript/Ide/Error.hs | 9 +- src/Language/PureScript/Ide/Externs.hs | 6 +- src/Language/PureScript/Ide/Filter.hs | 3 +- src/Language/PureScript/Ide/Rebuild.hs | 63 ++++++++-- src/Language/PureScript/Ide/State.hs | 5 + src/Language/PureScript/Ide/Types.hs | 11 +- src/Language/PureScript/Ide/Util.hs | 2 +- src/Language/PureScript/Make/Actions.hs | 6 +- src/Language/PureScript/Make/IdeCache.hs | 118 ++++++++++++++++++ src/Language/PureScript/Make/Monad.hs | 9 +- 18 files changed, 348 insertions(+), 38 deletions(-) create mode 100644 src/Language/PureScript/Make/IdeCache.hs diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index f5a501af75..3fa6304322 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -138,6 +138,7 @@ command = Opts.helper <*> subcommands where conf = IdeConfiguration { confLogLevel = logLevel , confOutputPath = outputPath + , sqliteFilePath = outputPath "cache.db" , confGlobs = globs , confGlobsFromFile = globsFromFile , confGlobsExclude = globsExcluded diff --git a/purescript.cabal b/purescript.cabal index cccaf7c01a..d9ae7906aa 100644 --- a/purescript.cabal +++ b/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 @@ -337,6 +343,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 diff --git a/src/Language/PureScript/AST/Declarations/ChainId.hs b/src/Language/PureScript/AST/Declarations/ChainId.hs index aacfc11fe8..a5847b93b1 100644 --- a/src/Language/PureScript/AST/Declarations/ChainId.hs +++ b/src/Language/PureScript/AST/Declarations/ChainId.hs @@ -7,6 +7,7 @@ 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 @@ -14,7 +15,7 @@ import Codec.Serialise (Serialise) -- 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) diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index 82139ccbe4..6f8b80a935 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/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 diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index e1f857031f..adb694d32f 100644 --- a/src/Language/PureScript/Environment.hs +++ b/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 diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs index 9e2af78668..ceeb76fddf 100644 --- a/src/Language/PureScript/Errors/JSON.hs +++ b/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 diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index a9669a9995..778bd7da43 100644 --- a/src/Language/PureScript/Externs.hs +++ b/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 diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 57601c3d45..b02c0589a9 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -30,19 +30,32 @@ import Language.PureScript.Ide.Command (Command(..), ImportCommand(..), ListType import Language.PureScript.Ide.Completion (CompletionOptions, 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.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) +import Language.PureScript.Ide.Types (Annotation(..), Ide, IdeConfiguration(..), IdeDeclarationAnn(..), IdeEnvironment(..), Success(..), Completion (..)) 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)) +import Data.Text qualified +import Data.Either (isLeft) +import Codec.Serialise (deserialise) +import Data.ByteString.Lazy qualified -- | Accepts a Command and runs it against psc-ide's State. This is the main -- entry point for the server. @@ -53,17 +66,21 @@ 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 + 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" @@ -111,7 +128,7 @@ handleCommand c = case c of findCompletions :: Ide m - => [Filter] + => [F.Filter] -> Matcher IdeDeclarationAnn -> Maybe P.ModuleName -> CompletionOptions @@ -121,20 +138,95 @@ findCompletions filters matcher currentModule complOptions = do let insertPrim = Map.union idePrimDeclarations pure (CompletionResult (getCompletions filters matcher complOptions (insertPrim modules))) +findCompletions' + :: Ide m + => [F.Filter] + -> Matcher IdeDeclarationAnn + -> Maybe P.ModuleName + -> CompletionOptions + -> m Success +findCompletions' filters matcher currentModule complOptions = do + sq <- sqliteFile + completions <- liftIO $ SQLite.withConnection sq $ \conn -> do + rows :: [(Text, Text, Maybe Text)] <- SQLite.query conn "select module_name, name, docs from declarations where name glob ?" (SQLite.Only (glob filters :: Text)) + return rows + + Debug.traceM $ show completions + + pure $ CompletionResult $ completions <&> \(module_name, name, docs) -> + Completion + { complModule = module_name + , complIdentifier = name + , complType = "TYPE" + , complExpandedType = "EXPANDED" + , complLocation = Just (SourceSpan + { spanName = ".spago/BuildInfo.purs" + , spanStart = SourcePos + { sourcePosLine = 3 + , sourcePosColumn = 1 + } + , spanEnd = SourcePos + { sourcePosLine = 1 + , sourcePosColumn = 1 + } + }) + , complDocumentation = docs + , complExportedFrom = [ModuleName "BuildInfo"] + , complDeclarationType = Nothing + } + where + glob :: [F.Filter] -> Text + glob f = mapMaybe globSearch f & head & fromMaybe "*" + globSearch :: F.Filter -> Maybe Text + globSearch (F.Filter (Right (F.Prefix p))) = Just (p <> "*") + globSearch (F.Filter (Right (F.Exact p))) = Just p + globSearch _ = Nothing + + + -- modules <- getAllModules currentModule + -- let insertPrim = Map.union idePrimDeclarations + -- pure (CompletionResult (getCompletions filters matcher complOptions (insertPrim modules))) + findType :: Ide m => Text - -> [Filter] + -> [F.Filter] -> Maybe P.ModuleName -> m Success findType search filters currentModule = do - modules <- getAllModules currentModule - let insertPrim = Map.union idePrimDeclarations - pure (CompletionResult (getExactCompletions search filters (insertPrim modules))) + sqlite <- getSqliteFilePath + rows <- liftIO $ SQLite.withConnection sqlite $ \conn -> do + SQLite.query_ conn $ SQLite.Query $ + "select module_name, name, type, span " <> + "from declarations where " <> + T.intercalate " and " ( + ("name glob '" <> search <> "' ") : mapMaybe (\case + F.Filter (Left modules) -> + Just $ "module_name in (" <> T.intercalate "," (toList modules <&> runModuleName <&> \m -> "'" <> m <> "'") <> ")" + F.Filter (Right (F.Exact f)) -> Just $ "name glob '" <> f <> "'" + F.Filter (Right (F.Prefix f)) -> Just $ "name glob '" <> f <> "*'" + F.Filter _ -> Nothing) + filters) + + pure $ CompletionResult (rows <&> \(module_name, name, type_, span) -> Completion + { complModule = module_name + , complIdentifier = name + , complType = "TYPE" + , complExpandedType = "EXPANDED" + , complLocation = deserialise span + , complDocumentation = Just type_ + , complExportedFrom = [ModuleName "MODDD"] + , complDeclarationType = Nothing + } + ) printModules :: Ide m => m Success printModules = ModuleList . map P.runModuleName <$> getLoadedModulenames +sqliteFile :: Ide m => m FilePath +sqliteFile = outputDirectory <&> ( "cache.db") + + outputDirectory :: Ide m => m FilePath outputDirectory = do outputPath <- confOutputPath . ideConfiguration <$> ask diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 8a23f574e0..bcd95a77b1 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -21,10 +21,13 @@ import Data.Aeson (KeyValue(..), ToJSON(..), Value, object) import Data.Aeson.Types qualified as Aeson import Data.Aeson.KeyMap qualified as KM import Data.Text qualified as T -import Language.PureScript qualified as P -import Language.PureScript.Errors.JSON (toJSONError) -import Language.PureScript.Ide.Types (ModuleIdent, Completion(..)) import Protolude +import Language.PureScript.Ide.Types (ModuleIdent, Completion (..)) +import Language.PureScript.Errors qualified as P +import Language.PureScript.Names qualified as P +import Language.PureScript.Pretty qualified as P +import Language.PureScript.Types qualified as P +import Language.PureScript.Errors.JSON (toJSONError) data IdeError = GeneralError Text diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 120c2da4f6..32bf3e7ccc 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -12,11 +12,15 @@ import Control.Lens (preview, view, (&), (^.)) import "monad-logger" Control.Monad.Logger (MonadLogger, logErrorN) import Data.Version (showVersion) import Data.Text qualified as Text -import Language.PureScript qualified as P import Language.PureScript.Make.Monad qualified as Make import Language.PureScript.Ide.Error (IdeError (..)) import Language.PureScript.Ide.Types (IdeDataConstructor(..), IdeDeclaration(..), IdeDeclarationAnn(..), IdeType(..), IdeTypeClass(..), IdeTypeOperator(..), IdeTypeSynonym(..), IdeValue(..), IdeValueOperator(..), _IdeDeclType, anyOf, emptyAnn, ideTypeKind, ideTypeName) import Language.PureScript.Ide.Util (properNameT) +import Language.PureScript.Externs qualified as P +import Paths_purescript qualified as P +import Language.PureScript.Names qualified as P +import Language.PureScript.AST.Declarations qualified as P +import Language.PureScript.Types qualified as P readExternFile :: (MonadIO m, MonadError IdeError m, MonadLogger m) diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index 9bb29d6e49..413683bdff 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -13,7 +13,8 @@ ----------------------------------------------------------------------------- module Language.PureScript.Ide.Filter - ( Filter + ( Filter(..) + , DeclarationFilter(..) , moduleFilter , namespaceFilter , exactFilter diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index ebc34339eb..36ae307195 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -11,7 +11,7 @@ import Protolude hiding (moduleName) import "monad-logger" Control.Monad.Logger (LoggingT, MonadLogger, logDebug) import Data.List qualified as List import Data.Map.Lazy qualified as M -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, catMaybes) import Data.Set qualified as S import Data.Time qualified as Time import Data.Text qualified as Text @@ -26,6 +26,19 @@ import Language.PureScript.Ide.State (cacheRebuild, getExternFiles, insertExtern import Language.PureScript.Ide.Types (Ide, IdeConfiguration(..), IdeEnvironment(..), ModuleMap, Success(..)) import Language.PureScript.Ide.Util (ideReadFile) import System.Directory (getCurrentDirectory) +import Database.SQLite.Simple qualified as SQLite +import System.FilePath (()) +import Data.Aeson (decode) +import Language.PureScript.Externs (ExternsFile(ExternsFile)) +import Data.ByteString qualified as T +import Data.ByteString.Lazy qualified as TE +import Language.PureScript.Names (runModuleName) +import Data.Text (intercalate) +import Unsafe.Coerce (unsafeCoerce) +import Database.SQLite.Simple (Query(fromQuery), ToRow, SQLData (SQLText)) +import Data.String (String) +import Codec.Serialise (deserialise) +import Language.PureScript (ModuleName) -- | Given a filepath performs the following steps: -- @@ -64,10 +77,11 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do throwError $ RebuildError [(fp', input)] $ CST.toMultipleErrors fp' parseError Right m -> pure m let moduleName = P.getModuleName m + outputDirectory <- confOutputPath . ideConfiguration <$> ask -- Externs files must be sorted ahead of time, so that they get applied -- in the right order (bottom up) to the 'Environment'. - externs <- logPerf (labelTimespec "Sorting externs") (sortExterns m =<< getExternFiles) - outputDirectory <- confOutputPath . ideConfiguration <$> ask + -- externs' <- logPerf (labelTimespec "Sorting externs") (sortExterns m =<< getExternFiles) + !externs <- logPerf (labelTimespec "Sorting externs") (sortExterns' outputDirectory m) -- For rebuilding, we want to 'RebuildAlways', but for inferring foreign -- modules using their file paths, we need to specify the path in the 'Map'. let filePathMap = M.singleton moduleName (Left P.RebuildAlways) @@ -88,11 +102,11 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do Left errors -> throwError (RebuildError [(fp', input)] errors) Right newExterns -> do - insertModule (fromMaybe file actualFile, m) - insertExterns newExterns - void populateVolatileState + -- insertModule (fromMaybe file actualFile, m) + -- insertExterns newExterns + -- void populateVolatileState _ <- updateCacheTimestamp - runOpenBuild (rebuildModuleOpen makeEnv externs m) + -- runOpenBuild (rebuildModuleOpen makeEnv externs m) pure (RebuildSuccess (CST.toMultipleWarnings fp pwarnings <> warnings)) -- | When adjusting the cache db file after a rebuild we always pick a @@ -228,6 +242,41 @@ sortExterns m ex = do inOrderOf :: (Ord a) => [a] -> [a] -> [a] inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys +sortExterns' + :: (Ide m) + => FilePath + -> P.Module + -> m [P.ExternsFile] +sortExterns' outputDir m = liftIO do + let P.Module _ _ _ declarations _ = m + let moduleDependencies = declarations >>= \case + P.ImportDeclaration _ importName _ _ -> [importName] + _ -> [] + topo outputDir moduleDependencies + +topo :: FilePath -> [ModuleName] -> IO [ExternsFile] +topo outputDir dependencies = do + !r <- SQLite.withConnection (outputDir "cache.db") \conn -> + SQLite.query conn query (SQLite.Only $ "[" <> Data.Text.intercalate ", " (dependencies <&> \v -> "\"" <> runModuleName v <> "\"") <> "]") + <&> \r -> (r >>= identity) <&> deserialise + pure r + + where + query = " with recursive \ + \ graph(dependency, level) as ( \ + \ select module_name , 1 as level \ + \ from modules where module_name in (select value from json_each(?)) \ + \ union \ + \ select d.dependency as dep, graph.level + 1 as level \ + \ from graph join dependencies d on graph.dependency = d.module_name \ + \ ), \ + \ topo as ( \ + \ select dependency, max(level) as level \ + \ from graph group by dependency \ + \ ) \ + \ select extern \ + \ from topo join modules on topo.dependency = modules.module_name order by level desc;" + -- | Removes a modules export list. openModuleExports :: P.Module -> P.Module openModuleExports (P.Module ss cs mn decls _) = P.Module ss cs mn decls Nothing diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 06eed507e4..110ae48186 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -30,6 +30,7 @@ module Language.PureScript.Ide.State , populateVolatileStateSync , populateVolatileStateSTM , getOutputDirectory + , getSqliteFilePath , updateCacheTimestamp -- for tests , resolveOperatorsForModule @@ -67,6 +68,10 @@ getOutputDirectory :: Ide m => m FilePath getOutputDirectory = do confOutputPath . ideConfiguration <$> ask +getSqliteFilePath :: Ide m => m FilePath +getSqliteFilePath = do + sqliteFilePath . ideConfiguration <$> ask + getCacheTimestamp :: Ide m => m (Maybe UTCTime) getCacheTimestamp = do x <- ideCacheDbTimestamp <$> ask diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 5fa304166b..e417f3bd02 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -15,9 +15,15 @@ import Data.Aeson qualified as Aeson import Data.IORef (IORef) import Data.Time.Clock (UTCTime) import Data.Map.Lazy qualified as M -import Language.PureScript qualified as P -import Language.PureScript.Errors.JSON qualified as P import Language.PureScript.Ide.Filter.Declaration (DeclarationType(..)) +import Language.PureScript.Names qualified as P +import Language.PureScript.Types qualified as P +import Language.PureScript.AST.Operators qualified as P +import Language.PureScript.AST.SourcePos qualified as P +import Language.PureScript.Externs qualified as P +import Language.PureScript.AST.Declarations qualified as P +import Language.PureScript.Errors qualified as P +import Language.PureScript.Errors.JSON qualified as P type ModuleIdent = Text type ModuleMap a = Map P.ModuleName a @@ -160,6 +166,7 @@ data IdeLogLevel = LogDebug | LogPerf | LogAll | LogDefault | LogNone data IdeConfiguration = IdeConfiguration { confOutputPath :: FilePath + , sqliteFilePath :: FilePath , confLogLevel :: IdeLogLevel , confGlobs :: [FilePath] , confGlobsFromFile :: Maybe FilePath diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 854391dcae..8357591f6d 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -37,12 +37,12 @@ import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode) import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding as TLE -import Language.PureScript qualified as P import Language.PureScript.Ide.Error (IdeError(..)) import Language.PureScript.Ide.Logging import Language.PureScript.Ide.Types (IdeDeclaration(..), IdeDeclarationAnn(..), IdeNamespace(..), Match(..), emptyAnn, ideDtorName, ideSynonymName, ideTCName, ideTypeName, ideTypeOpName, ideValueIdent, ideValueOpName) import System.IO.UTF8 (readUTF8FileT) import System.Directory (makeAbsolute) +import Language.PureScript.Names qualified as P identifierFromIdeDeclaration :: IdeDeclaration -> Text identifierFromIdeDeclaration d = case d of diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index f138327c8d..efd27f76ef 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -58,6 +58,7 @@ import System.Directory (getCurrentDirectory) import System.FilePath ((), makeRelative, splitPath, normalise, splitDirectories) import System.FilePath.Posix qualified as Posix import System.IO (stderr) +import Language.PureScript.Make.IdeCache (sqliteInit, sqliteExtern) -- | Determines when to rebuild a module data RebuildPolicy @@ -141,7 +142,8 @@ readCacheDb' => FilePath -- ^ The path to the output directory -> m CacheDb -readCacheDb' outputDir = +readCacheDb' outputDir = do + sqliteInit outputDir fromMaybe mempty <$> readJSONFile (cacheDbFile outputDir) writeCacheDb' @@ -249,6 +251,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = codegen m docs exts = do let mn = CF.moduleName m lift $ writeCborFile (outputFilename mn externsFileName) exts + lift $ sqliteInit outputDir + lift $ sqliteExtern outputDir docs exts codegenTargets <- lift $ asks optionsCodegenTargets when (S.member CoreFn codegenTargets) $ do let coreFnFile = targetFilename mn CoreFn diff --git a/src/Language/PureScript/Make/IdeCache.hs b/src/Language/PureScript/Make/IdeCache.hs new file mode 100644 index 0000000000..e0f137edff --- /dev/null +++ b/src/Language/PureScript/Make/IdeCache.hs @@ -0,0 +1,118 @@ +module Language.PureScript.Make.IdeCache where + +import Prelude +import Database.SQLite.Simple (NamedParam(..)) +import Database.SQLite.Simple qualified as SQLite +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.Externs (ExternsFile(..), ExternsImport(..)) +import Data.Foldable (for_) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import System.Directory (createDirectoryIfMissing) +import Language.PureScript.Externs qualified as P +import Data.Text qualified as Text +import Data.Maybe (isNothing, fromMaybe) +import Language.PureScript.CST.Utils (ProperName(..)) +import Language.PureScript.Docs.Types qualified as Docs +import Language.PureScript.Ide.Externs (convertExterns) +import Language.PureScript.Ide.Util (identifierFromIdeDeclaration, discardAnn) +import Data.Function ((&)) +import Data.Bifunctor (first) +import Data.Text (Text) +import Language.PureScript.Ide.Types (idaDeclaration) +import Language.PureScript.Docs.Types (Declaration(declChildren)) +import Language.PureScript.Docs.Render (renderDeclaration) +import Language.PureScript.Docs.AsMarkdown (codeToString, declAsMarkdown, runDocs) +import Codec.Serialise (serialise) + +sqliteExtern :: (MonadIO m) => FilePath -> Docs.Module -> ExternsFile -> m () +sqliteExtern outputDir docs extern = liftIO $ do + conn <- SQLite.open db + withRetry $ SQLite.executeNamed conn + "INSERT INTO modules (module_name, comment, extern, dec) VALUES (:module_name, :docs, :extern, :dec)" + [ ":module_name" := runModuleName ( efModuleName extern ) + , ":docs" := Docs.modComments docs + , ":extern" := Serialise.serialise extern + , ":dec" := show ( efExports extern ) + ] + for_ (efImports extern) (\i -> do + withRetry $ SQLite.executeNamed conn "INSERT INTO dependencies (module_name, dependency) VALUES (:module_name, :dependency)" + [ ":module_name" := runModuleName (efModuleName extern ) + , ":dependency" := runModuleName (eiModule i) + ]) + + for_ (fst $ convertExterns extern) (\i -> do + withRetry $ SQLite.executeNamed conn "INSERT INTO decla (module_name, id) VALUES (:module_name, :id)" + [ ":module_name" := runModuleName (efModuleName extern ) + , ":id" := identifierFromIdeDeclaration (discardAnn i) + ]) + + for_ (Docs.modDeclarations docs) (\d -> do + withRetry $ SQLite.executeNamed conn "INSERT INTO declarations (module_name, name, span, type, docs, declaration) VALUES (:module_name, :name, :span, :type, :docs, :declaration)" + [ ":module_name" := runModuleName (efModuleName extern) + , ":name" := Docs.declTitle d + , ":span" := serialise (Docs.declSourceSpan d) + , ":docs" := Docs.declComments d + , ":type" := runDocs (declAsMarkdown d) + , ":declaration" := show d + ] + + + for_ (declChildren d) $ \ch -> do + withRetry $ SQLite.executeNamed conn "INSERT INTO declarations (module_name, name, span, docs, declaration) VALUES (:module_name, :name, :span, :docs, :declaration)" + [ ":module_name" := runModuleName (efModuleName extern) + , ":name" := Docs.cdeclTitle ch + , ":span" := serialise (Docs.declSourceSpan d) + , ":docs" := Docs.cdeclComments ch + , ":declaration" := show d + ] + ) + + SQLite.close conn + return () + where + db = outputDir "cache.db" + + +convertDecl :: P.ExternsDeclaration -> Text.Text +convertDecl = \case + P.EDType{..} -> runProperName edTypeName + P.EDDataConstructor{..} -> runProperName edDataCtorName + P.EDValue{..} -> runIdent edValueName + _ -> "OTHER" + +spanDecl :: P.ExternsDeclaration -> Text.Text +spanDecl = \case + _ -> "NO SPAN" + +withRetry :: IO () -> IO () +withRetry op = do + r <- try op + case r of + Left (SQLite.SQLError SQLite.ErrorBusy _ _) -> do + threadDelay 50 + withRetry op + return () + Left _ -> do + return () + Right qr -> return qr + + +createParentDirectory :: FilePath -> IO () +createParentDirectory = createDirectoryIfMissing True . takeDirectory + +sqliteInit :: (MonadIO m) => FilePath -> m () +sqliteInit outputDir = liftIO $ do + createParentDirectory db + conn <- SQLite.open db + withRetry $ SQLite.execute_ conn "pragma journal_mode=wal" + withRetry $ SQLite.execute_ conn "create table if not exists modules (module_name text primary key, comment text, extern blob, dec text, unique (module_name) on conflict replace)" + withRetry $ SQLite.execute_ conn "create table if not exists dependencies (id integer primary key, module_name text not null, dependency text not null, unique (module_name, dependency) on conflict ignore)" + withRetry $ SQLite.execute_ conn "create table if not exists declarations (module_name text, name text not null, span blob, type text, docs text, declaration text not null)" + withRetry $ SQLite.execute_ conn "create table if not exists decla(module_name text primary key, id text)" + SQLite.close conn + where + db = outputDir "cache.db" diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs index 8c86144e9a..47209c2505 100644 --- a/src/Language/PureScript/Make/Monad.hs +++ b/src/Language/PureScript/Make/Monad.hs @@ -23,7 +23,7 @@ import Prelude import Codec.Serialise (Serialise) import Codec.Serialise qualified as Serialise -import Control.Exception (fromException, tryJust, Exception (displayException)) +import Control.Exception (fromException, tryJust, Exception (displayException), try) import Control.Monad (join, guard) import Control.Monad.Base (MonadBase(..)) import Control.Monad.Error.Class (MonadError(..)) @@ -39,7 +39,7 @@ import Data.Text (Text) import Data.Text qualified as Text import Data.Time.Clock (UTCTime) import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors, SimpleErrorMessage(..), singleError) -import Language.PureScript.Externs (ExternsFile, externsIsCurrentVersion) +import Language.PureScript.Externs (ExternsFile (efModuleName, efImports, efExports), externsIsCurrentVersion, ExternsImport (eiModule)) import Language.PureScript.Make.Cache (ContentHash, hash) import Language.PureScript.Options (Options) import System.Directory (createDirectoryIfMissing, getModificationTime) @@ -47,6 +47,11 @@ import System.Directory qualified as Directory import System.FilePath (takeDirectory) import System.IO.Error (tryIOError, isDoesNotExistError) import System.IO.UTF8 (readUTF8FileT) +import System.FilePath.Posix (()) +import Language.PureScript.Names (runModuleName) +import Control.Concurrent (threadDelay) +import Data.Foldable (for_) +import Data.Aeson (ToJSON(toJSON)) -- | A monad for running make actions newtype Make a = Make From d803b1d6f57040f0b30b66373dbce4a72b38e6f2 Mon Sep 17 00:00:00 2001 From: seastian Date: Fri, 20 Sep 2024 08:31:59 +0200 Subject: [PATCH 03/38] fix --- src/Language/PureScript/Ide.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index b02c0589a9..0a73b20ca2 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -214,7 +214,7 @@ findType search filters currentModule = do , complType = "TYPE" , complExpandedType = "EXPANDED" , complLocation = deserialise span - , complDocumentation = Just type_ + , complDocumentation = type_ , complExportedFrom = [ModuleName "MODDD"] , complDeclarationType = Nothing } @@ -226,7 +226,6 @@ printModules = ModuleList . map P.runModuleName <$> getLoadedModulenames sqliteFile :: Ide m => m FilePath sqliteFile = outputDirectory <&> ( "cache.db") - outputDirectory :: Ide m => m FilePath outputDirectory = do outputPath <- confOutputPath . ideConfiguration <$> ask From 14b1cd871bea43dcc3380d1662de2a56089979ee Mon Sep 17 00:00:00 2001 From: seastian Date: Fri, 20 Sep 2024 09:12:04 +0200 Subject: [PATCH 04/38] wip --- src/Language/PureScript/Ide.hs | 54 +++++++++++++++++++--------------- 1 file changed, 30 insertions(+), 24 deletions(-) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 0a73b20ca2..e91e95315f 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -27,7 +27,7 @@ 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 qualified as F @@ -51,7 +51,7 @@ import Language.PureScript (cacheDbFile, runModuleName) import Debug.Trace qualified as Debug import Data.Maybe (catMaybes) import Protolude (head) -import Data.Foldable (find, Foldable (toList)) +import Data.Foldable (find, Foldable (toList, foldMap)) import Data.Text qualified import Data.Either (isLeft) import Codec.Serialise (deserialise) @@ -78,9 +78,10 @@ handleCommand c = case c of pure $ TextResult "Done" -- loadModulesSync modules Type search filters currentModule -> - findType search filters currentModule + findDeclarations (F.Filter (Right $ F.Exact search) : filters) currentModule Nothing Complete filters matcher currentModule complOptions -> - findCompletions' filters matcher currentModule complOptions + findDeclarations filters 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" @@ -151,8 +152,6 @@ findCompletions' filters matcher currentModule complOptions = do rows :: [(Text, Text, Maybe Text)] <- SQLite.query conn "select module_name, name, docs from declarations where name glob ?" (SQLite.Only (glob filters :: Text)) return rows - Debug.traceM $ show completions - pure $ CompletionResult $ completions <&> \(module_name, name, docs) -> Completion { complModule = module_name @@ -187,28 +186,35 @@ findCompletions' filters matcher currentModule complOptions = do -- let insertPrim = Map.union idePrimDeclarations -- pure (CompletionResult (getCompletions filters matcher complOptions (insertPrim modules))) -findType +findDeclarations :: Ide m - => Text - -> [F.Filter] + => [F.Filter] -> Maybe P.ModuleName + -> Maybe CompletionOptions -> m Success -findType search filters currentModule = do +findDeclarations filters currentModule completionOptions = do sqlite <- getSqliteFilePath - rows <- liftIO $ SQLite.withConnection sqlite $ \conn -> do - SQLite.query_ conn $ SQLite.Query $ - "select module_name, name, type, span " <> - "from declarations where " <> - T.intercalate " and " ( - ("name glob '" <> search <> "' ") : mapMaybe (\case - F.Filter (Left modules) -> - Just $ "module_name in (" <> T.intercalate "," (toList modules <&> runModuleName <&> \m -> "'" <> m <> "'") <> ")" - F.Filter (Right (F.Exact f)) -> Just $ "name glob '" <> f <> "'" - F.Filter (Right (F.Prefix f)) -> Just $ "name glob '" <> f <> "*'" - F.Filter _ -> Nothing) - filters) + let q = SQLite.Query $ + "select module_name, name, type, span " <> + "from declarations where " <> + T.intercalate " and " ( + mapMaybe (\case + F.Filter (Left modules) -> + Just $ "module_name in (" <> T.intercalate "," (toList modules <&> runModuleName <&> \m -> "'" <> m <> "'") <> ")" + F.Filter (Right (F.Exact f)) -> Just $ "name glob '" <> f <> "'" + F.Filter (Right (F.Prefix f)) -> Just $ "name glob '" <> f <> "*'" + F.Filter _ -> Nothing) + filters) <> + foldMap (\maxResults -> " limit " <> show maxResults ) (coMaxResults =<< completionOptions) + + + rows <- liftIO $ SQLite.withConnection sqlite $ \conn -> do + SQLite.query_ conn q + + Debug.traceM $ show q + Debug.traceM $ show rows - pure $ CompletionResult (rows <&> \(module_name, name, type_, span) -> Completion + pure $ CompletionResult (rows <&> \(module_name, name, type_, span) -> Completion { complModule = module_name , complIdentifier = name , complType = "TYPE" @@ -218,7 +224,7 @@ findType search filters currentModule = do , complExportedFrom = [ModuleName "MODDD"] , complDeclarationType = Nothing } - ) + ) printModules :: Ide m => m Success printModules = ModuleList . map P.runModuleName <$> getLoadedModulenames From c6d940a41aa1320a842055afa8384885c234bcb4 Mon Sep 17 00:00:00 2001 From: seastian Date: Fri, 20 Sep 2024 09:31:02 +0200 Subject: [PATCH 05/38] query --- app/Command/Ide.hs | 3 +++ src/Language/PureScript/Ide/Types.hs | 2 ++ 2 files changed, 5 insertions(+) diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index 3fa6304322..5a4669c867 100644 --- a/app/Command/Ide.hs +++ b/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 @@ -149,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 diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index e417f3bd02..91faa59cfb 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -24,6 +24,7 @@ import Language.PureScript.Externs qualified as P import Language.PureScript.AST.Declarations qualified as P import Language.PureScript.Errors qualified as P import Language.PureScript.Errors.JSON qualified as P +import Database.SQLite.Simple qualified as SQLite type ModuleIdent = Text type ModuleMap a = Map P.ModuleName a @@ -178,6 +179,7 @@ data IdeEnvironment = { ideStateVar :: TVar IdeState , ideConfiguration :: IdeConfiguration , ideCacheDbTimestamp :: IORef (Maybe UTCTime) + , query :: forall a. SQLite.FromRow a => Text -> IO [a] } type Ide m = (MonadIO m, MonadReader IdeEnvironment m) From c3b3b6ac125404edc10083609d46b90c0c5f85d0 Mon Sep 17 00:00:00 2001 From: seastian Date: Fri, 20 Sep 2024 09:55:39 +0200 Subject: [PATCH 06/38] run query --- src/Language/PureScript/Ide/State.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 110ae48186..932926ab87 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -57,6 +57,7 @@ import Language.PureScript.Ide.SourceFile (extractAstInformation) import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util (discardAnn, displayTimeSpec, logPerf, opNameT, properNameT, runLogger) import System.Directory (getModificationTime) +import Database.SQLite.Simple qualified as SQLite -- | Resets all State inside psc-ide resetIdeState :: Ide m => m () @@ -72,6 +73,11 @@ getSqliteFilePath :: Ide m => m FilePath getSqliteFilePath = do sqliteFilePath . ideConfiguration <$> ask +runQuery :: SQLite.FromRow r => Ide m => Text -> m [r] +runQuery q = do + IdeEnvironment{..} <- ask + liftIO $ query q + getCacheTimestamp :: Ide m => m (Maybe UTCTime) getCacheTimestamp = do x <- ideCacheDbTimestamp <$> ask From eb8c5cb81cb337953bdf8f1e0f1c138ea9e36f5d Mon Sep 17 00:00:00 2001 From: seastian Date: Fri, 20 Sep 2024 10:02:04 +0200 Subject: [PATCH 07/38] run query --- src/Language/PureScript/Ide.hs | 32 +++++++++++----------------- src/Language/PureScript/Ide/State.hs | 3 +++ 2 files changed, 16 insertions(+), 19 deletions(-) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index e91e95315f..e7ad0a799b 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -37,7 +37,7 @@ import Language.PureScript.Ide.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, getSqliteFilePath) +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 (..)) import Language.PureScript.Ide.Util (discardAnn, identifierFromIdeDeclaration, namespaceForDeclaration, withEmptyAnn) import Language.PureScript.Ide.Usage (findUsages) @@ -193,25 +193,19 @@ findDeclarations -> Maybe CompletionOptions -> m Success findDeclarations filters currentModule completionOptions = do - sqlite <- getSqliteFilePath - let q = SQLite.Query $ - "select module_name, name, type, span " <> - "from declarations where " <> - T.intercalate " and " ( - mapMaybe (\case - F.Filter (Left modules) -> - Just $ "module_name in (" <> T.intercalate "," (toList modules <&> runModuleName <&> \m -> "'" <> m <> "'") <> ")" - F.Filter (Right (F.Exact f)) -> Just $ "name glob '" <> f <> "'" - F.Filter (Right (F.Prefix f)) -> Just $ "name glob '" <> f <> "*'" - F.Filter _ -> Nothing) - filters) <> - foldMap (\maxResults -> " limit " <> show maxResults ) (coMaxResults =<< completionOptions) + rows <- runQuery $ + "select module_name, name, type, span " <> + "from declarations where " <> + T.intercalate " and " ( + mapMaybe (\case + F.Filter (Left modules) -> + Just $ "module_name in (" <> T.intercalate "," (toList modules <&> runModuleName <&> \m -> "'" <> m <> "'") <> ")" + F.Filter (Right (F.Exact f)) -> Just $ "name glob '" <> f <> "'" + F.Filter (Right (F.Prefix f)) -> Just $ "name glob '" <> f <> "*'" + F.Filter _ -> Nothing) + filters) <> + foldMap (\maxResults -> " limit " <> show maxResults ) (coMaxResults =<< completionOptions) - - rows <- liftIO $ SQLite.withConnection sqlite $ \conn -> do - SQLite.query_ conn q - - Debug.traceM $ show q Debug.traceM $ show rows pure $ CompletionResult (rows <&> \(module_name, name, type_, span) -> Completion diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 932926ab87..7ded175e88 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -30,6 +30,7 @@ module Language.PureScript.Ide.State , populateVolatileStateSync , populateVolatileStateSTM , getOutputDirectory + , runQuery , getSqliteFilePath , updateCacheTimestamp -- for tests @@ -58,6 +59,7 @@ import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util (discardAnn, displayTimeSpec, logPerf, opNameT, properNameT, runLogger) import System.Directory (getModificationTime) import Database.SQLite.Simple qualified as SQLite +import Debug.Trace qualified as Debug -- | Resets all State inside psc-ide resetIdeState :: Ide m => m () @@ -75,6 +77,7 @@ getSqliteFilePath = do runQuery :: SQLite.FromRow r => Ide m => Text -> m [r] runQuery q = do + Debug.traceM $ show q IdeEnvironment{..} <- ask liftIO $ query q From e4fb44bd85d08274fc6e117a97308ee8c569e985 Mon Sep 17 00:00:00 2001 From: seastian Date: Fri, 20 Sep 2024 10:14:58 +0200 Subject: [PATCH 08/38] list modules --- src/Language/PureScript/Ide.hs | 16 +++------------- 1 file changed, 3 insertions(+), 13 deletions(-) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index e7ad0a799b..a508b32f29 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -56,6 +56,7 @@ import Data.Text qualified import Data.Either (isLeft) import Codec.Serialise (deserialise) import Data.ByteString.Lazy qualified +import Database.SQLite.Simple (Only(Only)) -- | Accepts a Command and runs it against psc-ide's State. This is the main -- entry point for the server. @@ -85,9 +86,9 @@ handleCommand c = case c of 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 -> @@ -220,9 +221,6 @@ findDeclarations filters currentModule completionOptions = do } ) -printModules :: Ide m => m Success -printModules = ModuleList . map P.runModuleName <$> getLoadedModulenames - sqliteFile :: Ide m => m FilePath sqliteFile = outputDirectory <&> ( "cache.db") @@ -232,14 +230,6 @@ outputDirectory = do 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 From dadf247324de426d11d568cdf9d586f75a447e90 Mon Sep 17 00:00:00 2001 From: seastian Date: Fri, 20 Sep 2024 11:07:10 +0200 Subject: [PATCH 09/38] clean up --- src/Language/PureScript/Make/IdeCache.hs | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/src/Language/PureScript/Make/IdeCache.hs b/src/Language/PureScript/Make/IdeCache.hs index e0f137edff..10c94fdf1e 100644 --- a/src/Language/PureScript/Make/IdeCache.hs +++ b/src/Language/PureScript/Make/IdeCache.hs @@ -38,18 +38,13 @@ sqliteExtern outputDir docs extern = liftIO $ do , ":extern" := Serialise.serialise extern , ":dec" := show ( efExports extern ) ] + for_ (efImports extern) (\i -> do withRetry $ SQLite.executeNamed conn "INSERT INTO dependencies (module_name, dependency) VALUES (:module_name, :dependency)" [ ":module_name" := runModuleName (efModuleName extern ) , ":dependency" := runModuleName (eiModule i) ]) - for_ (fst $ convertExterns extern) (\i -> do - withRetry $ SQLite.executeNamed conn "INSERT INTO decla (module_name, id) VALUES (:module_name, :id)" - [ ":module_name" := runModuleName (efModuleName extern ) - , ":id" := identifierFromIdeDeclaration (discardAnn i) - ]) - for_ (Docs.modDeclarations docs) (\d -> do withRetry $ SQLite.executeNamed conn "INSERT INTO declarations (module_name, name, span, type, docs, declaration) VALUES (:module_name, :name, :span, :type, :docs, :declaration)" [ ":module_name" := runModuleName (efModuleName extern) @@ -59,7 +54,6 @@ sqliteExtern outputDir docs extern = liftIO $ do , ":type" := runDocs (declAsMarkdown d) , ":declaration" := show d ] - for_ (declChildren d) $ \ch -> do withRetry $ SQLite.executeNamed conn "INSERT INTO declarations (module_name, name, span, docs, declaration) VALUES (:module_name, :name, :span, :docs, :declaration)" @@ -112,7 +106,7 @@ sqliteInit outputDir = liftIO $ do withRetry $ SQLite.execute_ conn "create table if not exists modules (module_name text primary key, comment text, extern blob, dec text, unique (module_name) on conflict replace)" withRetry $ SQLite.execute_ conn "create table if not exists dependencies (id integer primary key, module_name text not null, dependency text not null, unique (module_name, dependency) on conflict ignore)" withRetry $ SQLite.execute_ conn "create table if not exists declarations (module_name text, name text not null, span blob, type text, docs text, declaration text not null)" - withRetry $ SQLite.execute_ conn "create table if not exists decla(module_name text primary key, id text)" + withRetry $ SQLite.execute_ conn "create index dm on declarations(module_name); create index dn on declarations(name);" SQLite.close conn where db = outputDir "cache.db" From 7da06bef5ffe4538099560d7207718d55c4062e1 Mon Sep 17 00:00:00 2001 From: Rory Campbell Date: Fri, 20 Sep 2024 12:25:17 +0200 Subject: [PATCH 10/38] adds prim modules to sort externs --- src/Language/PureScript/Ide/Rebuild.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 36ae307195..05475fa559 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -39,6 +39,7 @@ import Database.SQLite.Simple (Query(fromQuery), ToRow, SQLData (SQLText)) import Data.String (String) import Codec.Serialise (deserialise) import Language.PureScript (ModuleName) +import Language.PureScript.Constants.Prim (primModules) -- | Given a filepath performs the following steps: -- @@ -252,7 +253,7 @@ sortExterns' outputDir m = liftIO do let moduleDependencies = declarations >>= \case P.ImportDeclaration _ importName _ _ -> [importName] _ -> [] - topo outputDir moduleDependencies + topo outputDir (primModules <> moduleDependencies) topo :: FilePath -> [ModuleName] -> IO [ExternsFile] topo outputDir dependencies = do From bf48b97881129bcee0bb1afa88ed26f1e346ea6c Mon Sep 17 00:00:00 2001 From: seastian Date: Fri, 20 Sep 2024 16:27:38 +0200 Subject: [PATCH 11/38] with prim --- src/Language/PureScript/Make.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 5228dc86e6..5d073d8f6d 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -126,7 +126,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ -- a bug in the compiler, which should be reported as such. -- 2. We do not want to perform any extra work generating docs unless the -- user has asked for docs to be generated. - let docs = case Docs.convertModule externs exEnv env' m of + let docs = case Docs.convertModule externs exEnv env' withPrim of Left errs -> internalError $ "Failed to produce docs for " ++ T.unpack (runModuleName moduleName) ++ "; details:\n" ++ prettyPrintMultipleErrors defaultPPEOptions errs From d4d221cb9c0d43678ffe8883fe0b6b250785e70b Mon Sep 17 00:00:00 2001 From: seastian Date: Fri, 20 Sep 2024 17:14:40 +0200 Subject: [PATCH 12/38] refactor --- src/Language/PureScript/Ide/Rebuild.hs | 49 +++++++++++++------------- 1 file changed, 25 insertions(+), 24 deletions(-) diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 05475fa559..bab8d84d42 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -22,7 +22,7 @@ import Language.PureScript.CST qualified as CST import Language.PureScript.Ide.Error (IdeError(..)) import Language.PureScript.Ide.Logging (labelTimespec, logPerf, runLogger) -import Language.PureScript.Ide.State (cacheRebuild, getExternFiles, insertExterns, insertModule, populateVolatileState, updateCacheTimestamp) +import Language.PureScript.Ide.State (cacheRebuild, getExternFiles, insertExterns, insertModule, populateVolatileState, updateCacheTimestamp, runQuery) import Language.PureScript.Ide.Types (Ide, IdeConfiguration(..), IdeEnvironment(..), ModuleMap, Success(..)) import Language.PureScript.Ide.Util (ideReadFile) import System.Directory (getCurrentDirectory) @@ -40,6 +40,7 @@ import Data.String (String) import Codec.Serialise (deserialise) import Language.PureScript (ModuleName) import Language.PureScript.Constants.Prim (primModules) +import Data.Foldable (concat) -- | Given a filepath performs the following steps: -- @@ -248,35 +249,35 @@ sortExterns' => FilePath -> P.Module -> m [P.ExternsFile] -sortExterns' outputDir m = liftIO do +sortExterns' outputDir m = do let P.Module _ _ _ declarations _ = m let moduleDependencies = declarations >>= \case P.ImportDeclaration _ importName _ _ -> [importName] _ -> [] - topo outputDir (primModules <> moduleDependencies) -topo :: FilePath -> [ModuleName] -> IO [ExternsFile] -topo outputDir dependencies = do - !r <- SQLite.withConnection (outputDir "cache.db") \conn -> - SQLite.query conn query (SQLite.Only $ "[" <> Data.Text.intercalate ", " (dependencies <&> \v -> "\"" <> runModuleName v <> "\"") <> "]") - <&> \r -> (r >>= identity) <&> deserialise - pure r + externs <- runQuery $ unlines [ + "with recursive", + "graph(dependency, level) as (", + " select module_name , 1 as level", + " from modules where module_name in (" <> Data.Text.intercalate ", " (moduleDependencies <&> \v -> "'" <> runModuleName v <> "'") <> ")", + " union ", + " select d.dependency as dep, graph.level + 1 as level", + " from graph join dependencies d on graph.dependency = d.module_name", + "),", + "topo as (", + " select dependency, max(level) as level", + " from graph group by dependency", + ") ", + "select extern", + "from topo join modules on topo.dependency = modules.module_name order by level desc;" + ] - where - query = " with recursive \ - \ graph(dependency, level) as ( \ - \ select module_name , 1 as level \ - \ from modules where module_name in (select value from json_each(?)) \ - \ union \ - \ select d.dependency as dep, graph.level + 1 as level \ - \ from graph join dependencies d on graph.dependency = d.module_name \ - \ ), \ - \ topo as ( \ - \ select dependency, max(level) as level \ - \ from graph group by dependency \ - \ ) \ - \ select extern \ - \ from topo join modules on topo.dependency = modules.module_name order by level desc;" + pure $ (externs >>= identity) <&> deserialise + + -- !r <- SQLite.withConnection (outputDir "cache.db") \conn -> + -- SQLite.query conn query (SQLite.Only $ "[" <> Data.Text.intercalate ", " (dependencies <&> \v -> "\"" <> runModuleName v <> "\"") <> "]") + -- <&> \r -> (r >>= identity) <&> deserialise + -- pure r -- | Removes a modules export list. openModuleExports :: P.Module -> P.Module From ccc139af379cf48ed2c4ffaaed474d0e07d0c8d3 Mon Sep 17 00:00:00 2001 From: seastian Date: Fri, 20 Sep 2024 17:45:09 +0200 Subject: [PATCH 13/38] drop log --- src/Language/PureScript/Ide.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index a508b32f29..e9478246d5 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -207,8 +207,6 @@ findDeclarations filters currentModule completionOptions = do filters) <> foldMap (\maxResults -> " limit " <> show maxResults ) (coMaxResults =<< completionOptions) - Debug.traceM $ show rows - pure $ CompletionResult (rows <&> \(module_name, name, type_, span) -> Completion { complModule = module_name , complIdentifier = name From 75d692e677c4008d54683daebcd2c6558efc18ab Mon Sep 17 00:00:00 2001 From: seastian Date: Fri, 20 Sep 2024 18:24:34 +0200 Subject: [PATCH 14/38] add ide declarations --- src/Language/PureScript/Ide/Types.hs | 28 ++++++++++++++---------- src/Language/PureScript/Make/IdeCache.hs | 12 +++++++++- 2 files changed, 28 insertions(+), 12 deletions(-) diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 91faa59cfb..b929117972 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -25,6 +25,7 @@ import Language.PureScript.AST.Declarations qualified as P import Language.PureScript.Errors qualified as P import Language.PureScript.Errors.JSON qualified as P import Database.SQLite.Simple qualified as SQLite +import Codec.Serialise (Serialise) type ModuleIdent = Text type ModuleMap a = Map P.ModuleName a @@ -38,43 +39,43 @@ data IdeDeclaration | IdeDeclValueOperator IdeValueOperator | IdeDeclTypeOperator IdeTypeOperator | IdeDeclModule P.ModuleName - deriving (Show, Eq, Ord, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData, Serialise) data IdeValue = IdeValue { _ideValueIdent :: P.Ident , _ideValueType :: P.SourceType - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord, Generic, NFData, Serialise) data IdeType = IdeType { _ideTypeName :: P.ProperName 'P.TypeName , _ideTypeKind :: P.SourceType , _ideTypeDtors :: [(P.ProperName 'P.ConstructorName, P.SourceType)] - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord, Generic, NFData, Serialise) data IdeTypeSynonym = IdeTypeSynonym { _ideSynonymName :: P.ProperName 'P.TypeName , _ideSynonymType :: P.SourceType , _ideSynonymKind :: P.SourceType - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord, Generic, NFData, Serialise) data IdeDataConstructor = IdeDataConstructor { _ideDtorName :: P.ProperName 'P.ConstructorName , _ideDtorTypeName :: P.ProperName 'P.TypeName , _ideDtorType :: P.SourceType - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord, Generic, NFData, Serialise) data IdeTypeClass = IdeTypeClass { _ideTCName :: P.ProperName 'P.ClassName , _ideTCKind :: P.SourceType , _ideTCInstances :: [IdeInstance] - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord, Generic, NFData, Serialise) data IdeInstance = IdeInstance { _ideInstanceModule :: P.ModuleName , _ideInstanceName :: P.Ident , _ideInstanceTypes :: [P.SourceType] , _ideInstanceConstraints :: Maybe [P.SourceConstraint] - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord, Generic, NFData, Serialise) data IdeValueOperator = IdeValueOperator { _ideValueOpName :: P.OpName 'P.ValueOpName @@ -82,7 +83,7 @@ data IdeValueOperator = IdeValueOperator , _ideValueOpPrecedence :: P.Precedence , _ideValueOpAssociativity :: P.Associativity , _ideValueOpType :: Maybe P.SourceType - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord, Generic, NFData, Serialise) data IdeTypeOperator = IdeTypeOperator { _ideTypeOpName :: P.OpName 'P.TypeOpName @@ -90,7 +91,7 @@ data IdeTypeOperator = IdeTypeOperator , _ideTypeOpPrecedence :: P.Precedence , _ideTypeOpAssociativity :: P.Associativity , _ideTypeOpKind :: Maybe P.SourceType - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord, Generic, NFData, Serialise) _IdeDeclValue :: Traversal' IdeDeclaration IdeValue _IdeDeclValue f (IdeDeclValue x) = map IdeDeclValue (f x) @@ -138,7 +139,7 @@ makeLenses ''IdeTypeOperator data IdeDeclarationAnn = IdeDeclarationAnn { _idaAnnotation :: Annotation , _idaDeclaration :: IdeDeclaration - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord, Generic, NFData, Serialise) data Annotation = Annotation @@ -146,7 +147,7 @@ data Annotation , _annExportedFrom :: Maybe P.ModuleName , _annTypeAnnotation :: Maybe P.SourceType , _annDocumentation :: Maybe Text - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord, Generic, NFData, Serialise) makeLenses ''Annotation makeLenses ''IdeDeclarationAnn @@ -331,6 +332,11 @@ instance FromJSON IdeNamespace where "module" -> pure IdeNSModule s -> fail ("Unknown namespace: " <> show s) +instance ToJSON IdeNamespace where + toJSON IdeNSValue = "value" + toJSON IdeNSType = "type" + toJSON IdeNSModule = "module" + -- | A name tagged with a namespace data IdeNamespaced = IdeNamespaced IdeNamespace Text deriving (Show, Eq, Ord, Generic, NFData) diff --git a/src/Language/PureScript/Make/IdeCache.hs b/src/Language/PureScript/Make/IdeCache.hs index 10c94fdf1e..5795ab9317 100644 --- a/src/Language/PureScript/Make/IdeCache.hs +++ b/src/Language/PureScript/Make/IdeCache.hs @@ -18,7 +18,7 @@ import Data.Maybe (isNothing, fromMaybe) import Language.PureScript.CST.Utils (ProperName(..)) import Language.PureScript.Docs.Types qualified as Docs import Language.PureScript.Ide.Externs (convertExterns) -import Language.PureScript.Ide.Util (identifierFromIdeDeclaration, discardAnn) +import Language.PureScript.Ide.Util (identifierFromIdeDeclaration, discardAnn, namespaceForDeclaration) import Data.Function ((&)) import Data.Bifunctor (first) import Data.Text (Text) @@ -27,6 +27,7 @@ import Language.PureScript.Docs.Types (Declaration(declChildren)) import Language.PureScript.Docs.Render (renderDeclaration) import Language.PureScript.Docs.AsMarkdown (codeToString, declAsMarkdown, runDocs) import Codec.Serialise (serialise) +import Data.Aeson (encode) sqliteExtern :: (MonadIO m) => FilePath -> Docs.Module -> ExternsFile -> m () sqliteExtern outputDir docs extern = liftIO $ do @@ -45,6 +46,14 @@ sqliteExtern outputDir docs extern = liftIO $ do , ":dependency" := runModuleName (eiModule i) ]) + for_ (fst $ convertExterns extern) (\ideDeclaration -> do + withRetry $ SQLite.executeNamed conn "INSERT INTO ide_declarations (module_name, name, namespace, declaration) VALUES (:module_name, :name, :namespace, :declaration)" + [ ":module_name" := runModuleName (efModuleName extern ) + , ":name" := identifierFromIdeDeclaration (discardAnn ideDeclaration) + , ":namespace" := encode (namespaceForDeclaration (discardAnn ideDeclaration)) + , ":declaration" := serialise ideDeclaration + ]) + for_ (Docs.modDeclarations docs) (\d -> do withRetry $ SQLite.executeNamed conn "INSERT INTO declarations (module_name, name, span, type, docs, declaration) VALUES (:module_name, :name, :span, :type, :docs, :declaration)" [ ":module_name" := runModuleName (efModuleName extern) @@ -107,6 +116,7 @@ sqliteInit outputDir = liftIO $ do withRetry $ SQLite.execute_ conn "create table if not exists dependencies (id integer primary key, module_name text not null, dependency text not null, unique (module_name, dependency) on conflict ignore)" withRetry $ SQLite.execute_ conn "create table if not exists declarations (module_name text, name text not null, span blob, type text, docs text, declaration text not null)" withRetry $ SQLite.execute_ conn "create index dm on declarations(module_name); create index dn on declarations(name);" + withRetry $ SQLite.execute_ conn "create table if not exists ide_declarations (module_name text, name text, namespace text, declaration blob)" SQLite.close conn where db = outputDir "cache.db" From e9c1e4f042e35b1890924f9d9d4e0cf668954224 Mon Sep 17 00:00:00 2001 From: seastian Date: Sat, 21 Sep 2024 02:13:21 +0200 Subject: [PATCH 15/38] ToField --- src/Language/PureScript/Ide/Filter/Declaration.hs | 12 ++++++++++++ src/Language/PureScript/Ide/Types.hs | 11 +++++++---- src/Language/PureScript/Make/IdeCache.hs | 9 +++++---- 3 files changed, 24 insertions(+), 8 deletions(-) diff --git a/src/Language/PureScript/Ide/Filter/Declaration.hs b/src/Language/PureScript/Ide/Filter/Declaration.hs index 7875f7851c..4c34fc5335 100644 --- a/src/Language/PureScript/Ide/Filter/Declaration.hs +++ b/src/Language/PureScript/Ide/Filter/Declaration.hs @@ -6,6 +6,8 @@ import Protolude hiding (isPrefixOf) import Control.Monad.Fail (fail) import Data.Aeson (FromJSON(..), ToJSON(..), withText) +import Database.SQLite.Simple.ToField (ToField(..)) +import Database.SQLite.Simple (SQLData(..)) data DeclarationType = Value @@ -40,3 +42,13 @@ instance ToJSON DeclarationType where ValueOperator -> "valueoperator" TypeOperator -> "typeoperator" Module -> "module" + +instance ToField DeclarationType where + toField Value = SQLText "value" + toField Type = SQLText "type" + toField Synonym = SQLText "synonym" + toField DataConstructor = SQLText "dataconstructor" + toField TypeClass = SQLText "typeclass" + toField ValueOperator = SQLText "valueoperator" + toField TypeOperator = SQLText "typeoperator" + toField Module = SQLText "module" diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index b929117972..515426564d 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -26,6 +26,8 @@ import Language.PureScript.Errors qualified as P import Language.PureScript.Errors.JSON qualified as P import Database.SQLite.Simple qualified as SQLite import Codec.Serialise (Serialise) +import Database.SQLite.Simple.ToField (ToField(..)) +import Database.SQLite.Simple (SQLData(SQLText)) type ModuleIdent = Text type ModuleMap a = Map P.ModuleName a @@ -332,10 +334,11 @@ instance FromJSON IdeNamespace where "module" -> pure IdeNSModule s -> fail ("Unknown namespace: " <> show s) -instance ToJSON IdeNamespace where - toJSON IdeNSValue = "value" - toJSON IdeNSType = "type" - toJSON IdeNSModule = "module" +instance ToField IdeNamespace where + toField IdeNSValue = SQLText "value" + toField IdeNSType = SQLText "type" + toField IdeNSModule = SQLText "module" + -- | A name tagged with a namespace data IdeNamespaced = IdeNamespaced IdeNamespace Text diff --git a/src/Language/PureScript/Make/IdeCache.hs b/src/Language/PureScript/Make/IdeCache.hs index 5795ab9317..5e1fba7107 100644 --- a/src/Language/PureScript/Make/IdeCache.hs +++ b/src/Language/PureScript/Make/IdeCache.hs @@ -22,7 +22,7 @@ import Language.PureScript.Ide.Util (identifierFromIdeDeclaration, discardAnn, n import Data.Function ((&)) import Data.Bifunctor (first) import Data.Text (Text) -import Language.PureScript.Ide.Types (idaDeclaration) +import Language.PureScript.Ide.Types (idaDeclaration, declarationType) import Language.PureScript.Docs.Types (Declaration(declChildren)) import Language.PureScript.Docs.Render (renderDeclaration) import Language.PureScript.Docs.AsMarkdown (codeToString, declAsMarkdown, runDocs) @@ -47,10 +47,11 @@ sqliteExtern outputDir docs extern = liftIO $ do ]) for_ (fst $ convertExterns extern) (\ideDeclaration -> do - withRetry $ SQLite.executeNamed conn "INSERT INTO ide_declarations (module_name, name, namespace, declaration) VALUES (:module_name, :name, :namespace, :declaration)" + withRetry $ SQLite.executeNamed conn "INSERT INTO ide_declarations (module_name, name, namespace, declaration_type, declaration) VALUES (:module_name, :name, :namespace, :declaration_type, :declaration)" [ ":module_name" := runModuleName (efModuleName extern ) , ":name" := identifierFromIdeDeclaration (discardAnn ideDeclaration) - , ":namespace" := encode (namespaceForDeclaration (discardAnn ideDeclaration)) + , ":namespace" := namespaceForDeclaration (discardAnn ideDeclaration) + , ":declaration_type" := declarationType (discardAnn ideDeclaration) , ":declaration" := serialise ideDeclaration ]) @@ -116,7 +117,7 @@ sqliteInit outputDir = liftIO $ do withRetry $ SQLite.execute_ conn "create table if not exists dependencies (id integer primary key, module_name text not null, dependency text not null, unique (module_name, dependency) on conflict ignore)" withRetry $ SQLite.execute_ conn "create table if not exists declarations (module_name text, name text not null, span blob, type text, docs text, declaration text not null)" withRetry $ SQLite.execute_ conn "create index dm on declarations(module_name); create index dn on declarations(name);" - withRetry $ SQLite.execute_ conn "create table if not exists ide_declarations (module_name text, name text, namespace text, declaration blob)" + withRetry $ SQLite.execute_ conn "create table if not exists ide_declarations (module_name text, name text, namespace text, declaration_type text, declaration blob)" SQLite.close conn where db = outputDir "cache.db" From 006e512d2903bf7f12d89feab89548b55c39892e Mon Sep 17 00:00:00 2001 From: seastian Date: Sat, 21 Sep 2024 02:47:13 +0200 Subject: [PATCH 16/38] filters --- src/Language/PureScript/Ide.hs | 10 +++++++-- .../PureScript/Ide/Filter/Declaration.hs | 21 ++++++++++++------- src/Language/PureScript/Ide/Types.hs | 10 +++++---- 3 files changed, 27 insertions(+), 14 deletions(-) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index e9478246d5..b2ccd4da95 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -38,7 +38,7 @@ 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, getSqliteFilePath, runQuery) -import Language.PureScript.Ide.Types (Annotation(..), Ide, IdeConfiguration(..), IdeDeclarationAnn(..), IdeEnvironment(..), Success(..), Completion (..)) +import Language.PureScript.Ide.Types (Annotation(..), Ide, IdeConfiguration(..), IdeDeclarationAnn(..), IdeEnvironment(..), Success(..), Completion (..), toText) import Language.PureScript.Ide.Util (discardAnn, identifierFromIdeDeclaration, namespaceForDeclaration, withEmptyAnn) import Language.PureScript.Ide.Usage (findUsages) import System.Directory (getCurrentDirectory, getDirectoryContents, doesDirectoryExist, doesFileExist) @@ -57,6 +57,8 @@ 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) -- | Accepts a Command and runs it against psc-ide's State. This is the main -- entry point for the server. @@ -201,8 +203,12 @@ findDeclarations filters currentModule completionOptions = do mapMaybe (\case F.Filter (Left modules) -> Just $ "module_name in (" <> T.intercalate "," (toList modules <&> runModuleName <&> \m -> "'" <> m <> "'") <> ")" - F.Filter (Right (F.Exact f)) -> Just $ "name glob '" <> f <> "'" F.Filter (Right (F.Prefix f)) -> Just $ "name glob '" <> f <> "*'" + F.Filter (Right (F.Exact f)) -> Just $ "name glob '" <> f <> "'" + F.Filter (Right (F.Namespace namespaces)) -> + Just $ "namespace in (" <> T.intercalate "," (toList namespaces <&> \n -> "'" <> toText n <> "'") <> ")" + F.Filter (Right (F.DeclType dt)) -> + Just $ "namespace in (" <> T.intercalate "," (toList dt <&> \t -> "'" <> declarationTypeToText t <> "'") <> ")" F.Filter _ -> Nothing) filters) <> foldMap (\maxResults -> " limit " <> show maxResults ) (coMaxResults =<< completionOptions) diff --git a/src/Language/PureScript/Ide/Filter/Declaration.hs b/src/Language/PureScript/Ide/Filter/Declaration.hs index 4c34fc5335..c17e6f285e 100644 --- a/src/Language/PureScript/Ide/Filter/Declaration.hs +++ b/src/Language/PureScript/Ide/Filter/Declaration.hs @@ -1,5 +1,6 @@ module Language.PureScript.Ide.Filter.Declaration ( DeclarationType(..) + , declarationTypeToText ) where import Protolude hiding (isPrefixOf) @@ -43,12 +44,16 @@ instance ToJSON DeclarationType where TypeOperator -> "typeoperator" Module -> "module" +declarationTypeToText :: DeclarationType -> Text +declarationTypeToText Value = "value" +declarationTypeToText Type = "type" +declarationTypeToText Synonym = "synonym" +declarationTypeToText DataConstructor = "dataconstructor" +declarationTypeToText TypeClass = "typeclass" +declarationTypeToText ValueOperator = "valueoperator" +declarationTypeToText TypeOperator = "typeoperator" +declarationTypeToText Module = "module" + + instance ToField DeclarationType where - toField Value = SQLText "value" - toField Type = SQLText "type" - toField Synonym = SQLText "synonym" - toField DataConstructor = SQLText "dataconstructor" - toField TypeClass = SQLText "typeclass" - toField ValueOperator = SQLText "valueoperator" - toField TypeOperator = SQLText "typeoperator" - toField Module = SQLText "module" + toField d = SQLText $ declarationTypeToText d diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 515426564d..d855e9d159 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -334,11 +334,13 @@ instance FromJSON IdeNamespace where "module" -> pure IdeNSModule s -> fail ("Unknown namespace: " <> show s) -instance ToField IdeNamespace where - toField IdeNSValue = SQLText "value" - toField IdeNSType = SQLText "type" - toField IdeNSModule = SQLText "module" +toText :: IdeNamespace -> Text +toText IdeNSValue = "value" +toText IdeNSType = "type" +toText IdeNSModule = "module" +instance ToField IdeNamespace where + toField n = SQLText $ toText n -- | A name tagged with a namespace data IdeNamespaced = IdeNamespaced IdeNamespace Text From 7e51fd2e5d746a22e57d7134da826a5748405870 Mon Sep 17 00:00:00 2001 From: seastian Date: Sat, 21 Sep 2024 09:45:43 +0200 Subject: [PATCH 17/38] wip --- src/Language/PureScript/Ide.hs | 8 ++-- .../PureScript/Ide/Imports/Actions.hs | 46 ++++++++++++++++--- src/Language/PureScript/Ide/Util.hs | 3 +- src/Language/PureScript/Make/IdeCache.hs | 7 +-- 4 files changed, 48 insertions(+), 16 deletions(-) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index b2ccd4da95..117c626083 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -197,8 +197,8 @@ findDeclarations -> m Success findDeclarations filters currentModule completionOptions = do rows <- runQuery $ - "select module_name, name, type, span " <> - "from declarations where " <> + "select module_name, name, span " <> + "from ide_declarations where " <> T.intercalate " and " ( mapMaybe (\case F.Filter (Left modules) -> @@ -213,13 +213,13 @@ findDeclarations filters currentModule completionOptions = do filters) <> foldMap (\maxResults -> " limit " <> show maxResults ) (coMaxResults =<< completionOptions) - pure $ CompletionResult (rows <&> \(module_name, name, type_, span) -> Completion + pure $ CompletionResult (rows <&> \(module_name, name, span) -> Completion { complModule = module_name , complIdentifier = name , complType = "TYPE" , complExpandedType = "EXPANDED" , complLocation = deserialise span - , complDocumentation = type_ + , complDocumentation = Just "adfadsf" , complExportedFrom = [ModuleName "MODDD"] , complDeclarationType = Nothing } diff --git a/src/Language/PureScript/Ide/Imports/Actions.hs b/src/Language/PureScript/Ide/Imports/Actions.hs index bc79f2184d..969465d18a 100644 --- a/src/Language/PureScript/Ide/Imports/Actions.hs +++ b/src/Language/PureScript/Ide/Imports/Actions.hs @@ -23,11 +23,18 @@ import Language.PureScript.Ide.Completion (getExactMatches) import Language.PureScript.Ide.Error (IdeError(..)) import Language.PureScript.Ide.Filter (Filter) import Language.PureScript.Ide.Imports (Import(..), parseImportsFromFile', prettyPrintImportSection) -import Language.PureScript.Ide.State (getAllModules) +import Language.PureScript.Ide.State (getAllModules, runQuery) import Language.PureScript.Ide.Prim (idePrimDeclarations) -import Language.PureScript.Ide.Types (Ide, IdeDeclaration(..), IdeType(..), Match(..), Success(..), _IdeDeclModule, ideDtorName, ideDtorTypeName, ideTCName, ideTypeName, ideTypeOpName, ideValueOpName) +import Language.PureScript.Ide.Types (Ide, IdeDeclaration(..), IdeType(..), Match(..), Success(..), _IdeDeclModule, ideDtorName, ideDtorTypeName, ideTCName, ideTypeName, ideTypeOpName, ideValueOpName, toText) import Language.PureScript.Ide.Util (discardAnn, identifierFromIdeDeclaration) import System.IO.UTF8 (writeUTF8FileT) +import Language.PureScript.Ide.Filter qualified as F +import Language.PureScript.Names (runModuleName) +import Language.PureScript.Ide.Filter.Declaration (declarationTypeToText) +import Codec.Serialise (deserialise) +import Data.List qualified as List +import Data.ByteString.Lazy qualified as Lazy +import Language.PureScript (ModuleName(..)) -- | Adds an implicit import like @import Prelude@ to a Sourcefile. addImplicitImport @@ -162,13 +169,38 @@ addImportForIdentifier -> Maybe P.ModuleName -- ^ The optional qualifier under which to import -> [Filter] -- ^ Filters to apply before searching for the identifier -> m (Either [Match IdeDeclaration] [Text]) -addImportForIdentifier fp ident qual filters = do - let addPrim = Map.union idePrimDeclarations +addImportForIdentifier fp ident qual filters' = do + let filters = F.exactFilter ident : filters' + + + rows :: [(Text, Lazy.ByteString)] <- runQuery $ + "select module_name, declaration " <> + "from ide_declarations where " <> + T.intercalate " and " ( + mapMaybe (\case + F.Filter (Left modules) -> + Just $ "module_name in (" <> T.intercalate "," (toList modules <&> runModuleName <&> \m -> "'" <> m <> "'") <> ")" + F.Filter (Right (F.Prefix f)) -> Just $ "name glob '" <> f <> "*'" + F.Filter (Right (F.Exact f)) -> Just $ "name glob '" <> f <> "'" + F.Filter (Right (F.Namespace namespaces)) -> + Just $ "namespace in (" <> T.intercalate "," (toList namespaces <&> \n -> "'" <> toText n <> "'") <> ")" + F.Filter (Right (F.DeclType dt)) -> + Just $ "namespace in (" <> T.intercalate "," (toList dt <&> \t -> "'" <> declarationTypeToText t <> "'") <> ")" + F.Filter _ -> Nothing) + filters) + + let declarations :: [Match IdeDeclaration] = rows <&> \(m, bs) -> Match (ModuleName m, discardAnn $ deserialise bs) + + + + -- getExactMatches ident filters (addPrim modules) + + + -- let addPrim = Map.union idePrimDeclarations + modules <- getAllModules Nothing let - matches = - getExactMatches ident filters (addPrim modules) - & map (fmap discardAnn) + matches = declarations & filter (\(Match (_, d)) -> not (has _IdeDeclModule d)) case matches of diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 8357591f6d..bfbb38bf21 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -29,8 +29,7 @@ module Language.PureScript.Ide.Util , module Language.PureScript.Ide.Logging ) where -import Protolude hiding (decodeUtf8, - encodeUtf8, to) +import Protolude hiding (decodeUtf8, encodeUtf8, to) import Control.Lens (Getting, to, (^.)) import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode) diff --git a/src/Language/PureScript/Make/IdeCache.hs b/src/Language/PureScript/Make/IdeCache.hs index 5e1fba7107..b36ccf0e42 100644 --- a/src/Language/PureScript/Make/IdeCache.hs +++ b/src/Language/PureScript/Make/IdeCache.hs @@ -22,7 +22,7 @@ import Language.PureScript.Ide.Util (identifierFromIdeDeclaration, discardAnn, n import Data.Function ((&)) import Data.Bifunctor (first) import Data.Text (Text) -import Language.PureScript.Ide.Types (idaDeclaration, declarationType) +import Language.PureScript.Ide.Types (Annotation(..), idaDeclaration, declarationType, IdeDeclarationAnn (_idaAnnotation)) import Language.PureScript.Docs.Types (Declaration(declChildren)) import Language.PureScript.Docs.Render (renderDeclaration) import Language.PureScript.Docs.AsMarkdown (codeToString, declAsMarkdown, runDocs) @@ -47,11 +47,12 @@ sqliteExtern outputDir docs extern = liftIO $ do ]) for_ (fst $ convertExterns extern) (\ideDeclaration -> do - withRetry $ SQLite.executeNamed conn "INSERT INTO ide_declarations (module_name, name, namespace, declaration_type, declaration) VALUES (:module_name, :name, :namespace, :declaration_type, :declaration)" + withRetry $ SQLite.executeNamed conn "INSERT INTO ide_declarations (module_name, name, namespace, declaration_type, span, declaration) VALUES (:module_name, :name, :namespace, :declaration_type, :span, :declaration)" [ ":module_name" := runModuleName (efModuleName extern ) , ":name" := identifierFromIdeDeclaration (discardAnn ideDeclaration) , ":namespace" := namespaceForDeclaration (discardAnn ideDeclaration) , ":declaration_type" := declarationType (discardAnn ideDeclaration) + , ":span" := serialise (_annLocation $ _idaAnnotation ideDeclaration) , ":declaration" := serialise ideDeclaration ]) @@ -117,7 +118,7 @@ sqliteInit outputDir = liftIO $ do withRetry $ SQLite.execute_ conn "create table if not exists dependencies (id integer primary key, module_name text not null, dependency text not null, unique (module_name, dependency) on conflict ignore)" withRetry $ SQLite.execute_ conn "create table if not exists declarations (module_name text, name text not null, span blob, type text, docs text, declaration text not null)" withRetry $ SQLite.execute_ conn "create index dm on declarations(module_name); create index dn on declarations(name);" - withRetry $ SQLite.execute_ conn "create table if not exists ide_declarations (module_name text, name text, namespace text, declaration_type text, declaration blob)" + 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)" SQLite.close conn where db = outputDir "cache.db" From f5580ddc57d76d29da86e85afaea527ef451e69e Mon Sep 17 00:00:00 2001 From: seastian Date: Sat, 21 Sep 2024 09:48:25 +0200 Subject: [PATCH 18/38] delete dead code --- src/Language/PureScript/Ide.hs | 47 ---------------------------------- 1 file changed, 47 deletions(-) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 117c626083..c9883e9290 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -142,53 +142,6 @@ findCompletions filters matcher currentModule complOptions = do let insertPrim = Map.union idePrimDeclarations pure (CompletionResult (getCompletions filters matcher complOptions (insertPrim modules))) -findCompletions' - :: Ide m - => [F.Filter] - -> Matcher IdeDeclarationAnn - -> Maybe P.ModuleName - -> CompletionOptions - -> m Success -findCompletions' filters matcher currentModule complOptions = do - sq <- sqliteFile - completions <- liftIO $ SQLite.withConnection sq $ \conn -> do - rows :: [(Text, Text, Maybe Text)] <- SQLite.query conn "select module_name, name, docs from declarations where name glob ?" (SQLite.Only (glob filters :: Text)) - return rows - - pure $ CompletionResult $ completions <&> \(module_name, name, docs) -> - Completion - { complModule = module_name - , complIdentifier = name - , complType = "TYPE" - , complExpandedType = "EXPANDED" - , complLocation = Just (SourceSpan - { spanName = ".spago/BuildInfo.purs" - , spanStart = SourcePos - { sourcePosLine = 3 - , sourcePosColumn = 1 - } - , spanEnd = SourcePos - { sourcePosLine = 1 - , sourcePosColumn = 1 - } - }) - , complDocumentation = docs - , complExportedFrom = [ModuleName "BuildInfo"] - , complDeclarationType = Nothing - } - where - glob :: [F.Filter] -> Text - glob f = mapMaybe globSearch f & head & fromMaybe "*" - globSearch :: F.Filter -> Maybe Text - globSearch (F.Filter (Right (F.Prefix p))) = Just (p <> "*") - globSearch (F.Filter (Right (F.Exact p))) = Just p - globSearch _ = Nothing - - - -- modules <- getAllModules currentModule - -- let insertPrim = Map.union idePrimDeclarations - -- pure (CompletionResult (getCompletions filters matcher complOptions (insertPrim modules))) - findDeclarations :: Ide m => [F.Filter] From a8c913e09be16e0f18897ad9a8f7b3c98e6b849e Mon Sep 17 00:00:00 2001 From: seastian Date: Sun, 22 Sep 2024 11:02:52 +0200 Subject: [PATCH 19/38] wip --- src/Language/PureScript/Ide.hs | 21 +++++++-------------- src/Language/PureScript/Make/IdeCache.hs | 10 +++++++++- 2 files changed, 16 insertions(+), 15 deletions(-) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index c9883e9290..3b874a7995 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -38,7 +38,7 @@ 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, getSqliteFilePath, runQuery) -import Language.PureScript.Ide.Types (Annotation(..), Ide, IdeConfiguration(..), IdeDeclarationAnn(..), IdeEnvironment(..), Success(..), Completion (..), toText) +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) @@ -59,6 +59,7 @@ 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 -- | Accepts a Command and runs it against psc-ide's State. This is the main -- entry point for the server. @@ -149,8 +150,8 @@ findDeclarations -> Maybe CompletionOptions -> m Success findDeclarations filters currentModule completionOptions = do - rows <- runQuery $ - "select module_name, name, span " <> + rows :: [(Text, Lazy.ByteString)] <- runQuery $ + "select module_name, declaration " <> "from ide_declarations where " <> T.intercalate " and " ( mapMaybe (\case @@ -166,17 +167,9 @@ findDeclarations filters currentModule completionOptions = do filters) <> foldMap (\maxResults -> " limit " <> show maxResults ) (coMaxResults =<< completionOptions) - pure $ CompletionResult (rows <&> \(module_name, name, span) -> Completion - { complModule = module_name - , complIdentifier = name - , complType = "TYPE" - , complExpandedType = "EXPANDED" - , complLocation = deserialise span - , complDocumentation = Just "adfadsf" - , complExportedFrom = [ModuleName "MODDD"] - , complDeclarationType = Nothing - } - ) + let matches = rows <&> \(m, decl) -> (Match (ModuleName m, deserialise decl), []) + + 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 b36ccf0e42..3c443ee56f 100644 --- a/src/Language/PureScript/Make/IdeCache.hs +++ b/src/Language/PureScript/Make/IdeCache.hs @@ -28,6 +28,7 @@ import Language.PureScript.Docs.Render (renderDeclaration) import Language.PureScript.Docs.AsMarkdown (codeToString, declAsMarkdown, runDocs) import Codec.Serialise (serialise) import Data.Aeson (encode) +import Debug.Trace qualified as Debug sqliteExtern :: (MonadIO m) => FilePath -> Docs.Module -> ExternsFile -> m () sqliteExtern outputDir docs extern = liftIO $ do @@ -46,8 +47,15 @@ sqliteExtern outputDir docs extern = liftIO $ do , ":dependency" := runModuleName (eiModule i) ]) + + Debug.traceM $ show $ convertExterns extern + Debug.traceM $ show $ Docs.modDeclarations docs + for_ (fst $ convertExterns extern) (\ideDeclaration -> do - withRetry $ SQLite.executeNamed conn "INSERT INTO ide_declarations (module_name, name, namespace, declaration_type, span, declaration) VALUES (:module_name, :name, :namespace, :declaration_type, :span, :declaration)" + withRetry $ SQLite.executeNamed conn + ("INSERT INTO ide_declarations (module_name, name, namespace, declaration_type, span, declaration) " <> + "VALUES (:module_name, :name, :namespace, :declaration_type, :span, :declaration)" + ) [ ":module_name" := runModuleName (efModuleName extern ) , ":name" := identifierFromIdeDeclaration (discardAnn ideDeclaration) , ":namespace" := namespaceForDeclaration (discardAnn ideDeclaration) From c94b046c9e3e61a6cfc5309571814b1bcb61fd85 Mon Sep 17 00:00:00 2001 From: seastian Date: Mon, 23 Sep 2024 20:01:52 +0200 Subject: [PATCH 20/38] something --- purescript.cabal | 2 + src/Language/PureScript/Ide/Rebuild.hs | 2 +- src/Language/PureScript/Ide/SourceFile.hs | 5 +- src/Language/PureScript/Ide/State.hs | 15 +++ src/Language/PureScript/Ide/ToIde.hs | 156 ++++++++++++++++++++++ src/Language/PureScript/Make.hs | 2 +- src/Language/PureScript/Make/Actions.hs | 10 +- src/Language/PureScript/Make/IdeCache.hs | 13 +- 8 files changed, 190 insertions(+), 15 deletions(-) create mode 100644 src/Language/PureScript/Ide/ToIde.hs diff --git a/purescript.cabal b/purescript.cabal index d9ae7906aa..1d51c57ac6 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -274,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 diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index bab8d84d42..9b82cc87d1 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -199,7 +199,7 @@ shushProgress ma = -- | Stops any kind of codegen shushCodegen :: Monad m => P.MakeActions m -> P.MakeActions m shushCodegen ma = - ma { P.codegen = \_ _ _ -> pure () + ma { P.codegen = \_ _ _ _ -> pure () , P.ffiCodegen = \_ -> pure () } diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index ea49fd6a55..e874d17ed4 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -24,11 +24,14 @@ import Protolude import Control.Parallel.Strategies (withStrategy, parList, rseq) import Data.Map qualified as Map -import Language.PureScript qualified as P import Language.PureScript.CST qualified as CST import Language.PureScript.Ide.Error (IdeError) import Language.PureScript.Ide.Types (DefinitionSites, IdeNamespace(..), IdeNamespaced(..), TypeAnnotations) import Language.PureScript.Ide.Util (ideReadFile) +import Language.PureScript.AST.Declarations qualified as P +import Language.PureScript.AST.SourcePos qualified as P +import Language.PureScript.Names qualified as P +import Language.PureScript.Types qualified as P parseModule :: FilePath -> Text -> Either FilePath (FilePath, P.Module) parseModule path file = diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 7ded175e88..fb9d6b0bde 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -19,6 +19,7 @@ module Language.PureScript.Ide.State ( getLoadedModulenames , getExternFiles , getFileState + , toIdeDeclarationAnn , resetIdeState , cacheRebuild , cachedRebuild @@ -251,6 +252,20 @@ populateVolatileStateSTM ref = do setVolatileStateSTM ref (IdeVolatileState (AstData asts) (map reResolved results) rebuildCache) pure (force results) +toIdeDeclarationAnn :: P.Module -> ExternsFile -> [IdeDeclarationAnn] +toIdeDeclarationAnn m e = results + where + asts = extractAstInformation m + (moduleDeclarations, reexportRefs) = convertExterns e + results = + moduleDeclarations + & resolveDataConstructorsForModule + & resolveLocationsForModule asts + & resolveDocumentationForModule m + -- & resolveInstances externs + -- & resolveOperators + -- & resolveReexports reexportRefs + resolveLocations :: ModuleMap (DefinitionSites P.SourceSpan, TypeAnnotations) -> ModuleMap [IdeDeclarationAnn] diff --git a/src/Language/PureScript/Ide/ToIde.hs b/src/Language/PureScript/Ide/ToIde.hs new file mode 100644 index 0000000000..2e9ff4f28a --- /dev/null +++ b/src/Language/PureScript/Ide/ToIde.hs @@ -0,0 +1,156 @@ +module Language.PureScript.Ide.ToIde where + +import Protolude hiding (moduleName, unzip) + +import Control.Concurrent.STM (TVar, modifyTVar, readTVar, readTVarIO, writeTVar) +import Control.Lens (Ixed(..), preview, view, (%~), (.~), (^.)) +import Data.IORef (readIORef, writeIORef) +import Data.Map.Lazy qualified as Map +import Data.Time.Clock (UTCTime) +import Data.Zip (unzip) +import Language.PureScript.Docs.Convert.Single (convertComments) +import Language.PureScript.Externs (ExternsDeclaration(..), ExternsFile(..)) +import Language.PureScript.Ide.Externs (convertExterns) +import Language.PureScript.Ide.SourceFile (extractAstInformation) +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util (discardAnn, displayTimeSpec, logPerf, opNameT, properNameT, runLogger) +import System.Directory (getModificationTime) +import Database.SQLite.Simple qualified as SQLite +import Debug.Trace qualified as Debug +import Language.PureScript.AST.Declarations (Module (..)) +import Language.PureScript.AST.SourcePos qualified as P +import Language.PureScript.Names qualified as P +import Data.Text (Text) +import Language.PureScript.AST.Declarations qualified as P +import Language.PureScript.Comments qualified as P +import Data.Maybe (Maybe) + +toIdeDeclarationAnn :: Module -> ExternsFile -> [IdeDeclarationAnn] +toIdeDeclarationAnn m e = results + where + asts = extractAstInformation m + (moduleDeclarations, reexportRefs) = convertExterns e + results = + moduleDeclarations + -- & resolveDataConstructorsForModule + & resolveLocationsForModule asts + & resolveDocumentationForModule m + -- & resolveInstances externs + -- & resolveOperators + -- & resolveReexports reexportRefs + + +resolveLocationsForModule + :: (DefinitionSites P.SourceSpan, TypeAnnotations) + -> [IdeDeclarationAnn] + -> [IdeDeclarationAnn] +resolveLocationsForModule (defs, types) = + map convertDeclaration + where + convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn + convertDeclaration (IdeDeclarationAnn ann d) = convertDeclaration' + annotateFunction + annotateValue + annotateDataConstructor + annotateType + annotateType -- type classes live in the type namespace + annotateModule + d + where + annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNamespaced IdeNSValue (P.runIdent x)) defs + , _annTypeAnnotation = Map.lookup x types + }) + annotateValue x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs}) + annotateDataConstructor x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs}) + annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSType x) defs}) + annotateModule x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSModule x) defs}) + +convertDeclaration' + :: (P.Ident -> IdeDeclaration -> IdeDeclarationAnn) + -> (Text -> IdeDeclaration -> IdeDeclarationAnn) + -> (Text -> IdeDeclaration -> IdeDeclarationAnn) + -> (Text -> IdeDeclaration -> IdeDeclarationAnn) + -> (Text -> IdeDeclaration -> IdeDeclarationAnn) + -> (Text -> IdeDeclaration -> IdeDeclarationAnn) + -> IdeDeclaration + -> IdeDeclarationAnn +convertDeclaration' annotateFunction annotateValue annotateDataConstructor annotateType annotateClass annotateModule d = + case d of + IdeDeclValue v -> + annotateFunction (v ^. ideValueIdent) d + IdeDeclType t -> + annotateType (t ^. ideTypeName . properNameT) d + IdeDeclTypeSynonym s -> + annotateType (s ^. ideSynonymName . properNameT) d + IdeDeclDataConstructor dtor -> + annotateDataConstructor (dtor ^. ideDtorName . properNameT) d + IdeDeclTypeClass tc -> + annotateClass (tc ^. ideTCName . properNameT) d + IdeDeclValueOperator operator -> + annotateValue (operator ^. ideValueOpName . opNameT) d + IdeDeclTypeOperator operator -> + annotateType (operator ^. ideTypeOpName . opNameT) d + IdeDeclModule mn -> + annotateModule (P.runModuleName mn) d + +resolveDocumentationForModule + :: Module + -> [IdeDeclarationAnn] + -> [IdeDeclarationAnn] +resolveDocumentationForModule (Module _ moduleComments moduleName sdecls _) = + map convertDecl + where + extractDeclComments :: P.Declaration -> [(P.Name, [P.Comment])] + extractDeclComments = \case + P.DataDeclaration (_, cs) _ ctorName _ ctors -> + (P.TyName ctorName, cs) : map dtorComments ctors + P.TypeClassDeclaration (_, cs) tyClassName _ _ _ members -> + (P.TyClassName tyClassName, cs) : concatMap extractDeclComments members + decl -> + maybe [] (\name' -> [(name', snd (P.declSourceAnn decl))]) (name decl) + + comments :: Map.Map P.Name [P.Comment] + comments = Map.insert (P.ModName moduleName) moduleComments $ + Map.fromListWith (flip (<>)) $ concatMap extractDeclComments sdecls + + dtorComments :: P.DataConstructorDeclaration -> (P.Name, [P.Comment]) + dtorComments dcd = (P.DctorName (P.dataCtorName dcd), snd (P.dataCtorAnn dcd)) + + name :: P.Declaration -> Maybe P.Name + name (P.TypeDeclaration d) = Just $ P.IdentName $ P.tydeclIdent d + name decl = P.declName decl + + convertDecl :: IdeDeclarationAnn -> IdeDeclarationAnn + convertDecl (IdeDeclarationAnn ann d) = + convertDeclaration' + (annotateValue . P.IdentName) + (annotateValue . P.IdentName . P.Ident) + (annotateValue . P.DctorName . P.ProperName) + (annotateValue . P.TyName . P.ProperName) + (annotateValue . P.TyClassName . P.ProperName) + (annotateValue . P.ModName . P.moduleNameFromString) + d + where + docs :: P.Name -> Text + docs ident = fromMaybe "" $ convertComments =<< Map.lookup ident comments + + annotateValue ident = IdeDeclarationAnn (ann { _annDocumentation = Just $ docs ident }) + +-- resolveDataConstructorsForModule +-- :: [IdeDeclarationAnn] +-- -> [IdeDeclarationAnn] +-- resolveDataConstructorsForModule decls = +-- map (idaDeclaration %~ resolveDataConstructors) decls +-- where +-- resolveDataConstructors :: IdeDeclaration -> IdeDeclaration +-- resolveDataConstructors decl = case decl of +-- IdeDeclType ty -> +-- IdeDeclType (ty & ideTypeDtors .~ fromMaybe [] (Map.lookup (ty ^. ideTypeName) dtors)) +-- _ -> +-- decl +-- +-- dtors = +-- decls +-- & Map.mapMaybe (preview (idaDeclaration . _IdeDeclDataConstructor)) +-- & foldr (\(IdeDataConstructor name typeName type') -> +-- Map.insertWith (<>) typeName [(name, type')]) Map.empty diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 5d073d8f6d..4a7ce34701 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -132,7 +132,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ ++ "; details:\n" ++ prettyPrintMultipleErrors defaultPPEOptions errs Right d -> d - evalSupplyT nextVar'' $ codegen renamed docs exts + evalSupplyT nextVar'' $ codegen withPrim renamed docs exts return exts -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file. diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index efd27f76ef..1e25f2a7cc 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -34,7 +34,7 @@ import Data.Text.Encoding qualified as TE import Data.Time.Clock (UTCTime) import Data.Version (showVersion) import Language.JavaScript.Parser qualified as JS -import Language.PureScript.AST (SourcePos(..)) +import Language.PureScript.AST (SourcePos(..), Module) import Language.PureScript.Bundle qualified as Bundle import Language.PureScript.CodeGen.JS qualified as J import Language.PureScript.CodeGen.JS.Printer (prettyPrintJS, prettyPrintJSWithSourceMaps) @@ -113,7 +113,7 @@ data MakeActions m = MakeActions , readExterns :: ModuleName -> m (FilePath, Maybe ExternsFile) -- ^ Read the externs file for a module as a string and also return the actual -- path for the file. - , codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m () + , codegen :: Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m () -- ^ Run the code generator for the module and write any required output files. , ffiCodegen :: CF.Module CF.Ann -> m () -- ^ Check ffi and print it in the output directory. @@ -247,12 +247,12 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = when (S.member Docs codegenTargets) $ for_ Docs.Prim.primModules $ \docsMod@Docs.Module{..} -> writeJSONFile (outputFilename modName "docs.json") docsMod - codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make () - codegen m docs exts = do + codegen :: Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make () + codegen ast m docs exts = do let mn = CF.moduleName m lift $ writeCborFile (outputFilename mn externsFileName) exts lift $ sqliteInit outputDir - lift $ sqliteExtern outputDir docs exts + lift $ sqliteExtern outputDir ast docs exts codegenTargets <- lift $ asks optionsCodegenTargets when (S.member CoreFn codegenTargets) $ do let coreFnFile = targetFilename mn CoreFn diff --git a/src/Language/PureScript/Make/IdeCache.hs b/src/Language/PureScript/Make/IdeCache.hs index 3c443ee56f..6372a77c4d 100644 --- a/src/Language/PureScript/Make/IdeCache.hs +++ b/src/Language/PureScript/Make/IdeCache.hs @@ -1,6 +1,8 @@ module Language.PureScript.Make.IdeCache where import Prelude + +import Language.PureScript.Ide.ToIde (toIdeDeclarationAnn) import Database.SQLite.Simple (NamedParam(..)) import Database.SQLite.Simple qualified as SQLite import Codec.Serialise qualified as Serialise @@ -29,9 +31,10 @@ 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) -sqliteExtern :: (MonadIO m) => FilePath -> Docs.Module -> ExternsFile -> m () -sqliteExtern outputDir docs extern = liftIO $ do +sqliteExtern :: (MonadIO m) => FilePath -> Module -> Docs.Module -> ExternsFile -> m () +sqliteExtern outputDir m docs extern = liftIO $ do conn <- SQLite.open db withRetry $ SQLite.executeNamed conn "INSERT INTO modules (module_name, comment, extern, dec) VALUES (:module_name, :docs, :extern, :dec)" @@ -47,11 +50,7 @@ sqliteExtern outputDir docs extern = liftIO $ do , ":dependency" := runModuleName (eiModule i) ]) - - Debug.traceM $ show $ convertExterns extern - Debug.traceM $ show $ Docs.modDeclarations docs - - for_ (fst $ convertExterns extern) (\ideDeclaration -> do + for_ (toIdeDeclarationAnn m extern) (\ideDeclaration -> do withRetry $ SQLite.executeNamed conn ("INSERT INTO ide_declarations (module_name, name, namespace, declaration_type, span, declaration) " <> "VALUES (:module_name, :name, :namespace, :declaration_type, :span, :declaration)" From 00331a1ed713a90ebf651585a1a0123e138e7e72 Mon Sep 17 00:00:00 2001 From: seastian Date: Tue, 24 Sep 2024 14:45:11 +0200 Subject: [PATCH 21/38] wip --- src/Language/PureScript/Ide/ToI.hs | 292 +++++++++++++++++++++++ src/Language/PureScript/Make/IdeCache.hs | 3 + 2 files changed, 295 insertions(+) create mode 100644 src/Language/PureScript/Ide/ToI.hs diff --git a/src/Language/PureScript/Ide/ToI.hs b/src/Language/PureScript/Ide/ToI.hs new file mode 100644 index 0000000000..cd1a5f2599 --- /dev/null +++ b/src/Language/PureScript/Ide/ToI.hs @@ -0,0 +1,292 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Ide.State +-- Description : Functions to access psc-ide's state +-- Copyright : Christoph Hegemann 2016 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Christoph Hegemann +-- Stability : experimental +-- +-- | +-- Functions to access psc-ide's state +----------------------------------------------------------------------------- + +{-# LANGUAGE TypeApplications #-} + +module Language.PureScript.Ide.ToI + ( toIdeDeclarationAnn + -- for tests + , resolveOperatorsForModule + , resolveInstances + , resolveDataConstructorsForModule + ) where + +import Protolude hiding (moduleName, unzip) + +import Control.Concurrent.STM (TVar, modifyTVar, readTVar, readTVarIO, writeTVar) +import Control.Lens (Ixed(..), preview, view, (%~), (.~), (^.)) +import Data.IORef (readIORef, writeIORef) +import Data.Map.Lazy qualified as Map +import Data.Time.Clock (UTCTime) +import Data.Zip (unzip) +import Language.PureScript.Docs.Convert.Single (convertComments) +import Language.PureScript.Externs (ExternsDeclaration(..), ExternsFile(..)) +import Language.PureScript.Ide.Externs (convertExterns) +import Language.PureScript.Ide.SourceFile (extractAstInformation) +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util (discardAnn, displayTimeSpec, logPerf, opNameT, properNameT, runLogger) +import System.Directory (getModificationTime) +import Database.SQLite.Simple qualified as SQLite +import Debug.Trace qualified as Debug +import Language.PureScript.AST.Declarations qualified as P +import Language.PureScript.AST.SourcePos qualified as P +import Language.PureScript.Names qualified as P +import Language.PureScript.Comments qualified as P +import Language.PureScript.Externs qualified as P +import Language.PureScript.Ide.Reexports (resolveReexports) + + +toI :: P.Module -> ExternsFile -> [IdeDeclarationAnn] +toI m e = do + let externs = Map.singleton (P.getModuleName m) e + let modules = Map.singleton (P.getModuleName m) (m, "adfasd") + let asts = map (extractAstInformation . fst) modules + let (moduleDeclarations, reexportRefs) = unzip (Map.map convertExterns externs) + results = + moduleDeclarations + & map resolveDataConstructorsForModule + & resolveLocations asts + & resolveDocumentation (map fst modules) + & resolveInstances externs + & resolveOperators + & resolveReexports reexportRefs + fromMaybe [] $ Map.lookup (P.getModuleName m) (map reResolved results) + +toIdeDeclarationAnn :: P.Module -> ExternsFile -> [IdeDeclarationAnn] +toIdeDeclarationAnn m e = results + where + asts = extractAstInformation m + (moduleDeclarations, reexportRefs) = convertExterns e + results = + moduleDeclarations + & resolveDataConstructorsForModule + & resolveLocationsForModule asts + & resolveDocumentationForModule m + -- & resolveInstances externs + -- & resolveOperators + -- & resolveReexports reexportRefs + +resolveLocations + :: ModuleMap (DefinitionSites P.SourceSpan, TypeAnnotations) + -> ModuleMap [IdeDeclarationAnn] + -> ModuleMap [IdeDeclarationAnn] +resolveLocations asts = + Map.mapWithKey (\mn decls -> + maybe decls (flip resolveLocationsForModule decls) (Map.lookup mn asts)) + +resolveLocationsForModule + :: (DefinitionSites P.SourceSpan, TypeAnnotations) + -> [IdeDeclarationAnn] + -> [IdeDeclarationAnn] +resolveLocationsForModule (defs, types) = + map convertDeclaration + where + convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn + convertDeclaration (IdeDeclarationAnn ann d) = convertDeclaration' + annotateFunction + annotateValue + annotateDataConstructor + annotateType + annotateType -- type classes live in the type namespace + annotateModule + d + where + annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNamespaced IdeNSValue (P.runIdent x)) defs + , _annTypeAnnotation = Map.lookup x types + }) + annotateValue x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs}) + annotateDataConstructor x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs}) + annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSType x) defs}) + annotateModule x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSModule x) defs}) + +convertDeclaration' + :: (P.Ident -> IdeDeclaration -> IdeDeclarationAnn) + -> (Text -> IdeDeclaration -> IdeDeclarationAnn) + -> (Text -> IdeDeclaration -> IdeDeclarationAnn) + -> (Text -> IdeDeclaration -> IdeDeclarationAnn) + -> (Text -> IdeDeclaration -> IdeDeclarationAnn) + -> (Text -> IdeDeclaration -> IdeDeclarationAnn) + -> IdeDeclaration + -> IdeDeclarationAnn +convertDeclaration' annotateFunction annotateValue annotateDataConstructor annotateType annotateClass annotateModule d = + case d of + IdeDeclValue v -> + annotateFunction (v ^. ideValueIdent) d + IdeDeclType t -> + annotateType (t ^. ideTypeName . properNameT) d + IdeDeclTypeSynonym s -> + annotateType (s ^. ideSynonymName . properNameT) d + IdeDeclDataConstructor dtor -> + annotateDataConstructor (dtor ^. ideDtorName . properNameT) d + IdeDeclTypeClass tc -> + annotateClass (tc ^. ideTCName . properNameT) d + IdeDeclValueOperator operator -> + annotateValue (operator ^. ideValueOpName . opNameT) d + IdeDeclTypeOperator operator -> + annotateType (operator ^. ideTypeOpName . opNameT) d + IdeDeclModule mn -> + annotateModule (P.runModuleName mn) d + +resolveDocumentation + :: ModuleMap P.Module + -> ModuleMap [IdeDeclarationAnn] + -> ModuleMap [IdeDeclarationAnn] +resolveDocumentation modules = + Map.mapWithKey (\mn decls -> + maybe decls (flip resolveDocumentationForModule decls) (Map.lookup mn modules)) + +resolveDocumentationForModule + :: P.Module + -> [IdeDeclarationAnn] + -> [IdeDeclarationAnn] +resolveDocumentationForModule (P.Module _ moduleComments moduleName sdecls _) = + map convertDecl + where + extractDeclComments :: P.Declaration -> [(P.Name, [P.Comment])] + extractDeclComments = \case + P.DataDeclaration (_, cs) _ ctorName _ ctors -> + (P.TyName ctorName, cs) : map dtorComments ctors + P.TypeClassDeclaration (_, cs) tyClassName _ _ _ members -> + (P.TyClassName tyClassName, cs) : concatMap extractDeclComments members + decl -> + maybe [] (\name' -> [(name', snd (P.declSourceAnn decl))]) (name decl) + + comments :: Map P.Name [P.Comment] + comments = Map.insert (P.ModName moduleName) moduleComments $ + Map.fromListWith (flip (<>)) $ concatMap extractDeclComments sdecls + + dtorComments :: P.DataConstructorDeclaration -> (P.Name, [P.Comment]) + dtorComments dcd = (P.DctorName (P.dataCtorName dcd), snd (P.dataCtorAnn dcd)) + + name :: P.Declaration -> Maybe P.Name + name (P.TypeDeclaration d) = Just $ P.IdentName $ P.tydeclIdent d + name decl = P.declName decl + + convertDecl :: IdeDeclarationAnn -> IdeDeclarationAnn + convertDecl (IdeDeclarationAnn ann d) = + convertDeclaration' + (annotateValue . P.IdentName) + (annotateValue . P.IdentName . P.Ident) + (annotateValue . P.DctorName . P.ProperName) + (annotateValue . P.TyName . P.ProperName) + (annotateValue . P.TyClassName . P.ProperName) + (annotateValue . P.ModName . P.moduleNameFromString) + d + where + docs :: P.Name -> Text + docs ident = fromMaybe "" $ convertComments =<< Map.lookup ident comments + + annotateValue ident = IdeDeclarationAnn (ann { _annDocumentation = Just $ docs ident }) + +resolveInstances + :: ModuleMap P.ExternsFile + -> ModuleMap [IdeDeclarationAnn] + -> ModuleMap [IdeDeclarationAnn] +resolveInstances externs declarations = + Map.foldr (flip (foldr go)) declarations + . Map.mapWithKey (\mn ef -> mapMaybe (extractInstances mn) (efDeclarations ef)) + $ externs + where + extractInstances mn P.EDInstance{..} = + case edInstanceClassName of + P.Qualified (P.ByModuleName classModule) className -> + Just (IdeInstance mn + edInstanceName + edInstanceTypes + edInstanceConstraints, classModule, className) + _ -> Nothing + extractInstances _ _ = Nothing + + go + :: (IdeInstance, P.ModuleName, P.ProperName 'P.ClassName) + -> ModuleMap [IdeDeclarationAnn] + -> ModuleMap [IdeDeclarationAnn] + go (ideInstance, classModule, className) acc' = + let + matchTC = + anyOf (idaDeclaration . _IdeDeclTypeClass . ideTCName) (== className) + updateDeclaration = + mapIf matchTC (idaDeclaration + . _IdeDeclTypeClass + . ideTCInstances + %~ (ideInstance :)) + in + acc' & ix classModule %~ updateDeclaration + +resolveOperators + :: ModuleMap [IdeDeclarationAnn] + -> ModuleMap [IdeDeclarationAnn] +resolveOperators modules = + map (resolveOperatorsForModule modules) modules + +-- | Looks up the types and kinds for operators and assigns them to their +-- declarations +resolveOperatorsForModule + :: ModuleMap [IdeDeclarationAnn] + -> [IdeDeclarationAnn] + -> [IdeDeclarationAnn] +resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator) + where + getDeclarations :: P.ModuleName -> [IdeDeclaration] + getDeclarations moduleName = + Map.lookup moduleName modules + & foldMap (map discardAnn) + + resolveOperator (IdeDeclValueOperator op) + | (P.Qualified (P.ByModuleName mn) (Left ident)) <- op ^. ideValueOpAlias = + let t = getDeclarations mn + & mapMaybe (preview _IdeDeclValue) + & filter (anyOf ideValueIdent (== ident)) + & map (view ideValueType) + & listToMaybe + in IdeDeclValueOperator (op & ideValueOpType .~ t) + | (P.Qualified (P.ByModuleName mn) (Right dtor)) <- op ^. ideValueOpAlias = + let t = getDeclarations mn + & mapMaybe (preview _IdeDeclDataConstructor) + & filter (anyOf ideDtorName (== dtor)) + & map (view ideDtorType) + & listToMaybe + in IdeDeclValueOperator (op & ideValueOpType .~ t) + resolveOperator (IdeDeclTypeOperator op) + | P.Qualified (P.ByModuleName mn) properName <- op ^. ideTypeOpAlias = + let k = getDeclarations mn + & mapMaybe (preview _IdeDeclType) + & filter (anyOf ideTypeName (== properName)) + & map (view ideTypeKind) + & listToMaybe + in IdeDeclTypeOperator (op & ideTypeOpKind .~ k) + resolveOperator x = x + + +mapIf :: Functor f => (b -> Bool) -> (b -> b) -> f b -> f b +mapIf p f = map (\x -> if p x then f x else x) + +resolveDataConstructorsForModule + :: [IdeDeclarationAnn] + -> [IdeDeclarationAnn] +resolveDataConstructorsForModule decls = + map (idaDeclaration %~ resolveDataConstructors) decls + where + resolveDataConstructors :: IdeDeclaration -> IdeDeclaration + resolveDataConstructors decl = case decl of + IdeDeclType ty -> + IdeDeclType (ty & ideTypeDtors .~ fromMaybe [] (Map.lookup (ty ^. ideTypeName) dtors)) + _ -> + decl + + dtors = + decls + & mapMaybe (preview (idaDeclaration . _IdeDeclDataConstructor)) + & foldr (\(IdeDataConstructor name typeName type') -> + Map.insertWith (<>) typeName [(name, type')]) Map.empty diff --git a/src/Language/PureScript/Make/IdeCache.hs b/src/Language/PureScript/Make/IdeCache.hs index 6372a77c4d..592330d280 100644 --- a/src/Language/PureScript/Make/IdeCache.hs +++ b/src/Language/PureScript/Make/IdeCache.hs @@ -2,6 +2,7 @@ module Language.PureScript.Make.IdeCache where import Prelude +import Language.PureScript.Ide.ToI (toI) import Language.PureScript.Ide.ToIde (toIdeDeclarationAnn) import Database.SQLite.Simple (NamedParam(..)) import Database.SQLite.Simple qualified as SQLite @@ -50,6 +51,8 @@ sqliteExtern outputDir m docs extern = liftIO $ do , ":dependency" := runModuleName (eiModule i) ]) + toI + for_ (toIdeDeclarationAnn m extern) (\ideDeclaration -> do withRetry $ SQLite.executeNamed conn ("INSERT INTO ide_declarations (module_name, name, namespace, declaration_type, span, declaration) " <> From 0e138e919cc7d18a69c1a4e8cb2250eb1953b56f Mon Sep 17 00:00:00 2001 From: seastian Date: Wed, 25 Sep 2024 18:25:55 +0200 Subject: [PATCH 22/38] wip --- .../PureScript/Ide/Filter/Declaration.hs | 1 - src/Language/PureScript/Ide/ToI.hs | 494 +++++++++--------- src/Language/PureScript/Make/IdeCache.hs | 81 ++- 3 files changed, 310 insertions(+), 266 deletions(-) diff --git a/src/Language/PureScript/Ide/Filter/Declaration.hs b/src/Language/PureScript/Ide/Filter/Declaration.hs index c17e6f285e..9f17ebe7c6 100644 --- a/src/Language/PureScript/Ide/Filter/Declaration.hs +++ b/src/Language/PureScript/Ide/Filter/Declaration.hs @@ -54,6 +54,5 @@ declarationTypeToText ValueOperator = "valueoperator" declarationTypeToText TypeOperator = "typeoperator" declarationTypeToText Module = "module" - instance ToField DeclarationType where toField d = SQLText $ declarationTypeToText d diff --git a/src/Language/PureScript/Ide/ToI.hs b/src/Language/PureScript/Ide/ToI.hs index cd1a5f2599..a4a52a5c33 100644 --- a/src/Language/PureScript/Ide/ToI.hs +++ b/src/Language/PureScript/Ide/ToI.hs @@ -14,13 +14,7 @@ {-# LANGUAGE TypeApplications #-} -module Language.PureScript.Ide.ToI - ( toIdeDeclarationAnn - -- for tests - , resolveOperatorsForModule - , resolveInstances - , resolveDataConstructorsForModule - ) where +module Language.PureScript.Ide.ToI where import Protolude hiding (moduleName, unzip) @@ -47,246 +41,246 @@ import Language.PureScript.Externs qualified as P import Language.PureScript.Ide.Reexports (resolveReexports) -toI :: P.Module -> ExternsFile -> [IdeDeclarationAnn] -toI m e = do - let externs = Map.singleton (P.getModuleName m) e - let modules = Map.singleton (P.getModuleName m) (m, "adfasd") - let asts = map (extractAstInformation . fst) modules - let (moduleDeclarations, reexportRefs) = unzip (Map.map convertExterns externs) - results = - moduleDeclarations - & map resolveDataConstructorsForModule - & resolveLocations asts - & resolveDocumentation (map fst modules) - & resolveInstances externs - & resolveOperators - & resolveReexports reexportRefs - fromMaybe [] $ Map.lookup (P.getModuleName m) (map reResolved results) - -toIdeDeclarationAnn :: P.Module -> ExternsFile -> [IdeDeclarationAnn] -toIdeDeclarationAnn m e = results - where - asts = extractAstInformation m - (moduleDeclarations, reexportRefs) = convertExterns e - results = - moduleDeclarations - & resolveDataConstructorsForModule - & resolveLocationsForModule asts - & resolveDocumentationForModule m - -- & resolveInstances externs - -- & resolveOperators - -- & resolveReexports reexportRefs - -resolveLocations - :: ModuleMap (DefinitionSites P.SourceSpan, TypeAnnotations) - -> ModuleMap [IdeDeclarationAnn] - -> ModuleMap [IdeDeclarationAnn] -resolveLocations asts = - Map.mapWithKey (\mn decls -> - maybe decls (flip resolveLocationsForModule decls) (Map.lookup mn asts)) - -resolveLocationsForModule - :: (DefinitionSites P.SourceSpan, TypeAnnotations) - -> [IdeDeclarationAnn] - -> [IdeDeclarationAnn] -resolveLocationsForModule (defs, types) = - map convertDeclaration - where - convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn - convertDeclaration (IdeDeclarationAnn ann d) = convertDeclaration' - annotateFunction - annotateValue - annotateDataConstructor - annotateType - annotateType -- type classes live in the type namespace - annotateModule - d - where - annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNamespaced IdeNSValue (P.runIdent x)) defs - , _annTypeAnnotation = Map.lookup x types - }) - annotateValue x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs}) - annotateDataConstructor x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs}) - annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSType x) defs}) - annotateModule x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSModule x) defs}) - -convertDeclaration' - :: (P.Ident -> IdeDeclaration -> IdeDeclarationAnn) - -> (Text -> IdeDeclaration -> IdeDeclarationAnn) - -> (Text -> IdeDeclaration -> IdeDeclarationAnn) - -> (Text -> IdeDeclaration -> IdeDeclarationAnn) - -> (Text -> IdeDeclaration -> IdeDeclarationAnn) - -> (Text -> IdeDeclaration -> IdeDeclarationAnn) - -> IdeDeclaration - -> IdeDeclarationAnn -convertDeclaration' annotateFunction annotateValue annotateDataConstructor annotateType annotateClass annotateModule d = - case d of - IdeDeclValue v -> - annotateFunction (v ^. ideValueIdent) d - IdeDeclType t -> - annotateType (t ^. ideTypeName . properNameT) d - IdeDeclTypeSynonym s -> - annotateType (s ^. ideSynonymName . properNameT) d - IdeDeclDataConstructor dtor -> - annotateDataConstructor (dtor ^. ideDtorName . properNameT) d - IdeDeclTypeClass tc -> - annotateClass (tc ^. ideTCName . properNameT) d - IdeDeclValueOperator operator -> - annotateValue (operator ^. ideValueOpName . opNameT) d - IdeDeclTypeOperator operator -> - annotateType (operator ^. ideTypeOpName . opNameT) d - IdeDeclModule mn -> - annotateModule (P.runModuleName mn) d - -resolveDocumentation - :: ModuleMap P.Module - -> ModuleMap [IdeDeclarationAnn] - -> ModuleMap [IdeDeclarationAnn] -resolveDocumentation modules = - Map.mapWithKey (\mn decls -> - maybe decls (flip resolveDocumentationForModule decls) (Map.lookup mn modules)) - -resolveDocumentationForModule - :: P.Module - -> [IdeDeclarationAnn] - -> [IdeDeclarationAnn] -resolveDocumentationForModule (P.Module _ moduleComments moduleName sdecls _) = - map convertDecl - where - extractDeclComments :: P.Declaration -> [(P.Name, [P.Comment])] - extractDeclComments = \case - P.DataDeclaration (_, cs) _ ctorName _ ctors -> - (P.TyName ctorName, cs) : map dtorComments ctors - P.TypeClassDeclaration (_, cs) tyClassName _ _ _ members -> - (P.TyClassName tyClassName, cs) : concatMap extractDeclComments members - decl -> - maybe [] (\name' -> [(name', snd (P.declSourceAnn decl))]) (name decl) - - comments :: Map P.Name [P.Comment] - comments = Map.insert (P.ModName moduleName) moduleComments $ - Map.fromListWith (flip (<>)) $ concatMap extractDeclComments sdecls - - dtorComments :: P.DataConstructorDeclaration -> (P.Name, [P.Comment]) - dtorComments dcd = (P.DctorName (P.dataCtorName dcd), snd (P.dataCtorAnn dcd)) - - name :: P.Declaration -> Maybe P.Name - name (P.TypeDeclaration d) = Just $ P.IdentName $ P.tydeclIdent d - name decl = P.declName decl - - convertDecl :: IdeDeclarationAnn -> IdeDeclarationAnn - convertDecl (IdeDeclarationAnn ann d) = - convertDeclaration' - (annotateValue . P.IdentName) - (annotateValue . P.IdentName . P.Ident) - (annotateValue . P.DctorName . P.ProperName) - (annotateValue . P.TyName . P.ProperName) - (annotateValue . P.TyClassName . P.ProperName) - (annotateValue . P.ModName . P.moduleNameFromString) - d - where - docs :: P.Name -> Text - docs ident = fromMaybe "" $ convertComments =<< Map.lookup ident comments - - annotateValue ident = IdeDeclarationAnn (ann { _annDocumentation = Just $ docs ident }) - -resolveInstances - :: ModuleMap P.ExternsFile - -> ModuleMap [IdeDeclarationAnn] - -> ModuleMap [IdeDeclarationAnn] -resolveInstances externs declarations = - Map.foldr (flip (foldr go)) declarations - . Map.mapWithKey (\mn ef -> mapMaybe (extractInstances mn) (efDeclarations ef)) - $ externs - where - extractInstances mn P.EDInstance{..} = - case edInstanceClassName of - P.Qualified (P.ByModuleName classModule) className -> - Just (IdeInstance mn - edInstanceName - edInstanceTypes - edInstanceConstraints, classModule, className) - _ -> Nothing - extractInstances _ _ = Nothing - - go - :: (IdeInstance, P.ModuleName, P.ProperName 'P.ClassName) - -> ModuleMap [IdeDeclarationAnn] - -> ModuleMap [IdeDeclarationAnn] - go (ideInstance, classModule, className) acc' = - let - matchTC = - anyOf (idaDeclaration . _IdeDeclTypeClass . ideTCName) (== className) - updateDeclaration = - mapIf matchTC (idaDeclaration - . _IdeDeclTypeClass - . ideTCInstances - %~ (ideInstance :)) - in - acc' & ix classModule %~ updateDeclaration - -resolveOperators - :: ModuleMap [IdeDeclarationAnn] - -> ModuleMap [IdeDeclarationAnn] -resolveOperators modules = - map (resolveOperatorsForModule modules) modules - --- | Looks up the types and kinds for operators and assigns them to their --- declarations -resolveOperatorsForModule - :: ModuleMap [IdeDeclarationAnn] - -> [IdeDeclarationAnn] - -> [IdeDeclarationAnn] -resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator) - where - getDeclarations :: P.ModuleName -> [IdeDeclaration] - getDeclarations moduleName = - Map.lookup moduleName modules - & foldMap (map discardAnn) - - resolveOperator (IdeDeclValueOperator op) - | (P.Qualified (P.ByModuleName mn) (Left ident)) <- op ^. ideValueOpAlias = - let t = getDeclarations mn - & mapMaybe (preview _IdeDeclValue) - & filter (anyOf ideValueIdent (== ident)) - & map (view ideValueType) - & listToMaybe - in IdeDeclValueOperator (op & ideValueOpType .~ t) - | (P.Qualified (P.ByModuleName mn) (Right dtor)) <- op ^. ideValueOpAlias = - let t = getDeclarations mn - & mapMaybe (preview _IdeDeclDataConstructor) - & filter (anyOf ideDtorName (== dtor)) - & map (view ideDtorType) - & listToMaybe - in IdeDeclValueOperator (op & ideValueOpType .~ t) - resolveOperator (IdeDeclTypeOperator op) - | P.Qualified (P.ByModuleName mn) properName <- op ^. ideTypeOpAlias = - let k = getDeclarations mn - & mapMaybe (preview _IdeDeclType) - & filter (anyOf ideTypeName (== properName)) - & map (view ideTypeKind) - & listToMaybe - in IdeDeclTypeOperator (op & ideTypeOpKind .~ k) - resolveOperator x = x - - -mapIf :: Functor f => (b -> Bool) -> (b -> b) -> f b -> f b -mapIf p f = map (\x -> if p x then f x else x) - -resolveDataConstructorsForModule - :: [IdeDeclarationAnn] - -> [IdeDeclarationAnn] -resolveDataConstructorsForModule decls = - map (idaDeclaration %~ resolveDataConstructors) decls - where - resolveDataConstructors :: IdeDeclaration -> IdeDeclaration - resolveDataConstructors decl = case decl of - IdeDeclType ty -> - IdeDeclType (ty & ideTypeDtors .~ fromMaybe [] (Map.lookup (ty ^. ideTypeName) dtors)) - _ -> - decl - - dtors = - decls - & mapMaybe (preview (idaDeclaration . _IdeDeclDataConstructor)) - & foldr (\(IdeDataConstructor name typeName type') -> - Map.insertWith (<>) typeName [(name, type')]) Map.empty +-- toI :: P.Module -> ExternsFile -> [IdeDeclarationAnn] +-- toI m e = do +-- let externs = Map.singleton (P.getModuleName m) e +-- let modules = Map.singleton (P.getModuleName m) (m, "adfasd") +-- let asts = map (extractAstInformation . fst) modules +-- let (moduleDeclarations, reexportRefs) = unzip (Map.map convertExterns externs) +-- results = +-- moduleDeclarations +-- & map resolveDataConstructorsForModule +-- & resolveLocations asts +-- & resolveDocumentation (map fst modules) +-- & resolveInstances externs +-- & resolveOperators +-- & resolveReexports reexportRefs +-- fromMaybe [] $ Map.lookup (P.getModuleName m) (map reResolved results) +-- +-- toIdeDeclarationAnn :: P.Module -> ExternsFile -> [IdeDeclarationAnn] +-- toIdeDeclarationAnn m e = results +-- where +-- asts = extractAstInformation m +-- (moduleDeclarations, reexportRefs) = convertExterns e +-- results = +-- moduleDeclarations +-- & resolveDataConstructorsForModule +-- & resolveLocationsForModule asts +-- & resolveDocumentationForModule m +-- -- & resolveInstances externs +-- -- & resolveOperators +-- -- & resolveReexports reexportRefs +-- +-- resolveLocations +-- :: ModuleMap (DefinitionSites P.SourceSpan, TypeAnnotations) +-- -> ModuleMap [IdeDeclarationAnn] +-- -> ModuleMap [IdeDeclarationAnn] +-- resolveLocations asts = +-- Map.mapWithKey (\mn decls -> +-- maybe decls (flip resolveLocationsForModule decls) (Map.lookup mn asts)) +-- +-- resolveLocationsForModule +-- :: (DefinitionSites P.SourceSpan, TypeAnnotations) +-- -> [IdeDeclarationAnn] +-- -> [IdeDeclarationAnn] +-- resolveLocationsForModule (defs, types) = +-- map convertDeclaration +-- where +-- convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn +-- convertDeclaration (IdeDeclarationAnn ann d) = convertDeclaration' +-- annotateFunction +-- annotateValue +-- annotateDataConstructor +-- annotateType +-- annotateType -- type classes live in the type namespace +-- annotateModule +-- d +-- where +-- annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNamespaced IdeNSValue (P.runIdent x)) defs +-- , _annTypeAnnotation = Map.lookup x types +-- }) +-- annotateValue x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs}) +-- annotateDataConstructor x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs}) +-- annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSType x) defs}) +-- annotateModule x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSModule x) defs}) +-- +-- convertDeclaration' +-- :: (P.Ident -> IdeDeclaration -> IdeDeclarationAnn) +-- -> (Text -> IdeDeclaration -> IdeDeclarationAnn) +-- -> (Text -> IdeDeclaration -> IdeDeclarationAnn) +-- -> (Text -> IdeDeclaration -> IdeDeclarationAnn) +-- -> (Text -> IdeDeclaration -> IdeDeclarationAnn) +-- -> (Text -> IdeDeclaration -> IdeDeclarationAnn) +-- -> IdeDeclaration +-- -> IdeDeclarationAnn +-- convertDeclaration' annotateFunction annotateValue annotateDataConstructor annotateType annotateClass annotateModule d = +-- case d of +-- IdeDeclValue v -> +-- annotateFunction (v ^. ideValueIdent) d +-- IdeDeclType t -> +-- annotateType (t ^. ideTypeName . properNameT) d +-- IdeDeclTypeSynonym s -> +-- annotateType (s ^. ideSynonymName . properNameT) d +-- IdeDeclDataConstructor dtor -> +-- annotateDataConstructor (dtor ^. ideDtorName . properNameT) d +-- IdeDeclTypeClass tc -> +-- annotateClass (tc ^. ideTCName . properNameT) d +-- IdeDeclValueOperator operator -> +-- annotateValue (operator ^. ideValueOpName . opNameT) d +-- IdeDeclTypeOperator operator -> +-- annotateType (operator ^. ideTypeOpName . opNameT) d +-- IdeDeclModule mn -> +-- annotateModule (P.runModuleName mn) d +-- +-- resolveDocumentation +-- :: ModuleMap P.Module +-- -> ModuleMap [IdeDeclarationAnn] +-- -> ModuleMap [IdeDeclarationAnn] +-- resolveDocumentation modules = +-- Map.mapWithKey (\mn decls -> +-- maybe decls (flip resolveDocumentationForModule decls) (Map.lookup mn modules)) +-- +-- resolveDocumentationForModule +-- :: P.Module +-- -> [IdeDeclarationAnn] +-- -> [IdeDeclarationAnn] +-- resolveDocumentationForModule (P.Module _ moduleComments moduleName sdecls _) = +-- map convertDecl +-- where +-- extractDeclComments :: P.Declaration -> [(P.Name, [P.Comment])] +-- extractDeclComments = \case +-- P.DataDeclaration (_, cs) _ ctorName _ ctors -> +-- (P.TyName ctorName, cs) : map dtorComments ctors +-- P.TypeClassDeclaration (_, cs) tyClassName _ _ _ members -> +-- (P.TyClassName tyClassName, cs) : concatMap extractDeclComments members +-- decl -> +-- maybe [] (\name' -> [(name', snd (P.declSourceAnn decl))]) (name decl) +-- +-- comments :: Map P.Name [P.Comment] +-- comments = Map.insert (P.ModName moduleName) moduleComments $ +-- Map.fromListWith (flip (<>)) $ concatMap extractDeclComments sdecls +-- +-- dtorComments :: P.DataConstructorDeclaration -> (P.Name, [P.Comment]) +-- dtorComments dcd = (P.DctorName (P.dataCtorName dcd), snd (P.dataCtorAnn dcd)) +-- +-- name :: P.Declaration -> Maybe P.Name +-- name (P.TypeDeclaration d) = Just $ P.IdentName $ P.tydeclIdent d +-- name decl = P.declName decl +-- +-- convertDecl :: IdeDeclarationAnn -> IdeDeclarationAnn +-- convertDecl (IdeDeclarationAnn ann d) = +-- convertDeclaration' +-- (annotateValue . P.IdentName) +-- (annotateValue . P.IdentName . P.Ident) +-- (annotateValue . P.DctorName . P.ProperName) +-- (annotateValue . P.TyName . P.ProperName) +-- (annotateValue . P.TyClassName . P.ProperName) +-- (annotateValue . P.ModName . P.moduleNameFromString) +-- d +-- where +-- docs :: P.Name -> Text +-- docs ident = fromMaybe "" $ convertComments =<< Map.lookup ident comments +-- +-- annotateValue ident = IdeDeclarationAnn (ann { _annDocumentation = Just $ docs ident }) +-- +-- resolveInstances +-- :: ModuleMap P.ExternsFile +-- -> ModuleMap [IdeDeclarationAnn] +-- -> ModuleMap [IdeDeclarationAnn] +-- resolveInstances externs declarations = +-- Map.foldr (flip (foldr go)) declarations +-- . Map.mapWithKey (\mn ef -> mapMaybe (extractInstances mn) (efDeclarations ef)) +-- $ externs +-- where +-- extractInstances mn P.EDInstance{..} = +-- case edInstanceClassName of +-- P.Qualified (P.ByModuleName classModule) className -> +-- Just (IdeInstance mn +-- edInstanceName +-- edInstanceTypes +-- edInstanceConstraints, classModule, className) +-- _ -> Nothing +-- extractInstances _ _ = Nothing +-- +-- go +-- :: (IdeInstance, P.ModuleName, P.ProperName 'P.ClassName) +-- -> ModuleMap [IdeDeclarationAnn] +-- -> ModuleMap [IdeDeclarationAnn] +-- go (ideInstance, classModule, className) acc' = +-- let +-- matchTC = +-- anyOf (idaDeclaration . _IdeDeclTypeClass . ideTCName) (== className) +-- updateDeclaration = +-- mapIf matchTC (idaDeclaration +-- . _IdeDeclTypeClass +-- . ideTCInstances +-- %~ (ideInstance :)) +-- in +-- acc' & ix classModule %~ updateDeclaration +-- +-- resolveOperators +-- :: ModuleMap [IdeDeclarationAnn] +-- -> ModuleMap [IdeDeclarationAnn] +-- resolveOperators modules = +-- map (resolveOperatorsForModule modules) modules +-- +-- -- | Looks up the types and kinds for operators and assigns them to their +-- -- declarations +-- resolveOperatorsForModule +-- :: ModuleMap [IdeDeclarationAnn] +-- -> [IdeDeclarationAnn] +-- -> [IdeDeclarationAnn] +-- resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator) +-- where +-- getDeclarations :: P.ModuleName -> [IdeDeclaration] +-- getDeclarations moduleName = +-- Map.lookup moduleName modules +-- & foldMap (map discardAnn) +-- +-- resolveOperator (IdeDeclValueOperator op) +-- | (P.Qualified (P.ByModuleName mn) (Left ident)) <- op ^. ideValueOpAlias = +-- let t = getDeclarations mn +-- & mapMaybe (preview _IdeDeclValue) +-- & filter (anyOf ideValueIdent (== ident)) +-- & map (view ideValueType) +-- & listToMaybe +-- in IdeDeclValueOperator (op & ideValueOpType .~ t) +-- | (P.Qualified (P.ByModuleName mn) (Right dtor)) <- op ^. ideValueOpAlias = +-- let t = getDeclarations mn +-- & mapMaybe (preview _IdeDeclDataConstructor) +-- & filter (anyOf ideDtorName (== dtor)) +-- & map (view ideDtorType) +-- & listToMaybe +-- in IdeDeclValueOperator (op & ideValueOpType .~ t) +-- resolveOperator (IdeDeclTypeOperator op) +-- | P.Qualified (P.ByModuleName mn) properName <- op ^. ideTypeOpAlias = +-- let k = getDeclarations mn +-- & mapMaybe (preview _IdeDeclType) +-- & filter (anyOf ideTypeName (== properName)) +-- & map (view ideTypeKind) +-- & listToMaybe +-- in IdeDeclTypeOperator (op & ideTypeOpKind .~ k) +-- resolveOperator x = x +-- +-- +-- mapIf :: Functor f => (b -> Bool) -> (b -> b) -> f b -> f b +-- mapIf p f = map (\x -> if p x then f x else x) +-- +-- resolveDataConstructorsForModule +-- :: [IdeDeclarationAnn] +-- -> [IdeDeclarationAnn] +-- resolveDataConstructorsForModule decls = +-- map (idaDeclaration %~ resolveDataConstructors) decls +-- where +-- resolveDataConstructors :: IdeDeclaration -> IdeDeclaration +-- resolveDataConstructors decl = case decl of +-- IdeDeclType ty -> +-- IdeDeclType (ty & ideTypeDtors .~ fromMaybe [] (Map.lookup (ty ^. ideTypeName) dtors)) +-- _ -> +-- decl +-- +-- dtors = +-- decls +-- & mapMaybe (preview (idaDeclaration . _IdeDeclDataConstructor)) +-- & foldr (\(IdeDataConstructor name typeName type') -> +-- Map.insertWith (<>) typeName [(name, type')]) Map.empty diff --git a/src/Language/PureScript/Make/IdeCache.hs b/src/Language/PureScript/Make/IdeCache.hs index 592330d280..4a76d18ff2 100644 --- a/src/Language/PureScript/Make/IdeCache.hs +++ b/src/Language/PureScript/Make/IdeCache.hs @@ -2,7 +2,6 @@ module Language.PureScript.Make.IdeCache where import Prelude -import Language.PureScript.Ide.ToI (toI) import Language.PureScript.Ide.ToIde (toIdeDeclarationAnn) import Database.SQLite.Simple (NamedParam(..)) import Database.SQLite.Simple qualified as SQLite @@ -25,7 +24,7 @@ import Language.PureScript.Ide.Util (identifierFromIdeDeclaration, discardAnn, n import Data.Function ((&)) import Data.Bifunctor (first) import Data.Text (Text) -import Language.PureScript.Ide.Types (Annotation(..), idaDeclaration, declarationType, IdeDeclarationAnn (_idaAnnotation)) +import Language.PureScript.Ide.Types (Annotation(..), idaDeclaration, declarationType, IdeDeclarationAnn (_idaAnnotation), IdeNamespace (IdeNSValue, IdeNSType)) import Language.PureScript.Docs.Types (Declaration(declChildren)) import Language.PureScript.Docs.Render (renderDeclaration) import Language.PureScript.Docs.AsMarkdown (codeToString, declAsMarkdown, runDocs) @@ -33,12 +32,14 @@ import Codec.Serialise (serialise) import Data.Aeson (encode) import Debug.Trace qualified as Debug import Language.PureScript.AST.Declarations (Module) +import Language.PureScript.Ide.Filter.Declaration (DeclarationType (..)) +import Data.Aeson qualified as Aeson sqliteExtern :: (MonadIO m) => FilePath -> Module -> Docs.Module -> ExternsFile -> m () -sqliteExtern outputDir m docs extern = liftIO $ do +sqliteExtern outputDir m docs extern = liftIO $ do conn <- SQLite.open db withRetry $ SQLite.executeNamed conn - "INSERT INTO modules (module_name, comment, extern, dec) VALUES (:module_name, :docs, :extern, :dec)" + "INSERT INTO modules (module_name, comment, extern, dec) VALUES (:module_name, :docs, :extern, :dec)" [ ":module_name" := runModuleName ( efModuleName extern ) , ":docs" := Docs.modComments docs , ":extern" := Serialise.serialise extern @@ -51,8 +52,6 @@ sqliteExtern outputDir m docs extern = liftIO $ do , ":dependency" := runModuleName (eiModule i) ]) - toI - for_ (toIdeDeclarationAnn m extern) (\ideDeclaration -> do withRetry $ SQLite.executeNamed conn ("INSERT INTO ide_declarations (module_name, name, namespace, declaration_type, span, declaration) " <> @@ -67,25 +66,50 @@ sqliteExtern outputDir m docs extern = liftIO $ do ]) for_ (Docs.modDeclarations docs) (\d -> do - withRetry $ SQLite.executeNamed conn "INSERT INTO declarations (module_name, name, span, type, docs, declaration) VALUES (:module_name, :name, :span, :type, :docs, :declaration)" + withRetry $ SQLite.executeNamed conn + ("INSERT INTO declarations (module_name, name, namespace, declaration_type, span, type, docs, declaration) " <> + "VALUES (:module_name, :name, :namespace, :declaration_type, :span, :type, :docs, :declaration)" + ) [ ":module_name" := runModuleName (efModuleName extern) , ":name" := Docs.declTitle d - , ":span" := serialise (Docs.declSourceSpan d) + , ":namespace" := toIdeNamespace d + , ":declaration_type" := toDeclarationType d + , ":span" := Aeson.encode (Docs.declSourceSpan d) , ":docs" := Docs.declComments d , ":type" := runDocs (declAsMarkdown d) , ":declaration" := show d ] + for_ (declChildren d) $ \ch -> do - withRetry $ SQLite.executeNamed conn "INSERT INTO declarations (module_name, name, span, docs, declaration) VALUES (:module_name, :name, :span, :docs, :declaration)" + withRetry $ SQLite.executeNamed conn + ("INSERT INTO declarations (module_name, name, span, docs, declaration) " <> + "VALUES (:module_name, :name, :span, :docs, :declaration)") [ ":module_name" := runModuleName (efModuleName extern) , ":name" := Docs.cdeclTitle ch - , ":span" := serialise (Docs.declSourceSpan d) + , ":span" := Aeson.encode (Docs.declSourceSpan d) , ":docs" := Docs.cdeclComments ch , ":declaration" := show d ] ) + + for_ (Docs.modReExports docs) $ \rexport -> do + for_ (snd rexport) $ \d -> do + withRetry $ SQLite.executeNamed conn + ("INSERT INTO declarations (module_name, name, rexported_from, declaration_type, span, type, docs, declaration)" <> + "VALUES (:module_name, :name, :rexported_from, :declaration_type, :span, :type, :docs, :declaration)" + ) + [ ":module_name" := runModuleName (efModuleName extern) + , ":name" := Docs.declTitle d + , ":rexported_from" := ("HOLAS" :: Text) --runModuleName (Docs.ignorePackage (fst rexport)) + , ":declaration_type" := toDeclarationType d + , ":span" := Aeson.encode (Docs.declSourceSpan d) + , ":docs" := Docs.declComments d + , ":type" := runDocs (declAsMarkdown d) + , ":declaration" := show d + ] + SQLite.close conn return () where @@ -93,7 +117,7 @@ sqliteExtern outputDir m docs extern = liftIO $ do convertDecl :: P.ExternsDeclaration -> Text.Text -convertDecl = \case +convertDecl = \case P.EDType{..} -> runProperName edTypeName P.EDDataConstructor{..} -> runProperName edDataCtorName P.EDValue{..} -> runIdent edValueName @@ -107,11 +131,12 @@ withRetry :: IO () -> IO () withRetry op = do r <- try op case r of - Left (SQLite.SQLError SQLite.ErrorBusy _ _) -> do + Left (SQLite.SQLError SQLite.ErrorBusy _ _) -> do threadDelay 50 withRetry op return () - Left _ -> do + Left e -> do + Debug.traceM $ show e return () Right qr -> return qr @@ -126,9 +151,35 @@ sqliteInit outputDir = liftIO $ do withRetry $ SQLite.execute_ conn "pragma journal_mode=wal" withRetry $ SQLite.execute_ conn "create table if not exists modules (module_name text primary key, comment text, extern blob, dec text, unique (module_name) on conflict replace)" withRetry $ SQLite.execute_ conn "create table if not exists dependencies (id integer primary key, module_name text not null, dependency text not null, unique (module_name, dependency) on conflict ignore)" - withRetry $ SQLite.execute_ conn "create table if not exists declarations (module_name text, name text not null, span blob, type text, docs text, declaration text not null)" - withRetry $ SQLite.execute_ conn "create index dm on declarations(module_name); create index dn on declarations(name);" + + withRetry $ SQLite.execute_ conn $ SQLite.Query $ Text.pack $ unlines + [ "create table if not exists declarations" + , "( module_name text" + , ", name text not null" + , ", namespace text" + , ", rexported_from text" + , ", span text" + , ", declaration_type text" + , ", type text" + , ", docs text" + , ", declaration text not null" + , ")" + ] + + withRetry $ SQLite.execute_ conn "create index if not exists dm on declarations(module_name); create index dn on declarations(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)" SQLite.close conn where db = outputDir "cache.db" + +toDeclarationType :: Declaration -> DeclarationType +toDeclarationType (Docs.Declaration _ _ _ _ (Docs.ValueDeclaration _) _) = Value +toDeclarationType (Docs.Declaration _ _ _ _ (Docs.DataDeclaration _ _ _) _) = Type +toDeclarationType (Docs.Declaration _ _ _ _ _ _ ) = Value + + +toIdeNamespace :: Declaration -> IdeNamespace +toIdeNamespace (Docs.Declaration _ _ _ _ declInfo _) = case Docs.declInfoNamespace declInfo of + Docs.ValueLevel -> IdeNSValue + Docs.TypeLevel -> IdeNSType From 8874857e76bc2dc549014aa3314fcb8d00e1ecb3 Mon Sep 17 00:00:00 2001 From: seastian Date: Wed, 25 Sep 2024 18:32:54 +0200 Subject: [PATCH 23/38] wip --- src/Language/PureScript/Make/IdeCache.hs | 30 +++++++++++++++--------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/Make/IdeCache.hs b/src/Language/PureScript/Make/IdeCache.hs index 4a76d18ff2..a1fb613c3a 100644 --- a/src/Language/PureScript/Make/IdeCache.hs +++ b/src/Language/PureScript/Make/IdeCache.hs @@ -149,20 +149,28 @@ sqliteInit outputDir = liftIO $ do createParentDirectory db conn <- SQLite.open db withRetry $ SQLite.execute_ conn "pragma journal_mode=wal" - withRetry $ SQLite.execute_ conn "create table if not exists modules (module_name text primary key, comment text, extern blob, dec text, unique (module_name) on conflict replace)" + withRetry $ SQLite.execute_ conn $ SQLite.Query $ Text.pack $ unlines + [ "create table if not exists modules (" + , " module_name text primary key," + , " comment text," + , " extern blob," + , " dec text," + , " unique (module_name) on conflict replace" + , ")" + ] withRetry $ SQLite.execute_ conn "create table if not exists dependencies (id integer primary key, module_name text not null, dependency text not null, unique (module_name, dependency) on conflict ignore)" withRetry $ SQLite.execute_ conn $ SQLite.Query $ Text.pack $ unlines - [ "create table if not exists declarations" - , "( module_name text" - , ", name text not null" - , ", namespace text" - , ", rexported_from text" - , ", span text" - , ", declaration_type text" - , ", type text" - , ", docs text" - , ", declaration text not null" + [ "create table if not exists declarations (" + , " module_name text," + , " name text not null," + , " namespace text," + , " rexported_from text," + , " span text," + , " declaration_type text," + , " type text," + , " docs text," + , " declaration text not null" , ")" ] From 694b21bd97f050e1caab9c2dbdff90f3684a9b4a Mon Sep 17 00:00:00 2001 From: seastian Date: Wed, 25 Sep 2024 18:59:45 +0200 Subject: [PATCH 24/38] foreign keys --- src/Language/PureScript/Make/IdeCache.hs | 45 ++++++++++++++++-------- 1 file changed, 31 insertions(+), 14 deletions(-) diff --git a/src/Language/PureScript/Make/IdeCache.hs b/src/Language/PureScript/Make/IdeCache.hs index a1fb613c3a..175c6fb2e8 100644 --- a/src/Language/PureScript/Make/IdeCache.hs +++ b/src/Language/PureScript/Make/IdeCache.hs @@ -38,8 +38,16 @@ import Data.Aeson qualified as Aeson sqliteExtern :: (MonadIO m) => FilePath -> Module -> Docs.Module -> ExternsFile -> m () sqliteExtern outputDir m docs extern = liftIO $ do conn <- SQLite.open db + + withRetry $ SQLite.execute_ conn "pragma foreign_keys = ON;" + + withRetry $ SQLite.executeNamed conn + "delete from modules where module_name = :module_name" + [ ":module_name" := runModuleName ( efModuleName extern ) + ] + withRetry $ SQLite.executeNamed conn - "INSERT INTO modules (module_name, comment, extern, dec) VALUES (:module_name, :docs, :extern, :dec)" + "insert into modules (module_name, comment, extern, dec) values (:module_name, :docs, :extern, :dec)" [ ":module_name" := runModuleName ( efModuleName extern ) , ":docs" := Docs.modComments docs , ":extern" := Serialise.serialise extern @@ -47,15 +55,15 @@ sqliteExtern outputDir m docs extern = liftIO $ do ] for_ (efImports extern) (\i -> do - withRetry $ SQLite.executeNamed conn "INSERT INTO dependencies (module_name, dependency) VALUES (:module_name, :dependency)" + withRetry $ SQLite.executeNamed conn "insert into dependencies (module_name, dependency) values (:module_name, :dependency)" [ ":module_name" := runModuleName (efModuleName extern ) , ":dependency" := runModuleName (eiModule i) ]) for_ (toIdeDeclarationAnn m extern) (\ideDeclaration -> do withRetry $ SQLite.executeNamed conn - ("INSERT INTO ide_declarations (module_name, name, namespace, declaration_type, span, declaration) " <> - "VALUES (:module_name, :name, :namespace, :declaration_type, :span, :declaration)" + ("insert into ide_declarations (module_name, name, namespace, declaration_type, span, declaration) " <> + "values (:module_name, :name, :namespace, :declaration_type, :span, :declaration)" ) [ ":module_name" := runModuleName (efModuleName extern ) , ":name" := identifierFromIdeDeclaration (discardAnn ideDeclaration) @@ -67,8 +75,8 @@ sqliteExtern outputDir m docs extern = liftIO $ do for_ (Docs.modDeclarations docs) (\d -> do withRetry $ SQLite.executeNamed conn - ("INSERT INTO declarations (module_name, name, namespace, declaration_type, span, type, docs, declaration) " <> - "VALUES (:module_name, :name, :namespace, :declaration_type, :span, :type, :docs, :declaration)" + ("insert into declarations (module_name, name, namespace, declaration_type, span, type, docs, declaration) " <> + "values (:module_name, :name, :namespace, :declaration_type, :span, :type, :docs, :declaration)" ) [ ":module_name" := runModuleName (efModuleName extern) , ":name" := Docs.declTitle d @@ -83,8 +91,8 @@ sqliteExtern outputDir m docs extern = liftIO $ do for_ (declChildren d) $ \ch -> do withRetry $ SQLite.executeNamed conn - ("INSERT INTO declarations (module_name, name, span, docs, declaration) " <> - "VALUES (:module_name, :name, :span, :docs, :declaration)") + ("insert into declarations (module_name, name, span, docs, declaration) " <> + "values (:module_name, :name, :span, :docs, :declaration)") [ ":module_name" := runModuleName (efModuleName extern) , ":name" := Docs.cdeclTitle ch , ":span" := Aeson.encode (Docs.declSourceSpan d) @@ -97,8 +105,8 @@ sqliteExtern outputDir m docs extern = liftIO $ do for_ (Docs.modReExports docs) $ \rexport -> do for_ (snd rexport) $ \d -> do withRetry $ SQLite.executeNamed conn - ("INSERT INTO declarations (module_name, name, rexported_from, declaration_type, span, type, docs, declaration)" <> - "VALUES (:module_name, :name, :rexported_from, :declaration_type, :span, :type, :docs, :declaration)" + ("insert into declarations (module_name, name, rexported_from, declaration_type, span, type, docs, declaration)" <> + "values (:module_name, :name, :rexported_from, :declaration_type, :span, :type, :docs, :declaration)" ) [ ":module_name" := runModuleName (efModuleName extern) , ":name" := Docs.declTitle d @@ -148,7 +156,8 @@ sqliteInit :: (MonadIO m) => FilePath -> m () sqliteInit outputDir = liftIO $ do createParentDirectory db conn <- SQLite.open db - withRetry $ SQLite.execute_ conn "pragma journal_mode=wal" + withRetry $ SQLite.execute_ conn "pragma journal_mode=wal;" + withRetry $ SQLite.execute_ conn "pragma foreign_keys = ON;" withRetry $ SQLite.execute_ conn $ SQLite.Query $ Text.pack $ unlines [ "create table if not exists modules (" , " module_name text primary key," @@ -158,11 +167,18 @@ sqliteInit outputDir = liftIO $ do , " unique (module_name) on conflict replace" , ")" ] - withRetry $ SQLite.execute_ conn "create table if not exists dependencies (id integer primary key, module_name text not null, dependency text not null, unique (module_name, dependency) on conflict ignore)" + + withRetry $ SQLite.execute_ conn $ SQLite.Query $ Text.pack $ unlines + [ "create table if not exists dependencies (" + , " module_name text not null references modules(module_name) on delete cascade," + , " dependency text not null," + , " unique (module_name, dependency) on conflict ignore" + , ")" + ] withRetry $ SQLite.execute_ conn $ SQLite.Query $ Text.pack $ unlines [ "create table if not exists declarations (" - , " module_name text," + , " module_name text references modules(module_name) on delete cascade," , " name text not null," , " namespace text," , " rexported_from text," @@ -174,7 +190,8 @@ sqliteInit outputDir = liftIO $ do , ")" ] - withRetry $ SQLite.execute_ conn "create index if not exists dm on declarations(module_name); create index dn on declarations(name);" + 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 table if not exists ide_declarations (module_name text, name text, namespace text, declaration_type text, span blob, declaration blob)" SQLite.close conn From 1f464daf9db2315aeef18d2a66b40d8d92bfddcb Mon Sep 17 00:00:00 2001 From: seastian Date: Wed, 25 Sep 2024 19:18:24 +0200 Subject: [PATCH 25/38] wip --- src/Language/PureScript/Make/IdeCache.hs | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/Make/IdeCache.hs b/src/Language/PureScript/Make/IdeCache.hs index 175c6fb2e8..4126791844 100644 --- a/src/Language/PureScript/Make/IdeCache.hs +++ b/src/Language/PureScript/Make/IdeCache.hs @@ -91,10 +91,11 @@ sqliteExtern outputDir m docs extern = liftIO $ do for_ (declChildren d) $ \ch -> do withRetry $ SQLite.executeNamed conn - ("insert into declarations (module_name, name, span, docs, declaration) " <> - "values (:module_name, :name, :span, :docs, :declaration)") + ("insert into declarations (module_name, name, namespace, span, docs, declaration) " <> + "values (:module_name, :name, :namespace, :span, :docs, :declaration)") [ ":module_name" := runModuleName (efModuleName extern) , ":name" := Docs.cdeclTitle ch + , ":namespace" := childDeclInfoNamespaceIde (Docs.cdeclInfo ch) , ":span" := Aeson.encode (Docs.declSourceSpan d) , ":docs" := Docs.cdeclComments ch , ":declaration" := show d @@ -181,11 +182,11 @@ sqliteInit outputDir = liftIO $ do , " module_name text references modules(module_name) on delete cascade," , " name text not null," , " namespace text," - , " rexported_from text," - , " span text," , " declaration_type text," + , " rexported_from text," , " type text," , " docs text," + , " span text," , " declaration text not null" , ")" ] @@ -203,8 +204,14 @@ toDeclarationType (Docs.Declaration _ _ _ _ (Docs.ValueDeclaration _) _) = Value toDeclarationType (Docs.Declaration _ _ _ _ (Docs.DataDeclaration _ _ _) _) = Type toDeclarationType (Docs.Declaration _ _ _ _ _ _ ) = Value +toIdeN :: Docs.Namespace -> IdeNamespace +toIdeN Docs.ValueLevel = IdeNSValue +toIdeN Docs.TypeLevel = IdeNSType toIdeNamespace :: Declaration -> IdeNamespace toIdeNamespace (Docs.Declaration _ _ _ _ declInfo _) = case Docs.declInfoNamespace declInfo of Docs.ValueLevel -> IdeNSValue Docs.TypeLevel -> IdeNSType + +childDeclInfoNamespaceIde :: Docs.ChildDeclarationInfo -> IdeNamespace +childDeclInfoNamespaceIde = toIdeN . Docs.childDeclInfoNamespace From e38460491f7c3ae0ef1648a43ca4f80a5f435aab Mon Sep 17 00:00:00 2001 From: seastian Date: Thu, 26 Sep 2024 09:21:28 +0200 Subject: [PATCH 26/38] 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" From 944982af336d00cdd49a36fec8693f234ad13a9b Mon Sep 17 00:00:00 2001 From: seastian Date: Thu, 26 Sep 2024 10:24:40 +0200 Subject: [PATCH 27/38] include self --- src/Language/PureScript/Ide.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 3eb92f3145..dc79676e62 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -101,9 +101,9 @@ handleCommand c = case c of MultilineTextResult <$> CS.addClause l wca FindUsages moduleName ident namespace -> do r :: [Only Lazy.ByteString] <- runQuery $ unlines - [ "select a.span" + [ "select distinct a.span" , "from dependencies d join asts a on d.module_name = a.module_name" - , "where d.dependency = '" <> runModuleName moduleName <> "' and a.name = '" <> ident <> "'" + , "where (d.dependency = '" <> runModuleName moduleName <> "' or d.module_name = '" <> runModuleName moduleName <> "') and a.name = '" <> ident <> "'" ] pure $ UsagesResult (mapMaybe (\(Only span) -> Aeson.decode span) r) From 7a89afb1451abd18a526588a6a866dc1ab010aa2 Mon Sep 17 00:00:00 2001 From: seastian Date: Thu, 26 Sep 2024 14:19:17 +0200 Subject: [PATCH 28/38] idxs --- src/Language/PureScript/Make/IdeCache.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Language/PureScript/Make/IdeCache.hs b/src/Language/PureScript/Make/IdeCache.hs index a95e65d3f2..a0c1a0b27e 100644 --- a/src/Language/PureScript/Make/IdeCache.hs +++ b/src/Language/PureScript/Make/IdeCache.hs @@ -228,6 +228,9 @@ sqliteInit outputDir = liftIO $ do 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 index if not exists ide_declarations_name_idx on ide_declarations(name);" + withRetry $ SQLite.execute_ conn "create index if not exists ide_declarations_module_name_idx on ide_declarations(module_name);" + 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 From d4fedb68d16a64c23c2c02539d4da13e5542dd2a Mon Sep 17 00:00:00 2001 From: seastian Date: Sat, 28 Sep 2024 15:42:06 +0200 Subject: [PATCH 29/38] reexports --- src/Language/PureScript/Ide.hs | 15 +++++++++------ src/Language/PureScript/Make/IdeCache.hs | 23 +++++++++++++++++++++-- 2 files changed, 30 insertions(+), 8 deletions(-) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index dc79676e62..9214d2e7a8 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -162,17 +162,20 @@ findDeclarations findDeclarations filters currentModule completionOptions = do rows :: [(Text, Lazy.ByteString)] <- runQuery $ "select module_name, declaration " <> - "from ide_declarations where " <> + "from ide_declarations id where " <> T.intercalate " and " ( mapMaybe (\case F.Filter (Left modules) -> - Just $ "module_name in (" <> T.intercalate "," (toList modules <&> runModuleName <&> \m -> "'" <> m <> "'") <> ")" - F.Filter (Right (F.Prefix f)) -> Just $ "name glob '" <> f <> "*'" - F.Filter (Right (F.Exact f)) -> Just $ "name glob '" <> f <> "'" + 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 $ "namespace in (" <> T.intercalate "," (toList namespaces <&> \n -> "'" <> toText n <> "'") <> ")" + Just $ "id.namespace in (" <> T.intercalate "," (toList namespaces <&> \n -> "'" <> toText n <> "'") <> ")" F.Filter (Right (F.DeclType dt)) -> - Just $ "namespace in (" <> T.intercalate "," (toList dt <&> \t -> "'" <> declarationTypeToText t <> "'") <> ")" + Just $ "id.namespace in (" <> T.intercalate "," (toList dt <&> \t -> "'" <> declarationTypeToText t <> "'") <> ")" F.Filter _ -> Nothing) filters) <> foldMap (\maxResults -> " limit " <> show maxResults ) (coMaxResults =<< completionOptions) diff --git a/src/Language/PureScript/Make/IdeCache.hs b/src/Language/PureScript/Make/IdeCache.hs index a0c1a0b27e..124b80ad3e 100644 --- a/src/Language/PureScript/Make/IdeCache.hs +++ b/src/Language/PureScript/Make/IdeCache.hs @@ -31,7 +31,7 @@ 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, Expr (Var), getModuleDeclarations) +import Language.PureScript.AST.Declarations (Module, Expr (Var), getModuleDeclarations, DeclarationRef (..), ExportSource (..)) import Language.PureScript.Ide.Filter.Declaration (DeclarationType (..)) import Data.Aeson qualified as Aeson import Language.PureScript.AST.Traversals (everywhereOnValuesM) @@ -41,7 +41,7 @@ sqliteExtern :: (MonadIO m) => FilePath -> Module -> Docs.Module -> ExternsFile sqliteExtern outputDir m docs extern = liftIO $ do conn <- SQLite.open db - -- Debug.traceM $ show m + Debug.traceM $ show extern let (doDecl, _, _) = everywhereOnValuesM (pure . identity) (\expr -> case expr of Var ss i -> do @@ -77,6 +77,16 @@ sqliteExtern outputDir m docs extern = liftIO $ do for_ (getModuleDeclarations m) (\d -> doDecl d) + for_ (efExports extern) (\case + ReExportRef _ (ExportSource _ definedIn) (ValueRef _ (Ident i)) -> do + withRetry $ SQLite.executeNamed conn "insert into exports (module_name, name, defined_in, declaration_type) values (:module_name, :name, :defined_in, 'value')" + [ ":module_name" := runModuleName (efModuleName extern ) + , ":name" := i + , ":defined_in" := runModuleName definedIn + ] + _ -> pure () + ) + for_ (efImports extern) (\i -> do withRetry $ SQLite.executeNamed conn "insert into dependencies (module_name, dependency) values (:module_name, :dependency)" [ ":module_name" := runModuleName (efModuleName extern ) @@ -222,6 +232,15 @@ sqliteInit outputDir = liftIO $ do , ")" ] + withRetry $ SQLite.execute_ conn $ SQLite.Query $ Text.pack $ unlines + [ "create table if not exists exports (" + , "module_name text references modules(module_name) on delete cascade," + , "name text not null," + , "defined_in text," + , "declaration_type 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);" From c5326034956066d2e786ce9312a6b4ac022167f8 Mon Sep 17 00:00:00 2001 From: seastian Date: Sat, 28 Sep 2024 17:01:36 +0200 Subject: [PATCH 30/38] type class exports --- src/Language/PureScript/Make/IdeCache.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Make/IdeCache.hs b/src/Language/PureScript/Make/IdeCache.hs index 124b80ad3e..3e279dbc68 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, disqualify, Ident (..)) +import Language.PureScript.Names (runModuleName, ProperName (runProperName), runIdent, disqualify, Ident (..), OpName (OpName)) import Language.PureScript.Externs (ExternsFile(..), ExternsImport(..)) import Data.Foldable (for_) import Control.Monad.IO.Class (MonadIO (liftIO)) @@ -36,6 +36,7 @@ import Language.PureScript.Ide.Filter.Declaration (DeclarationType (..)) import Data.Aeson qualified as Aeson import Language.PureScript.AST.Traversals (everywhereOnValuesM) import Protolude (identity) +import Language.PureScript.Names qualified as T sqliteExtern :: (MonadIO m) => FilePath -> Module -> Docs.Module -> ExternsFile -> m () sqliteExtern outputDir m docs extern = liftIO $ do @@ -84,6 +85,18 @@ sqliteExtern outputDir m docs extern = liftIO $ do , ":name" := i , ":defined_in" := runModuleName definedIn ] + ReExportRef _ (ExportSource _ definedIn) (ValueOpRef _ (OpName n)) -> do + withRetry $ SQLite.executeNamed conn "insert into exports (module_name, name, defined_in, declaration_type) values (:module_name, :name, :defined_in, 'valueoperator')" + [ ":module_name" := runModuleName (efModuleName extern ) + , ":name" := n + , ":defined_in" := runModuleName definedIn + ] + ReExportRef _ (ExportSource _ definedIn) (TypeClassRef _ (T.ProperName n)) -> do + withRetry $ SQLite.executeNamed conn "insert into exports (module_name, name, defined_in, declaration_type) values (:module_name, :name, :defined_in, 'typeclass')" + [ ":module_name" := runModuleName (efModuleName extern ) + , ":name" := n + , ":defined_in" := runModuleName definedIn + ] _ -> pure () ) From bb0cf2145441341a2e8b6cb1ba2d0e3e18e52c38 Mon Sep 17 00:00:00 2001 From: seastian Date: Mon, 30 Sep 2024 09:16:28 +0200 Subject: [PATCH 31/38] exports --- src/Language/PureScript/Make.hs | 2 ++ src/Language/PureScript/Make/IdeCache.hs | 13 ++++++++++--- 2 files changed, 12 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 4a7ce34701..06868339bd 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -53,6 +53,7 @@ import Language.PureScript.Make.Monad as Monad import Language.PureScript.CoreFn qualified as CF import System.Directory (doesFileExist) import System.FilePath (replaceExtension) +import Debug.Trace qualified as Debug -- | Rebuild a single module. -- @@ -97,6 +98,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ (desugared, (exEnv', usedImports)) <- runStateT (desugar externs withPrim) (exEnv, mempty) let modulesExports = (\(_, _, exports) -> exports) <$> exEnv' (checked, CheckState{..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env + -- Debug.traceM $ show checkEnv let usedImports' = foldl' (flip $ \(fromModuleName, newtypeCtorName) -> M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName) usedImports checkConstructorImportsForCoercible -- Imports cannot be linted before type checking because we need to diff --git a/src/Language/PureScript/Make/IdeCache.hs b/src/Language/PureScript/Make/IdeCache.hs index 3e279dbc68..670430bc98 100644 --- a/src/Language/PureScript/Make/IdeCache.hs +++ b/src/Language/PureScript/Make/IdeCache.hs @@ -42,7 +42,7 @@ sqliteExtern :: (MonadIO m) => FilePath -> Module -> Docs.Module -> ExternsFile sqliteExtern outputDir m docs extern = liftIO $ do conn <- SQLite.open db - Debug.traceM $ show extern + -- Debug.traceM $ show extern let (doDecl, _, _) = everywhereOnValuesM (pure . identity) (\expr -> case expr of Var ss i -> do @@ -260,10 +260,17 @@ sqliteInit outputDir = liftIO $ do 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 index if not exists ide_declarations_name_idx on ide_declarations(name);" - withRetry $ SQLite.execute_ conn "create index if not exists ide_declarations_module_name_idx on ide_declarations(module_name);" + + withRetry $ SQLite.execute_ conn "create index if not exists exports_name_idx on exports(name);" + withRetry $ SQLite.execute_ conn "create index if not exists exports_module_name_idx on exports(module_name);" + + withRetry $ SQLite.execute_ conn "create index if not exists exports_defined_in_id on exports(defined_in);" + withRetry $ SQLite.execute_ conn "create index if not exists exports_declaration_type_idx on exports(declaration_type);" 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)" + + withRetry $ SQLite.execute_ conn "create index if not exists ide_declarations_name_idx on ide_declarations(name);" + withRetry $ SQLite.execute_ conn "create index if not exists ide_declarations_module_name_idx on ide_declarations(module_name);" SQLite.close conn where db = outputDir "cache.db" From df1b0304cb168f61bf1e189f6b26c6b08fa1f310 Mon Sep 17 00:00:00 2001 From: seastian Date: Tue, 1 Oct 2024 22:13:30 +0200 Subject: [PATCH 32/38] matchers --- src/Language/PureScript/Ide.hs | 20 +++++++++++++------- src/Language/PureScript/Ide/Command.hs | 6 +++--- src/Language/PureScript/Ide/Matcher.hs | 21 +++++++++++++++++++++ 3 files changed, 37 insertions(+), 10 deletions(-) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 9214d2e7a8..ef3b9a27f7 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -33,7 +33,7 @@ import Language.PureScript.Ide.Externs (readExternFile) 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) @@ -84,8 +84,12 @@ handleCommand c = case c of -- loadModulesSync modules Type search filters currentModule -> findDeclarations (F.Filter (Right $ F.Exact search) : filters) currentModule Nothing - Complete filters matcher currentModule complOptions -> - findDeclarations filters currentModule (Just complOptions) + Complete filters matcher currentModule complOptions -> do + Debug.traceM $ show matcher + + 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 @@ -162,12 +166,12 @@ findDeclarations findDeclarations filters currentModule completionOptions = do rows :: [(Text, Lazy.ByteString)] <- runQuery $ "select module_name, declaration " <> - "from ide_declarations id where " <> - T.intercalate " and " ( + "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 <> "'") <> + 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 <> "*'" @@ -177,7 +181,9 @@ findDeclarations filters currentModule completionOptions = do F.Filter (Right (F.DeclType dt)) -> Just $ "id.namespace in (" <> T.intercalate "," (toList dt <&> \t -> "'" <> declarationTypeToText t <> "'") <> ")" F.Filter _ -> Nothing) - filters) <> + filters + & \f -> if null f then " " else " where " <> T.intercalate " and " f + ) <> foldMap (\maxResults -> " limit " <> show maxResults ) (coMaxResults =<< completionOptions) let matches = rows <&> \(m, decl) -> (Match (ModuleName m, deserialise decl), []) diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index ae4b6c9d8e..b69394e709 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -24,7 +24,7 @@ import Language.PureScript qualified as P import Language.PureScript.Ide.CaseSplit (WildcardAnnotations, explicitAnnotations, noAnnotations) import Language.PureScript.Ide.Completion (CompletionOptions, defaultCompletionOptions) import Language.PureScript.Ide.Filter (Filter) -import Language.PureScript.Ide.Matcher (Matcher) +import Language.PureScript.Ide.Matcher (Matcher, Matcher') import Language.PureScript.Ide.Types (IdeDeclarationAnn, IdeNamespace) data Command @@ -37,7 +37,7 @@ data Command } | Complete { completeFilters :: [Filter] - , completeMatcher :: Matcher IdeDeclarationAnn + , completeMatcher :: Maybe Matcher' , completeCurrentModule :: Maybe P.ModuleName , completeOptions :: CompletionOptions } @@ -141,7 +141,7 @@ instance FromJSON Command where params <- o .: "params" Complete <$> params .:? "filters" .!= [] - <*> params .:? "matcher" .!= mempty + <*> params .:? "matcher" .!= Nothing <*> (fmap P.moduleNameFromString <$> params .:? "currentModule") <*> params .:? "options" .!= defaultCompletionOptions "caseSplit" -> do diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs index d77516bd32..0d33fe15d3 100644 --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -14,6 +14,7 @@ module Language.PureScript.Ide.Matcher ( Matcher + , Matcher'(..) , runMatcher -- for tests , flexMatcher @@ -35,6 +36,26 @@ type ScoredMatch a = (Match a, Double) newtype Matcher a = Matcher (Endo [Match a]) deriving (Semigroup, Monoid) +data Matcher' + = Distance { search:: Text, maximumDistance :: Int } + | Flex { search:: Text } + deriving (Show) + +instance FromJSON Matcher' where + parseJSON = withObject "matcher" $ \o -> do + (matcher :: Maybe Text) <- o .:? "matcher" + case matcher of + Just "flex" -> do + params <- o .: "params" + Flex <$> params .: "search" + Just "distance" -> do + params <- o .: "params" + Distance + <$> params .: "search" + <*> params .: "maximumDistance" + Just s -> fail ("Unknown matcher: " <> show s) + Nothing -> fail "Unknown matcher" + instance FromJSON (Matcher IdeDeclarationAnn) where parseJSON = withObject "matcher" $ \o -> do (matcher :: Maybe Text) <- o .:? "matcher" From ea08bb4a137d08df3287b76a7dbdfb76deb6f349 Mon Sep 17 00:00:00 2001 From: seastian Date: Tue, 1 Oct 2024 22:14:02 +0200 Subject: [PATCH 33/38] remove traceM --- src/Language/PureScript/Ide.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index ef3b9a27f7..2c5a12853d 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -85,7 +85,6 @@ handleCommand c = case c of Type search filters currentModule -> findDeclarations (F.Filter (Right $ F.Exact search) : filters) currentModule Nothing Complete filters matcher currentModule complOptions -> do - Debug.traceM $ show matcher findDeclarations (filters <> foldMap (\case Flex q -> [F.Filter (Right $ F.Prefix q)] From 32cbdc99038a01e7cc708f4f69a29404bfd90254 Mon Sep 17 00:00:00 2001 From: seastian Date: Sat, 5 Oct 2024 12:22:14 +0200 Subject: [PATCH 34/38] use busy timeout pragma --- src/Language/PureScript/Make/IdeCache.hs | 77 ++++++++++-------------- 1 file changed, 33 insertions(+), 44 deletions(-) diff --git a/src/Language/PureScript/Make/IdeCache.hs b/src/Language/PureScript/Make/IdeCache.hs index 670430bc98..8bd52e8a4e 100644 --- a/src/Language/PureScript/Make/IdeCache.hs +++ b/src/Language/PureScript/Make/IdeCache.hs @@ -41,6 +41,7 @@ import Language.PureScript.Names qualified as T sqliteExtern :: (MonadIO m) => FilePath -> Module -> Docs.Module -> ExternsFile -> m () sqliteExtern outputDir m docs extern = liftIO $ do conn <- SQLite.open db + SQLite.execute_ conn "pragma busy_timeout = 300000;" -- Debug.traceM $ show extern @@ -49,7 +50,7 @@ sqliteExtern outputDir m docs extern = liftIO $ do let iv = disqualify i case iv of Ident t -> do - withRetry $ SQLite.executeNamed conn + SQLite.executeNamed conn "insert into asts (module_name, name, span) values (:module_name, :name, :span)" [ ":module_name" := runModuleName ( efModuleName extern ) , ":name" := t @@ -60,15 +61,15 @@ sqliteExtern outputDir m docs extern = liftIO $ do _ -> pure expr ) (pure . identity) - withRetry $ SQLite.execute_ conn "pragma foreign_keys = ON;" + SQLite.execute_ conn "pragma foreign_keys = ON;" - withRetry $ SQLite.executeNamed conn + SQLite.executeNamed conn "delete from modules where module_name = :module_name" [ ":module_name" := runModuleName ( efModuleName extern ) ] - withRetry $ SQLite.executeNamed conn + SQLite.executeNamed conn "insert into modules (module_name, comment, extern, dec) values (:module_name, :docs, :extern, :dec)" [ ":module_name" := runModuleName ( efModuleName extern ) , ":docs" := Docs.modComments docs @@ -80,19 +81,19 @@ sqliteExtern outputDir m docs extern = liftIO $ do for_ (efExports extern) (\case ReExportRef _ (ExportSource _ definedIn) (ValueRef _ (Ident i)) -> do - withRetry $ SQLite.executeNamed conn "insert into exports (module_name, name, defined_in, declaration_type) values (:module_name, :name, :defined_in, 'value')" + SQLite.executeNamed conn "insert into exports (module_name, name, defined_in, declaration_type) values (:module_name, :name, :defined_in, 'value')" [ ":module_name" := runModuleName (efModuleName extern ) , ":name" := i , ":defined_in" := runModuleName definedIn ] ReExportRef _ (ExportSource _ definedIn) (ValueOpRef _ (OpName n)) -> do - withRetry $ SQLite.executeNamed conn "insert into exports (module_name, name, defined_in, declaration_type) values (:module_name, :name, :defined_in, 'valueoperator')" + SQLite.executeNamed conn "insert into exports (module_name, name, defined_in, declaration_type) values (:module_name, :name, :defined_in, 'valueoperator')" [ ":module_name" := runModuleName (efModuleName extern ) , ":name" := n , ":defined_in" := runModuleName definedIn ] ReExportRef _ (ExportSource _ definedIn) (TypeClassRef _ (T.ProperName n)) -> do - withRetry $ SQLite.executeNamed conn "insert into exports (module_name, name, defined_in, declaration_type) values (:module_name, :name, :defined_in, 'typeclass')" + SQLite.executeNamed conn "insert into exports (module_name, name, defined_in, declaration_type) values (:module_name, :name, :defined_in, 'typeclass')" [ ":module_name" := runModuleName (efModuleName extern ) , ":name" := n , ":defined_in" := runModuleName definedIn @@ -101,13 +102,13 @@ sqliteExtern outputDir m docs extern = liftIO $ do ) for_ (efImports extern) (\i -> do - withRetry $ SQLite.executeNamed conn "insert into dependencies (module_name, dependency) values (:module_name, :dependency)" + SQLite.executeNamed conn "insert into dependencies (module_name, dependency) values (:module_name, :dependency)" [ ":module_name" := runModuleName (efModuleName extern ) , ":dependency" := runModuleName (eiModule i) ]) for_ (toIdeDeclarationAnn m extern) (\ideDeclaration -> do - withRetry $ SQLite.executeNamed conn + SQLite.executeNamed conn ("insert into ide_declarations (module_name, name, namespace, declaration_type, span, declaration) " <> "values (:module_name, :name, :namespace, :declaration_type, :span, :declaration)" ) @@ -120,7 +121,7 @@ sqliteExtern outputDir m docs extern = liftIO $ do ]) for_ (Docs.modDeclarations docs) (\d -> do - withRetry $ SQLite.executeNamed conn + SQLite.executeNamed conn ("insert into declarations (module_name, name, namespace, declaration_type, span, type, docs, declaration) " <> "values (:module_name, :name, :namespace, :declaration_type, :span, :type, :docs, :declaration)" ) @@ -136,7 +137,7 @@ sqliteExtern outputDir m docs extern = liftIO $ do for_ (declChildren d) $ \ch -> do - withRetry $ SQLite.executeNamed conn + SQLite.executeNamed conn ("insert into declarations (module_name, name, namespace, span, docs, declaration) " <> "values (:module_name, :name, :namespace, :span, :docs, :declaration)") [ ":module_name" := runModuleName (efModuleName extern) @@ -151,7 +152,7 @@ sqliteExtern outputDir m docs extern = liftIO $ do for_ (Docs.modReExports docs) $ \rexport -> do for_ (snd rexport) $ \d -> do - withRetry $ SQLite.executeNamed conn + SQLite.executeNamed conn ("insert into declarations (module_name, name, rexported_from, declaration_type, span, type, docs, declaration)" <> "values (:module_name, :name, :rexported_from, :declaration_type, :span, :type, :docs, :declaration)" ) @@ -182,20 +183,6 @@ spanDecl :: P.ExternsDeclaration -> Text.Text spanDecl = \case _ -> "NO SPAN" -withRetry :: IO () -> IO () -withRetry op = do - r <- try op - case r of - Left (SQLite.SQLError SQLite.ErrorBusy _ _) -> do - threadDelay 50 - withRetry op - return () - Left e -> do - Debug.traceM $ show e - return () - Right qr -> return qr - - createParentDirectory :: FilePath -> IO () createParentDirectory = createDirectoryIfMissing True . takeDirectory @@ -203,9 +190,10 @@ sqliteInit :: (MonadIO m) => FilePath -> m () sqliteInit outputDir = liftIO $ do createParentDirectory db conn <- SQLite.open db - withRetry $ SQLite.execute_ conn "pragma journal_mode=wal;" - withRetry $ SQLite.execute_ conn "pragma foreign_keys = ON;" - withRetry $ SQLite.execute_ conn $ SQLite.Query $ Text.pack $ unlines + SQLite.execute_ conn "pragma journal_mode=wal;" + SQLite.execute_ conn "pragma foreign_keys = ON;" + SQLite.execute_ conn "pragma busy_timeout = 300000;" + SQLite.execute_ conn $ SQLite.Query $ Text.pack $ unlines [ "create table if not exists modules (" , " module_name text primary key," , " comment text," @@ -215,7 +203,7 @@ sqliteInit outputDir = liftIO $ do , ")" ] - withRetry $ SQLite.execute_ conn $ SQLite.Query $ Text.pack $ unlines + SQLite.execute_ conn $ SQLite.Query $ Text.pack $ unlines [ "create table if not exists dependencies (" , " module_name text not null references modules(module_name) on delete cascade," , " dependency text not null," @@ -223,7 +211,7 @@ sqliteInit outputDir = liftIO $ do , ")" ] - withRetry $ SQLite.execute_ conn $ SQLite.Query $ Text.pack $ unlines + SQLite.execute_ conn $ SQLite.Query $ Text.pack $ unlines [ "create table if not exists declarations (" , " module_name text references modules(module_name) on delete cascade," , " name text not null," @@ -237,7 +225,7 @@ sqliteInit outputDir = liftIO $ do , ")" ] - withRetry $ SQLite.execute_ conn $ SQLite.Query $ Text.pack $ unlines + 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," @@ -245,7 +233,7 @@ sqliteInit outputDir = liftIO $ do , ")" ] - withRetry $ SQLite.execute_ conn $ SQLite.Query $ Text.pack $ unlines + SQLite.execute_ conn $ SQLite.Query $ Text.pack $ unlines [ "create table if not exists exports (" , "module_name text references modules(module_name) on delete cascade," , "name text not null," @@ -254,23 +242,24 @@ sqliteInit outputDir = liftIO $ do , ")" ] - 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);" + SQLite.execute_ conn "create index if not exists dm on declarations(module_name)" + 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);" + SQLite.execute_ conn "create index if not exists asts_module_name_idx on asts(module_name);" + SQLite.execute_ conn "create index if not exists asts_name_idx on asts(name);" + + SQLite.execute_ conn "create index if not exists exports_name_idx on exports(name);" + SQLite.execute_ conn "create index if not exists exports_module_name_idx on exports(module_name);" - withRetry $ SQLite.execute_ conn "create index if not exists exports_name_idx on exports(name);" - withRetry $ SQLite.execute_ conn "create index if not exists exports_module_name_idx on exports(module_name);" + SQLite.execute_ conn "create index if not exists exports_defined_in_id on exports(defined_in);" + SQLite.execute_ conn "create index if not exists exports_declaration_type_idx on exports(declaration_type);" - withRetry $ SQLite.execute_ conn "create index if not exists exports_defined_in_id on exports(defined_in);" - withRetry $ SQLite.execute_ conn "create index if not exists exports_declaration_type_idx on exports(declaration_type);" + 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)" - 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.execute_ conn "create index if not exists ide_declarations_name_idx on ide_declarations(name);" + SQLite.execute_ conn "create index if not exists ide_declarations_module_name_idx on ide_declarations(module_name);" - withRetry $ SQLite.execute_ conn "create index if not exists ide_declarations_name_idx on ide_declarations(name);" - withRetry $ SQLite.execute_ conn "create index if not exists ide_declarations_module_name_idx on ide_declarations(module_name);" SQLite.close conn where db = outputDir "cache.db" From 846c6886520079e25bc4b110f7471b65d5b7f7e1 Mon Sep 17 00:00:00 2001 From: seastian Date: Fri, 29 Nov 2024 14:54:51 -0300 Subject: [PATCH 35/38] wip --- src/Language/PureScript/Make/IdeCache.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Make/IdeCache.hs b/src/Language/PureScript/Make/IdeCache.hs index 8bd52e8a4e..1ce9babe47 100644 --- a/src/Language/PureScript/Make/IdeCache.hs +++ b/src/Language/PureScript/Make/IdeCache.hs @@ -190,9 +190,9 @@ sqliteInit :: (MonadIO m) => FilePath -> m () sqliteInit outputDir = liftIO $ do createParentDirectory db conn <- SQLite.open db + SQLite.execute_ conn "pragma busy_timeout = 300000;" SQLite.execute_ conn "pragma journal_mode=wal;" SQLite.execute_ conn "pragma foreign_keys = ON;" - SQLite.execute_ conn "pragma busy_timeout = 300000;" SQLite.execute_ conn $ SQLite.Query $ Text.pack $ unlines [ "create table if not exists modules (" , " module_name text primary key," From 77819228e1b9a77c3660c5b1e214158ca2ecccce Mon Sep 17 00:00:00 2001 From: seastian Date: Fri, 29 Nov 2024 16:40:05 -0300 Subject: [PATCH 36/38] add qb --- app/Command/QuickBuild.hs | 248 +++++++++++++++++++++++++++ purescript.cabal | 1 + src/Language/PureScript/Ide/State.hs | 2 +- 3 files changed, 250 insertions(+), 1 deletion(-) create mode 100644 app/Command/QuickBuild.hs diff --git a/app/Command/QuickBuild.hs b/app/Command/QuickBuild.hs new file mode 100644 index 0000000000..dec0e1f4f2 --- /dev/null +++ b/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 +-- 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 diff --git a/purescript.cabal b/purescript.cabal index 1d51c57ac6..68ec3710e6 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -432,6 +432,7 @@ executable purs Command.Graph Command.Hierarchy Command.Ide + Command.QuickBuild Command.Publish Command.REPL SharedCLI diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index fb9d6b0bde..d22e3b9bf3 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -78,7 +78,7 @@ getSqliteFilePath = do runQuery :: SQLite.FromRow r => Ide m => Text -> m [r] runQuery q = do - Debug.traceM $ show q + -- Debug.traceM $ show q IdeEnvironment{..} <- ask liftIO $ query q From 5a85528ee643354319e9b30bf3aeec85ee35874b Mon Sep 17 00:00:00 2001 From: seastian Date: Fri, 29 Nov 2024 16:40:08 -0300 Subject: [PATCH 37/38] wip --- app/Main.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/app/Main.hs b/app/Main.hs index c925a4a313..9f86ee10e1 100644 --- a/app/Main.hs +++ b/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) @@ -76,6 +77,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")) From 90bf2e9958c596fcd8569796768485dc7047a94c Mon Sep 17 00:00:00 2001 From: seastian Date: Mon, 3 Feb 2025 10:37:35 -0300 Subject: [PATCH 38/38] init --- app/Command/Bundle.hs | 9 ++++++++- app/Command/Ide.hs | 5 ++++- app/Main.hs | 3 +++ src/Language/PureScript/Make/Actions.hs | 4 +--- 4 files changed, 16 insertions(+), 5 deletions(-) diff --git a/app/Command/Bundle.hs b/app/Command/Bundle.hs index 99c72312b9..bf82429b99 100644 --- a/app/Command/Bundle.hs +++ b/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" diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index 5a4669c867..38d986e3a6 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -151,7 +151,10 @@ command = Opts.helper <*> subcommands where , ideConfiguration = conf , ideCacheDbTimestamp = ts , query = \q -> SQLite.withConnection (outputPath "cache.db") - (\conn -> SQLite.query_ conn $ SQLite.Query q) + (\conn -> do + SQLite.execute_ conn "pragma busy_timeout = 30000;" + SQLite.query_ conn $ SQLite.Query q + ) } startServer port env diff --git a/app/Main.hs b/app/Main.hs index 9f86ee10e1..374fcee282 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -62,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")) diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 1e25f2a7cc..3803c54efb 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -58,7 +58,7 @@ import System.Directory (getCurrentDirectory) import System.FilePath ((), makeRelative, splitPath, normalise, splitDirectories) import System.FilePath.Posix qualified as Posix import System.IO (stderr) -import Language.PureScript.Make.IdeCache (sqliteInit, sqliteExtern) +import Language.PureScript.Make.IdeCache ( sqliteExtern) -- | Determines when to rebuild a module data RebuildPolicy @@ -143,7 +143,6 @@ readCacheDb' -- ^ The path to the output directory -> m CacheDb readCacheDb' outputDir = do - sqliteInit outputDir fromMaybe mempty <$> readJSONFile (cacheDbFile outputDir) writeCacheDb' @@ -251,7 +250,6 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = codegen ast m docs exts = do let mn = CF.moduleName m lift $ writeCborFile (outputFilename mn externsFileName) exts - lift $ sqliteInit outputDir lift $ sqliteExtern outputDir ast docs exts codegenTargets <- lift $ asks optionsCodegenTargets when (S.member CoreFn codegenTargets) $ do