Skip to content

Commit 607ae3b

Browse files
pepeiborrajneira
pepeiborra
and
jneira
authored
support custom Ide commands (#1666)
* Added a command to index the database and exit * WIP wait for it * Load FOIs (otherwise nothing happens) and wait for the hiedb writer * Add a command in ghcide exe * reuse Development.IDE.Main.Command * Fix verbosity * Fix Wrapper * Fix tests * projectRoot * Generalized custom commands Co-authored-by: Javier Neira <atreyu.bbb@gmail.com>
1 parent d5c5874 commit 607ae3b

File tree

10 files changed

+159
-134
lines changed

10 files changed

+159
-134
lines changed

‎exe/Main.hs‎

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,8 @@
44
{-# LANGUAGE RecordWildCards #-}
55
module Main(main) where
66

7-
import Ide.Arguments (Arguments (..), LspArguments (..), getArguments)
7+
import Ide.Arguments (Arguments (..), GhcideArguments (..),
8+
getArguments)
89
import Ide.Main (defaultMain)
910
import Plugins
1011

@@ -14,7 +15,7 @@ main = do
1415

1516
let withExamples =
1617
case args of
17-
LspMode LspArguments{..} -> argsExamplePlugin
18-
_ -> False
18+
Ghcide GhcideArguments{..} -> argsExamplePlugin
19+
_ -> False
1920

2021
defaultMain args (idePlugins withExamples)

‎exe/Wrapper.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -49,8 +49,8 @@ main = do
4949
launchHaskellLanguageServer :: Arguments -> IO ()
5050
launchHaskellLanguageServer parsedArgs = do
5151
case parsedArgs of
52-
LspMode LspArguments{..} -> whenJust argsCwd setCurrentDirectory
53-
_ -> pure ()
52+
Ghcide GhcideArguments{..} -> whenJust argsCwd setCurrentDirectory
53+
_ -> pure ()
5454

5555
d <- getCurrentDirectory
5656

@@ -59,7 +59,7 @@ launchHaskellLanguageServer parsedArgs = do
5959
setCurrentDirectory $ cradleRootDir cradle
6060

6161
case parsedArgs of
62-
LspMode LspArguments{..} ->
62+
Ghcide GhcideArguments{..} ->
6363
when argsProjectGhcVersion $ getRuntimeGhcVersion' cradle >>= putStrLn >> exitSuccess
6464
_ -> pure ()
6565

‎ghcide/exe/Arguments.hs‎

Lines changed: 10 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -1,18 +1,13 @@
11
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
22
-- SPDX-License-Identifier: Apache-2.0
33

4-
module Arguments(Arguments, Arguments'(..), getArguments, IdeCmd(..)) where
4+
module Arguments(Arguments(..), getArguments) where
55

6-
import HieDb.Run
6+
import Development.IDE.Main (Command (..), commandP)
77
import Options.Applicative
88

9-
type Arguments = Arguments' IdeCmd
10-
11-
data IdeCmd = Typecheck [FilePath] | DbCmd Options Command | LSP
12-
13-
data Arguments' a = Arguments
14-
{argLSP :: Bool
15-
,argsCwd :: Maybe FilePath
9+
data Arguments = Arguments
10+
{argsCwd :: Maybe FilePath
1611
,argsVersion :: Bool
1712
,argsVSCodeExtensionSchema :: Bool
1813
,argsDefaultConfig :: Bool
@@ -22,7 +17,7 @@ data Arguments' a = Arguments
2217
,argsDisableKick :: Bool
2318
,argsThreads :: Int
2419
,argsVerbose :: Bool
25-
,argFilesOrCmd :: a
20+
,argsCommand :: Command
2621
}
2722

2823
getArguments :: IO Arguments
@@ -34,8 +29,7 @@ getArguments = execParser opts
3429

3530
arguments :: Parser Arguments
3631
arguments = Arguments
37-
<$> switch (long "lsp" <> help "Start talking to an LSP client")
38-
<*> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory")
32+
<$> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory")
3933
<*> switch (long "version" <> help "Show ghcide and GHC versions")
4034
<*> switch (long "vscode-extension-schema" <> help "Print generic config schema for plugins (used in the package.json of haskell vscode extension)")
4135
<*> switch (long "generate-default-config" <> help "Print config supported by the server with default values")
@@ -45,12 +39,7 @@ arguments = Arguments
4539
<*> switch (long "test-no-kick" <> help "Disable kick. Useful for testing cancellation")
4640
<*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault)
4741
<*> switch (long "verbose" <> help "Include internal events in logging output")
48-
<*> ( hsubparser (command "typecheck" (info (Typecheck <$> fileCmd) fileInfo)
49-
<> command "hiedb" (info (DbCmd <$> optParser "" True <*> cmdParser <**> helper) hieInfo)
50-
<> command "lsp" (info (pure LSP <**> helper) lspInfo) )
51-
<|> Typecheck <$> fileCmd )
52-
where
53-
fileCmd = many (argument str (metavar "FILES/DIRS..."))
54-
lspInfo = fullDesc <> progDesc "Start talking to an LSP client"
55-
fileInfo = fullDesc <> progDesc "Used as a test bed to check your IDE will work"
56-
hieInfo = fullDesc <> progDesc "Query .hie files"
42+
<*> (commandP <|> lspCommand <|> checkCommand)
43+
where
44+
checkCommand = Check <$> many (argument str (metavar "FILES/DIRS..."))
45+
lspCommand = LSP <$ switch (long "lsp" <> help "Start talking to an LSP client")

‎ghcide/exe/Main.hs‎

Lines changed: 43 additions & 59 deletions
Original file line numberDiff line numberDiff line change
@@ -5,8 +5,8 @@
55

66
module Main(main) where
77

8-
import Arguments (Arguments' (..),
9-
IdeCmd (..), getArguments)
8+
import Arguments (Arguments (..),
9+
getArguments)
1010
import Control.Concurrent.Extra (newLock, withLock)
1111
import Control.Monad.Extra (unless, when, whenJust)
1212
import qualified Data.Aeson.Encode.Pretty as A
@@ -22,23 +22,20 @@ import Development.IDE (Logger (Logger),
2222
Priority (Info), action)
2323
import Development.IDE.Core.OfInterest (kick)
2424
import Development.IDE.Core.Rules (mainRule)
25+
import Development.IDE.Main (Command (LSP))
2526
import qualified Development.IDE.Main as Main
2627
import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde
2728
import qualified Development.IDE.Plugin.Test as Test
28-
import Development.IDE.Session (getHieDbLoc,
29-
setInitialDynFlags)
3029
import Development.IDE.Types.Options
3130
import Development.Shake (ShakeOptions (shakeThreads))
32-
import HieDb.Run (Options (..), runCommand)
3331
import Ide.Plugin.Config (Config (checkParents, checkProject))
3432
import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig,
3533
pluginsToVSCodeExtensionSchema)
3634
import Ide.PluginUtils (pluginDescToIdePlugins)
3735
import Paths_ghcide (version)
3836
import qualified System.Directory.Extra as IO
3937
import System.Environment (getExecutablePath)
40-
import System.Exit (ExitCode (ExitFailure),
41-
exitSuccess, exitWith)
38+
import System.Exit (exitSuccess)
4239
import System.IO (hPutStrLn, stderr)
4340
import System.Info (compilerVersion)
4441

@@ -80,56 +77,43 @@ main = do
8077
T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
8178
logLevel = if argsVerbose then minBound else Info
8279

83-
case argFilesOrCmd of
84-
DbCmd opts cmd -> do
85-
dir <- IO.getCurrentDirectory
86-
dbLoc <- getHieDbLoc dir
87-
mlibdir <- setInitialDynFlags def
88-
case mlibdir of
89-
Nothing -> exitWith $ ExitFailure 1
90-
Just libdir -> runCommand libdir opts{database = dbLoc} cmd
91-
92-
_ -> do
93-
94-
case argFilesOrCmd of
95-
LSP -> do
96-
hPutStrLn stderr "Starting LSP server..."
97-
hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
98-
_ -> return ()
99-
100-
Main.defaultMain def
101-
{Main.argFiles = case argFilesOrCmd of
102-
Typecheck x | not argLSP -> Just x
103-
_ -> Nothing
104-
105-
,Main.argsLogger = pure logger
106-
107-
,Main.argsRules = do
108-
-- install the main and ghcide-plugin rules
109-
mainRule
110-
-- install the kick action, which triggers a typecheck on every
111-
-- Shake database restart, i.e. on every user edit.
112-
unless argsDisableKick $
113-
action kick
114-
115-
,Main.argsHlsPlugins =
116-
pluginDescToIdePlugins $
117-
GhcIde.descriptors
118-
++ [Test.blockCommandDescriptor "block-command" | argsTesting]
119-
120-
,Main.argsGhcidePlugin = if argsTesting
121-
then Test.plugin
122-
else mempty
123-
124-
,Main.argsIdeOptions = \config sessionLoader ->
125-
let defOptions = defaultIdeOptions sessionLoader
126-
in defOptions
127-
{ optShakeProfiling = argsShakeProfiling
128-
, optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
129-
, optTesting = IdeTesting argsTesting
130-
, optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}
131-
, optCheckParents = pure $ checkParents config
132-
, optCheckProject = pure $ checkProject config
133-
}
134-
}
80+
case argsCommand of
81+
LSP -> do
82+
hPutStrLn stderr "Starting LSP server..."
83+
hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
84+
_ -> return ()
85+
86+
Main.defaultMain def
87+
{Main.argCommand = argsCommand
88+
89+
,Main.argsLogger = pure logger
90+
91+
,Main.argsRules = do
92+
-- install the main and ghcide-plugin rules
93+
mainRule
94+
-- install the kick action, which triggers a typecheck on every
95+
-- Shake database restart, i.e. on every user edit.
96+
unless argsDisableKick $
97+
action kick
98+
99+
,Main.argsHlsPlugins =
100+
pluginDescToIdePlugins $
101+
GhcIde.descriptors
102+
++ [Test.blockCommandDescriptor "block-command" | argsTesting]
103+
104+
,Main.argsGhcidePlugin = if argsTesting
105+
then Test.plugin
106+
else mempty
107+
108+
,Main.argsIdeOptions = \config sessionLoader ->
109+
let defOptions = defaultIdeOptions sessionLoader
110+
in defOptions
111+
{ optShakeProfiling = argsShakeProfiling
112+
, optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
113+
, optTesting = IdeTesting argsTesting
114+
, optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}
115+
, optCheckParents = pure $ checkParents config
116+
, optCheckProject = pure $ checkProject config
117+
}
118+
}
135119

‎ghcide/ghcide.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -64,6 +64,7 @@ library
6464
lsp == 1.2.*,
6565
mtl,
6666
network-uri,
67+
optparse-applicative,
6768
parallel,
6869
prettyprinter-ansi-terminal,
6970
prettyprinter-ansi-terminal,

‎ghcide/src/Development/IDE/Main.hs‎

Lines changed: 70 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,12 @@
1-
module Development.IDE.Main (Arguments(..), defaultMain) where
1+
{-# OPTIONS_GHC -Wno-orphans #-}
2+
module Development.IDE.Main
3+
(Arguments(..)
4+
,Command(..)
5+
,IdeCommand(..)
6+
,isLSP
7+
,commandP
8+
,defaultMain
9+
) where
210
import Control.Concurrent.Extra (newLock, readVar,
311
withLock)
412
import Control.Exception.Safe (Exception (displayException),
@@ -57,6 +65,7 @@ import Development.Shake (action)
5765
import GHC.IO.Encoding (setLocaleEncoding)
5866
import GHC.IO.Handle (hDuplicate)
5967
import HIE.Bios.Cradle (findCradle)
68+
import qualified HieDb.Run as HieDb
6069
import Ide.Plugin.Config (CheckParents (NeverCheck),
6170
Config,
6271
getConfigFromNotification)
@@ -65,6 +74,7 @@ import Ide.PluginUtils (allLspCmdIds',
6574
pluginDescToIdePlugins)
6675
import Ide.Types (IdePlugins)
6776
import qualified Language.LSP.Server as LSP
77+
import Options.Applicative hiding (action)
6878
import qualified System.Directory.Extra as IO
6979
import System.Exit (ExitCode (ExitFailure),
7080
exitWith)
@@ -80,9 +90,41 @@ import System.Time.Extra (offsetTime,
8090
showDuration)
8191
import Text.Printf (printf)
8292

93+
data Command
94+
= Check [FilePath] -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures
95+
| Db {projectRoot :: FilePath, hieOptions :: HieDb.Options, hieCommand :: HieDb.Command}
96+
-- ^ Run a command in the hiedb
97+
| LSP -- ^ Run the LSP server
98+
| Custom {projectRoot :: FilePath, ideCommand :: IdeCommand} -- ^ User defined
99+
deriving Show
100+
101+
newtype IdeCommand = IdeCommand (IdeState -> IO ())
102+
103+
instance Show IdeCommand where show _ = "<ide command>"
104+
105+
-- TODO move these to hiedb
106+
deriving instance Show HieDb.Command
107+
deriving instance Show HieDb.Options
108+
109+
isLSP :: Command -> Bool
110+
isLSP LSP = True
111+
isLSP _ = False
112+
113+
commandP :: Parser Command
114+
commandP = hsubparser (command "typecheck" (info (Check <$> fileCmd) fileInfo)
115+
<> command "hiedb" (info (Db "." <$> HieDb.optParser "" True <*> HieDb.cmdParser <**> helper) hieInfo)
116+
<> command "lsp" (info (pure LSP <**> helper) lspInfo)
117+
)
118+
where
119+
fileCmd = many (argument str (metavar "FILES/DIRS..."))
120+
lspInfo = fullDesc <> progDesc "Start talking to an LSP client"
121+
fileInfo = fullDesc <> progDesc "Used as a test bed to check your IDE will work"
122+
hieInfo = fullDesc <> progDesc "Query .hie files"
123+
124+
83125
data Arguments = Arguments
84126
{ argsOTMemoryProfiling :: Bool
85-
, argFiles :: Maybe [FilePath] -- ^ Nothing: lsp server ; Just: typecheck and exit
127+
, argCommand :: Command
86128
, argsLogger :: IO Logger
87129
, argsRules :: Rules ()
88130
, argsHlsPlugins :: IdePlugins IdeState
@@ -100,7 +142,7 @@ data Arguments = Arguments
100142
instance Default Arguments where
101143
def = Arguments
102144
{ argsOTMemoryProfiling = False
103-
, argFiles = Nothing
145+
, argCommand = LSP
104146
, argsLogger = stderrLogger
105147
, argsRules = mainRule >> action kick
106148
, argsGhcidePlugin = mempty
@@ -153,8 +195,8 @@ defaultMain Arguments{..} = do
153195
inH <- argsHandleIn
154196
outH <- argsHandleOut
155197

156-
case argFiles of
157-
Nothing -> do
198+
case argCommand of
199+
LSP -> do
158200
t <- offsetTime
159201
hPutStrLn stderr "Starting LSP server..."
160202
hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
@@ -188,7 +230,7 @@ defaultMain Arguments{..} = do
188230
vfs
189231
hiedb
190232
hieChan
191-
Just argFiles -> do
233+
Check argFiles -> do
192234
dir <- IO.getCurrentDirectory
193235
dbLoc <- getHieDbLoc dir
194236
runWithDb dbLoc $ \hiedb hieChan -> do
@@ -249,8 +291,30 @@ defaultMain Arguments{..} = do
249291
measureMemory logger [keys] consoleObserver valuesRef
250292

251293
unless (null failed) (exitWith $ ExitFailure (length failed))
294+
Db dir opts cmd -> do
295+
dbLoc <- getHieDbLoc dir
296+
hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc
297+
mlibdir <- setInitialDynFlags def
298+
case mlibdir of
299+
Nothing -> exitWith $ ExitFailure 1
300+
Just libdir -> HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd
301+
Custom projectRoot (IdeCommand c) -> do
302+
dbLoc <- getHieDbLoc projectRoot
303+
runWithDb dbLoc $ \hiedb hieChan -> do
304+
vfs <- makeVFSHandle
305+
sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions "."
306+
let options =
307+
(argsIdeOptions argsDefaultHlsConfig sessionLoader)
308+
{ optCheckParents = pure NeverCheck,
309+
optCheckProject = pure False
310+
}
311+
ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan
312+
registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)
313+
c ide
314+
252315
{-# ANN defaultMain ("HLint: ignore Use nubOrd" :: String) #-}
253316

317+
254318
expandFiles :: [FilePath] -> IO [FilePath]
255319
expandFiles = concatMapM $ \x -> do
256320
b <- IO.doesFileExist x

0 commit comments

Comments
 (0)