git.iko.soy/ghcide
on debugging help sign in
ghcide/exe/Main.hs
216 lines 8.6 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 #-}
7module Main(main) where
9import Arguments
10import Data.Maybe
11import Data.List.Extra
12import System.FilePath
13import Control.Concurrent.Extra
14import Control.Exception
15import Control.Monad.Extra
16import Control.Monad.IO.Class
17import Data.Default
18import System.Time.Extra
19import Development.IDE.Core.FileStore
20import Development.IDE.Core.OfInterest
21import Development.IDE.Core.Service
22import Development.IDE.Core.Rules
23import Development.IDE.Core.Shake
24import Development.IDE.Core.RuleTypes
25import Development.IDE.LSP.Protocol
26import Development.IDE.Types.Location
27import Development.IDE.Types.Diagnostics
28import Development.IDE.Types.Options
29import Development.IDE.Types.Logger
30import Development.IDE.GHC.Util
31import qualified Data.Text as T
32import qualified Data.Text.IO as T
33import Language.Haskell.LSP.Messages
34import Language.Haskell.LSP.Types (LspId(IdInt))
35import Linker
36import Data.Version
37import Development.IDE.LSP.LanguageServer
38import System.Directory.Extra as IO
39import System.Environment
40import System.IO
41import System.Exit
42import Paths_ghcide
43import Development.GitRev
44import Development.Shake (Action, action)
45import qualified Data.Set as Set
46import qualified Data.Map.Strict as Map
48import GHC hiding (def)
49import qualified GHC.Paths
51import HIE.Bios
53-- Set the GHC libdir to the nix libdir if it's present.
54getLibdir :: IO FilePath
55getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"
57ghcideVersion :: IO String
58ghcideVersion = do
59 path <- getExecutablePath
60 let gitHashSection = case $(gitHash) of
61 x | x == "UNKNOWN" -> ""
62 x -> " (GIT hash: " <> x <> ")"
63 return $ "ghcide version: " <> showVersion version
64 <> " (GHC: " <> VERSION_ghc
65 <> ") (PATH: " <> path <> ")"
66 <> gitHashSection
68main :: IO ()
69main = do
70 -- WARNING: If you write to stdout before runLanguageServer
71 -- then the language server will not work
72 Arguments{..} <- getArguments
74 if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess
75 else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion
77 -- lock to avoid overlapping output on stdout
78 lock <- newLock
79 let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
80 T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
82 whenJust argsCwd setCurrentDirectory
84 dir <- getCurrentDirectory
86 if argLSP then do
87 t <- offsetTime
88 hPutStrLn stderr "Starting LSP server..."
89 hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcidie WITHOUT the --lsp option!"
90 runLanguageServer def def $ \getLspId event vfs caps -> do
91 t <- t
92 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
93 -- very important we only call loadSession once, and it's fast, so just do it before starting
94 session <- loadSession dir
95 let options = (defaultIdeOptions $ return session)
96 { optReportProgress = clientSupportsProgress caps
97 , optShakeProfiling = argsShakeProfiling
98 }
99 initialise (mainRule >> action kick) getLspId event (logger minBound) options vfs
100 else do
101 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
102 putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"
104 putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir
105 files <- nubOrd <$> expandFiles (argFiles ++ ["." | null argFiles])
106 putStrLn $ "Found " ++ show (length files) ++ " files"
108 putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup"
109 cradles <- mapM findCradle files
110 let ucradles = nubOrd cradles
111 let n = length ucradles
112 putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
113 sessions <- forM (zipFrom (1 :: Int) ucradles) $ \(i, x) -> do
114 let msg = maybe ("Implicit cradle for " ++ dir) ("Loading " ++) x
115 putStrLn $ "\nStep 3/6, Cradle " ++ show i ++ "/" ++ show n ++ ": " ++ msg
116 cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x
117 when (isNothing x) $ print cradle
118 putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session"
119 cradleToSession cradle
121 putStrLn "\nStep 5/6: Initializing the IDE"
122 vfs <- makeVFSHandle
123 let cradlesToSessions = Map.fromList $ zip ucradles sessions
124 let filesToCradles = Map.fromList $ zip files cradles
125 let grab file = fromMaybe (head sessions) $ do
126 cradle <- Map.lookup file filesToCradles
127 Map.lookup cradle cradlesToSessions
128 ide <- initialise mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) (defaultIdeOptions $ return $ return . grab) vfs
130 putStrLn "\nStep 6/6: Type checking the files"
131 setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files
132 results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files
133 let (worked, failed) = partition fst $ zip (map isJust results) files
134 when (failed /= []) $
135 putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
137 let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"
138 putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"
140 unless (null failed) exitFailure
143expandFiles :: [FilePath] -> IO [FilePath]
144expandFiles = concatMapM $ \x -> do
145 b <- IO.doesFileExist x
146 if b then return [x] else do
147 let recurse "." = True
148 recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc
149 recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories
150 files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> listFilesInside (return . recurse) x
151 when (null files) $
152 fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
153 return files
156kick :: Action ()
157kick = do
158 files <- getFilesOfInterest
159 void $ uses TypeCheck $ Set.toList files
161-- | Print an LSP event.
162showEvent :: Lock -> FromServerMessage -> IO ()
163showEvent _ (EventFileDiagnostics _ []) = return ()
164showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
165 withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
166showEvent lock e = withLock lock $ print e
169cradleToSession :: Cradle -> IO HscEnvEq
170cradleToSession cradle = do
171 cradleRes <- getCompilerOptions "" cradle
172 opts <- case cradleRes of
173 CradleSuccess r -> pure r
174 CradleFail err -> throwIO err
175 -- TODO Rather than failing here, we should ignore any files that use this cradle.
176 -- That will require some more changes.
177 CradleNone -> fail "'none' cradle is not yet supported"
178 libdir <- getLibdir
179 env <- runGhc (Just libdir) $ do
180 _targets <- initSession opts
181 getSession
182 initDynLinker env
183 newHscEnvEq env
186loadSession :: FilePath -> IO (FilePath -> Action HscEnvEq)
187loadSession dir = do
188 cradleLoc <- memoIO $ \v -> do
189 res <- findCradle v
190 -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
191 -- try and normalise that
192 -- e.g. see https://github.com/digital-asset/ghcide/issues/126
193 res' <- traverse makeAbsolute res
194 return $ normalise <$> res'
195 session <- memoIO $ \file -> do
196 c <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file
197 cradleToSession c
198 return $ \file -> liftIO $ session =<< cradleLoc file
201-- | Memoize an IO function, with the characteristics:
202--
203-- * If multiple people ask for a result simultaneously, make sure you only compute it once.
204--
205-- * If there are exceptions, repeatedly reraise them.
206--
207-- * If the caller is aborted (async exception) finish computing it anyway.
208memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b)
209memoIO op = do
210 ref <- newVar Map.empty
211 return $ \k -> join $ mask_ $ modifyVar ref $ \mp ->
212 case Map.lookup k mp of
213 Nothing -> do
214 res <- onceFork $ op k
215 return (Map.insert k res mp, res)
216 Just res -> return (mp, res)