-
-
Notifications
You must be signed in to change notification settings - Fork 386
/
Copy pathMain.hs
214 lines (187 loc) · 9.11 KB
/
Main.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE CPP #-} -- To get precise GHC version
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Ide.Main(defaultMain, runLspMode) where
import Control.Concurrent.Extra
import Control.Monad.Extra
import Data.Default
import Data.List.Extra
import qualified Data.Map.Strict as Map
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Development.IDE.Core.Debouncer
import Development.IDE.Core.FileStore
import Development.IDE.Core.OfInterest
import Development.IDE.Core.RuleTypes
import Development.IDE.Core.Rules
import Development.IDE.Core.Service
import Development.IDE.Core.Shake
import Development.IDE.LSP.LanguageServer
import Development.IDE.LSP.Protocol
import Development.IDE.Plugin
import Development.IDE.Plugin.HLS
import Development.IDE.Session (loadSession, findCradle, defaultLoadingOptions)
import Development.IDE.Types.Diagnostics
import Development.IDE.Types.Location
import Development.IDE.Types.Logger as G
import Development.IDE.Types.Options
import qualified Language.Haskell.LSP.Core as LSP
import Ide.Arguments
import Ide.Logger
import Ide.Version
import Ide.Plugin.Config
import Ide.PluginUtils
import Ide.Types (IdePlugins, ipMap)
import Language.Haskell.LSP.Messages
import Language.Haskell.LSP.Types
import qualified System.Directory.Extra as IO
import System.Exit
import System.FilePath
import System.IO
import qualified System.Log.Logger as L
import System.Time.Extra
import Development.Shake (action)
-- ---------------------------------------------------------------------
-- ghcide partialhandlers
import Development.IDE.Plugin.CodeAction as CodeAction
import Development.IDE.Plugin.Completions as Completions
import Development.IDE.LSP.HoverDefinition as HoverDefinition
-- ---------------------------------------------------------------------
ghcIdePlugins :: T.Text -> IdePlugins IdeState -> (Plugin Config, [T.Text])
ghcIdePlugins pid ps = (asGhcIdePlugin ps, allLspCmdIds' pid ps)
defaultMain :: Arguments -> IdePlugins IdeState -> IO ()
defaultMain args idePlugins = do
-- WARNING: If you write to stdout before runLanguageServer
-- then the language server will not work
hlsVer <- haskellLanguageServerVersion
case args of
ProbeToolsMode -> do
programsOfInterest <- findProgramVersions
putStrLn hlsVer
putStrLn "Tool versions found on the $PATH"
putStrLn $ showProgramVersionOfInterest programsOfInterest
VersionMode PrintVersion ->
putStrLn hlsVer
VersionMode PrintNumericVersion ->
putStrLn haskellLanguageServerNumericVersion
LspMode lspArgs -> do
{- see WARNING above -}
hPutStrLn stderr hlsVer
runLspMode lspArgs idePlugins
-- ---------------------------------------------------------------------
hlsLogger :: G.Logger
hlsLogger = G.Logger $ \pri txt ->
case pri of
G.Telemetry -> logm (T.unpack txt)
G.Debug -> debugm (T.unpack txt)
G.Info -> logm (T.unpack txt)
G.Warning -> warningm (T.unpack txt)
G.Error -> errorm (T.unpack txt)
-- ---------------------------------------------------------------------
runLspMode :: LspArguments -> IdePlugins IdeState -> IO ()
runLspMode lspArgs@LspArguments{..} idePlugins = do
LSP.setupLogger argsLogFile ["hls", "hie-bios"]
$ if argsDebugOn then L.DEBUG else L.INFO
-- 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
whenJust argsCwd IO.setCurrentDirectory
dir <- IO.getCurrentDirectory
pid <- T.pack . show <$> getProcessID
let
(ps, commandIds) = ghcIdePlugins pid idePlugins
plugins = Completions.plugin <> CodeAction.plugin <>
Plugin mempty HoverDefinition.setHandlersDefinition <>
ps
options = def { LSP.executeCommandCommands = Just commandIds
, LSP.completionTriggerCharacters = Just "."
}
if argLSP then do
t <- offsetTime
hPutStrLn stderr "Starting (haskell-language-server)LSP server..."
hPutStrLn stderr $ " with arguments: " <> show lspArgs
hPutStrLn stderr $ " with plugins: " <> show (Map.keys $ ipMap idePlugins)
hPutStrLn stderr $ " in directory: " <> dir
hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
runLanguageServer options (pluginHandler plugins) getInitialConfig getConfigFromNotification $ \getLspId event vfs caps wProg wIndefProg _getConfig _rootPath -> do
t <- t
hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
sessionLoader <- loadSession dir
-- config <- fromMaybe defaultLspConfig <$> getConfig
let options = (defaultIdeOptions sessionLoader)
{ optReportProgress = clientSupportsProgress caps
, optShakeProfiling = argsShakeProfiling
, optTesting = IdeTesting argsTesting
, optThreads = argsThreads
-- , optCheckParents = checkParents config
-- , optCheckProject = checkProject config
}
debouncer <- newAsyncDebouncer
initialise caps (mainRule >> pluginRules plugins >> action kick)
getLspId event wProg wIndefProg hlsLogger debouncer options vfs
else do
-- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
hSetEncoding stdout utf8
hSetEncoding stderr utf8
putStrLn $ "(haskell-language-server)Ghcide setup tester in " ++ dir ++ "."
putStrLn "Report bugs at https://github.com/haskell/haskell-language-server/issues"
programsOfInterest <- findProgramVersions
putStrLn ""
putStrLn "Tool versions found on the $PATH"
putStrLn $ showProgramVersionOfInterest programsOfInterest
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 defaultLoadingOptions) files
let ucradles = nubOrd cradles
let n = length ucradles
putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
putStrLn "\nStep 3/4: Initializing the IDE"
vfs <- makeVFSHandle
debouncer <- newAsyncDebouncer
let dummyWithProg _ _ f = f (const (pure ()))
sessionLoader <- loadSession dir
ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger Info) debouncer (defaultIdeOptions sessionLoader) vfs
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)
let (worked, failed) = partition fst $ zip (map isJust results) files
when (failed /= []) $
putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"
putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"
unless (null failed) (exitWith $ ExitFailure (length failed))
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