Skip to content

Commit

Permalink
support custom Ide commands (#1666)
Browse files Browse the repository at this point in the history 
* 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 <[email protected]>
  • Loading branch information
@pepeiborra @jneira
pepeiborra and jneira authored Apr 8, 2021
1 parent d5c5874 commit 607ae3b
Show file tree
Hide file tree
Showing 10 changed files with 159 additions and 134 deletions.
7 changes: 4 additions & 3 deletions exe/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand All @@ -14,7 +15,7 @@ main = do

let withExamples =
case args of
LspMode LspArguments{..} -> argsExamplePlugin
_ -> False
Ghcide GhcideArguments{..} -> argsExamplePlugin
_ -> False

defaultMain args (idePlugins withExamples)
6 changes: 3 additions & 3 deletions exe/Wrapper.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand All @@ -59,7 +59,7 @@ launchHaskellLanguageServer parsedArgs = do
setCurrentDirectory $ cradleRootDir cradle

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

Expand Down
31 changes: 10 additions & 21 deletions ghcide/exe/Arguments.hs
View file
Original file line number Diff line number Diff line change
@@ -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 | LSP

data Arguments' a = Arguments
{argLSP :: Bool
,argsCwd :: Maybe FilePath
data Arguments = Arguments
{argsCwd :: Maybe FilePath
,argsVersion :: Bool
,argsVSCodeExtensionSchema :: Bool
,argsDefaultConfig :: Bool
Expand All @@ -22,7 +17,7 @@ data Arguments' a = Arguments
,argsDisableKick :: Bool
,argsThreads :: Int
,argsVerbose :: Bool
,argFilesOrCmd :: a
,argsCommand :: Command
}

getArguments :: IO Arguments
Expand All @@ -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")
Expand All @@ -45,12 +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 "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"
<*> (commandP <|> lspCommand <|> checkCommand)
where
checkCommand = Check <$> many (argument str (metavar "FILES/DIRS..."))
lspCommand = LSP <$ switch (long "lsp" <> help "Start talking to an LSP client")
102 changes: 43 additions & 59 deletions ghcide/exe/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -22,23 +22,20 @@ 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
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)
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)

Expand Down Expand Up @@ -80,56 +77,43 @@ main = do
T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
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
}
}
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 = argsCommand

,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
}
}

1 change: 1 addition & 0 deletions ghcide/ghcide.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -64,6 +64,7 @@ library
lsp == 1.2.*,
mtl,
network-uri,
optparse-applicative,
parallel,
prettyprinter-ansi-terminal,
prettyprinter-ansi-terminal,
Expand Down
76 changes: 70 additions & 6 deletions ghcide/src/Development/IDE/Main.hs
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,12 @@
module Development.IDE.Main (Arguments(..), defaultMain) where
{-# OPTIONS_GHC -Wno-orphans #-}
module Development.IDE.Main
(Arguments(..)
,Command(..)
,IdeCommand(..)
,isLSP
,commandP
,defaultMain
) where
import Control.Concurrent.Extra (newLock, readVar,
withLock)
import Control.Exception.Safe (Exception (displayException),
Expand Down Expand Up @@ -57,6 +65,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)
Expand All @@ -65,6 +74,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)
Expand All @@ -80,9 +90,41 @@ import System.Time.Extra (offsetTime,
showDuration)
import Text.Printf (printf)

data Command
= Check [FilePath] -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures
| 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 _ = "<ide command>"

-- 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 "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"


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
Expand All @@ -100,7 +142,7 @@ data Arguments = Arguments
instance Default Arguments where
def = Arguments
{ argsOTMemoryProfiling = False
, argFiles = Nothing
, argCommand = LSP
, argsLogger = stderrLogger
, argsRules = mainRule >> action kick
, argsGhcidePlugin = mempty
Expand Down Expand Up @@ -153,8 +195,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!"
Expand Down Expand Up @@ -188,7 +230,7 @@ defaultMain Arguments{..} = do
vfs
hiedb
hieChan
Just argFiles -> do
Check argFiles -> do
dir <- IO.getCurrentDirectory
dbLoc <- getHieDbLoc dir
runWithDb dbLoc $ \hiedb hieChan -> do
Expand Down Expand Up @@ -249,8 +291,30 @@ defaultMain Arguments{..} = do
measureMemory logger [keys] consoleObserver valuesRef

unless (null failed) (exitWith $ ExitFailure (length failed))
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
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) #-}


expandFiles :: [FilePath] -> IO [FilePath]
expandFiles = concatMapM $ \x -> do
b <- IO.doesFileExist x
Expand Down
Loading

0 comments on commit 607ae3b

Please sign in to comment.