support custom Ide commands

exe/Main.hs

@@ -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
 
@@ -14,7 +15,7 @@ main = do
 
     let withExamples =
             case args of
-                LspMode LspArguments{..} -> argsExamplePlugin
-                _                        -> False
+                Ghcide GhcideArguments{..} -> argsExamplePlugin
+                _                          -> False
 
     defaultMain args (idePlugins withExamples)

exe/Wrapper.hs

@@ -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
 
@@ -59,7 +59,7 @@ launchHaskellLanguageServer parsedArgs = do
   setCurrentDirectory $ cradleRootDir cradle
 
   case parsedArgs of
-    LspMode LspArguments{..} ->
+    Ghcide GhcideArguments{..} ->
       when argsProjectGhcVersion $ getRuntimeGhcVersion' cradle >>= putStrLn >> exitSuccess
     _ -> pure ()
 

ghcide/exe/Arguments.hs

@@ -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
@@ -22,7 +17,7 @@ data Arguments' a = Arguments
     ,argsDisableKick           :: Bool
     ,argsThreads               :: Int
     ,argsVerbose               :: Bool
-    ,argFilesOrCmd             :: a
+    ,argsCommand               :: Command
     }
 
 getArguments :: IO Arguments
@@ -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")
@@ -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")

ghcide/exe/Main.hs

@@ -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
@@ -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)
 
@@ -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
+                }
+        }
 

ghcide/ghcide.cabal

@@ -64,6 +64,7 @@ library
         lsp == 1.2.*,
         mtl,
         network-uri,
+        optparse-applicative,
         parallel,
         prettyprinter-ansi-terminal,
         prettyprinter-ansi-terminal,

ghcide/src/Development/IDE/Main.hs

@@ -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),
@@ -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)
@@ -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)
@@ -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
@@ -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
@@ -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!"
@@ -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
@@ -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