Skip to content

Commit ec82770

Browse files
jneirajneira
authored
Merge pull request #379 from jneira/hls-plugin-api
2 parents c457699 + af69f89 commit ec82770

36 files changed

+682
-443
lines changed

‎cabal.project

+1
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
packages:
22
./
33
ghcide
4+
hls-plugin-api
45

56
source-repository-package
67
type: git

‎exe/Main.hs

+11-201
Original file line numberDiff line numberDiff line change
@@ -1,66 +1,13 @@
11
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
22
-- SPDX-License-Identifier: Apache-2.0
3-
{-# LANGUAGE CPP #-} -- To get precise GHC version
4-
{-# LANGUAGE TemplateHaskell #-}
5-
{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above
6-
{-# LANGUAGE DeriveGeneric #-}
7-
{-# LANGUAGE LambdaCase #-}
8-
{-# LANGUAGE NamedFieldPuns #-}
3+
{-# LANGUAGE CPP #-}
94
{-# LANGUAGE OverloadedStrings #-}
105
{-# LANGUAGE RecordWildCards #-}
11-
{-# LANGUAGE ScopedTypeVariables #-}
12-
{-# LANGUAGE TupleSections #-}
13-
{-# LANGUAGE TypeFamilies #-}
14-
{-# LANGUAGE ViewPatterns #-}
15-
166
module Main(main) where
177

18-
import Arguments
19-
import Control.Concurrent.Extra
20-
import Control.Monad.Extra
21-
import Data.Default
22-
import qualified Data.HashSet as HashSet
23-
import Data.List.Extra
24-
import qualified Data.Map.Strict as Map
25-
import Data.Maybe
26-
import qualified Data.Text as T
27-
import qualified Data.Text.IO as T
28-
import Development.IDE.Core.Debouncer
29-
import Development.IDE.Core.FileStore
30-
import Development.IDE.Core.OfInterest
31-
import Development.IDE.Core.RuleTypes
32-
import Development.IDE.Core.Rules
33-
import Development.IDE.Core.Service
34-
import Development.IDE.Core.Shake
35-
import Development.IDE.LSP.LanguageServer
36-
import Development.IDE.LSP.Protocol
37-
import Development.IDE.Plugin
38-
import Development.IDE.Session
39-
import Development.IDE.Types.Diagnostics
40-
import Development.IDE.Types.Location
41-
import Development.IDE.Types.Logger
42-
import Development.IDE.Types.Options
43-
import HIE.Bios.Cradle
44-
import qualified Language.Haskell.LSP.Core as LSP
45-
import Ide.Logger
46-
import Ide.Plugin
47-
import Ide.Version
48-
import Ide.Plugin.Config
49-
import Ide.Types (IdePlugins, ipMap)
50-
import Language.Haskell.LSP.Messages
51-
import Language.Haskell.LSP.Types
52-
import qualified System.Directory.Extra as IO
53-
import System.Exit
54-
import System.FilePath
55-
import System.IO
56-
import qualified System.Log.Logger as L
57-
import System.Time.Extra
58-
59-
-- ---------------------------------------------------------------------
60-
-- ghcide partialhandlers
61-
import Development.IDE.Plugin.CodeAction as CodeAction
62-
import Development.IDE.Plugin.Completions as Completions
63-
import Development.IDE.LSP.HoverDefinition as HoverDefinition
8+
import Ide.Arguments (Arguments(..), LspArguments(..), getArguments)
9+
import Ide.Main (defaultMain)
10+
import Ide.Types (IdePlugins)
6411

6512
-- haskell-language-server plugins
6613
import Ide.Plugin.Eval as Eval
@@ -77,12 +24,11 @@ import Ide.Plugin.Retrie as Retrie
7724
import Ide.Plugin.Brittany as Brittany
7825
#endif
7926
import Ide.Plugin.Pragmas as Pragmas
27+
import Ide.Plugin (pluginDescToIdePlugins)
8028

8129

8230
-- ---------------------------------------------------------------------
8331

84-
85-
8632
-- | The plugins configured for use in this instance of the language
8733
-- server.
8834
-- These can be freely added or removed to tailor the available
@@ -95,19 +41,10 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
9541
then basePlugins ++ examplePlugins
9642
else basePlugins
9743
basePlugins =
98-
[
99-
-- applyRefactDescriptor "applyrefact"
100-
-- , haddockDescriptor "haddock"
101-
-- , hareDescriptor "hare"
102-
-- , hsimportDescriptor "hsimport"
103-
-- , liquidDescriptor "liquid"
104-
-- , packageDescriptor "package"
105-
GhcIde.descriptor "ghcide"
44+
[ GhcIde.descriptor "ghcide"
10645
, Pragmas.descriptor "pragmas"
10746
, Floskell.descriptor "floskell"
10847
, Fourmolu.descriptor "fourmolu"
109-
-- , genericDescriptor "generic"
110-
-- , ghcmodDescriptor "ghcmod"
11148
, Ormolu.descriptor "ormolu"
11249
, StylishHaskell.descriptor "stylish-haskell"
11350
, Retrie.descriptor "retrie"
@@ -120,144 +57,17 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
12057
examplePlugins =
12158
[Example.descriptor "eg"
12259
,Example2.descriptor "eg2"
123-
-- ,hfaAlignDescriptor "hfaa"
12460
]
12561

126-
ghcIdePlugins :: T.Text -> IdePlugins -> (Plugin Config, [T.Text])
127-
ghcIdePlugins pid ps = (asGhcIdePlugin ps, allLspCmdIds' pid ps)
128-
12962
-- ---------------------------------------------------------------------
13063

13164
main :: IO ()
13265
main = do
133-
-- WARNING: If you write to stdout before runLanguageServer
134-
-- then the language server will not work
13566
args <- getArguments "haskell-language-server"
13667

137-
hlsVer <- haskellLanguageServerVersion
138-
case args of
139-
ProbeToolsMode -> do
140-
programsOfInterest <- findProgramVersions
141-
putStrLn hlsVer
142-
putStrLn "Tool versions found on the $PATH"
143-
putStrLn $ showProgramVersionOfInterest programsOfInterest
144-
145-
VersionMode PrintVersion ->
146-
putStrLn hlsVer
147-
148-
VersionMode PrintNumericVersion ->
149-
putStrLn haskellLanguageServerNumericVersion
150-
151-
LspMode lspArgs -> do
152-
{- see WARNING above -}
153-
hPutStrLn stderr hlsVer
154-
runLspMode lspArgs
155-
156-
runLspMode :: LspArguments -> IO ()
157-
runLspMode lspArgs@LspArguments {..} = do
158-
LSP.setupLogger argsLogFile ["hls", "hie-bios"]
159-
$ if argsDebugOn then L.DEBUG else L.INFO
160-
161-
-- lock to avoid overlapping output on stdout
162-
lock <- newLock
163-
let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
164-
T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
165-
166-
whenJust argsCwd IO.setCurrentDirectory
167-
168-
dir <- IO.getCurrentDirectory
169-
170-
pid <- getPid
171-
let
172-
idePlugins' = idePlugins argsExamplePlugin
173-
(ps, commandIds) = ghcIdePlugins pid idePlugins'
174-
plugins = Completions.plugin <> CodeAction.plugin <>
175-
Plugin mempty HoverDefinition.setHandlersDefinition <>
176-
ps
177-
options = def { LSP.executeCommandCommands = Just commandIds
178-
, LSP.completionTriggerCharacters = Just "."
179-
}
180-
181-
if argLSP then do
182-
t <- offsetTime
183-
hPutStrLn stderr "Starting (haskell-language-server)LSP server..."
184-
hPutStrLn stderr $ " with arguments: " <> show lspArgs
185-
hPutStrLn stderr $ " with plugins: " <> show (Map.keys $ ipMap idePlugins')
186-
hPutStrLn stderr $ " in directory: " <> dir
187-
hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
188-
189-
runLanguageServer options (pluginHandler plugins) getInitialConfig getConfigFromNotification $ \getLspId event vfs caps wProg wIndefProg _getConfig _rootPath -> do
190-
t <- t
191-
hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
192-
sessionLoader <- loadSession dir
193-
-- config <- fromMaybe defaultLspConfig <$> getConfig
194-
let options = (defaultIdeOptions sessionLoader)
195-
{ optReportProgress = clientSupportsProgress caps
196-
, optShakeProfiling = argsShakeProfiling
197-
, optTesting = IdeTesting argsTesting
198-
, optThreads = argsThreads
199-
-- , optCheckParents = checkParents config
200-
-- , optCheckProject = checkProject config
201-
}
202-
debouncer <- newAsyncDebouncer
203-
initialise caps (mainRule >> pluginRules plugins)
204-
getLspId event wProg wIndefProg hlsLogger debouncer options vfs
205-
else do
206-
-- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
207-
hSetEncoding stdout utf8
208-
hSetEncoding stderr utf8
209-
210-
putStrLn $ "(haskell-language-server)Ghcide setup tester in " ++ dir ++ "."
211-
putStrLn "Report bugs at https://github.com/haskell/haskell-language-server/issues"
212-
programsOfInterest <- findProgramVersions
213-
putStrLn ""
214-
putStrLn "Tool versions found on the $PATH"
215-
putStrLn $ showProgramVersionOfInterest programsOfInterest
216-
217-
putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir
218-
files <- expandFiles (argFiles ++ ["." | null argFiles])
219-
-- LSP works with absolute file paths, so try and behave similarly
220-
files <- nubOrd <$> mapM IO.canonicalizePath files
221-
putStrLn $ "Found " ++ show (length files) ++ " files"
222-
223-
putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup"
224-
cradles <- mapM findCradle files
225-
let ucradles = nubOrd cradles
226-
let n = length ucradles
227-
putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
228-
putStrLn "\nStep 3/4: Initializing the IDE"
229-
vfs <- makeVFSHandle
230-
debouncer <- newAsyncDebouncer
231-
let dummyWithProg _ _ f = f (const (pure ()))
232-
sessionLoader <- loadSession dir
233-
ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger Info) debouncer (defaultIdeOptions sessionLoader) vfs
234-
235-
putStrLn "\nStep 4/4: Type checking the files"
236-
setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files
237-
results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' files)
238-
let (worked, failed) = partition fst $ zip (map isJust results) files
239-
when (failed /= []) $
240-
putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
241-
242-
let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"
243-
putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"
244-
unless (null failed) (exitWith $ ExitFailure (length failed))
245-
246-
expandFiles :: [FilePath] -> IO [FilePath]
247-
expandFiles = concatMapM $ \x -> do
248-
b <- IO.doesFileExist x
249-
if b then return [x] else do
250-
let recurse "." = True
251-
recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc
252-
recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories
253-
files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> IO.listFilesInside (return . recurse) x
254-
when (null files) $
255-
fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
256-
return files
68+
let withExamples =
69+
case args of
70+
LspMode (LspArguments{..}) -> argsExamplePlugin
71+
_ -> False
25772

258-
-- | Print an LSP event.
259-
showEvent :: Lock -> FromServerMessage -> IO ()
260-
showEvent _ (EventFileDiagnostics _ []) = return ()
261-
showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) =
262-
withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
263-
showEvent lock e = withLock lock $ print e
73+
defaultMain args (idePlugins withExamples)

‎exe/Wrapper.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -3,14 +3,14 @@
33
-- https://github.com/alanz/vscode-hie-server
44
module Main where
55

6-
import Arguments
76
import Control.Monad.Extra
87
import Data.Foldable
98
import Data.List
109
import Data.Void
1110
import HIE.Bios
1211
import HIE.Bios.Environment
1312
import HIE.Bios.Types
13+
import Ide.Arguments
1414
import Ide.Version
1515
import System.Directory
1616
import System.Environment

0 commit comments

Comments
 (0)