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