Skip to content

Commit a49f366

Browse files
pepeiborrapepeiborra
authored
Default main for ghcide (#1338)
* 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
1 parent c2fe061 commit a49f366

File tree

7 files changed

+362
-342
lines changed

7 files changed

+362
-342
lines changed

‎ghcide/CHANGELOG.md‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,6 @@
1+
### 0.7.5 (2021-02-??)
2+
* Added Development.IDE.Main (#1338) - Pepe Iborra
3+
14
### 0.7.4 (2021-02-08)
25
* Support for references via hiedb (#704) - wz1000
36
* Fix space leak on cradle reloads (#1316) - Pepe Iborra

‎ghcide/exe/Main.hs‎

Lines changed: 76 additions & 210 deletions
Original file line numberDiff line numberDiff line change
@@ -5,61 +5,34 @@
55

66
module Main(main) where
77

8-
import Arguments
9-
import Control.Concurrent.Extra
10-
import Control.Monad.Extra
11-
import Control.Exception.Safe
12-
import Control.Lens ( (^.) )
13-
import Data.Default
14-
import Data.List.Extra
15-
import Data.Maybe
8+
import Arguments ( Arguments'(..), IdeCmd(..), getArguments )
9+
import Control.Concurrent.Extra ( newLock, withLock )
10+
import Control.Monad.Extra ( unless, when, whenJust )
11+
import Data.Default ( Default(def) )
12+
import Data.List.Extra ( upper )
13+
import Data.Maybe (fromMaybe)
1614
import qualified Data.Text as T
1715
import qualified Data.Text.IO as T
18-
import Data.Version
19-
import Development.IDE.Core.Debouncer
20-
import Development.IDE.Core.FileStore
21-
import Development.IDE.Core.OfInterest
22-
import Development.IDE.Core.Service
23-
import Development.IDE.Core.Rules
24-
import Development.IDE.Core.Shake
25-
import Development.IDE.Core.RuleTypes
26-
import Development.IDE.LSP.Protocol
27-
import Development.IDE.Types.Location
28-
import Development.IDE.Types.Diagnostics
16+
import Data.Version ( showVersion )
17+
import Development.GitRev ( gitHash )
18+
import Development.IDE ( Logger(Logger), Priority(Info), action )
19+
import Development.IDE.Core.OfInterest (kick)
20+
import Development.IDE.Core.Rules (mainRule)
21+
import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde
22+
import qualified Development.IDE.Plugin.Test as Test
23+
import Development.IDE.Session (setInitialDynFlags, getHieDbLoc, runWithDb)
2924
import Development.IDE.Types.Options
30-
import Development.IDE.Types.Logger
31-
import Development.IDE.Plugin
32-
import Development.IDE.Plugin.Test as Test
33-
import Development.IDE.Session (loadSession, setInitialDynFlags, getHieDbLoc, runWithDb)
34-
import Development.Shake (ShakeOptions (shakeThreads))
35-
import qualified Language.Haskell.LSP.Core as LSP
36-
import Language.Haskell.LSP.Messages
37-
import Language.Haskell.LSP.Types
38-
import Language.Haskell.LSP.Types.Lens (params, initializationOptions)
39-
import Development.IDE.LSP.LanguageServer
40-
import qualified System.Directory.Extra as IO
41-
import System.Environment
42-
import System.IO
43-
import System.Info
44-
import System.Exit
45-
import System.FilePath
46-
import System.Time.Extra
47-
import Paths_ghcide
48-
import Development.GitRev
49-
import qualified Data.HashMap.Strict as HashMap
50-
import qualified Data.Aeson as J
51-
52-
import HIE.Bios.Cradle
53-
import Development.IDE (action)
54-
import Text.Printf
55-
import Development.IDE.Core.Tracing
56-
import Development.IDE.Types.Shake (Key(Key))
57-
import Development.IDE.Plugin.HLS (asGhcIdePlugin)
58-
import Development.IDE.Plugin.HLS.GhcIde as GhcIde
59-
import Ide.Plugin.Config
60-
import Ide.PluginUtils (allLspCmdIds', getProcessID, pluginDescToIdePlugins)
61-
25+
import qualified Development.IDE.Main as Main
26+
import Development.Shake (ShakeOptions(shakeThreads))
27+
import Ide.Plugin.Config (Config(checkParents, checkProject))
28+
import Ide.PluginUtils (pluginDescToIdePlugins)
6229
import HieDb.Run (Options(..), runCommand)
30+
import Paths_ghcide ( version )
31+
import qualified System.Directory.Extra as IO
32+
import System.Environment ( getExecutablePath )
33+
import System.Exit ( ExitCode(ExitFailure), exitSuccess, exitWith )
34+
import System.Info ( compilerVersion )
35+
import System.IO ( stderr, hPutStrLn )
6336

6437
ghcideVersion :: IO String
6538
ghcideVersion = do
@@ -83,171 +56,64 @@ main = do
8356

8457
whenJust argsCwd IO.setCurrentDirectory
8558

86-
8759
dir <- IO.getCurrentDirectory
8860
dbLoc <- getHieDbLoc dir
8961

62+
-- lock to avoid overlapping output on stdout
63+
lock <- newLock
64+
let logger = Logger $ \pri msg -> when (pri >= logLevel) $ withLock lock $
65+
T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
66+
logLevel = if argsVerbose then minBound else Info
67+
9068
case argFilesOrCmd of
9169
DbCmd opts cmd -> do
9270
mlibdir <- setInitialDynFlags
9371
case mlibdir of
9472
Nothing -> exitWith $ ExitFailure 1
95-
Just libdir ->
96-
runCommand libdir opts{database = dbLoc} cmd
97-
Typecheck (Just -> argFilesOrCmd) | not argLSP -> runWithDb dbLoc $ runIde Arguments{..}
98-
_ -> let argFilesOrCmd = Nothing in runWithDb dbLoc $ runIde Arguments{..}
99-
100-
101-
runIde :: Arguments' (Maybe [FilePath]) -> HieDb -> IndexQueue -> IO ()
102-
runIde Arguments{..} hiedb hiechan = do
103-
-- lock to avoid overlapping output on stdout
104-
lock <- newLock
105-
let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
106-
T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
107-
108-
dir <- IO.getCurrentDirectory
109-
110-
let hlsPlugins = pluginDescToIdePlugins $
111-
GhcIde.descriptors ++
112-
[ Test.blockCommandDescriptor "block-command" | argsTesting]
113-
114-
pid <- T.pack . show <$> getProcessID
115-
let hlsPlugin = asGhcIdePlugin hlsPlugins
116-
hlsCommands = allLspCmdIds' pid hlsPlugins
117-
118-
let plugins = hlsPlugin
119-
<> if argsTesting then Test.plugin else mempty
120-
onInitialConfiguration :: InitializeRequest -> Either T.Text Config
121-
onInitialConfiguration x = case x ^. params . initializationOptions of
122-
Nothing -> Right def
123-
Just v -> case J.fromJSON v of
124-
J.Error err -> Left $ T.pack err
125-
J.Success a -> Right a
126-
onConfigurationChange = const $ Left "Updating Not supported"
127-
options = def { LSP.executeCommandCommands = Just hlsCommands
128-
, LSP.completionTriggerCharacters = Just "."
73+
Just libdir -> runCommand libdir opts{database = dbLoc} cmd
74+
75+
_ -> do
76+
77+
case argFilesOrCmd of
78+
LSP -> do
79+
hPutStrLn stderr "Starting LSP server..."
80+
hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
81+
_ -> return ()
82+
83+
runWithDb dbLoc $ \hiedb hiechan ->
84+
Main.defaultMain (Main.defArguments hiedb hiechan)
85+
{Main.argFiles = case argFilesOrCmd of
86+
Typecheck x | not argLSP -> Just x
87+
_ -> Nothing
88+
89+
,Main.argsLogger = logger
90+
91+
,Main.argsRules = do
92+
-- install the main and ghcide-plugin rules
93+
mainRule
94+
-- install the kick action, which triggers a typecheck on every
95+
-- Shake database restart, i.e. on every user edit.
96+
unless argsDisableKick $
97+
action kick
98+
99+
,Main.argsHlsPlugins =
100+
pluginDescToIdePlugins $
101+
GhcIde.descriptors
102+
++ [Test.blockCommandDescriptor "block-command" | argsTesting]
103+
104+
,Main.argsGhcidePlugin = if argsTesting
105+
then Test.plugin
106+
else mempty
107+
108+
,Main.argsIdeOptions = \(fromMaybe def -> config) sessionLoader ->
109+
let defOptions = defaultIdeOptions sessionLoader
110+
in defOptions
111+
{ optShakeProfiling = argsShakeProfiling
112+
, optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
113+
, optTesting = IdeTesting argsTesting
114+
, optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}
115+
, optCheckParents = checkParents config
116+
, optCheckProject = checkProject config
129117
}
130-
case argFilesOrCmd of
131-
Nothing -> do
132-
t <- offsetTime
133-
hPutStrLn stderr "Starting LSP server..."
134-
hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
135-
runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps wProg wIndefProg getConfig rootPath -> do
136-
t <- t
137-
hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
138-
139-
-- We want to set the global DynFlags right now, so that we can use
140-
-- `unsafeGlobalDynFlags` even before the project is configured
141-
-- We do it here since haskell-lsp changes our working directory to the correct place ('rootPath')
142-
-- before calling this function
143-
_mlibdir <- setInitialDynFlags
144-
`catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing)
145-
146-
sessionLoader <- loadSession $ fromMaybe dir rootPath
147-
config <- fromMaybe def <$> getConfig
148-
let options = defOptions
149-
{ optReportProgress = clientSupportsProgress caps
150-
, optShakeProfiling = argsShakeProfiling
151-
, optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
152-
, optTesting = IdeTesting argsTesting
153-
, optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}
154-
, optCheckParents = checkParents config
155-
, optCheckProject = checkProject config
156-
}
157-
defOptions = defaultIdeOptions sessionLoader
158-
logLevel = if argsVerbose then minBound else Info
159-
debouncer <- newAsyncDebouncer
160-
let rules = do
161-
-- install the main and ghcide-plugin rules
162-
mainRule
163-
pluginRules plugins
164-
-- install the kick action, which triggers a typecheck on every
165-
-- Shake database restart, i.e. on every user edit.
166-
unless argsDisableKick $
167-
action kick
168-
initialise caps rules
169-
getLspId event wProg wIndefProg (logger logLevel) debouncer options vfs hiedb hiechan
170-
Just argFiles -> do
171-
-- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
172-
hSetEncoding stdout utf8
173-
hSetEncoding stderr utf8
174-
175-
putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
176-
putStrLn "Report bugs at https://github.com/haskell/ghcide/issues"
177-
178-
putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir
179-
files <- expandFiles (argFiles ++ ["." | null argFiles])
180-
-- LSP works with absolute file paths, so try and behave similarly
181-
files <- nubOrd <$> mapM IO.canonicalizePath files
182-
putStrLn $ "Found " ++ show (length files) ++ " files"
183-
184-
putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup"
185-
cradles <- mapM findCradle files
186-
let ucradles = nubOrd cradles
187-
let n = length ucradles
188-
putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
189-
when (n > 0) $ putStrLn $ " (" ++ intercalate ", " (catMaybes ucradles) ++ ")"
190-
putStrLn "\nStep 3/4: Initializing the IDE"
191-
vfs <- makeVFSHandle
192-
debouncer <- newAsyncDebouncer
193-
let dummyWithProg _ _ f = f (const (pure ()))
194-
sessionLoader <- loadSession dir
195-
let options = defOptions
196-
{ optShakeProfiling = argsShakeProfiling
197-
-- , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
198-
, optTesting = IdeTesting argsTesting
199-
, optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}
200-
, optCheckParents = NeverCheck
201-
, optCheckProject = False
202-
}
203-
defOptions = defaultIdeOptions sessionLoader
204-
logLevel = if argsVerbose then minBound else Info
205-
ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger logLevel) debouncer options vfs hiedb hiechan
206-
207-
putStrLn "\nStep 4/4: Type checking the files"
208-
setFilesOfInterest ide $ HashMap.fromList $ map ((, OnDisk) . toNormalizedFilePath') files
209-
results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' files)
210-
_results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' files)
211-
_results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' files)
212-
let (worked, failed) = partition fst $ zip (map isJust results) files
213-
when (failed /= []) $
214-
putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
215-
216-
let nfiles xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"
217-
putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)"
218-
219-
when argsOTMemoryProfiling $ do
220-
let valuesRef = state $ shakeExtras ide
221-
values <- readVar valuesRef
222-
let consoleObserver Nothing = return $ \size -> printf "Total: %.2fMB\n" (fromIntegral @Int @Double size / 1e6)
223-
consoleObserver (Just k) = return $ \size -> printf " - %s: %.2fKB\n" (show k) (fromIntegral @Int @Double size / 1e3)
224-
225-
printf "# Shake value store contents(%d):\n" (length values)
226-
let keys = nub
227-
$ Key GhcSession : Key GhcSessionDeps
228-
: [ k | (_,k) <- HashMap.keys values, k /= Key GhcSessionIO]
229-
++ [Key GhcSessionIO]
230-
measureMemory (logger logLevel) [keys] consoleObserver valuesRef
231-
232-
unless (null failed) (exitWith $ ExitFailure (length failed))
233-
234-
{-# ANN runIde ("HLint: ignore Use nubOrd" :: String) #-}
235-
236-
expandFiles :: [FilePath] -> IO [FilePath]
237-
expandFiles = concatMapM $ \x -> do
238-
b <- IO.doesFileExist x
239-
if b then return [x] else do
240-
let recurse "." = True
241-
recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc
242-
recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories
243-
files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> IO.listFilesInside (return . recurse) x
244-
when (null files) $
245-
fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
246-
return files
247-
248-
-- | Print an LSP event.
249-
showEvent :: Lock -> FromServerMessage -> IO ()
250-
showEvent _ (EventFileDiagnostics _ []) = return ()
251-
showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) =
252-
withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
253-
showEvent lock e = withLock lock $ print e
118+
}
119+

‎ghcide/ghcide.cabal‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,7 @@ cabal-version: 1.20
22
build-type: Simple
33
category: Development
44
name: ghcide
5-
version: 0.7.4.0
5+
version: 0.7.5.0
66
license: Apache-2.0
77
license-file: LICENSE
88
author: Digital Asset and Ghcide contributors
@@ -138,6 +138,7 @@ library
138138
include
139139
exposed-modules:
140140
Development.IDE
141+
Development.IDE.Main
141142
Development.IDE.Core.Debouncer
142143
Development.IDE.Core.FileStore
143144
Development.IDE.Core.IdeConfiguration

0 commit comments

Comments
 (0)