diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index f5a501af75..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 @@ -138,6 +139,7 @@ command = Opts.helper <*> subcommands where conf = IdeConfiguration { confLogLevel = logLevel , confOutputPath = outputPath + , sqliteFilePath = outputPath "cache.db" , confGlobs = globs , confGlobsFromFile = globsFromFile , confGlobsExclude = globsExcluded @@ -148,6 +150,8 @@ command = Opts.helper <*> subcommands where { ideStateVar = ideState , ideConfiguration = conf , ideCacheDbTimestamp = ts + , query = \q -> SQLite.withConnection (outputPath "cache.db") + (\conn -> SQLite.query_ conn $ SQLite.Query q) } startServer port env diff --git a/purescript.cabal b/purescript.cabal index 0d32ce4814..1d51c57ac6 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 @@ -198,6 +204,7 @@ common defaults semigroups ==0.20.*, semialign >=1.2.0.1 && <1.3, sourcemap >=0.1.7 && <0.2, + sqlite-simple ==0.4.18.2, stm >=2.5.0.2 && <2.6, stringsearch >=0.3.6.6 && <0.4, template-haskell >=2.18.0.0 && <2.19, @@ -267,6 +274,8 @@ library Language.PureScript.CST.Parser Language.PureScript.CST.Positions Language.PureScript.CST.Print + Language.PureScript.Ide.ToIde + Language.PureScript.Ide.ToI Language.PureScript.CST.Traversals Language.PureScript.CST.Traversals.Type Language.PureScript.CST.Types @@ -336,6 +345,7 @@ library Language.PureScript.Make.Actions Language.PureScript.Make.BuildPlan Language.PureScript.Make.Cache + Language.PureScript.Make.IdeCache Language.PureScript.Make.Monad Language.PureScript.ModuleDependencies Language.PureScript.Names 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..2c5a12853d 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -27,22 +27,40 @@ import Language.PureScript qualified as P import Language.PureScript.Glob (toInputGlobs, PSCGlobs(..)) import Language.PureScript.Ide.CaseSplit qualified as CS import Language.PureScript.Ide.Command (Command(..), ImportCommand(..), ListType(..)) -import Language.PureScript.Ide.Completion (CompletionOptions, completionFromMatch, getCompletions, getExactCompletions, simpleExport) +import Language.PureScript.Ide.Completion (CompletionOptions (coMaxResults), completionFromMatch, getCompletions, getExactCompletions, simpleExport) import Language.PureScript.Ide.Error (IdeError(..)) import Language.PureScript.Ide.Externs (readExternFile) -import Language.PureScript.Ide.Filter (Filter) +import Language.PureScript.Ide.Filter qualified as F import Language.PureScript.Ide.Imports (parseImportsFromFile) import Language.PureScript.Ide.Imports.Actions (addImplicitImport, addImportForIdentifier, addQualifiedImport, answerRequest) -import Language.PureScript.Ide.Matcher (Matcher) +import Language.PureScript.Ide.Matcher (Matcher, Matcher' (..)) import Language.PureScript.Ide.Prim (idePrimDeclarations) import Language.PureScript.Ide.Rebuild (rebuildFileAsync, rebuildFileSync) import Language.PureScript.Ide.SourceFile (parseModulesFromFiles) -import Language.PureScript.Ide.State (getAllModules, getLoadedModulenames, insertExterns, insertModule, populateVolatileState, populateVolatileStateSync, resetIdeState) -import Language.PureScript.Ide.Types (Annotation(..), Ide, IdeConfiguration(..), IdeDeclarationAnn(..), IdeEnvironment(..), Success(..)) +import Language.PureScript.Ide.State (getAllModules, getLoadedModulenames, insertExterns, insertModule, populateVolatileState, populateVolatileStateSync, resetIdeState, getSqliteFilePath, runQuery) +import Language.PureScript.Ide.Types (Annotation(..), Ide, IdeConfiguration(..), IdeDeclarationAnn(..), IdeEnvironment(..), Success(..), Completion (..), toText, Match (..)) import Language.PureScript.Ide.Util (discardAnn, identifierFromIdeDeclaration, namespaceForDeclaration, withEmptyAnn) import Language.PureScript.Ide.Usage (findUsages) import System.Directory (getCurrentDirectory, getDirectoryContents, doesDirectoryExist, doesFileExist) import System.FilePath ((), normalise) +import Language.PureScript.Names (ModuleName(ModuleName)) +import Language.PureScript.AST.SourcePos (SourceSpan(SourceSpan)) +import Language.PureScript.Errors (SourcePos(..)) +import Database.SQLite.Simple qualified as SQLite +import Language.PureScript (cacheDbFile, runModuleName) +import Debug.Trace qualified as Debug +import Data.Maybe (catMaybes) +import Protolude (head) +import Data.Foldable (find, Foldable (toList, foldMap)) +import Data.Text qualified +import Data.Either (isLeft) +import Codec.Serialise (deserialise) +import Data.ByteString.Lazy qualified +import Database.SQLite.Simple (Only(Only)) +import Database.SQLite.Simple.ToField (ToField(..)) +import Language.PureScript.Ide.Filter.Declaration (declarationTypeToText) +import Data.ByteString.Lazy qualified as Lazy +import Data.Aeson qualified as Aeson -- | Accepts a Command and runs it against psc-ide's State. This is the main -- entry point for the server. @@ -53,23 +71,31 @@ handleCommand handleCommand c = case c of Load [] -> -- Clearing the State before populating it to avoid a space leak - resetIdeState *> findAvailableExterns >>= loadModulesAsync + pure $ TextResult "Done" + -- resetIdeState *> findAvailableExterns >>= loadModulesAsync Load modules -> - loadModulesAsync modules + pure $ TextResult "Done" + -- loadModulesAsync modules LoadSync [] -> - findAvailableExterns >>= loadModulesSync + pure $ TextResult "Done" + -- findAvailableExterns >>= loadModulesSync LoadSync modules -> - loadModulesSync modules + pure $ TextResult "Done" + -- loadModulesSync modules Type search filters currentModule -> - findType search filters currentModule - Complete filters matcher currentModule complOptions -> - findCompletions filters matcher currentModule complOptions + findDeclarations (F.Filter (Right $ F.Exact search) : filters) currentModule Nothing + Complete filters matcher currentModule complOptions -> do + + findDeclarations (filters <> foldMap (\case + Flex q -> [F.Filter (Right $ F.Prefix q)] + Distance q _ -> [F.Filter (Right $ F.Prefix q)]) matcher) currentModule (Just complOptions) + -- findCompletions' filters matcher currentModule complOptions List LoadedModules -> do logWarnN "Listing the loaded modules command is DEPRECATED, use the completion command and filter it to modules instead" - printModules + ModuleList . join <$> runQuery "select module_name from modules" List AvailableModules -> - listAvailableModules + ModuleList . join <$> runQuery "select module_name from modules" List (Imports fp) -> ImportList <$> parseImportsFromFile fp CaseSplit l b e wca t -> @@ -77,15 +103,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 distinct a.span" + , "from dependencies d join asts a on d.module_name = a.module_name" + , "where (d.dependency = '" <> runModuleName moduleName <> "' or d.module_name = '" <> runModuleName moduleName <> "') and a.name = '" <> ident <> "'" + ] + + pure $ UsagesResult (mapMaybe (\(Only span) -> Aeson.decode span) r) + + + -- Map.lookup moduleName <$> getAllModules Nothing >>= \case + -- Nothing -> throwError (GeneralError "Module not found") + -- Just decls -> do + -- case find (\d -> namespaceForDeclaration (discardAnn d) == namespace + -- && identifierFromIdeDeclaration (discardAnn d) == ident) decls of + -- Nothing -> throwError (GeneralError "Declaration not found") + -- Just declaration -> do + -- let sourceModule = fromMaybe moduleName (declaration & _idaAnnotation & _annExportedFrom) + -- UsagesResult . foldMap toList <$> findUsages (discardAnn declaration) sourceModule Import fp outfp _ (AddImplicitImport mn) -> do rs <- addImplicitImport fp mn answerRequest outfp rs @@ -111,7 +146,7 @@ handleCommand c = case c of findCompletions :: Ide m - => [Filter] + => [F.Filter] -> Matcher IdeDeclarationAnn -> Maybe P.ModuleName -> CompletionOptions @@ -121,19 +156,41 @@ findCompletions filters matcher currentModule complOptions = do let insertPrim = Map.union idePrimDeclarations pure (CompletionResult (getCompletions filters matcher complOptions (insertPrim modules))) -findType +findDeclarations :: Ide m - => Text - -> [Filter] + => [F.Filter] -> Maybe P.ModuleName + -> Maybe CompletionOptions -> m Success -findType search filters currentModule = do - modules <- getAllModules currentModule - let insertPrim = Map.union idePrimDeclarations - pure (CompletionResult (getExactCompletions search filters (insertPrim modules))) +findDeclarations filters currentModule completionOptions = do + rows :: [(Text, Lazy.ByteString)] <- runQuery $ + "select module_name, declaration " <> + "from ide_declarations id " <> + ( + mapMaybe (\case + F.Filter (Left modules) -> + Just $ "(exists (select 1 from exports e where id.module_name = e.defined_in and id.name = e.name and id.declaration_type = e.declaration_type and e.module_name in (" <> + T.intercalate "," (toList modules <&> runModuleName <&> \m -> "'" <> m <> "'") <> + "))" <> + " or " <> "id.module_name in (" <> T.intercalate "," (toList modules <&> runModuleName <&> \m -> "'" <> m <> "'") <> "))" + F.Filter (Right (F.Prefix f)) -> Just $ "id.name glob '" <> f <> "*'" + F.Filter (Right (F.Exact f)) -> Just $ "id.name glob '" <> f <> "'" + F.Filter (Right (F.Namespace namespaces)) -> + Just $ "id.namespace in (" <> T.intercalate "," (toList namespaces <&> \n -> "'" <> toText n <> "'") <> ")" + F.Filter (Right (F.DeclType dt)) -> + Just $ "id.namespace in (" <> T.intercalate "," (toList dt <&> \t -> "'" <> declarationTypeToText t <> "'") <> ")" + F.Filter _ -> Nothing) + filters + & \f -> if null f then " " else " where " <> T.intercalate " and " f + ) <> + foldMap (\maxResults -> " limit " <> show maxResults ) (coMaxResults =<< completionOptions) -printModules :: Ide m => m Success -printModules = ModuleList . map P.runModuleName <$> getLoadedModulenames + let matches = rows <&> \(m, decl) -> (Match (ModuleName m, deserialise decl), []) + + pure $ CompletionResult $ completionFromMatch <$> matches + +sqliteFile :: Ide m => m FilePath +sqliteFile = outputDirectory <&> ( "cache.db") outputDirectory :: Ide m => m FilePath outputDirectory = do @@ -141,14 +198,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 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/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/Filter/Declaration.hs b/src/Language/PureScript/Ide/Filter/Declaration.hs index 7875f7851c..9f17ebe7c6 100644 --- a/src/Language/PureScript/Ide/Filter/Declaration.hs +++ b/src/Language/PureScript/Ide/Filter/Declaration.hs @@ -1,11 +1,14 @@ module Language.PureScript.Ide.Filter.Declaration ( DeclarationType(..) + , declarationTypeToText ) where 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 +43,16 @@ instance ToJSON DeclarationType where ValueOperator -> "valueoperator" 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 d = SQLText $ declarationTypeToText d 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/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" diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index ebc34339eb..9b82cc87d1 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 @@ -22,10 +22,25 @@ 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) +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) +import Language.PureScript.Constants.Prim (primModules) +import Data.Foldable (concat) -- | Given a filepath performs the following steps: -- @@ -64,10 +79,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 +104,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 @@ -183,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 () } @@ -228,6 +244,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 = do + let P.Module _ _ _ declarations _ = m + let moduleDependencies = declarations >>= \case + P.ImportDeclaration _ importName _ _ -> [importName] + _ -> [] + + 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;" + ] + + 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 openModuleExports (P.Module ss cs mn decls _) = P.Module ss cs mn decls Nothing 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 06eed507e4..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 @@ -30,6 +31,8 @@ module Language.PureScript.Ide.State , populateVolatileStateSync , populateVolatileStateSTM , getOutputDirectory + , runQuery + , getSqliteFilePath , updateCacheTimestamp -- for tests , resolveOperatorsForModule @@ -56,6 +59,8 @@ 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 -- | Resets all State inside psc-ide resetIdeState :: Ide m => m () @@ -67,6 +72,16 @@ getOutputDirectory :: Ide m => m FilePath getOutputDirectory = do confOutputPath . ideConfiguration <$> ask +getSqliteFilePath :: Ide m => m FilePath +getSqliteFilePath = do + sqliteFilePath . ideConfiguration <$> ask + +runQuery :: SQLite.FromRow r => Ide m => Text -> m [r] +runQuery q = do + Debug.traceM $ show q + IdeEnvironment{..} <- ask + liftIO $ query q + getCacheTimestamp :: Ide m => m (Maybe UTCTime) getCacheTimestamp = do x <- ideCacheDbTimestamp <$> ask @@ -237,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/ToI.hs b/src/Language/PureScript/Ide/ToI.hs new file mode 100644 index 0000000000..a4a52a5c33 --- /dev/null +++ b/src/Language/PureScript/Ide/ToI.hs @@ -0,0 +1,286 @@ +----------------------------------------------------------------------------- +-- +-- 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 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/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/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 5fa304166b..d855e9d159 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -15,9 +15,19 @@ 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 +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 @@ -31,43 +41,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 @@ -75,7 +85,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 @@ -83,7 +93,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) @@ -131,7 +141,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 @@ -139,7 +149,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 @@ -160,6 +170,7 @@ data IdeLogLevel = LogDebug | LogPerf | LogAll | LogDefault | LogNone data IdeConfiguration = IdeConfiguration { confOutputPath :: FilePath + , sqliteFilePath :: FilePath , confLogLevel :: IdeLogLevel , confGlobs :: [FilePath] , confGlobsFromFile :: Maybe FilePath @@ -171,6 +182,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) @@ -322,6 +334,14 @@ instance FromJSON IdeNamespace where "module" -> pure IdeNSModule s -> fail ("Unknown namespace: " <> show s) +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 deriving (Show, Eq, Ord, Generic, NFData) diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 854391dcae..bfbb38bf21 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -29,20 +29,19 @@ 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) 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.hs b/src/Language/PureScript/Make.hs index 5228dc86e6..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 @@ -126,13 +128,13 @@ 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 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 f138327c8d..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) @@ -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 @@ -112,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. @@ -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' @@ -245,10 +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 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 new file mode 100644 index 0000000000..8bd52e8a4e --- /dev/null +++ b/src/Language/PureScript/Make/IdeCache.hs @@ -0,0 +1,282 @@ +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 +import Control.Concurrent (threadDelay) +import Control.Exception (try) +import System.FilePath ((), takeDirectory) +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)) +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, namespaceForDeclaration) +import Data.Function ((&)) +import Data.Bifunctor (first) +import Data.Text (Text) +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) +import Codec.Serialise (serialise) +import Data.Aeson (encode) +import Debug.Trace qualified as Debug +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) +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 + conn <- SQLite.open db + SQLite.execute_ conn "pragma busy_timeout = 300000;" + + -- Debug.traceM $ show extern + + let (doDecl, _, _) = everywhereOnValuesM (pure . identity) (\expr -> case expr of + Var ss i -> do + let iv = disqualify i + case iv of + Ident t -> do + 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) + + SQLite.execute_ conn "pragma foreign_keys = ON;" + + SQLite.executeNamed conn + "delete from modules where module_name = :module_name" + [ ":module_name" := runModuleName ( efModuleName extern ) + ] + + + 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_ (getModuleDeclarations m) (\d -> doDecl d) + + for_ (efExports extern) (\case + ReExportRef _ (ExportSource _ definedIn) (ValueRef _ (Ident i)) -> do + 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 + 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 + 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 () + ) + + for_ (efImports extern) (\i -> do + 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 + 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 + ]) + + for_ (Docs.modDeclarations docs) (\d -> do + 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 + , ":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 + 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) + , ":name" := Docs.cdeclTitle ch + , ":namespace" := childDeclInfoNamespaceIde (Docs.cdeclInfo ch) + , ":span" := Aeson.encode (Docs.declSourceSpan d) + , ":docs" := Docs.cdeclComments ch + , ":declaration" := show d + ] + ) + + + for_ (Docs.modReExports docs) $ \rexport -> do + for_ (snd rexport) $ \d -> do + 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 + 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" + +createParentDirectory :: FilePath -> IO () +createParentDirectory = createDirectoryIfMissing True . takeDirectory + +sqliteInit :: (MonadIO m) => FilePath -> m () +sqliteInit outputDir = liftIO $ do + createParentDirectory db + conn <- SQLite.open db + 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," + , " extern blob," + , " dec text," + , " unique (module_name) on conflict replace" + , ")" + ] + + 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" + , ")" + ] + + 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," + , " namespace text," + , " declaration_type text," + , " rexported_from text," + , " type text," + , " docs text," + , " span text," + , " declaration text not null" + , ")" + ] + + 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" + , ")" + ] + + 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" + , ")" + ] + + 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);" + + 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);" + + 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);" + + 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);" + + 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 + +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 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