Skip to content

Commit

Permalink
Default main for ghcide (#1338)
Browse files Browse the repository at this point in the history 
* Development.IDE.Main

* Reuse Development.IDE.Main in HLS

* Bump ghcide version number and HLS minbound

Seems like now is the best moment to do it and avoid later accidents

* (unrelated) disable cradle experiments in ghcide test suite

```
  benchmark experiments
674
    hover:                                                                                                OK (30.50s)
675
    hover after edit:                                                                                     OK (65.67s)
676
    getDefinition:                                                                                        OK (12.24s)
677
    getDefinition after edit:                                                                             OK (62.37s)
678
    documentSymbols:                                                                                      OK (13.95s)
679
    documentSymbols after edit:                                                                           OK (16.87s)
680
    completions:                                                                                          OK (13.64s)
681
    completions after edit:                                                                               OK (66.82s)
682
    code actions:                                                                                         OK (13.80s)
683
    code actions after edit:                                                                              OK (58.70s)
684
    code actions after cradle edit:                                                                       OK (1244.46s)
685
    hover after cradle edit:
    OK (1230.61s)
    ```

* Fix config
  • Loading branch information
@pepeiborra
pepeiborra committed Feb 12, 2021
1 parent c2fe061 commit a49f366
Show file tree
Hide file tree
Showing 7 changed files with 362 additions and 342 deletions.
3 changes: 3 additions & 0 deletions ghcide/CHANGELOG.md
View file
@@ -1,3 +1,6 @@
### 0.7.5 (2021-02-??)
* Added Development.IDE.Main (#1338) - Pepe Iborra

### 0.7.4 (2021-02-08)
* Support for references via hiedb (#704) - wz1000
* Fix space leak on cradle reloads (#1316) - Pepe Iborra
Expand Down
286 changes: 76 additions & 210 deletions ghcide/exe/Main.hs
View file
Expand Up @@ -5,61 +5,34 @@

module Main(main) where

import Arguments
import Control.Concurrent.Extra
import Control.Monad.Extra
import Control.Exception.Safe
import Control.Lens ( (^.) )
import Data.Default
import Data.List.Extra
import Data.Maybe
import Arguments ( Arguments'(..), IdeCmd(..), getArguments )
import Control.Concurrent.Extra ( newLock, withLock )
import Control.Monad.Extra ( unless, when, whenJust )
import Data.Default ( Default(def) )
import Data.List.Extra ( upper )
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Version
import Development.IDE.Core.Debouncer
import Development.IDE.Core.FileStore
import Development.IDE.Core.OfInterest
import Development.IDE.Core.Service
import Development.IDE.Core.Rules
import Development.IDE.Core.Shake
import Development.IDE.Core.RuleTypes
import Development.IDE.LSP.Protocol
import Development.IDE.Types.Location
import Development.IDE.Types.Diagnostics
import Data.Version ( showVersion )
import Development.GitRev ( gitHash )
import Development.IDE ( Logger(Logger), Priority(Info), action )
import Development.IDE.Core.OfInterest (kick)
import Development.IDE.Core.Rules (mainRule)
import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde
import qualified Development.IDE.Plugin.Test as Test
import Development.IDE.Session (setInitialDynFlags, getHieDbLoc, runWithDb)
import Development.IDE.Types.Options
import Development.IDE.Types.Logger
import Development.IDE.Plugin
import Development.IDE.Plugin.Test as Test
import Development.IDE.Session (loadSession, setInitialDynFlags, getHieDbLoc, runWithDb)
import Development.Shake (ShakeOptions (shakeThreads))
import qualified Language.Haskell.LSP.Core as LSP
import Language.Haskell.LSP.Messages
import Language.Haskell.LSP.Types
import Language.Haskell.LSP.Types.Lens (params, initializationOptions)
import Development.IDE.LSP.LanguageServer
import qualified System.Directory.Extra as IO
import System.Environment
import System.IO
import System.Info
import System.Exit
import System.FilePath
import System.Time.Extra
import Paths_ghcide
import Development.GitRev
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Aeson as J

import HIE.Bios.Cradle
import Development.IDE (action)
import Text.Printf
import Development.IDE.Core.Tracing
import Development.IDE.Types.Shake (Key(Key))
import Development.IDE.Plugin.HLS (asGhcIdePlugin)
import Development.IDE.Plugin.HLS.GhcIde as GhcIde
import Ide.Plugin.Config
import Ide.PluginUtils (allLspCmdIds', getProcessID, pluginDescToIdePlugins)

import qualified Development.IDE.Main as Main
import Development.Shake (ShakeOptions(shakeThreads))
import Ide.Plugin.Config (Config(checkParents, checkProject))
import Ide.PluginUtils (pluginDescToIdePlugins)
import HieDb.Run (Options(..), runCommand)
import Paths_ghcide ( version )
import qualified System.Directory.Extra as IO
import System.Environment ( getExecutablePath )
import System.Exit ( ExitCode(ExitFailure), exitSuccess, exitWith )
import System.Info ( compilerVersion )
import System.IO ( stderr, hPutStrLn )

ghcideVersion :: IO String
ghcideVersion = do
Expand All @@ -83,171 +56,64 @@ main = do

whenJust argsCwd IO.setCurrentDirectory


dir <- IO.getCurrentDirectory
dbLoc <- getHieDbLoc dir

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

case argFilesOrCmd of
DbCmd opts cmd -> do
mlibdir <- setInitialDynFlags
case mlibdir of
Nothing -> exitWith $ ExitFailure 1
Just libdir ->
runCommand libdir opts{database = dbLoc} cmd
Typecheck (Just -> argFilesOrCmd) | not argLSP -> runWithDb dbLoc $ runIde Arguments{..}
_ -> let argFilesOrCmd = Nothing in runWithDb dbLoc $ runIde Arguments{..}


runIde :: Arguments' (Maybe [FilePath]) -> HieDb -> IndexQueue -> IO ()
runIde Arguments{..} hiedb hiechan = do
-- lock to avoid overlapping output on stdout
lock <- newLock
let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg

dir <- IO.getCurrentDirectory

let hlsPlugins = pluginDescToIdePlugins $
GhcIde.descriptors ++
[ Test.blockCommandDescriptor "block-command" | argsTesting]

pid <- T.pack . show <$> getProcessID
let hlsPlugin = asGhcIdePlugin hlsPlugins
hlsCommands = allLspCmdIds' pid hlsPlugins

let plugins = hlsPlugin
<> if argsTesting then Test.plugin else mempty
onInitialConfiguration :: InitializeRequest -> Either T.Text Config
onInitialConfiguration x = case x ^. params . initializationOptions of
Nothing -> Right def
Just v -> case J.fromJSON v of
J.Error err -> Left $ T.pack err
J.Success a -> Right a
onConfigurationChange = const $ Left "Updating Not supported"
options = def { LSP.executeCommandCommands = Just hlsCommands
, LSP.completionTriggerCharacters = Just "."
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 ()

runWithDb dbLoc $ \hiedb hiechan ->
Main.defaultMain (Main.defArguments hiedb hiechan)
{Main.argFiles = case argFilesOrCmd of
Typecheck x | not argLSP -> Just x
_ -> Nothing

,Main.argsLogger = 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 = \(fromMaybe def -> config) sessionLoader ->
let defOptions = defaultIdeOptions sessionLoader
in defOptions
{ optShakeProfiling = argsShakeProfiling
, optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
, optTesting = IdeTesting argsTesting
, optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}
, optCheckParents = checkParents config
, optCheckProject = checkProject config
}
case argFilesOrCmd of
Nothing -> 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!"
runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps wProg wIndefProg getConfig rootPath -> do
t <- t
hPutStrLn stderr $ "Started LSP server in " ++ showDuration t

-- We want to set the global DynFlags right now, so that we can use
-- `unsafeGlobalDynFlags` even before the project is configured
-- We do it here since haskell-lsp changes our working directory to the correct place ('rootPath')
-- before calling this function
_mlibdir <- setInitialDynFlags
`catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing)

sessionLoader <- loadSession $ fromMaybe dir rootPath
config <- fromMaybe def <$> getConfig
let options = defOptions
{ optReportProgress = clientSupportsProgress caps
, optShakeProfiling = argsShakeProfiling
, optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
, optTesting = IdeTesting argsTesting
, optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}
, optCheckParents = checkParents config
, optCheckProject = checkProject config
}
defOptions = defaultIdeOptions sessionLoader
logLevel = if argsVerbose then minBound else Info
debouncer <- newAsyncDebouncer
let rules = do
-- install the main and ghcide-plugin rules
mainRule
pluginRules plugins
-- install the kick action, which triggers a typecheck on every
-- Shake database restart, i.e. on every user edit.
unless argsDisableKick $
action kick
initialise caps rules
getLspId event wProg wIndefProg (logger logLevel) debouncer options vfs hiedb hiechan
Just argFiles -> do
-- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
hSetEncoding stdout utf8
hSetEncoding stderr utf8

putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
putStrLn "Report bugs at https://github.com/haskell/ghcide/issues"

putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir
files <- expandFiles (argFiles ++ ["." | null argFiles])
-- LSP works with absolute file paths, so try and behave similarly
files <- nubOrd <$> mapM IO.canonicalizePath files
putStrLn $ "Found " ++ show (length files) ++ " files"

putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup"
cradles <- mapM findCradle files
let ucradles = nubOrd cradles
let n = length ucradles
putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
when (n > 0) $ putStrLn $ " (" ++ intercalate ", " (catMaybes ucradles) ++ ")"
putStrLn "\nStep 3/4: Initializing the IDE"
vfs <- makeVFSHandle
debouncer <- newAsyncDebouncer
let dummyWithProg _ _ f = f (const (pure ()))
sessionLoader <- loadSession dir
let options = defOptions
{ optShakeProfiling = argsShakeProfiling
-- , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
, optTesting = IdeTesting argsTesting
, optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}
, optCheckParents = NeverCheck
, optCheckProject = False
}
defOptions = defaultIdeOptions sessionLoader
logLevel = if argsVerbose then minBound else Info
ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger logLevel) debouncer options vfs hiedb hiechan

putStrLn "\nStep 4/4: Type checking the files"
setFilesOfInterest ide $ HashMap.fromList $ map ((, OnDisk) . toNormalizedFilePath') files
results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' files)
_results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' files)
_results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' files)
let (worked, failed) = partition fst $ zip (map isJust results) files
when (failed /= []) $
putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed

let nfiles xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"
putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)"

when argsOTMemoryProfiling $ do
let valuesRef = state $ shakeExtras ide
values <- readVar valuesRef
let consoleObserver Nothing = return $ \size -> printf "Total: %.2fMB\n" (fromIntegral @Int @Double size / 1e6)
consoleObserver (Just k) = return $ \size -> printf " - %s: %.2fKB\n" (show k) (fromIntegral @Int @Double size / 1e3)

printf "# Shake value store contents(%d):\n" (length values)
let keys = nub
$ Key GhcSession : Key GhcSessionDeps
: [ k | (_,k) <- HashMap.keys values, k /= Key GhcSessionIO]
++ [Key GhcSessionIO]
measureMemory (logger logLevel) [keys] consoleObserver valuesRef

unless (null failed) (exitWith $ ExitFailure (length failed))

{-# ANN runIde ("HLint: ignore Use nubOrd" :: String) #-}

expandFiles :: [FilePath] -> IO [FilePath]
expandFiles = concatMapM $ \x -> do
b <- IO.doesFileExist x
if b then return [x] else do
let recurse "." = True
recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc
recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories
files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> IO.listFilesInside (return . recurse) x
when (null files) $
fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
return files

-- | Print an LSP event.
showEvent :: Lock -> FromServerMessage -> IO ()
showEvent _ (EventFileDiagnostics _ []) = return ()
showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) =
withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
showEvent lock e = withLock lock $ print e
}

3 changes: 2 additions & 1 deletion ghcide/ghcide.cabal
View file
Expand Up @@ -2,7 +2,7 @@ cabal-version: 1.20
build-type: Simple
category: Development
name: ghcide
version: 0.7.4.0
version: 0.7.5.0
license: Apache-2.0
license-file: LICENSE
author: Digital Asset and Ghcide contributors
Expand Down Expand Up @@ -138,6 +138,7 @@ library
include
exposed-modules:
Development.IDE
Development.IDE.Main
Development.IDE.Core.Debouncer
Development.IDE.Core.FileStore
Development.IDE.Core.IdeConfiguration
Expand Down

0 comments on commit a49f366

Please sign in to comment.