Skip to content

Commit 5471382

Browse files
pepeiborrapepeiborra
authored
Allow HLS plugins to declare cli commands (#1999)
* turn into subcommands and move to Default.Main * remove redundant logger * fixup subcommands * HLS plugin cli commands * Add an example * print -> putStrLn
1 parent ce15ff6 commit 5471382

File tree

10 files changed

+90
-81
lines changed

10 files changed

+90
-81
lines changed

‎exe/Main.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,7 @@ import Plugins
1111

1212
main :: IO ()
1313
main = do
14-
args <- getArguments "haskell-language-server"
14+
args <- getArguments "haskell-language-server" (idePlugins False)
1515

1616
let withExamples =
1717
case args of

‎exe/Wrapper.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -27,7 +27,7 @@ main :: IO ()
2727
main = do
2828
-- WARNING: If you write to stdout before runLanguageServer
2929
-- then the language server will not work
30-
args <- getArguments "haskell-language-server-wrapper"
30+
args <- getArguments "haskell-language-server-wrapper" mempty
3131

3232
hlsVer <- haskellLanguageServerVersion
3333
case args of

‎ghcide/exe/Arguments.hs‎

Lines changed: 17 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -3,43 +3,41 @@
33

44
module Arguments(Arguments(..), getArguments) where
55

6+
import Development.IDE (IdeState)
67
import Development.IDE.Main (Command (..), commandP)
8+
import Ide.Types (IdePlugins)
79
import Options.Applicative
810

911
data Arguments = Arguments
10-
{argsCwd :: Maybe FilePath
11-
,argsVersion :: Bool
12-
,argsVSCodeExtensionSchema :: Bool
13-
,argsDefaultConfig :: Bool
14-
,argsShakeProfiling :: Maybe FilePath
15-
,argsOTMemoryProfiling :: Bool
16-
,argsTesting :: Bool
17-
,argsDisableKick :: Bool
18-
,argsThreads :: Int
19-
,argsVerbose :: Bool
20-
,argsCommand :: Command
12+
{argsCwd :: Maybe FilePath
13+
,argsVersion :: Bool
14+
,argsShakeProfiling :: Maybe FilePath
15+
,argsOTMemoryProfiling :: Bool
16+
,argsTesting :: Bool
17+
,argsDisableKick :: Bool
18+
,argsThreads :: Int
19+
,argsVerbose :: Bool
20+
,argsCommand :: Command
2121
}
2222

23-
getArguments :: IO Arguments
24-
getArguments = execParser opts
23+
getArguments :: IdePlugins IdeState -> IO Arguments
24+
getArguments plugins = execParser opts
2525
where
26-
opts = info (arguments <**> helper)
26+
opts = info (arguments plugins <**> helper)
2727
( fullDesc
2828
<> header "ghcide - the core of a Haskell IDE")
2929

30-
arguments :: Parser Arguments
31-
arguments = Arguments
30+
arguments :: IdePlugins IdeState -> Parser Arguments
31+
arguments plugins = Arguments
3232
<$> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory")
3333
<*> switch (long "version" <> help "Show ghcide and GHC versions")
34-
<*> switch (long "vscode-extension-schema" <> help "Print generic config schema for plugins (used in the package.json of haskell vscode extension)")
35-
<*> switch (long "generate-default-config" <> help "Print config supported by the server with default values")
3634
<*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")
3735
<*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect")
3836
<*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite")
3937
<*> switch (long "test-no-kick" <> help "Disable kick. Useful for testing cancellation")
4038
<*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault)
4139
<*> switch (long "verbose" <> help "Include internal events in logging output")
42-
<*> (commandP <|> lspCommand <|> checkCommand)
40+
<*> (commandP plugins <|> lspCommand <|> checkCommand)
4341
where
4442
checkCommand = Check <$> many (argument str (metavar "FILES/DIRS..."))
4543
lspCommand = LSP <$ flag' True (long "lsp" <> help "Start talking to an LSP client")

‎ghcide/exe/Main.hs‎

Lines changed: 4 additions & 31 deletions
Original file line numberDiff line numberDiff line change
@@ -7,19 +7,11 @@ module Main(main) where
77

88
import Arguments (Arguments (..),
99
getArguments)
10-
import Control.Concurrent.Extra (newLock, withLock)
11-
import Control.Monad.Extra (unless, when, whenJust)
12-
import qualified Data.Aeson.Encode.Pretty as A
10+
import Control.Monad.Extra (unless, whenJust)
1311
import Data.Default (Default (def))
14-
import Data.List.Extra (upper)
15-
import qualified Data.Text as T
16-
import qualified Data.Text.IO as T
17-
import Data.Text.Lazy.Encoding (decodeUtf8)
18-
import qualified Data.Text.Lazy.IO as LT
1912
import Data.Version (showVersion)
2013
import Development.GitRev (gitHash)
21-
import Development.IDE (Logger (Logger),
22-
Priority (Info), action)
14+
import Development.IDE (action)
2315
import Development.IDE.Core.OfInterest (kick)
2416
import Development.IDE.Core.Rules (mainRule)
2517
import Development.IDE.Graph (ShakeOptions (shakeThreads))
@@ -28,8 +20,6 @@ import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde
2820
import qualified Development.IDE.Plugin.Test as Test
2921
import Development.IDE.Types.Options
3022
import Ide.Plugin.Config (Config (checkParents, checkProject))
31-
import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig,
32-
pluginsToVSCodeExtensionSchema)
3323
import Ide.PluginUtils (pluginDescToIdePlugins)
3424
import Paths_ghcide (version)
3525
import qualified System.Directory.Extra as IO
@@ -51,36 +41,19 @@ ghcideVersion = do
5141

5242
main :: IO ()
5343
main = do
44+
let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors
5445
-- WARNING: If you write to stdout before runLanguageServer
5546
-- then the language server will not work
56-
Arguments{..} <- getArguments
47+
Arguments{..} <- getArguments hlsPlugins
5748

5849
if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess
5950
else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion
6051

61-
let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors
62-
63-
when argsVSCodeExtensionSchema $ do
64-
LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToVSCodeExtensionSchema hlsPlugins
65-
exitSuccess
66-
67-
when argsDefaultConfig $ do
68-
LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig hlsPlugins
69-
exitSuccess
70-
7152
whenJust argsCwd IO.setCurrentDirectory
7253

73-
-- lock to avoid overlapping output on stdout
74-
lock <- newLock
75-
let logger = Logger $ \pri msg -> when (pri >= logLevel) $ withLock lock $
76-
T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
77-
logLevel = if argsVerbose then minBound else Info
78-
7954
Main.defaultMain def
8055
{Main.argCommand = argsCommand
8156

82-
,Main.argsLogger = pure logger
83-
8457
,Main.argsRules = do
8558
-- install the main and ghcide-plugin rules
8659
mainRule

‎ghcide/ghcide.cabal‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -34,6 +34,7 @@ library
3434
default-language: Haskell2010
3535
build-depends:
3636
aeson,
37+
aeson-pretty,
3738
array,
3839
async,
3940
base == 4.*,
@@ -286,7 +287,6 @@ executable ghcide
286287
hls-graph,
287288
text,
288289
unordered-containers,
289-
aeson-pretty
290290
other-modules:
291291
Arguments
292292
Paths_ghcide

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

Lines changed: 38 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,7 @@ import Control.Exception.Safe (Exception (displayExcept
1313
catchAny)
1414
import Control.Monad.Extra (concatMapM, unless,
1515
when)
16+
import qualified Data.Aeson.Encode.Pretty as A
1617
import Data.Default (Default (def))
1718
import Data.Foldable (traverse_)
1819
import qualified Data.HashMap.Strict as HashMap
@@ -22,6 +23,8 @@ import Data.List.Extra (intercalate, isPrefixOf,
2223
import Data.Maybe (catMaybes, isJust)
2324
import qualified Data.Text as T
2425
import qualified Data.Text.IO as T
26+
import Data.Text.Lazy.Encoding (decodeUtf8)
27+
import qualified Data.Text.Lazy.IO as LT
2528
import Development.IDE (Action, Rules,
2629
hDuplicateTo')
2730
import Development.IDE.Core.Debouncer (Debouncer,
@@ -71,10 +74,16 @@ import qualified HieDb.Run as HieDb
7174
import Ide.Plugin.Config (CheckParents (NeverCheck),
7275
Config,
7376
getConfigFromNotification)
77+
import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig,
78+
pluginsToVSCodeExtensionSchema)
7479
import Ide.PluginUtils (allLspCmdIds',
7580
getProcessID,
7681
pluginDescToIdePlugins)
77-
import Ide.Types (IdePlugins)
82+
import Ide.Types (IdeCommand (IdeCommand),
83+
IdePlugins,
84+
PluginDescriptor (PluginDescriptor, pluginCli),
85+
PluginId (PluginId),
86+
ipMap)
7887
import qualified Language.LSP.Server as LSP
7988
import Options.Applicative hiding (action)
8089
import qualified System.Directory.Extra as IO
@@ -97,12 +106,11 @@ data Command
97106
| Db {projectRoot :: FilePath, hieOptions :: HieDb.Options, hieCommand :: HieDb.Command}
98107
-- ^ Run a command in the hiedb
99108
| LSP -- ^ Run the LSP server
100-
| Custom {projectRoot :: FilePath, ideCommand :: IdeCommand} -- ^ User defined
109+
| PrintExtensionSchema
110+
| PrintDefaultConfig
111+
| Custom {projectRoot :: FilePath, ideCommand :: IdeCommand IdeState} -- ^ User defined
101112
deriving Show
102113

103-
newtype IdeCommand = IdeCommand (IdeState -> IO ())
104-
105-
instance Show IdeCommand where show _ = "<ide command>"
106114

107115
-- TODO move these to hiedb
108116
deriving instance Show HieDb.Command
@@ -112,16 +120,31 @@ isLSP :: Command -> Bool
112120
isLSP LSP = True
113121
isLSP _ = False
114122

115-
commandP :: Parser Command
116-
commandP = hsubparser (command "typecheck" (info (Check <$> fileCmd) fileInfo)
117-
<> command "hiedb" (info (Db "." <$> HieDb.optParser "" True <*> HieDb.cmdParser <**> helper) hieInfo)
118-
<> command "lsp" (info (pure LSP <**> helper) lspInfo)
119-
)
123+
commandP :: IdePlugins IdeState -> Parser Command
124+
commandP plugins =
125+
hsubparser(command "typecheck" (info (Check <$> fileCmd) fileInfo)
126+
<> command "hiedb" (info (Db "." <$> HieDb.optParser "" True <*> HieDb.cmdParser <**> helper) hieInfo)
127+
<> command "lsp" (info (pure LSP <**> helper) lspInfo)
128+
<> command "vscode-extension-schema" extensionSchemaCommand
129+
<> command "generate-default-config" generateDefaultConfigCommand
130+
<> pluginCommands
131+
)
120132
where
121133
fileCmd = many (argument str (metavar "FILES/DIRS..."))
122134
lspInfo = fullDesc <> progDesc "Start talking to an LSP client"
123135
fileInfo = fullDesc <> progDesc "Used as a test bed to check your IDE will work"
124136
hieInfo = fullDesc <> progDesc "Query .hie files"
137+
extensionSchemaCommand =
138+
info (pure PrintExtensionSchema)
139+
(fullDesc <> progDesc "Print generic config schema for plugins (used in the package.json of haskell vscode extension)")
140+
generateDefaultConfigCommand =
141+
info (pure PrintDefaultConfig)
142+
(fullDesc <> progDesc "Print config supported by the server with default values")
143+
144+
pluginCommands = mconcat
145+
[ command (T.unpack pId) (Custom "." <$> p)
146+
| (PluginId pId, PluginDescriptor{pluginCli = Just p}) <- ipMap plugins
147+
]
125148

126149

127150
data Arguments = Arguments
@@ -198,6 +221,10 @@ defaultMain Arguments{..} = do
198221
outH <- argsHandleOut
199222

200223
case argCommand of
224+
PrintExtensionSchema ->
225+
LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToVSCodeExtensionSchema argsHlsPlugins
226+
PrintDefaultConfig ->
227+
LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig argsHlsPlugins
201228
LSP -> do
202229
t <- offsetTime
203230
hPutStrLn stderr "Starting LSP server..."
@@ -310,6 +337,7 @@ defaultMain Arguments{..} = do
310337
case mlibdir of
311338
Nothing -> exitWith $ ExitFailure 1
312339
Just libdir -> HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd
340+
313341
Custom projectRoot (IdeCommand c) -> do
314342
dbLoc <- getHieDbLoc projectRoot
315343
runWithDb dbLoc $ \hiedb hieChan -> do

‎hls-plugin-api/hls-plugin-api.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -55,6 +55,7 @@ library
5555
, hls-graph ^>=1.4
5656
, text
5757
, unordered-containers
58+
, optparse-applicative
5859

5960
if os(windows)
6061
build-depends: Win32

‎hls-plugin-api/src/Ide/Types.hs‎

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,9 +4,11 @@
44
{-# LANGUAGE DefaultSignatures #-}
55
{-# LANGUAGE DeriveAnyClass #-}
66
{-# LANGUAGE DeriveGeneric #-}
7+
{-# LANGUAGE DerivingStrategies #-}
78
{-# LANGUAGE FlexibleContexts #-}
89
{-# LANGUAGE FlexibleInstances #-}
910
{-# LANGUAGE GADTs #-}
11+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1012
{-# LANGUAGE OverloadedStrings #-}
1113
{-# LANGUAGE PolyKinds #-}
1214
{-# LANGUAGE ScopedTypeVariables #-}
@@ -49,13 +51,15 @@ import Language.LSP.Types.Capabilities
4951
import Language.LSP.Types.Lens as J hiding (id)
5052
import Language.LSP.VFS
5153
import OpenTelemetry.Eventlog
54+
import Options.Applicative (ParserInfo)
5255
import System.IO.Unsafe
5356
import Text.Regex.TDFA.Text ()
5457

5558
-- ---------------------------------------------------------------------
5659

5760
newtype IdePlugins ideState = IdePlugins
5861
{ ipMap :: [(PluginId, PluginDescriptor ideState)]}
62+
deriving newtype (Monoid, Semigroup)
5963

6064
-- | Hooks for modifying the 'DynFlags' at different times of the compilation
6165
-- process. Plugins can install a 'DynFlagsModifications' via
@@ -80,6 +84,10 @@ instance Semigroup DynFlagsModifications where
8084
instance Monoid DynFlagsModifications where
8185
mempty = DynFlagsModifications id id
8286

87+
-- ---------------------------------------------------------------------
88+
89+
newtype IdeCommand state = IdeCommand (state -> IO ())
90+
instance Show (IdeCommand st) where show _ = "<ide command>"
8391

8492
-- ---------------------------------------------------------------------
8593

@@ -91,6 +99,7 @@ data PluginDescriptor ideState =
9199
, pluginConfigDescriptor :: ConfigDescriptor
92100
, pluginNotificationHandlers :: PluginNotificationHandlers ideState
93101
, pluginModifyDynflags :: DynFlagsModifications
102+
, pluginCli :: Maybe (ParserInfo (IdeCommand ideState))
94103
}
95104

96105
-- | An existential wrapper of 'Properties'
@@ -324,6 +333,7 @@ defaultPluginDescriptor plId =
324333
defaultConfigDescriptor
325334
mempty
326335
mempty
336+
Nothing
327337

328338
newtype CommandId = CommandId T.Text
329339
deriving (Show, Read, Eq, Ord)
@@ -446,6 +456,8 @@ instance HasTracing WorkspaceSymbolParams where
446456
-- ---------------------------------------------------------------------
447457

448458
{-# NOINLINE pROCESS_ID #-}
459+
{-# LANGUAGE DerivingStrategies #-}
460+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
449461
pROCESS_ID :: T.Text
450462
pROCESS_ID = unsafePerformIO getPid
451463

‎plugins/default/src/Ide/Plugin/Example.hs‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -33,6 +33,7 @@ import Ide.PluginUtils
3333
import Ide.Types
3434
import Language.LSP.Server
3535
import Language.LSP.Types
36+
import Options.Applicative (ParserInfo, info)
3637
import Text.Regex.TDFA.Text ()
3738

3839
-- ---------------------------------------------------------------------
@@ -46,8 +47,13 @@ descriptor plId = (defaultPluginDescriptor plId)
4647
<> mkPluginHandler STextDocumentHover hover
4748
<> mkPluginHandler STextDocumentDocumentSymbol symbols
4849
<> mkPluginHandler STextDocumentCompletion completion
50+
, pluginCli = Just exampleCli
4951
}
5052

53+
exampleCli :: ParserInfo (IdeCommand IdeState)
54+
exampleCli = info p mempty
55+
where p = pure $ IdeCommand $ \_ideState -> putStrLn "hello HLS"
56+
5157
-- ---------------------------------------------------------------------
5258

5359
hover :: PluginMethodHandler IdeState TextDocumentHover

0 commit comments

Comments
 (0)