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/Compile.hs b/app/Command/Compile.hs index d81dd75c07..e861601cfd 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -24,6 +24,7 @@ import System.Exit (exitSuccess, exitFailure) import System.Directory (getCurrentDirectory) import System.IO (hPutStr, stderr, stdout) import System.IO.UTF8 (readUTF8FilesT) +import Language.PureScript.Make.IdeCache (sqliteInit) data PSCMakeOptions = PSCMakeOptions { pscmInput :: [FilePath] @@ -56,6 +57,7 @@ printWarningsAndErrors verbose True files warnings errors = do compile :: PSCMakeOptions -> IO () compile PSCMakeOptions{..} = do + sqliteInit "output" input <- toInputGlobs $ PSCGlobs { pscInputGlobs = pscmInput , pscInputGlobsFromFile = pscmInputFromFile diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index f5a501af75..f1a8686275 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -40,6 +40,8 @@ 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 +import Protolude qualified as D listenOnLocalhost :: Network.PortNumber -> IO Network.Socket listenOnLocalhost port = do @@ -138,6 +140,7 @@ command = Opts.helper <*> subcommands where conf = IdeConfiguration { confLogLevel = logLevel , confOutputPath = outputPath + , sqliteFilePath = outputPath "cache.db" , confGlobs = globs , confGlobsFromFile = globsFromFile , confGlobsExclude = globsExcluded @@ -148,6 +151,11 @@ command = Opts.helper <*> subcommands where { ideStateVar = ideState , ideConfiguration = conf , ideCacheDbTimestamp = ts + , query = \q -> SQLite.withConnection (outputPath "cache.db") + (\conn -> do + SQLite.execute_ conn "pragma busy_timeout = 30000;" + SQLite.query_ conn $ SQLite.Query q + ) } startServer port env @@ -189,6 +197,7 @@ startServer port env = Network.withSocketsDo $ do case accepted of Left err -> $(logError) err Right (cmd, h) -> do + -- traceM cmd case decodeT cmd of Right cmd' -> do let message duration = 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/app/Main.hs b/app/Main.hs index c925a4a313..374fcee282 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) @@ -61,6 +62,9 @@ main = do [ Opts.command "bundle" (Opts.info Bundle.command (Opts.progDesc "This command was removed in v0.15.0. Run this command for migration information.")) + , Opts.command "sqlite" + (Opts.info Bundle.initSqlite + (Opts.progDesc "Init sqlite")) , Opts.command "compile" (Opts.info Compile.command (Opts.progDesc "Compile PureScript source files")) @@ -76,6 +80,9 @@ main = do , Opts.command "ide" (Opts.info Ide.command (Opts.progDesc "Start or query an IDE server process")) + , Opts.command "qb" + (Opts.info QB.command + (Opts.progDesc "Quick build module")) , Opts.command "publish" (Opts.info Publish.command (Opts.progDesc "Generates documentation packages for upload to Pursuit")) diff --git a/profile-admin.txt b/profile-admin.txt index e5db10ead6..b8558f1c6e 100644 --- a/profile-admin.txt +++ b/profile-admin.txt @@ -1,27 +1,27 @@ 'purs' 'compile' '--source-globs-file' '.spago/sources.txt' +RTS '-N' '-sprofile.txt' -1,881,065,351,416 bytes allocated in the heap - 573,448,796,456 bytes copied during GC - 6,854,605,176 bytes maximum residency (51 sample(s)) - 96,912,208 bytes maximum slop - 19822 MiB total memory in use (0 MB lost due to fragmentation) + 765,357,373,648 bytes allocated in the heap + 360,583,388,216 bytes copied during GC + 6,131,704,224 bytes maximum residency (40 sample(s)) + 59,567,712 bytes maximum slop + 17666 MiB total memory in use (0 MB lost due to fragmentation) Tot time (elapsed) Avg pause Max pause - Gen 0 112618 colls, 112618 par 556.187s 189.050s 0.0017s 0.0491s - Gen 1 51 colls, 50 par 233.076s 122.893s 2.4097s 4.1721s + Gen 0 63238 colls, 63238 par 214.826s 86.156s 0.0014s 0.0344s + Gen 1 40 colls, 39 par 126.759s 24.613s 0.6153s 2.3480s - Parallel GC work balance: 72.00% (serial 0%, perfect 100%) + Parallel GC work balance: 62.83% (serial 0%, perfect 100%) - TASKS: 45 (1 bound, 44 peak workers (44 total), using -N10) + TASKS: 58 (1 bound, 57 peak workers (57 total), using -N10) SPARKS: 7516 (7516 converted, 0 overflowed, 0 dud, 0 GC'd, 0 fizzled) - INIT time 0.000s ( 0.004s elapsed) - MUT time 746.850s (124.852s elapsed) - GC time 789.263s (311.943s elapsed) - EXIT time 0.126s ( 0.007s elapsed) - Total time 1536.239s (436.806s elapsed) + INIT time 0.000s ( 0.003s elapsed) + MUT time 307.420s ( 79.011s elapsed) + GC time 341.586s (110.770s elapsed) + EXIT time 0.110s ( 0.004s elapsed) + Total time 649.117s (189.789s elapsed) - Alloc rate 2,518,666,039 bytes per MUT second + Alloc rate 2,489,613,396 bytes per MUT second - Productivity 48.6% of total user, 28.6% of total elapsed + Productivity 47.4% of total user, 41.6% of total elapsed diff --git a/profile.txt b/profile.txt index a9119003bd..153851c703 100644 --- a/profile.txt +++ b/profile.txt @@ -1,27 +1,27 @@ 'purs' 'compile' '--source-globs-file' '.spago/sources.txt' +RTS '-N' '-sprofile.txt' -3,482,404,119,952 bytes allocated in the heap - 907,304,406,504 bytes copied during GC - 4,217,119,128 bytes maximum residency (133 sample(s)) - 75,523,008 bytes maximum slop - 11887 MiB total memory in use (0 MB lost due to fragmentation) +1,516,071,924,704 bytes allocated in the heap + 574,866,053,056 bytes copied during GC + 3,401,220,216 bytes maximum residency (98 sample(s)) + 49,707,176 bytes maximum slop + 9222 MiB total memory in use (0 MB lost due to fragmentation) Tot time (elapsed) Avg pause Max pause - Gen 0 173582 colls, 173582 par 885.786s 237.209s 0.0014s 0.0167s - Gen 1 133 colls, 132 par 347.505s 47.618s 0.3580s 0.5545s + Gen 0 105895 colls, 105895 par 366.037s 140.943s 0.0013s 0.0198s + Gen 1 98 colls, 97 par 222.211s 29.697s 0.3030s 0.4475s - Parallel GC work balance: 71.47% (serial 0%, perfect 100%) + Parallel GC work balance: 63.05% (serial 0%, perfect 100%) - TASKS: 42 (1 bound, 41 peak workers (41 total), using -N10) + TASKS: 70 (1 bound, 66 peak workers (69 total), using -N10) SPARKS: 7516 (7516 converted, 0 overflowed, 0 dud, 0 GC'd, 0 fizzled) - INIT time 0.000s ( 0.008s elapsed) - MUT time 1332.818s (174.863s elapsed) - GC time 1233.290s (284.827s elapsed) - EXIT time 0.050s ( 0.001s elapsed) - Total time 2566.158s (459.698s elapsed) + INIT time 0.000s ( 0.004s elapsed) + MUT time 631.223s (120.429s elapsed) + GC time 588.249s (170.640s elapsed) + EXIT time 0.050s ( 0.010s elapsed) + Total time 1219.522s (291.083s elapsed) - Alloc rate 2,612,813,741 bytes per MUT second + Alloc rate 2,401,800,958 bytes per MUT second - Productivity 51.9% of total user, 38.0% of total elapsed + Productivity 51.8% of total user, 41.4% of total elapsed diff --git a/purescript.cabal b/purescript.cabal index 0d32ce4814..a1bac408ff 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 @@ -158,6 +164,7 @@ common defaults ansi-terminal >=0.11.3 && <0.12, array >=0.5.4.0 && <0.6, base >=4.16.2.0 && <4.17, + intern ==0.9.4, blaze-html >=0.9.1.2 && <0.10, bower-json >=1.1.0.0 && <1.2, boxes >=0.1.5 && <0.2, @@ -198,6 +205,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 +275,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 +346,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 @@ -392,6 +403,7 @@ library System.IO.UTF8 other-modules: Data.Text.PureScript + Data.InternedName Language.PureScript.Constants.TH Paths_purescript autogen-modules: @@ -401,7 +413,7 @@ executable purs import: defaults hs-source-dirs: app main-is: Main.hs - ghc-options: -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N -Wno-unused-packages + ghc-options: -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N -Wno-unused-packages -eventlog build-depends: ansi-wl-pprint >=0.6.9 && <0.7, exceptions >=0.10.4 && <0.11, @@ -422,6 +434,7 @@ executable purs Command.Graph Command.Hierarchy Command.Ide + Command.QuickBuild Command.Publish Command.REPL SharedCLI diff --git a/src/Data/InternedName.hs b/src/Data/InternedName.hs new file mode 100644 index 0000000000..3a71d1f25a --- /dev/null +++ b/src/Data/InternedName.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DerivingStrategies #-} +module Data.InternedName where + +import Prelude +import Data.Aeson (FromJSON(..), ToJSON(..)) +import Data.Interned (intern, unintern) +import Data.Interned.Text (InternedText) +import Control.DeepSeq (NFData(..)) +import Codec.Serialise (Serialise(..), encode, decode) +import Data.Text as T + +newtype InternedName = InternedName InternedText + deriving stock (Show) + deriving newtype (Eq, Ord) + +internName :: String -> InternedName +internName name = InternedName $ intern $ T.pack name + +uninternName :: InternedName -> String +uninternName (InternedName name) = T.unpack $ unintern name + +instance FromJSON InternedName where + parseJSON = fmap internName . parseJSON + +instance ToJSON InternedName where + toJSON = toJSON . uninternName + +instance Serialise InternedName where + encode = encode . uninternName + decode = fmap internName decode + +instance NFData InternedName where + rnf (InternedName name) = () diff --git a/src/Language/PureScript/AST/Declarations/ChainId.hs b/src/Language/PureScript/AST/Declarations/ChainId.hs index aacfc11fe8..12e64154ac 100644 --- a/src/Language/PureScript/AST/Declarations/ChainId.hs +++ b/src/Language/PureScript/AST/Declarations/ChainId.hs @@ -5,16 +5,18 @@ module Language.PureScript.AST.Declarations.ChainId import Prelude import Language.PureScript.AST.SourcePos qualified as Pos +import Data.InternedName (InternedName, internName) import Control.DeepSeq (NFData) import Codec.Serialise (Serialise) +import Data.Aeson (ToJSON, FromJSON) -- | -- For a given instance chain, stores the chain's file name and -- the starting source pos of the first instance in the chain. -- This data is used to determine which instances are part of -- the same instance chain. -newtype ChainId = ChainId (String, Pos.SourcePos) - deriving (Eq, Ord, Show, NFData, Serialise) +newtype ChainId = ChainId (InternedName, Pos.SourcePos) + deriving (Eq, Ord, Show, NFData, Serialise, ToJSON, FromJSON) mkChainId :: String -> Pos.SourcePos -> ChainId -mkChainId fileName startingSourcePos = ChainId (fileName, startingSourcePos) +mkChainId fileName startingSourcePos = ChainId (internName 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..ac372ce452 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -20,6 +20,7 @@ module Language.PureScript.Ide import Protolude hiding (moduleName) +import qualified Language.PureScript.Ide.Imports as IDEImports import "monad-logger" Control.Monad.Logger (MonadLogger, logWarnN) import Data.Map qualified as Map import Data.Text qualified as T @@ -27,22 +28,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, escapeSQL) +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 +72,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 +104,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 +147,7 @@ handleCommand c = case c of findCompletions :: Ide m - => [Filter] + => [F.Filter] -> Matcher IdeDeclarationAnn -> Maybe P.ModuleName -> CompletionOptions @@ -121,19 +157,52 @@ 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 -> "'" <> escapeSQL m <> "'") <> + "))" <> + " or " <> "id.module_name in (" <> T.intercalate "," (toList modules <&> runModuleName <&> \m -> "'" <> escapeSQL m <> "'") <> "))" + F.Filter (Right (F.Prefix "")) -> Nothing + F.Filter (Right (F.Prefix f)) -> Just $ "id.name glob '" <> escapeSQL f <> "*'" + F.Filter (Right (F.Exact f)) -> Just $ "id.name glob '" <> escapeSQL 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 (Right (F.Dependencies qualifier _ imports@(_:_))) -> + 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 " + <> moduleNames <> ") or id.module_name in" <> moduleNames <> ")" + where + moduleNames = " (" <> + T.intercalate "," (filter (\(IDEImports.Import _ _ qualified) -> case qualifier of + Nothing -> True + Just qual -> Just qual == qualified + ) imports <&> \(IDEImports.Import m _ _)-> "'" <> escapeSQL (runModuleName m) <> "'") <> ") " + 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 +210,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 32478d7000..d8604e953e 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,11 +31,14 @@ module Language.PureScript.Ide.State , populateVolatileStateSync , populateVolatileStateSTM , getOutputDirectory + , runQuery + , getSqliteFilePath , updateCacheTimestamp -- for tests , resolveOperatorsForModule , resolveInstances , resolveDataConstructorsForModule + , escapeSQL ) where import Protolude hiding (moduleName, unzip) @@ -56,6 +60,9 @@ import Language.PureScript.Ide.SourceFile (extractAstInformation) import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util (discardAnn, opNameT, properNameT, runLogger) import System.Directory (getModificationTime) +import Database.SQLite.Simple qualified as SQLite +import Debug.Trace qualified as Debug +import Data.Text qualified as T -- | Resets all State inside psc-ide resetIdeState :: Ide m => m () @@ -67,6 +74,19 @@ 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 + +escapeSQL :: Text -> Text +escapeSQL = T.replace "'" "''" + getCacheTimestamp :: Ide m => m (Maybe UTCTime) getCacheTimestamp = do x <- ideCacheDbTimestamp <$> ask @@ -234,6 +254,20 @@ populateVolatileStateSTM ref = do setVolatileStateSTM ref (IdeVolatileState (AstData asts) (map reResolved results) rebuildCache) pure 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 41532a3c51..b6cf3bee5d 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) + deriving (Show, Eq, Ord, Generic, NFData, Serialise) data IdeValue = IdeValue { _ideValueIdent :: P.Ident , _ideValueType :: P.SourceType - } deriving (Show, Eq, Ord) + } 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) + } 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) + } 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) + } deriving (Show, Eq, Ord, Generic, NFData, Serialise) data IdeTypeClass = IdeTypeClass { _ideTCName :: P.ProperName 'P.ClassName , _ideTCKind :: P.SourceType , _ideTCInstances :: [IdeInstance] - } deriving (Show, Eq, Ord) + } 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) + } 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) + } 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) + } 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) + } 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) + } 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) 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..3803c54efb 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 ( 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,7 @@ readCacheDb' => FilePath -- ^ The path to the output directory -> m CacheDb -readCacheDb' outputDir = +readCacheDb' outputDir = do fromMaybe mempty <$> readJSONFile (cacheDbFile outputDir) writeCacheDb' @@ -245,10 +246,11 @@ 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 $ 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..64a7e97463 --- /dev/null +++ b/src/Language/PureScript/Make/IdeCache.hs @@ -0,0 +1,285 @@ +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 busy_timeout = 300000;" + SQLite.execute_ conn "pragma journal_mode=wal;" + SQLite.execute_ conn "pragma foreign_keys = ON;" + 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.execute_ conn "create index if not exists exports_idx on exports(defined_in,name,declaration_type,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 diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index e4f1040ebf..7ce208fd24 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -107,6 +107,7 @@ unknownsInType t = everythingOnTypes (.) go t [] -- | Unify two types, updating the current substitution unifyTypes :: (MonadError MultipleErrors m, MonadState CheckState m) => SourceType -> SourceType -> m () +unifyTypes t1 t2 | t1 == t2 = return () unifyTypes t1 t2 = do sub <- gets checkSubstitution withErrorMessageHint (ErrorUnifyingTypes t1 t2) $ unifyTypes' (substituteType sub t1) (substituteType sub t2) diff --git a/stack.yaml b/stack.yaml index 88b27b1a46..66f79716a4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -6,7 +6,7 @@ packages: - '.' ghc-options: # Build with advanced optimizations enabled by default - "$locals": -O2 -Werror + "$locals": -O2 -fspecialize-aggressively -fexpose-all-unfoldings extra-deps: # As of 2021-11-08, the latest release of `language-javascript` is 0.7.1.0, # but it has a problem with parsing the `async` keyword. It doesn't allow