git.iko.soy/ghcide
on debug help sign in
ghcide/exe/Main.hs
222 lines 9.3 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
85 let plugins = Completions.plugin <> CodeAction.plugin
86 onInitialConfiguration = const $ Right ()
87 onConfigurationChange = const $ Right ()
88 options = def { LSP.executeCommandCommands = Just ["typesignature.add"]
89 , LSP.completionTriggerCharacters = Just "."
90 }
92 if argLSP then do
93 t <- offsetTime
94 hPutStrLn stderr "Starting LSP server..."
95 hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
96 runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do
97 t <- t
98 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
99 let options = (defaultIdeOptions $ loadSession dir)
100 { optReportProgress = clientSupportsProgress caps
101 , optShakeProfiling = argsShakeProfiling
102 , optTesting = argsTesting
103 }
104 debouncer <- newAsyncDebouncer
105 initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick)
106 getLspId event (logger minBound) debouncer options vfs
107 else do
108 -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
109 hSetEncoding stdout utf8
110 hSetEncoding stderr utf8
112 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
113 putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"
115 putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir
116 files <- expandFiles (argFiles ++ ["." | null argFiles])
117 -- LSP works with absolute file paths, so try and behave similarly
118 files <- nubOrd <$> mapM IO.canonicalizePath files
119 putStrLn $ "Found " ++ show (length files) ++ " files"
121 putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup"
122 cradles <- mapM findCradle files
123 let ucradles = nubOrd cradles
124 let n = length ucradles
125 putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
126 sessions <- forM (zipFrom (1 :: Int) ucradles) $ \(i, x) -> do
127 let msg = maybe ("Implicit cradle for " ++ dir) ("Loading " ++) x
128 putStrLn $ "\nStep 3/6, Cradle " ++ show i ++ "/" ++ show n ++ ": " ++ msg
129 cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x
130 when (isNothing x) $ print cradle
131 putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session"
132 opts <- getComponentOptions cradle
133 createSession opts
135 putStrLn "\nStep 5/6: Initializing the IDE"
136 vfs <- makeVFSHandle
137 let cradlesToSessions = Map.fromList $ zip ucradles sessions
138 let filesToCradles = Map.fromList $ zip files cradles
139 let grab file = fromMaybe (head sessions) $ do
140 cradle <- Map.lookup file filesToCradles
141 Map.lookup cradle cradlesToSessions
143 let options =
144 (defaultIdeOptions $ return $ return . grab)
145 { optShakeProfiling = argsShakeProfiling }
146 ide <- initialise def (cradleRules >> mainRule) (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs
148 putStrLn "\nStep 6/6: Type checking the files"
149 setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files
150 results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath' files
151 let (worked, failed) = partition fst $ zip (map isJust results) files
152 when (failed /= []) $
153 putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
155 let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"
156 putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"
158 unless (null failed) exitFailure
160cradleRules :: Rules ()
161cradleRules = do
162 loadGhcSession
163 cradleToSession
165expandFiles :: [FilePath] -> IO [FilePath]
166expandFiles = concatMapM $ \x -> do
167 b <- IO.doesFileExist x
168 if b then return [x] else do
169 let recurse "." = True
170 recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc
171 recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories
172 files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> IO.listFilesInside (return . recurse) x
173 when (null files) $
174 fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
175 return files
178kick :: Action ()
179kick = do
180 files <- getFilesOfInterest
181 void $ uses TypeCheck $ HashSet.toList files
183-- | Print an LSP event.
184showEvent :: Lock -> FromServerMessage -> IO ()
185showEvent _ (EventFileDiagnostics _ []) = return ()
186showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) =
187 withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
188showEvent lock e = withLock lock $ print e
190loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq)
191loadSession dir = liftIO $ do
192 cradleLoc <- memoIO $ \v -> do
193 res <- findCradle v
194 -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
195 -- try and normalise that
196 -- e.g. see https://github.com/digital-asset/ghcide/issues/126
197 res' <- traverse IO.makeAbsolute res
198 return $ normalise <$> res'
199 let session :: Maybe FilePath -> Action HscEnvEq
200 session file = do
201 -- In the absence of a cradle file, just pass the directory from where to calculate an implicit cradle
202 let cradle = toNormalizedFilePath' $ fromMaybe dir file
203 use_ LoadCradle cradle
204 return $ \file -> session =<< liftIO (cradleLoc file)
207-- | Memoize an IO function, with the characteristics:
208--
209-- * If multiple people ask for a result simultaneously, make sure you only compute it once.
210--
211-- * If there are exceptions, repeatedly reraise them.
212--
213-- * If the caller is aborted (async exception) finish computing it anyway.
214memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b)
215memoIO op = do
216 ref <- newVar Map.empty
217 return $ \k -> join $ mask_ $ modifyVar ref $ \mp ->
218 case Map.lookup k mp of
219 Nothing -> do
220 res <- onceFork $ op k
221 return (Map.insert k res mp, res)
222 Just res -> return (mp, res)