diff --git a/exe/Main.hs b/exe/Main.hs index 7c0ef2f90b..e5ba2cb6a7 100644 --- a/exe/Main.hs +++ b/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 diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index c7e1c225b4..2cb2084b0c 100644 --- a/exe/Wrapper.hs +++ b/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 diff --git a/ghcide/exe/Arguments.hs b/ghcide/exe/Arguments.hs index d88225ff5b..9f27265dc2 100644 --- a/ghcide/exe/Arguments.hs +++ b/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") diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 472798e99b..bb3615107d 100644 --- a/ghcide/exe/Main.hs +++ b/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 diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 7183c30493..8141737570 100644 --- a/ghcide/ghcide.cabal +++ b/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 diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 1003b32c6e..818feebef8 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/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 _ = "" -- 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 diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 611ad832c9..c5f002e49c 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/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 diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 00afd5892d..c2c6da2454 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/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,6 +51,7 @@ 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 () @@ -56,6 +59,7 @@ 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 _ = "" -- --------------------------------------------------------------------- @@ -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 diff --git a/plugins/default/src/Ide/Plugin/Example.hs b/plugins/default/src/Ide/Plugin/Example.hs index 39a676dccd..1097c43d0e 100644 --- a/plugins/default/src/Ide/Plugin/Example.hs +++ b/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 diff --git a/src/Ide/Arguments.hs b/src/Ide/Arguments.hs index 4863c8edc1..a7c5433ff5 100644 --- a/src/Ide/Arguments.hs +++ b/src/Ide/Arguments.hs @@ -18,7 +18,9 @@ module Ide.Arguments import Data.Version import Development.GitRev +import Development.IDE (IdeState) import Development.IDE.Main (Command (..), commandP) +import Ide.Types (IdePlugins) import Options.Applicative import Paths_haskell_language_server import System.Environment @@ -56,16 +58,15 @@ data BiosAction = PrintCradleType deriving (Show, Eq, Ord) -getArguments :: String -> IO Arguments -getArguments exeName = execParser opts +getArguments :: String -> IdePlugins IdeState -> IO Arguments +getArguments exeName plugins = execParser opts where opts = info (( VersionMode <$> printVersionParser exeName <|> probeToolsParser exeName <|> BiosMode <$> biosParser - <|> Ghcide <$> arguments - <|> vsCodeExtensionSchemaModeParser - <|> defaultConfigurationModeParser) + <|> Ghcide <$> arguments plugins + ) <**> helper) ( fullDesc <> progDesc "Used as a test bed to check your IDE Client will work" @@ -89,19 +90,9 @@ probeToolsParser exeName = flag' ProbeToolsMode (long "probe-tools" <> help ("Show " ++ exeName ++ " version and other tools of interest")) -vsCodeExtensionSchemaModeParser :: Parser Arguments -vsCodeExtensionSchemaModeParser = - flag' VSCodeExtensionSchemaMode - (long "vscode-extension-schema" <> help "Print generic config schema for plugins (used in the package.json of haskell vscode extension)") - -defaultConfigurationModeParser :: Parser Arguments -defaultConfigurationModeParser = - flag' DefaultConfigurationMode - (long "generate-default-config" <> help "Print config supported by the server with default values") - -arguments :: Parser GhcideArguments -arguments = GhcideArguments - <$> (commandP <|> lspCommand <|> checkCommand) +arguments :: IdePlugins IdeState -> Parser GhcideArguments +arguments plugins = GhcideArguments + <$> (commandP plugins <|> lspCommand <|> checkCommand) <*> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory") <*> optional (strOption $ long "shake-profiling" <> metavar "DIR"