From 8c0a46632428b6490383e1ea011137681c1a3095 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 4 Apr 2021 08:57:17 +0100 Subject: [PATCH 01/10] Added a command to index the database and exit --- ghcide/exe/Main.hs | 98 +++++++++++++----------------- ghcide/src/Development/IDE/Main.hs | 63 ++++++++++++++++--- src/Ide/Main.hs | 2 +- 3 files changed, 96 insertions(+), 67 deletions(-) diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 041c6a6186..768587e3d9 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -25,11 +25,8 @@ import Development.IDE.Core.Rules (mainRule) import qualified Development.IDE.Main as Main import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde import qualified Development.IDE.Plugin.Test as Test -import Development.IDE.Session (getHieDbLoc, - setInitialDynFlags) import Development.IDE.Types.Options import Development.Shake (ShakeOptions (shakeThreads)) -import HieDb.Run (Options (..), runCommand) import Ide.Plugin.Config (Config (checkParents, checkProject)) import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, pluginsToVSCodeExtensionSchema) @@ -37,8 +34,7 @@ import Ide.PluginUtils (pluginDescToIdePlugins) import Paths_ghcide (version) import qualified System.Directory.Extra as IO import System.Environment (getExecutablePath) -import System.Exit (ExitCode (ExitFailure), - exitSuccess, exitWith) +import System.Exit (exitSuccess) import System.IO (hPutStrLn, stderr) import System.Info (compilerVersion) @@ -81,55 +77,45 @@ main = do logLevel = if argsVerbose then minBound else Info case argFilesOrCmd of - DbCmd opts cmd -> do - dir <- IO.getCurrentDirectory - dbLoc <- getHieDbLoc dir - mlibdir <- setInitialDynFlags def - case mlibdir of - Nothing -> exitWith $ ExitFailure 1 - Just libdir -> runCommand libdir opts{database = dbLoc} cmd - - _ -> do - - case argFilesOrCmd of - LSP -> do - hPutStrLn stderr "Starting LSP server..." - hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" - _ -> return () - - Main.defaultMain def - {Main.argFiles = case argFilesOrCmd of - Typecheck x | not argLSP -> Just x - _ -> Nothing - - ,Main.argsLogger = pure logger - - ,Main.argsRules = do - -- install the main and ghcide-plugin rules - mainRule - -- install the kick action, which triggers a typecheck on every - -- Shake database restart, i.e. on every user edit. - unless argsDisableKick $ - action kick - - ,Main.argsHlsPlugins = - pluginDescToIdePlugins $ - GhcIde.descriptors - ++ [Test.blockCommandDescriptor "block-command" | argsTesting] - - ,Main.argsGhcidePlugin = if argsTesting - then Test.plugin - else mempty - - ,Main.argsIdeOptions = \config sessionLoader -> - let defOptions = defaultIdeOptions sessionLoader - in defOptions - { optShakeProfiling = argsShakeProfiling - , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling - , optTesting = IdeTesting argsTesting - , optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads} - , optCheckParents = pure $ checkParents config - , optCheckProject = pure $ checkProject config - } - } + LSP -> do + hPutStrLn stderr "Starting LSP server..." + hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" + _ -> return () + + Main.defaultMain def + {Main.argCommand = case argFilesOrCmd of + Typecheck x | not argLSP -> Main.Check x + DbCmd x y -> Main.Db "." x y + _ -> Main.Lsp + + ,Main.argsLogger = pure logger + + ,Main.argsRules = do + -- install the main and ghcide-plugin rules + mainRule + -- install the kick action, which triggers a typecheck on every + -- Shake database restart, i.e. on every user edit. + unless argsDisableKick $ + action kick + + ,Main.argsHlsPlugins = + pluginDescToIdePlugins $ + GhcIde.descriptors + ++ [Test.blockCommandDescriptor "block-command" | argsTesting] + + ,Main.argsGhcidePlugin = if argsTesting + then Test.plugin + else mempty + + ,Main.argsIdeOptions = \config sessionLoader -> + let defOptions = defaultIdeOptions sessionLoader + in defOptions + { optShakeProfiling = argsShakeProfiling + , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling + , optTesting = IdeTesting argsTesting + , optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads} + , optCheckParents = pure $ checkParents config + , optCheckProject = pure $ checkProject config + } + } diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 91da4a09d0..f620371432 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -1,21 +1,29 @@ -module Development.IDE.Main (Arguments(..), defaultMain) where +module Development.IDE.Main +(Arguments(..) +,Command(..) +,defaultMain +) where import Control.Concurrent.Extra (newLock, readVar, withLock) import Control.Exception.Safe (Exception (displayException), catchAny) import Control.Monad.Extra (concatMapM, unless, when) +import Control.Monad.IO.Class import Data.Default (Default (def)) +import Data.Foldable (toList) import qualified Data.HashMap.Strict as HashMap import Data.Hashable (hashed) import Data.List.Extra (intercalate, isPrefixOf, nub, nubOrd, partition) import Data.Maybe (catMaybes, fromMaybe, - isJust) + isJust, isNothing) import qualified Data.Text as T import qualified Data.Text.IO as T -import Development.IDE (Action, Rules, - hDuplicateTo') +import Development.IDE (Action, + GetKnownTargets (GetKnownTargets), + GetModIfaceFromDiskAndIndex (GetModIfaceFromDiskAndIndex), + Rules, hDuplicateTo') import Development.IDE.Core.Debouncer (Debouncer, newAsyncDebouncer) import Development.IDE.Core.FileStore (makeVFSHandle) @@ -34,7 +42,8 @@ import Development.IDE.Core.Rules (GhcSessionIO (GhcSession import Development.IDE.Core.Service (initialise, runAction) import Development.IDE.Core.Shake (IdeState (shakeExtras), ShakeExtras (state), - uses) + toKnownFiles, + useNoFile_, uses) import Development.IDE.Core.Tracing (measureMemory) import Development.IDE.LSP.LanguageServer (runLanguageServer) import Development.IDE.Plugin (Plugin (pluginHandlers, pluginRules)) @@ -57,6 +66,7 @@ import Development.Shake (action) import GHC.IO.Encoding (setLocaleEncoding) import GHC.IO.Handle (hDuplicate) import HIE.Bios.Cradle (findCradle) +import qualified HieDb.Run as HieDb import Ide.Plugin.Config (CheckParents (NeverCheck), Config, getConfigFromNotification) @@ -80,9 +90,15 @@ import System.Time.Extra (offsetTime, showDuration) import Text.Printf (printf) +data Command + = Lsp -- ^ Run the LSP server + | Check [FilePath] -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures + | Index FilePath -- ^ Index the whole project and print the path to the database + | Db FilePath HieDb.Options HieDb.Command -- ^ Run a command in the hiedb + data Arguments = Arguments { argsOTMemoryProfiling :: Bool - , argFiles :: Maybe [FilePath] -- ^ Nothing: lsp server ; Just: typecheck and exit + , argCommand :: Command , argsLogger :: IO Logger , argsRules :: Rules () , argsHlsPlugins :: IdePlugins IdeState @@ -100,7 +116,7 @@ data Arguments = Arguments instance Default Arguments where def = Arguments { argsOTMemoryProfiling = False - , argFiles = Nothing + , argCommand = Lsp , argsLogger = stderrLogger , argsRules = mainRule >> action kick , argsGhcidePlugin = mempty @@ -153,8 +169,8 @@ defaultMain Arguments{..} = do inH <- argsHandleIn outH <- argsHandleOut - case argFiles of - Nothing -> do + case argCommand of + Lsp -> do t <- offsetTime hPutStrLn stderr "Starting LSP server..." hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" @@ -188,7 +204,7 @@ defaultMain Arguments{..} = do vfs hiedb hieChan - Just argFiles -> do + Check argFiles -> do dir <- IO.getCurrentDirectory dbLoc <- getHieDbLoc dir runWithDb dbLoc $ \hiedb hieChan -> do @@ -249,8 +265,35 @@ defaultMain Arguments{..} = do measureMemory logger [keys] consoleObserver valuesRef unless (null failed) (exitWith $ ExitFailure (length failed)) + Index dir -> do + dbLoc <- getHieDbLoc dir + runWithDb dbLoc $ \hiedb hieChan -> do + vfs <- makeVFSHandle + sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir + let options = (argsIdeOptions argsDefaultHlsConfig sessionLoader) + { optCheckParents = pure NeverCheck + , optCheckProject = pure False + } + ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan + registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) + results <- runAction "Index" ide $ do + allKnownTargets <- toKnownFiles <$> useNoFile_ GetKnownTargets + liftIO $ hPutStrLn stderr $ "Found " <> show(length allKnownTargets) <> " targets" + uses GetModIfaceFromDiskAndIndex $ toList allKnownTargets + putStrLn dbLoc + let nfailures = length $ filter isNothing results + unless (nfailures == 0) $ exitWith $ ExitFailure nfailures + Db dir opts cmd -> do + dbLoc <- getHieDbLoc dir + hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc + mlibdir <- setInitialDynFlags def + case mlibdir of + Nothing -> exitWith $ ExitFailure 1 + Just libdir -> HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd + {-# ANN defaultMain ("HLint: ignore Use nubOrd" :: String) #-} + expandFiles :: [FilePath] -> IO [FilePath] expandFiles = concatMapM $ \x -> do b <- IO.doesFileExist x diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index d662cced3b..030bfbd13f 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -101,7 +101,7 @@ runLspMode lspArgs@LspArguments{..} idePlugins = do hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" Main.defaultMain def - { Main.argFiles = if argLSP then Nothing else Just argFiles + { Main.argCommand = if argLSP then Main.Lsp else Main.Check argFiles , Main.argsHlsPlugins = idePlugins , Main.argsLogger = pure hlsLogger , Main.argsIdeOptions = \_config sessionLoader -> From 818a18394f39f9881d684dcdbe2f114e71f4cc34 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 5 Apr 2021 08:09:49 +0100 Subject: [PATCH 02/10] WIP wait for it --- ghcide/src/Development/IDE/Main.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index f620371432..d686d8973f 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -5,6 +5,7 @@ module Development.IDE.Main ) where import Control.Concurrent.Extra (newLock, readVar, withLock) +import Control.Concurrent.STM import Control.Exception.Safe (Exception (displayException), catchAny) import Control.Monad.Extra (concatMapM, unless, @@ -40,8 +41,9 @@ import Development.IDE.Core.RuleTypes (GenerateCore (GenerateCo import Development.IDE.Core.Rules (GhcSessionIO (GhcSessionIO), mainRule) import Development.IDE.Core.Service (initialise, runAction) -import Development.IDE.Core.Shake (IdeState (shakeExtras), - ShakeExtras (state), +import Development.IDE.Core.Shake (HieDbWriter (indexPending), + IdeState (shakeExtras), + ShakeExtras (hiedbWriter, state), toKnownFiles, useNoFile_, uses) import Development.IDE.Core.Tracing (measureMemory) @@ -282,6 +284,13 @@ defaultMain Arguments{..} = do uses GetModIfaceFromDiskAndIndex $ toList allKnownTargets putStrLn dbLoc let nfailures = length $ filter isNothing results + let pending = indexPending $ hiedbWriter $ shakeExtras ide + + hPutStrLn stderr "Waiting for indexing..." + atomically $ do + n <- readTVar pending + unless (HashMap.size n == 0) retry + unless (nfailures == 0) $ exitWith $ ExitFailure nfailures Db dir opts cmd -> do dbLoc <- getHieDbLoc dir From 0785bcad5df1d195b740d3262be6072f84b428ad Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 5 Apr 2021 09:00:47 +0100 Subject: [PATCH 03/10] Load FOIs (otherwise nothing happens) and wait for the hiedb writer --- ghcide/src/Development/IDE/Main.hs | 25 ++++++++++++++++--------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index d686d8973f..35cca28958 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -95,7 +95,7 @@ import Text.Printf (printf) data Command = Lsp -- ^ Run the LSP server | Check [FilePath] -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures - | Index FilePath -- ^ Index the whole project and print the path to the database + | Index [FilePath] -- ^ Index all the targets and print the path to the database | Db FilePath HieDb.Options HieDb.Command -- ^ Run a command in the hiedb data Arguments = Arguments @@ -267,31 +267,38 @@ defaultMain Arguments{..} = do measureMemory logger [keys] consoleObserver valuesRef unless (null failed) (exitWith $ ExitFailure (length failed)) - Index dir -> do - dbLoc <- getHieDbLoc dir + Index argFiles -> do + dbLoc <- getHieDbLoc "." + files <- expandFiles (argFiles ++ ["." | null argFiles]) runWithDb dbLoc $ \hiedb hieChan -> do vfs <- makeVFSHandle - sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir + sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions "." let options = (argsIdeOptions argsDefaultHlsConfig sessionLoader) { optCheckParents = pure NeverCheck , optCheckProject = pure False } ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) + let fois = map toNormalizedFilePath' files + setFilesOfInterest ide $ HashMap.fromList $ map (,OnDisk) fois results <- runAction "Index" ide $ do + _ <- uses GetModIfaceFromDiskAndIndex fois allKnownTargets <- toKnownFiles <$> useNoFile_ GetKnownTargets - liftIO $ hPutStrLn stderr $ "Found " <> show(length allKnownTargets) <> " targets" + liftIO $ hPutStrLn stderr $ "Indexing " <> show(length allKnownTargets) <> " targets" uses GetModIfaceFromDiskAndIndex $ toList allKnownTargets - putStrLn dbLoc - let nfailures = length $ filter isNothing results - let pending = indexPending $ hiedbWriter $ shakeExtras ide - hPutStrLn stderr "Waiting for indexing..." + hPutStrLn stderr "Writing index... " + + let !nfailures = length $ filter isNothing results + let !pending = indexPending $ hiedbWriter $ shakeExtras ide + atomically $ do n <- readTVar pending unless (HashMap.size n == 0) retry + putStrLn dbLoc unless (nfailures == 0) $ exitWith $ ExitFailure nfailures + Db dir opts cmd -> do dbLoc <- getHieDbLoc dir hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc From 16a47dbad535c305a627497e83b15e5a9dc334bd Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 5 Apr 2021 09:01:23 +0100 Subject: [PATCH 04/10] Add a command in ghcide exe --- ghcide/exe/Arguments.hs | 6 ++++-- ghcide/exe/Main.hs | 1 + 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/ghcide/exe/Arguments.hs b/ghcide/exe/Arguments.hs index 125cf66961..85aec13ae9 100644 --- a/ghcide/exe/Arguments.hs +++ b/ghcide/exe/Arguments.hs @@ -8,7 +8,7 @@ import Options.Applicative type Arguments = Arguments' IdeCmd -data IdeCmd = Typecheck [FilePath] | DbCmd Options Command | LSP +data IdeCmd = Typecheck [FilePath] | DbCmd Options Command | DbIndex [FilePath] | LSP data Arguments' a = Arguments {argLSP :: Bool @@ -47,10 +47,12 @@ arguments = Arguments <*> switch (long "verbose" <> help "Include internal events in logging output") <*> ( hsubparser (command "typecheck" (info (Typecheck <$> fileCmd) fileInfo) <> command "hiedb" (info (DbCmd <$> optParser "" True <*> cmdParser <**> helper) hieInfo) - <> command "lsp" (info (pure LSP <**> helper) lspInfo) ) + <> command "index" (info (DbIndex <$> fileCmd) indexInfo) + <> command "lsp" (info (pure LSP <**> helper) lspInfo)) <|> Typecheck <$> fileCmd ) where fileCmd = many (argument str (metavar "FILES/DIRS...")) lspInfo = fullDesc <> progDesc "Start talking to an LSP client" fileInfo = fullDesc <> progDesc "Used as a test bed to check your IDE will work" hieInfo = fullDesc <> progDesc "Query .hie files" + indexInfo = fullDesc <> progDesc "Load the given files and index all the known targets" diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 768587e3d9..c1aff928a1 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -86,6 +86,7 @@ main = do {Main.argCommand = case argFilesOrCmd of Typecheck x | not argLSP -> Main.Check x DbCmd x y -> Main.Db "." x y + DbIndex dir -> Main.Index dir _ -> Main.Lsp ,Main.argsLogger = pure logger From e6583b5b94a0dda718d629c28f41b8095c38f9a5 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 5 Apr 2021 09:36:15 +0100 Subject: [PATCH 05/10] reuse Development.IDE.Main.Command --- exe/Main.hs | 7 +++--- ghcide/exe/Arguments.hs | 33 ++++++++------------------ ghcide/exe/Main.hs | 13 ++++------- ghcide/ghcide.cabal | 1 + ghcide/src/Development/IDE/Main.hs | 37 ++++++++++++++++++++++++++---- src/Ide/Arguments.hs | 26 ++++++++++----------- src/Ide/Main.hs | 28 +++++++--------------- 7 files changed, 72 insertions(+), 73 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index 21b9cdc774..7c0ef2f90b 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -4,7 +4,8 @@ {-# LANGUAGE RecordWildCards #-} module Main(main) where -import Ide.Arguments (Arguments (..), LspArguments (..), getArguments) +import Ide.Arguments (Arguments (..), GhcideArguments (..), + getArguments) import Ide.Main (defaultMain) import Plugins @@ -14,7 +15,7 @@ main = do let withExamples = case args of - LspMode LspArguments{..} -> argsExamplePlugin - _ -> False + Ghcide GhcideArguments{..} -> argsExamplePlugin + _ -> False defaultMain args (idePlugins withExamples) diff --git a/ghcide/exe/Arguments.hs b/ghcide/exe/Arguments.hs index 85aec13ae9..2563fdccb8 100644 --- a/ghcide/exe/Arguments.hs +++ b/ghcide/exe/Arguments.hs @@ -1,18 +1,13 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -module Arguments(Arguments, Arguments'(..), getArguments, IdeCmd(..)) where +module Arguments(Arguments(..), getArguments) where -import HieDb.Run +import Development.IDE.Main (Command (..), commandP) import Options.Applicative -type Arguments = Arguments' IdeCmd - -data IdeCmd = Typecheck [FilePath] | DbCmd Options Command | DbIndex [FilePath] | LSP - -data Arguments' a = Arguments - {argLSP :: Bool - ,argsCwd :: Maybe FilePath +data Arguments = Arguments + {argsCwd :: Maybe FilePath ,argsVersion :: Bool ,argsVSCodeExtensionSchema :: Bool ,argsDefaultConfig :: Bool @@ -22,7 +17,7 @@ data Arguments' a = Arguments ,argsDisableKick :: Bool ,argsThreads :: Int ,argsVerbose :: Bool - ,argFilesOrCmd :: a + ,argsCommand :: Command } getArguments :: IO Arguments @@ -34,8 +29,7 @@ getArguments = execParser opts arguments :: Parser Arguments arguments = Arguments - <$> switch (long "lsp" <> help "Start talking to an LSP client") - <*> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory") + <$> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory") <*> switch (long "version" <> help "Show ghcide and GHC versions") <*> switch (long "vscode-extension-schema" <> help "Print generic config schema for plugins (used in the package.json of haskell vscode extension)") <*> switch (long "generate-default-config" <> help "Print config supported by the server with default values") @@ -45,14 +39,7 @@ arguments = Arguments <*> switch (long "test-no-kick" <> help "Disable kick. Useful for testing cancellation") <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault) <*> switch (long "verbose" <> help "Include internal events in logging output") - <*> ( hsubparser (command "typecheck" (info (Typecheck <$> fileCmd) fileInfo) - <> command "hiedb" (info (DbCmd <$> optParser "" True <*> cmdParser <**> helper) hieInfo) - <> command "index" (info (DbIndex <$> fileCmd) indexInfo) - <> command "lsp" (info (pure LSP <**> helper) lspInfo)) - <|> Typecheck <$> fileCmd ) - where - fileCmd = many (argument str (metavar "FILES/DIRS...")) - lspInfo = fullDesc <> progDesc "Start talking to an LSP client" - fileInfo = fullDesc <> progDesc "Used as a test bed to check your IDE will work" - hieInfo = fullDesc <> progDesc "Query .hie files" - indexInfo = fullDesc <> progDesc "Load the given files and index all the known targets" + <*> (commandP <|> lspCommand <|> checkCommand) + where + checkCommand = Check <$> many (argument str (metavar "FILES/DIRS...")) + lspCommand = LSP <$ switch (long "lsp" <> help "Start talking to an LSP client") diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index c1aff928a1..2faa40b06f 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -5,8 +5,8 @@ module Main(main) where -import Arguments (Arguments' (..), - IdeCmd (..), getArguments) +import Arguments (Arguments (..), + getArguments) import Control.Concurrent.Extra (newLock, withLock) import Control.Monad.Extra (unless, when, whenJust) import qualified Data.Aeson.Encode.Pretty as A @@ -22,6 +22,7 @@ import Development.IDE (Logger (Logger), Priority (Info), action) import Development.IDE.Core.OfInterest (kick) import Development.IDE.Core.Rules (mainRule) +import Development.IDE.Main (Command (LSP)) import qualified Development.IDE.Main as Main import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde import qualified Development.IDE.Plugin.Test as Test @@ -76,18 +77,14 @@ main = do T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg logLevel = if argsVerbose then minBound else Info - case argFilesOrCmd of + case argsCommand of LSP -> do hPutStrLn stderr "Starting LSP server..." hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" _ -> return () Main.defaultMain def - {Main.argCommand = case argFilesOrCmd of - Typecheck x | not argLSP -> Main.Check x - DbCmd x y -> Main.Db "." x y - DbIndex dir -> Main.Index dir - _ -> Main.Lsp + {Main.argCommand = argsCommand ,Main.argsLogger = pure logger diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 19cbb0fa3c..46e4ebdb4b 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -64,6 +64,7 @@ library lsp == 1.2.*, mtl, network-uri, + optparse-applicative, parallel, prettyprinter-ansi-terminal, prettyprinter-ansi-terminal, diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 35cca28958..02a1ce3637 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -1,6 +1,9 @@ +{-# OPTIONS_GHC -Wno-orphans #-} module Development.IDE.Main (Arguments(..) ,Command(..) +,isLSP +,commandP ,defaultMain ) where import Control.Concurrent.Extra (newLock, readVar, @@ -77,6 +80,7 @@ import Ide.PluginUtils (allLspCmdIds', pluginDescToIdePlugins) import Ide.Types (IdePlugins) import qualified Language.LSP.Server as LSP +import Options.Applicative hiding (action) import qualified System.Directory.Extra as IO import System.Exit (ExitCode (ExitFailure), exitWith) @@ -93,10 +97,33 @@ import System.Time.Extra (offsetTime, import Text.Printf (printf) data Command - = Lsp -- ^ Run the LSP server - | Check [FilePath] -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures - | Index [FilePath] -- ^ Index all the targets and print the path to the database + = Check [FilePath] -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures | Db FilePath HieDb.Options HieDb.Command -- ^ Run a command in the hiedb + | Index [FilePath] -- ^ Index all the targets and print the path to the database + | LSP -- ^ Run the LSP server + deriving Show + +-- TODO move these to hiedb +deriving instance Show HieDb.Command +deriving instance Show HieDb.Options + +isLSP :: Command -> Bool +isLSP LSP = True +isLSP _ = False + +commandP :: Parser Command +commandP = hsubparser (command "typecheck" (info (Check <$> fileCmd) fileInfo) + <> command "hiedb" (info (Db "." <$> HieDb.optParser "" True <*> HieDb.cmdParser <**> helper) hieInfo) + <> command "index" (info (Index <$> fileCmd) indexInfo) + <> command "lsp" (info (pure LSP <**> helper) lspInfo) + ) + where + fileCmd = many (argument str (metavar "FILES/DIRS...")) + lspInfo = fullDesc <> progDesc "Start talking to an LSP client" + fileInfo = fullDesc <> progDesc "Used as a test bed to check your IDE will work" + hieInfo = fullDesc <> progDesc "Query .hie files" + indexInfo = fullDesc <> progDesc "Load the given files and index all the known targets" + data Arguments = Arguments { argsOTMemoryProfiling :: Bool @@ -118,7 +145,7 @@ data Arguments = Arguments instance Default Arguments where def = Arguments { argsOTMemoryProfiling = False - , argCommand = Lsp + , argCommand = LSP , argsLogger = stderrLogger , argsRules = mainRule >> action kick , argsGhcidePlugin = mempty @@ -172,7 +199,7 @@ defaultMain Arguments{..} = do outH <- argsHandleOut case argCommand of - Lsp -> do + LSP -> do t <- offsetTime hPutStrLn stderr "Starting LSP server..." hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" diff --git a/src/Ide/Arguments.hs b/src/Ide/Arguments.hs index efbae93621..a8781152d8 100644 --- a/src/Ide/Arguments.hs +++ b/src/Ide/Arguments.hs @@ -8,7 +8,7 @@ module Ide.Arguments ( Arguments(..) - , LspArguments(..) + , GhcideArguments(..) , PrintVersion(..) , getArguments , haskellLanguageServerVersion @@ -17,7 +17,7 @@ module Ide.Arguments import Data.Version import Development.GitRev -import HieDb.Run +import Development.IDE.Main (Command (..), commandP) import Options.Applicative import Paths_haskell_language_server import System.Environment @@ -27,15 +27,13 @@ import System.Environment data Arguments = VersionMode PrintVersion | ProbeToolsMode - | DbCmd Options Command - | LspMode LspArguments + | Ghcide GhcideArguments | VSCodeExtensionSchemaMode | DefaultConfigurationMode -data LspArguments = LspArguments - {argLSP :: Bool +data GhcideArguments = GhcideArguments + {argsCommand :: Command ,argsCwd :: Maybe FilePath - ,argFiles :: [FilePath] ,argsShakeProfiling :: Maybe FilePath ,argsTesting :: Bool ,argsExamplePlugin :: Bool @@ -55,12 +53,10 @@ data PrintVersion getArguments :: String -> IO Arguments getArguments exeName = execParser opts where - hieInfo = fullDesc <> progDesc "Query .hie files" opts = info (( VersionMode <$> printVersionParser exeName <|> probeToolsParser exeName - <|> hsubparser (command "hiedb" (info (DbCmd <$> optParser "" True <*> cmdParser <**> helper) hieInfo)) - <|> LspMode <$> arguments + <|> Ghcide <$> arguments <|> vsCodeExtensionSchemaModeParser <|> defaultConfigurationModeParser) <**> helper) @@ -91,12 +87,11 @@ defaultConfigurationModeParser = flag' DefaultConfigurationMode (long "generate-default-config" <> help "Print config supported by the server with default values") -arguments :: Parser LspArguments -arguments = LspArguments - <$> switch (long "lsp" <> help "Start talking to an LSP server") +arguments :: Parser GhcideArguments +arguments = GhcideArguments + <$> (commandP <|> lspCommand <|> checkCommand) <*> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory") - <*> many (argument str (metavar "FILES/DIRS...")) <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory") <*> switch (long "test" @@ -124,6 +119,9 @@ arguments = LspArguments ) <*> switch (long "project-ghc-version" <> help "Work out the project GHC version and print it") + where + lspCommand = LSP <$ switch (long "lsp" <> help "Start talking to an LSP server") + checkCommand = Check <$> many (argument str (metavar "FILES/DIRS...")) -- --------------------------------------------------------------------- diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 030bfbd13f..d70ff3c0b4 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -15,12 +15,11 @@ import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Default import qualified Data.Text as T import Development.IDE.Core.Rules +import Development.IDE.Main (isLSP) import qualified Development.IDE.Main as Main -import Development.IDE.Session (getHieDbLoc, setInitialDynFlags) import Development.IDE.Types.Logger as G import qualified Development.IDE.Types.Options as Ghcide import Development.Shake (ShakeOptions (shakeThreads)) -import HieDb.Run import Ide.Arguments import Ide.Logger import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, @@ -29,7 +28,6 @@ import Ide.Types (IdePlugins, ipMap) import Ide.Version import qualified Language.LSP.Server as LSP import qualified System.Directory.Extra as IO -import System.Exit import System.IO import qualified System.Log.Logger as L @@ -52,20 +50,10 @@ defaultMain args idePlugins = do VersionMode PrintNumericVersion -> putStrLn haskellLanguageServerNumericVersion - DbCmd opts cmd -> do - dir <- IO.getCurrentDirectory - dbLoc <- getHieDbLoc dir - hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc - mlibdir <- setInitialDynFlags def - case mlibdir of - Nothing -> exitWith $ ExitFailure 1 - Just libdir -> - runCommand libdir opts{database = dbLoc} cmd - - LspMode lspArgs -> do + Ghcide ghcideArgs -> do {- see WARNING above -} hPutStrLn stderr hlsVer - runLspMode lspArgs idePlugins + runLspMode ghcideArgs idePlugins VSCodeExtensionSchemaMode -> do LBS.putStrLn $ A.encodePretty $ pluginsToVSCodeExtensionSchema idePlugins @@ -86,22 +74,22 @@ hlsLogger = G.Logger $ \pri txt -> -- --------------------------------------------------------------------- -runLspMode :: LspArguments -> IdePlugins IdeState -> IO () -runLspMode lspArgs@LspArguments{..} idePlugins = do +runLspMode :: GhcideArguments -> IdePlugins IdeState -> IO () +runLspMode ghcideArgs@GhcideArguments{..} idePlugins = do whenJust argsCwd IO.setCurrentDirectory dir <- IO.getCurrentDirectory LSP.setupLogger argsLogFile ["hls", "hie-bios"] $ if argsDebugOn then L.DEBUG else L.INFO - when argLSP $ do + when (isLSP argsCommand) $ do hPutStrLn stderr "Starting (haskell-language-server)LSP server..." - hPutStrLn stderr $ " with arguments: " <> show lspArgs + hPutStrLn stderr $ " with arguments: " <> show ghcideArgs hPutStrLn stderr $ " with plugins: " <> show (map fst $ ipMap idePlugins) hPutStrLn stderr $ " in directory: " <> dir hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" Main.defaultMain def - { Main.argCommand = if argLSP then Main.Lsp else Main.Check argFiles + { Main.argCommand = argsCommand , Main.argsHlsPlugins = idePlugins , Main.argsLogger = pure hlsLogger , Main.argsIdeOptions = \_config sessionLoader -> From f02a0a8f40db2656b5cf99f5028cf32a66b7d6d0 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 5 Apr 2021 09:46:20 +0100 Subject: [PATCH 06/10] Fix verbosity --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index e72bf3e7eb..4877b7b7b8 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -190,7 +190,7 @@ rules plugin = do getIdeas :: NormalizedFilePath -> Action (Either ParseError [Idea]) getIdeas nfp = do - logm $ "hlint:getIdeas:file:" ++ show nfp + debugm $ "hlint:getIdeas:file:" ++ show nfp (flags, classify, hint) <- useNoFile_ GetHlintSettings let applyHints' (Just (Right modEx)) = Right $ applyHints classify hint [modEx] @@ -222,7 +222,7 @@ getIdeas nfp = do setExtensions flags = do hlintExts <- getExtensions flags nfp - logm $ "hlint:getIdeas:setExtensions:" ++ show hlintExts + debugm $ "hlint:getIdeas:setExtensions:" ++ show hlintExts return $ flags { enabledExtensions = hlintExts } getExtensions :: ParseFlags -> NormalizedFilePath -> Action [Extension] From 63917ccded3449e3961509db4e2def524127cdbc Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 5 Apr 2021 13:12:57 +0100 Subject: [PATCH 07/10] Fix Wrapper --- exe/Wrapper.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 975492f249..baa7d99764 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -49,8 +49,8 @@ main = do launchHaskellLanguageServer :: Arguments -> IO () launchHaskellLanguageServer parsedArgs = do case parsedArgs of - LspMode LspArguments{..} -> whenJust argsCwd setCurrentDirectory - _ -> pure () + Ghcide GhcideArguments{..} -> whenJust argsCwd setCurrentDirectory + _ -> pure () d <- getCurrentDirectory @@ -59,7 +59,7 @@ launchHaskellLanguageServer parsedArgs = do setCurrentDirectory $ cradleRootDir cradle case parsedArgs of - LspMode LspArguments{..} -> + Ghcide GhcideArguments{..} -> when argsProjectGhcVersion $ getRuntimeGhcVersion' cradle >>= putStrLn >> exitSuccess _ -> pure () From b113a6d13daabb4cfc221fa432f304d4ad70ab82 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 5 Apr 2021 17:36:11 +0100 Subject: [PATCH 08/10] Fix tests --- ghcide/test/exe/Main.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 712237a101..e02f13c709 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -36,7 +36,7 @@ import Development.IDE.Core.PositionMapping (PositionResult (..), positionResultToMaybe, toCurrent) import Development.IDE.Core.Shake (Q (..)) -import Development.IDE.Main as IDE +import qualified Development.IDE.Main as IDE import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types (extendImportCommandId) import Development.IDE.Plugin.TypeLenses (typeLensCommandId) @@ -1390,7 +1390,7 @@ extendImportTests = testGroup "extend import actions" ]) , expectFailBecause "importing pattern synonyms is unsupported" $ testSession "extend import list with pattern synonym" $ template - [("ModuleA.hs", T.unlines + [("ModuleA.hs", T.unlines [ "{-# LANGUAGE PatternSynonyms #-}" , "module ModuleA where" , "pattern Some x = Just x" @@ -5294,7 +5294,7 @@ unitTests = do | i <- [(1::Int)..20] ] ++ Ghcide.descriptors - testIde def{argsHlsPlugins = plugins} $ do + testIde def{IDE.argsHlsPlugins = plugins} $ do _ <- createDoc "haskell" "A.hs" "module A where" waitForProgressDone actualOrder <- liftIO $ readIORef orderRef @@ -5302,14 +5302,14 @@ unitTests = do liftIO $ actualOrder @?= reverse [(1::Int)..20] ] -testIde :: Arguments -> Session () -> IO () +testIde :: IDE.Arguments -> Session () -> IO () testIde arguments session = do config <- getConfigFromEnv (hInRead, hInWrite) <- createPipe (hOutRead, hOutWrite) <- createPipe let server = IDE.defaultMain arguments - { argsHandleIn = pure hInRead - , argsHandleOut = pure hOutWrite + { IDE.argsHandleIn = pure hInRead + , IDE.argsHandleOut = pure hOutWrite } withAsync server $ \_ -> From 85bacb198f4041d14b7a09ea50e51f935b9e5416 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 5 Apr 2021 20:28:08 +0100 Subject: [PATCH 09/10] projectRoot --- ghcide/src/Development/IDE/Main.hs | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 02a1ce3637..520c69b857 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -98,8 +98,10 @@ import Text.Printf (printf) data Command = Check [FilePath] -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures - | Db FilePath HieDb.Options HieDb.Command -- ^ Run a command in the hiedb - | Index [FilePath] -- ^ Index all the targets and print the path to the database + | Index {projectRoot :: FilePath, targetsToLoad :: [FilePath]} + -- ^ Index all the targets and print the path to the database + | Db {projectRoot :: FilePath, hieOptions :: HieDb.Options, hieCommand :: HieDb.Command} + -- ^ Run a command in the hiedb | LSP -- ^ Run the LSP server deriving Show @@ -113,10 +115,10 @@ isLSP _ = False commandP :: Parser Command commandP = hsubparser (command "typecheck" (info (Check <$> fileCmd) fileInfo) - <> command "hiedb" (info (Db "." <$> HieDb.optParser "" True <*> HieDb.cmdParser <**> helper) hieInfo) - <> command "index" (info (Index <$> fileCmd) indexInfo) - <> command "lsp" (info (pure LSP <**> helper) lspInfo) - ) + <> command "hiedb" (info (Db "." <$> HieDb.optParser "" True <*> HieDb.cmdParser <**> helper) hieInfo) + <> command "index" (info (Index "." <$> fileCmd) indexInfo) + <> command "lsp" (info (pure LSP <**> helper) lspInfo) + ) where fileCmd = many (argument str (metavar "FILES/DIRS...")) lspInfo = fullDesc <> progDesc "Start talking to an LSP client" @@ -294,9 +296,9 @@ defaultMain Arguments{..} = do measureMemory logger [keys] consoleObserver valuesRef unless (null failed) (exitWith $ ExitFailure (length failed)) - Index argFiles -> do - dbLoc <- getHieDbLoc "." - files <- expandFiles (argFiles ++ ["." | null argFiles]) + Index{..} -> do + dbLoc <- getHieDbLoc projectRoot + files <- expandFiles (targetsToLoad ++ [projectRoot | null targetsToLoad]) runWithDb dbLoc $ \hiedb hieChan -> do vfs <- makeVFSHandle sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions "." From 4542c093998c53bbf9d05cbd6b93a663555aad3c Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 7 Apr 2021 19:12:10 +0100 Subject: [PATCH 10/10] Generalized custom commands --- ghcide/src/Development/IDE/Main.hs | 74 ++++++++++-------------------- 1 file changed, 25 insertions(+), 49 deletions(-) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 520c69b857..7ef9e76df2 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -2,32 +2,28 @@ module Development.IDE.Main (Arguments(..) ,Command(..) +,IdeCommand(..) ,isLSP ,commandP ,defaultMain ) where import Control.Concurrent.Extra (newLock, readVar, withLock) -import Control.Concurrent.STM import Control.Exception.Safe (Exception (displayException), catchAny) import Control.Monad.Extra (concatMapM, unless, when) -import Control.Monad.IO.Class import Data.Default (Default (def)) -import Data.Foldable (toList) import qualified Data.HashMap.Strict as HashMap import Data.Hashable (hashed) import Data.List.Extra (intercalate, isPrefixOf, nub, nubOrd, partition) import Data.Maybe (catMaybes, fromMaybe, - isJust, isNothing) + isJust) import qualified Data.Text as T import qualified Data.Text.IO as T -import Development.IDE (Action, - GetKnownTargets (GetKnownTargets), - GetModIfaceFromDiskAndIndex (GetModIfaceFromDiskAndIndex), - Rules, hDuplicateTo') +import Development.IDE (Action, Rules, + hDuplicateTo') import Development.IDE.Core.Debouncer (Debouncer, newAsyncDebouncer) import Development.IDE.Core.FileStore (makeVFSHandle) @@ -44,11 +40,9 @@ import Development.IDE.Core.RuleTypes (GenerateCore (GenerateCo import Development.IDE.Core.Rules (GhcSessionIO (GhcSessionIO), mainRule) import Development.IDE.Core.Service (initialise, runAction) -import Development.IDE.Core.Shake (HieDbWriter (indexPending), - IdeState (shakeExtras), - ShakeExtras (hiedbWriter, state), - toKnownFiles, - useNoFile_, uses) +import Development.IDE.Core.Shake (IdeState (shakeExtras), + ShakeExtras (state), + uses) import Development.IDE.Core.Tracing (measureMemory) import Development.IDE.LSP.LanguageServer (runLanguageServer) import Development.IDE.Plugin (Plugin (pluginHandlers, pluginRules)) @@ -98,13 +92,16 @@ import Text.Printf (printf) data Command = Check [FilePath] -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures - | Index {projectRoot :: FilePath, targetsToLoad :: [FilePath]} - -- ^ Index all the targets and print the path to the database | Db {projectRoot :: FilePath, hieOptions :: HieDb.Options, hieCommand :: HieDb.Command} -- ^ Run a command in the hiedb | LSP -- ^ Run the LSP server + | Custom {projectRoot :: FilePath, ideCommand :: IdeCommand} -- ^ User defined deriving Show +newtype IdeCommand = IdeCommand (IdeState -> IO ()) + +instance Show IdeCommand where show _ = "" + -- TODO move these to hiedb deriving instance Show HieDb.Command deriving instance Show HieDb.Options @@ -116,7 +113,6 @@ isLSP _ = False commandP :: Parser Command commandP = hsubparser (command "typecheck" (info (Check <$> fileCmd) fileInfo) <> command "hiedb" (info (Db "." <$> HieDb.optParser "" True <*> HieDb.cmdParser <**> helper) hieInfo) - <> command "index" (info (Index "." <$> fileCmd) indexInfo) <> command "lsp" (info (pure LSP <**> helper) lspInfo) ) where @@ -124,7 +120,6 @@ commandP = hsubparser (command "typecheck" (info (Check <$> fileCmd) fileInfo) lspInfo = fullDesc <> progDesc "Start talking to an LSP client" fileInfo = fullDesc <> progDesc "Used as a test bed to check your IDE will work" hieInfo = fullDesc <> progDesc "Query .hie files" - indexInfo = fullDesc <> progDesc "Load the given files and index all the known targets" data Arguments = Arguments @@ -296,38 +291,6 @@ defaultMain Arguments{..} = do measureMemory logger [keys] consoleObserver valuesRef unless (null failed) (exitWith $ ExitFailure (length failed)) - Index{..} -> do - dbLoc <- getHieDbLoc projectRoot - files <- expandFiles (targetsToLoad ++ [projectRoot | null targetsToLoad]) - runWithDb dbLoc $ \hiedb hieChan -> do - vfs <- makeVFSHandle - sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions "." - let options = (argsIdeOptions argsDefaultHlsConfig sessionLoader) - { optCheckParents = pure NeverCheck - , optCheckProject = pure False - } - ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan - registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) - let fois = map toNormalizedFilePath' files - setFilesOfInterest ide $ HashMap.fromList $ map (,OnDisk) fois - results <- runAction "Index" ide $ do - _ <- uses GetModIfaceFromDiskAndIndex fois - allKnownTargets <- toKnownFiles <$> useNoFile_ GetKnownTargets - liftIO $ hPutStrLn stderr $ "Indexing " <> show(length allKnownTargets) <> " targets" - uses GetModIfaceFromDiskAndIndex $ toList allKnownTargets - - hPutStrLn stderr "Writing index... " - - let !nfailures = length $ filter isNothing results - let !pending = indexPending $ hiedbWriter $ shakeExtras ide - - atomically $ do - n <- readTVar pending - unless (HashMap.size n == 0) retry - - putStrLn dbLoc - unless (nfailures == 0) $ exitWith $ ExitFailure nfailures - Db dir opts cmd -> do dbLoc <- getHieDbLoc dir hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc @@ -335,6 +298,19 @@ defaultMain Arguments{..} = do case mlibdir of Nothing -> exitWith $ ExitFailure 1 Just libdir -> HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd + Custom projectRoot (IdeCommand c) -> do + dbLoc <- getHieDbLoc projectRoot + runWithDb dbLoc $ \hiedb hieChan -> do + vfs <- makeVFSHandle + sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions "." + let options = + (argsIdeOptions argsDefaultHlsConfig sessionLoader) + { optCheckParents = pure NeverCheck, + optCheckProject = pure False + } + ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan + registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) + c ide {-# ANN defaultMain ("HLint: ignore Use nubOrd" :: String) #-}