Skip to content

Commit 4cd3b1f

Browse files
pepeiborrapepeiborra
committed
Development.IDE.Main
1 parent 691d821 commit 4cd3b1f

File tree

3 files changed

+315
-207
lines changed

3 files changed

+315
-207
lines changed

‎ghcide/exe/Main.hs

+51-207
Original file line numberDiff line numberDiff line change
@@ -5,61 +5,30 @@
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(Typecheck, DbCmd), getArguments )
9+
import Control.Concurrent.Extra ( newLock, withLock )
10+
import Control.Monad.Extra ( unless, when, whenJust )
11+
import Data.List.Extra ( upper )
1612
import qualified Data.Text as T
1713
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
14+
import Data.Version ( showVersion )
15+
import Development.GitRev ( gitHash )
16+
import Development.IDE ( Logger(Logger), Priority(Info), action )
17+
import Development.IDE.Core.OfInterest (kick)
18+
import Development.IDE.Core.Rules (mainRule)
19+
import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde
20+
import qualified Development.IDE.Plugin.Test as Test
21+
import Development.IDE.Session (setInitialDynFlags, getHieDbLoc, runWithDb)
2922
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-
23+
import qualified Development.IDE.Main as Main
24+
import Development.Shake (ShakeOptions(shakeThreads))
6225
import HieDb.Run (Options(..), runCommand)
26+
import Paths_ghcide ( version )
27+
import qualified System.Directory.Extra as IO
28+
import System.Environment ( getExecutablePath )
29+
import System.Exit ( ExitCode(ExitFailure), exitSuccess, exitWith )
30+
import System.Info ( compilerVersion )
31+
import System.IO ( stderr, hPutStrLn )
6332

6433
ghcideVersion :: IO String
6534
ghcideVersion = do
@@ -83,171 +52,46 @@ main = do
8352

8453
whenJust argsCwd IO.setCurrentDirectory
8554

86-
8755
dir <- IO.getCurrentDirectory
8856
dbLoc <- getHieDbLoc dir
8957

58+
-- lock to avoid overlapping output on stdout
59+
lock <- newLock
60+
let logger = Logger $ \pri msg -> when (pri >= logLevel) $ withLock lock $
61+
T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
62+
logLevel = if argsVerbose then minBound else Info
63+
9064
case argFilesOrCmd of
9165
DbCmd opts cmd -> do
9266
mlibdir <- setInitialDynFlags
9367
case mlibdir of
9468
Nothing -> exitWith $ ExitFailure 1
9569
Just libdir ->
9670
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 "."
129-
}
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
71+
_ -> runWithDb dbLoc $ \hiedb hiechan ->
72+
Main.defaultMain (Main.defArguments hiedb hiechan) {
73+
Main.argFiles = case argFilesOrCmd of
74+
Typecheck x | argLSP -> Just x
75+
_ -> Nothing
76+
,Main.argsLogger = logger
77+
,Main.argsRules = do
78+
-- install the main and ghcide-plugin rules
79+
mainRule
80+
-- install the kick action, which triggers a typecheck on every
81+
-- Shake database restart, i.e. on every user edit.
82+
unless argsDisableKick $
83+
action kick
84+
85+
,Main.argsHlsPlugins = GhcIde.descriptors
86+
++ [Test.blockCommandDescriptor "block-command" | argsTesting]
87+
88+
,Main.argsIdeOptions = \sessionLoader ->
89+
let defOptions = defaultIdeOptions sessionLoader
90+
in defOptions{
91+
optShakeProfiling = argsShakeProfiling,
92+
optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling,
93+
optTesting = IdeTesting argsTesting,
94+
optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}
20295
}
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
96+
}
24797

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

‎ghcide/ghcide.cabal

+1
Original file line numberDiff line numberDiff line change
@@ -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)