Allow HLS plugins to declare cli commands

exe/Main.hs

@@ -11,7 +11,7 @@ import           Plugins
 
 main :: IO ()
 main = do
-    args <- getArguments "haskell-language-server"
+    args <- getArguments "haskell-language-server" (idePlugins False)
 
     let withExamples =
             case args of

exe/Wrapper.hs

@@ -27,7 +27,7 @@ main :: IO ()
 main = do
   -- WARNING: If you write to stdout before runLanguageServer
   --          then the language server will not work
-  args <- getArguments "haskell-language-server-wrapper"
+  args <- getArguments "haskell-language-server-wrapper" mempty
 
   hlsVer <- haskellLanguageServerVersion
   case args of

ghcide/exe/Arguments.hs

@@ -3,43 +3,41 @@
 
 module Arguments(Arguments(..), getArguments) where
 
+import           Development.IDE      (IdeState)
 import           Development.IDE.Main (Command (..), commandP)
+import           Ide.Types            (IdePlugins)
 import           Options.Applicative
 
 data Arguments = Arguments
-    {argsCwd                   :: Maybe FilePath
-    ,argsVersion               :: Bool
-    ,argsVSCodeExtensionSchema :: Bool
-    ,argsDefaultConfig         :: Bool
-    ,argsShakeProfiling        :: Maybe FilePath
-    ,argsOTMemoryProfiling     :: Bool
-    ,argsTesting               :: Bool
-    ,argsDisableKick           :: Bool
-    ,argsThreads               :: Int
-    ,argsVerbose               :: Bool
-    ,argsCommand               :: Command
+    {argsCwd               :: Maybe FilePath
+    ,argsVersion           :: Bool
+    ,argsShakeProfiling    :: Maybe FilePath
+    ,argsOTMemoryProfiling :: Bool
+    ,argsTesting           :: Bool
+    ,argsDisableKick       :: Bool
+    ,argsThreads           :: Int
+    ,argsVerbose           :: Bool
+    ,argsCommand           :: Command
     }
 
-getArguments :: IO Arguments
-getArguments = execParser opts
+getArguments :: IdePlugins IdeState -> IO Arguments
+getArguments plugins = execParser opts
   where
-    opts = info (arguments <**> helper)
+    opts = info (arguments plugins <**> helper)
       ( fullDesc
      <> header "ghcide - the core of a Haskell IDE")
 
-arguments :: Parser Arguments
-arguments = Arguments
+arguments :: IdePlugins IdeState -> Parser Arguments
+arguments plugins = Arguments
       <$> 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")
       <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")
       <*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect")
       <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite")
       <*> 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")
-      <*> (commandP <|> lspCommand <|> checkCommand)
+      <*> (commandP plugins <|> lspCommand <|> checkCommand)
       where
           checkCommand = Check <$> many (argument str (metavar "FILES/DIRS..."))
           lspCommand = LSP <$ flag' True (long "lsp" <> help "Start talking to an LSP client")

ghcide/exe/Main.hs

@@ -7,19 +7,11 @@ module Main(main) where
 
 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
+import           Control.Monad.Extra               (unless, whenJust)
 import           Data.Default                      (Default (def))
-import           Data.List.Extra                   (upper)
-import qualified Data.Text                         as T
-import qualified Data.Text.IO                      as T
-import           Data.Text.Lazy.Encoding           (decodeUtf8)
-import qualified Data.Text.Lazy.IO                 as LT
 import           Data.Version                      (showVersion)
 import           Development.GitRev                (gitHash)
-import           Development.IDE                   (Logger (Logger),
-                                                    Priority (Info), action)
+import           Development.IDE                   (action)
 import           Development.IDE.Core.OfInterest   (kick)
 import           Development.IDE.Core.Rules        (mainRule)
 import           Development.IDE.Graph             (ShakeOptions (shakeThreads))
@@ -28,8 +20,6 @@ import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde
 import qualified Development.IDE.Plugin.Test       as Test
 import           Development.IDE.Types.Options
 import           Ide.Plugin.Config                 (Config (checkParents, checkProject))
-import           Ide.Plugin.ConfigUtils            (pluginsToDefaultConfig,
-                                                    pluginsToVSCodeExtensionSchema)
 import           Ide.PluginUtils                   (pluginDescToIdePlugins)
 import           Paths_ghcide                      (version)
 import qualified System.Directory.Extra            as IO
@@ -51,36 +41,19 @@ ghcideVersion = do
 
 main :: IO ()
 main = do
+    let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors
     -- WARNING: If you write to stdout before runLanguageServer
     --          then the language server will not work
-    Arguments{..} <- getArguments
+    Arguments{..} <- getArguments hlsPlugins
 
     if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess
     else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion
 
-    let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors
-
-    when argsVSCodeExtensionSchema $ do
-      LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToVSCodeExtensionSchema hlsPlugins
-      exitSuccess
-
-    when argsDefaultConfig $ do
-      LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig hlsPlugins
-      exitSuccess
-
     whenJust argsCwd IO.setCurrentDirectory
 
-    -- lock to avoid overlapping output on stdout
-    lock <- newLock
-    let logger = Logger $ \pri msg -> when (pri >= logLevel) $ withLock lock $
-            T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
-        logLevel = if argsVerbose then minBound else Info
-
     Main.defaultMain def
         {Main.argCommand = argsCommand
 
-        ,Main.argsLogger = pure logger
-
         ,Main.argsRules = do
             -- install the main and ghcide-plugin rules
             mainRule

ghcide/ghcide.cabal

@@ -34,6 +34,7 @@ library
     default-language:   Haskell2010
     build-depends:
         aeson,
+        aeson-pretty,
         array,
         async,
         base == 4.*,
@@ -286,7 +287,6 @@ executable ghcide
         hls-graph,
         text,
         unordered-containers,
-        aeson-pretty
     other-modules:
         Arguments
         Paths_ghcide

ghcide/src/Development/IDE/Main.hs

@@ -13,6 +13,7 @@ import           Control.Exception.Safe                (Exception (displayExcept
                                                         catchAny)
 import           Control.Monad.Extra                   (concatMapM, unless,
                                                         when)
+import qualified Data.Aeson.Encode.Pretty              as A
 import           Data.Default                          (Default (def))
 import           Data.Foldable                         (traverse_)
 import qualified Data.HashMap.Strict                   as HashMap
@@ -22,6 +23,8 @@ import           Data.List.Extra                       (intercalate, isPrefixOf,
 import           Data.Maybe                            (catMaybes, isJust)
 import qualified Data.Text                             as T
 import qualified Data.Text.IO                          as T
+import           Data.Text.Lazy.Encoding               (decodeUtf8)
+import qualified Data.Text.Lazy.IO                     as LT
 import           Development.IDE                       (Action, Rules,
                                                         hDuplicateTo')
 import           Development.IDE.Core.Debouncer        (Debouncer,
@@ -71,10 +74,16 @@ import qualified HieDb.Run                             as HieDb
 import           Ide.Plugin.Config                     (CheckParents (NeverCheck),
                                                         Config,
                                                         getConfigFromNotification)
+import           Ide.Plugin.ConfigUtils                (pluginsToDefaultConfig,
+                                                        pluginsToVSCodeExtensionSchema)
 import           Ide.PluginUtils                       (allLspCmdIds',
                                                         getProcessID,
                                                         pluginDescToIdePlugins)
-import           Ide.Types                             (IdePlugins)
+import           Ide.Types                             (IdeCommand (IdeCommand),
+                                                        IdePlugins,
+                                                        PluginDescriptor (PluginDescriptor, pluginCli),
+                                                        PluginId (PluginId),
+                                                        ipMap)
 import qualified Language.LSP.Server                   as LSP
 import           Options.Applicative                   hiding (action)
 import qualified System.Directory.Extra                as IO
@@ -97,12 +106,11 @@ data Command
     | 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
+    | PrintExtensionSchema
+    | PrintDefaultConfig
+    | Custom {projectRoot :: FilePath, ideCommand :: IdeCommand IdeState} -- ^ User defined
     deriving Show
 
-newtype IdeCommand = IdeCommand (IdeState -> IO ())
-
-instance Show IdeCommand where show _ = "<ide command>"
 
 -- TODO move these to hiedb
 deriving instance Show HieDb.Command
@@ -112,16 +120,31 @@ 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 "lsp" (info (pure LSP <**> helper) lspInfo)
-                    )
+commandP :: IdePlugins IdeState -> Parser Command
+commandP plugins =
+    hsubparser(command "typecheck" (info (Check <$> fileCmd) fileInfo)
+            <> command "hiedb" (info (Db "." <$> HieDb.optParser "" True <*> HieDb.cmdParser <**> helper) hieInfo)
+            <> command "lsp" (info (pure LSP <**> helper) lspInfo)
+            <> command "vscode-extension-schema" extensionSchemaCommand
+            <> command "generate-default-config" generateDefaultConfigCommand
+            <> pluginCommands
+            )
   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"
+    extensionSchemaCommand =
+        info (pure PrintExtensionSchema)
+             (fullDesc <> progDesc "Print generic config schema for plugins (used in the package.json of haskell vscode extension)")
+    generateDefaultConfigCommand =
+        info (pure PrintDefaultConfig)
+             (fullDesc <> progDesc "Print config supported by the server with default values")
+
+    pluginCommands = mconcat
+        [ command (T.unpack pId) (Custom "." <$> p)
+        | (PluginId pId, PluginDescriptor{pluginCli = Just p}) <- ipMap plugins
+        ]
 
 
 data Arguments = Arguments
@@ -198,6 +221,10 @@ defaultMain Arguments{..} = do
     outH <- argsHandleOut
 
     case argCommand of
+        PrintExtensionSchema ->
+            LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToVSCodeExtensionSchema argsHlsPlugins
+        PrintDefaultConfig ->
+            LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig argsHlsPlugins
         LSP -> do
             t <- offsetTime
             hPutStrLn stderr "Starting LSP server..."
@@ -310,6 +337,7 @@ 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

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

@@ -55,6 +55,7 @@ library
     , hls-graph             ^>=1.4
     , text
     , unordered-containers
+    , optparse-applicative
 
   if os(windows)
     build-depends: Win32

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

@@ -4,9 +4,11 @@
 {-# LANGUAGE DefaultSignatures    #-}
 {-# LANGUAGE DeriveAnyClass       #-}
 {-# LANGUAGE DeriveGeneric        #-}
+{-# LANGUAGE DerivingStrategies   #-}
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE GADTs                #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings    #-}
 {-# LANGUAGE PolyKinds            #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
@@ -49,13 +51,15 @@ import           Language.LSP.Types.Capabilities
 import           Language.LSP.Types.Lens         as J hiding (id)
 import           Language.LSP.VFS
 import           OpenTelemetry.Eventlog
+import           Options.Applicative             (ParserInfo)
 import           System.IO.Unsafe
 import           Text.Regex.TDFA.Text            ()
 
 -- ---------------------------------------------------------------------
 
 newtype IdePlugins ideState = IdePlugins
   { ipMap :: [(PluginId, PluginDescriptor ideState)]}
+  deriving newtype (Monoid, Semigroup)
 
 -- | Hooks for modifying the 'DynFlags' at different times of the compilation
 -- process. Plugins can install a 'DynFlagsModifications' via
@@ -80,6 +84,10 @@ instance Semigroup DynFlagsModifications where
 instance Monoid DynFlagsModifications where
   mempty = DynFlagsModifications id id
 
+-- ---------------------------------------------------------------------
+
+newtype IdeCommand state = IdeCommand (state -> IO ())
+instance Show (IdeCommand st) where show _ = "<ide command>"
 
 -- ---------------------------------------------------------------------
 
@@ -91,6 +99,7 @@ data PluginDescriptor ideState =
                    , pluginConfigDescriptor :: ConfigDescriptor
                    , pluginNotificationHandlers :: PluginNotificationHandlers ideState
                    , pluginModifyDynflags :: DynFlagsModifications
+                   , pluginCli            :: Maybe (ParserInfo (IdeCommand ideState))
                    }
 
 -- | An existential wrapper of 'Properties'
@@ -324,6 +333,7 @@ defaultPluginDescriptor plId =
     defaultConfigDescriptor
     mempty
     mempty
+    Nothing
 
 newtype CommandId = CommandId T.Text
   deriving (Show, Read, Eq, Ord)
@@ -446,6 +456,8 @@ instance HasTracing WorkspaceSymbolParams where
 -- ---------------------------------------------------------------------
 
 {-# NOINLINE pROCESS_ID #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 pROCESS_ID :: T.Text
 pROCESS_ID = unsafePerformIO getPid
 

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

@@ -33,6 +33,7 @@ import           Ide.PluginUtils
 import           Ide.Types
 import           Language.LSP.Server
 import           Language.LSP.Types
+import           Options.Applicative        (ParserInfo, info)
 import           Text.Regex.TDFA.Text       ()
 
 -- ---------------------------------------------------------------------
@@ -46,8 +47,13 @@ descriptor plId = (defaultPluginDescriptor plId)
                   <> mkPluginHandler STextDocumentHover          hover
                   <> mkPluginHandler STextDocumentDocumentSymbol symbols
                   <> mkPluginHandler STextDocumentCompletion     completion
+  , pluginCli = Just exampleCli
   }
 
+exampleCli :: ParserInfo (IdeCommand IdeState)
+exampleCli = info p mempty
+  where p = pure $ IdeCommand $ \_ideState -> putStrLn "hello HLS"
+
 -- ---------------------------------------------------------------------
 
 hover :: PluginMethodHandler IdeState TextDocumentHover