git.iko.soy/ghcide
on wip/get-located-imports help sign in
ghcide/exe/Main.hs
225 lines 9.5 kB history raw
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
3{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above
4{-# LANGUAGE CPP #-} -- To get precise GHC version
5{-# LANGUAGE TemplateHaskell #-}
6{-# LANGUAGE TypeFamilies #-}
8module Main(main) where
10import Arguments
11import Data.Maybe
12import Data.List.Extra
13import System.FilePath
14import Control.Concurrent.Extra
15import Control.Exception
16import Control.Monad.Extra
17import Control.Monad.IO.Class
18import Data.Default
19import System.Time.Extra
20import Development.IDE.Core.Debouncer
21import Development.IDE.Core.FileStore
22import Development.IDE.Core.OfInterest
23import Development.IDE.Core.Service
24import Development.IDE.Core.Rules
25import Development.IDE.Core.Shake
26import Development.IDE.Core.RuleTypes
27import Development.IDE.LSP.Protocol
28import Development.IDE.Types.Location
29import Development.IDE.Types.Diagnostics
30import Development.IDE.Types.Options
31import Development.IDE.Types.Logger
32import Development.IDE.GHC.Util
33import Development.IDE.Plugin
34import Development.IDE.Plugin.Completions as Completions
35import Development.IDE.Plugin.CodeAction as CodeAction
36import qualified Data.Text as T
37import qualified Data.Text.IO as T
38import qualified Language.Haskell.LSP.Core as LSP
39import Language.Haskell.LSP.Messages
40import Language.Haskell.LSP.Types (LspId(IdInt))
41import Data.Version
42import Development.IDE.LSP.LanguageServer
43import qualified System.Directory.Extra as IO
44import System.Environment
45import System.IO
46import System.Exit
47import Paths_ghcide
48import Development.GitRev
49import Development.Shake (Action, Rules, action)
50import qualified Data.HashSet as HashSet
51import qualified Data.Map.Strict as Map
52import HIE.Bios
53import Rules
54import RuleTypes
56ghcideVersion :: IO String
57ghcideVersion = do
58 path <- getExecutablePath
59 let gitHashSection = case $(gitHash) of
60 x | x == "UNKNOWN" -> ""
61 x -> " (GIT hash: " <> x <> ")"
62 return $ "ghcide version: " <> showVersion version
63 <> " (GHC: " <> VERSION_ghc
64 <> ") (PATH: " <> path <> ")"
65 <> gitHashSection
67main :: IO ()
68main = do
69 -- WARNING: If you write to stdout before runLanguageServer
70 -- then the language server will not work
71 Arguments{..} <- getArguments
73 if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess
74 else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion
76 -- lock to avoid overlapping output on stdout
77 lock <- newLock
78 let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
79 T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
81 whenJust argsCwd IO.setCurrentDirectory
83 dir <- IO.getCurrentDirectory
84 command <- makeLspCommandId "typesignature.add"
86 let plugins = Completions.plugin <> CodeAction.plugin
87 onInitialConfiguration = const $ Right ()
88 onConfigurationChange = const $ Right ()
89 options = def { LSP.executeCommandCommands = Just [command]
90 , LSP.completionTriggerCharacters = Just "."
91 }
93 if argLSP then do
94 t <- offsetTime
95 hPutStrLn stderr "Starting LSP server..."
96 hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
97 runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do
98 t <- t
99 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
100 let options = (defaultIdeOptions $ loadSession dir)
101 { optReportProgress = clientSupportsProgress caps
102 , optShakeProfiling = argsShakeProfiling
103 , optTesting = argsTesting
104 , optThreads = argsThreads
105 , optInterfaceLoadingDiagnostics = argsTesting
106 }
107 debouncer <- newAsyncDebouncer
108 initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick)
109 getLspId event (logger minBound) debouncer options vfs
110 else do
111 -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
112 hSetEncoding stdout utf8
113 hSetEncoding stderr utf8
115 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
116 putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"
118 putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir
119 files <- expandFiles (argFiles ++ ["." | null argFiles])
120 -- LSP works with absolute file paths, so try and behave similarly
121 files <- nubOrd <$> mapM IO.canonicalizePath files
122 putStrLn $ "Found " ++ show (length files) ++ " files"
124 putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup"
125 cradles <- mapM findCradle files
126 let ucradles = nubOrd cradles
127 let n = length ucradles
128 putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
129 sessions <- forM (zipFrom (1 :: Int) ucradles) $ \(i, x) -> do
130 let msg = maybe ("Implicit cradle for " ++ dir) ("Loading " ++) x
131 putStrLn $ "\nStep 3/6, Cradle " ++ show i ++ "/" ++ show n ++ ": " ++ msg
132 cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x
133 when (isNothing x) $ print cradle
134 putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session"
135 opts <- getComponentOptions cradle
136 createSession opts
138 putStrLn "\nStep 5/6: Initializing the IDE"
139 vfs <- makeVFSHandle
140 let cradlesToSessions = Map.fromList $ zip ucradles sessions
141 let filesToCradles = Map.fromList $ zip files cradles
142 let grab file = fromMaybe (head sessions) $ do
143 cradle <- Map.lookup file filesToCradles
144 Map.lookup cradle cradlesToSessions
146 let options =
147 (defaultIdeOptions $ return $ return . grab)
148 { optShakeProfiling = argsShakeProfiling }
149 ide <- initialise def (cradleRules >> mainRule) (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs
151 putStrLn "\nStep 6/6: Type checking the files"
152 setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files
153 results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath' files
154 let (worked, failed) = partition fst $ zip (map isJust results) files
155 when (failed /= []) $
156 putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
158 let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"
159 putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"
161 unless (null failed) exitFailure
163cradleRules :: Rules ()
164cradleRules = do
165 loadGhcSession
166 cradleToSession
168expandFiles :: [FilePath] -> IO [FilePath]
169expandFiles = concatMapM $ \x -> do
170 b <- IO.doesFileExist x
171 if b then return [x] else do
172 let recurse "." = True
173 recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc
174 recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories
175 files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> IO.listFilesInside (return . recurse) x
176 when (null files) $
177 fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
178 return files
181kick :: Action ()
182kick = do
183 files <- getFilesOfInterest
184 void $ uses TypeCheck $ HashSet.toList files
186-- | Print an LSP event.
187showEvent :: Lock -> FromServerMessage -> IO ()
188showEvent _ (EventFileDiagnostics _ []) = return ()
189showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) =
190 withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
191showEvent lock e = withLock lock $ print e
193loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq)
194loadSession dir = liftIO $ do
195 cradleLoc <- memoIO $ \v -> do
196 res <- findCradle v
197 -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
198 -- try and normalise that
199 -- e.g. see https://github.com/digital-asset/ghcide/issues/126
200 res' <- traverse IO.makeAbsolute res
201 return $ normalise <$> res'
202 let session :: Maybe FilePath -> Action HscEnvEq
203 session file = do
204 -- In the absence of a cradle file, just pass the directory from where to calculate an implicit cradle
205 let cradle = toNormalizedFilePath' $ fromMaybe dir file
206 use_ LoadCradle cradle
207 return $ \file -> session =<< liftIO (cradleLoc file)
210-- | Memoize an IO function, with the characteristics:
211--
212-- * If multiple people ask for a result simultaneously, make sure you only compute it once.
213--
214-- * If there are exceptions, repeatedly reraise them.
215--
216-- * If the caller is aborted (async exception) finish computing it anyway.
217memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b)
218memoIO op = do
219 ref <- newVar Map.empty
220 return $ \k -> join $ mask_ $ modifyVar ref $ \mp ->
221 case Map.lookup k mp of
222 Nothing -> do
223 res <- onceFork $ op k
224 return (Map.insert k res mp, res)
225 Just res -> return (mp, res)