ghcide-0.0.6: exe/Main.hs
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above
{-# LANGUAGE CPP #-} -- To get precise GHC version
{-# LANGUAGE TemplateHaskell #-}
module Main(main) where
import Arguments
import Data.Maybe
import Data.List.Extra
import System.FilePath
import Control.Concurrent.Extra
import Control.Exception
import Control.Monad.Extra
import Control.Monad.IO.Class
import Data.Default
import System.Time.Extra
import Development.IDE.Core.FileStore
import Development.IDE.Core.OfInterest
import Development.IDE.Core.Service
import Development.IDE.Core.Rules
import Development.IDE.Core.Shake
import Development.IDE.Core.RuleTypes
import Development.IDE.LSP.Protocol
import Development.IDE.Types.Location
import Development.IDE.Types.Diagnostics
import Development.IDE.Types.Options
import Development.IDE.Types.Logger
import Development.IDE.GHC.Util
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Language.Haskell.LSP.Messages
import Language.Haskell.LSP.Types (LspId(IdInt))
import Linker
import Data.Version
import Development.IDE.LSP.LanguageServer
import System.Directory.Extra as IO
import System.Environment
import System.IO
import System.Exit
import Paths_ghcide
import Development.GitRev
import Development.Shake (Action, action)
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import GHC hiding (def)
import qualified GHC.Paths
import HIE.Bios
-- Set the GHC libdir to the nix libdir if it's present.
getLibdir :: IO FilePath
getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"
ghcideVersion :: IO String
ghcideVersion = do
path <- getExecutablePath
let gitHashSection = case $(gitHash) of
x | x == "UNKNOWN" -> ""
x -> " (GIT hash: " <> x <> ")"
return $ "ghcide version: " <> showVersion version
<> " (GHC: " <> VERSION_ghc
<> ") (PATH: " <> path <> ")"
<> gitHashSection
main :: IO ()
main = do
-- WARNING: If you write to stdout before runLanguageServer
-- then the language server will not work
Arguments{..} <- getArguments
if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess
else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion
-- lock to avoid overlapping output on stdout
lock <- newLock
let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
whenJust argsCwd setCurrentDirectory
dir <- getCurrentDirectory
if argLSP then do
t <- offsetTime
hPutStrLn stderr "Starting LSP server..."
hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcidie WITHOUT the --lsp option!"
runLanguageServer def def $ \getLspId event vfs caps -> do
t <- t
hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
-- very important we only call loadSession once, and it's fast, so just do it before starting
session <- loadSession dir
let options = (defaultIdeOptions $ return session)
{ optReportProgress = clientSupportsProgress caps
, optShakeProfiling = argsShakeProfiling
}
initialise (mainRule >> action kick) getLspId event (logger minBound) options vfs
else do
putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"
putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir
files <- nubOrd <$> expandFiles (argFiles ++ ["." | null argFiles])
putStrLn $ "Found " ++ show (length files) ++ " files"
putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup"
cradles <- mapM findCradle files
let ucradles = nubOrd cradles
let n = length ucradles
putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
sessions <- forM (zipFrom (1 :: Int) ucradles) $ \(i, x) -> do
let msg = maybe ("Implicit cradle for " ++ dir) ("Loading " ++) x
putStrLn $ "\nStep 3/6, Cradle " ++ show i ++ "/" ++ show n ++ ": " ++ msg
cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x
when (isNothing x) $ print cradle
putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session"
cradleToSession cradle
putStrLn "\nStep 5/6: Initializing the IDE"
vfs <- makeVFSHandle
let cradlesToSessions = Map.fromList $ zip ucradles sessions
let filesToCradles = Map.fromList $ zip files cradles
let grab file = fromMaybe (head sessions) $ do
cradle <- Map.lookup file filesToCradles
Map.lookup cradle cradlesToSessions
ide <- initialise mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) (defaultIdeOptions $ return $ return . grab) vfs
putStrLn "\nStep 6/6: Type checking the files"
setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files
results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files
let (worked, failed) = partition fst $ zip (map isJust results) files
when (failed /= []) $
putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"
putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"
unless (null failed) exitFailure
expandFiles :: [FilePath] -> IO [FilePath]
expandFiles = concatMapM $ \x -> do
b <- IO.doesFileExist x
if b then return [x] else do
let recurse "." = True
recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc
recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories
files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> listFilesInside (return . recurse) x
when (null files) $
fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
return files
kick :: Action ()
kick = do
files <- getFilesOfInterest
void $ uses TypeCheck $ Set.toList files
-- | Print an LSP event.
showEvent :: Lock -> FromServerMessage -> IO ()
showEvent _ (EventFileDiagnostics _ []) = return ()
showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
showEvent lock e = withLock lock $ print e
cradleToSession :: Cradle -> IO HscEnvEq
cradleToSession cradle = do
cradleRes <- getCompilerOptions "" cradle
opts <- case cradleRes of
CradleSuccess r -> pure r
CradleFail err -> throwIO err
-- TODO Rather than failing here, we should ignore any files that use this cradle.
-- That will require some more changes.
CradleNone -> fail "'none' cradle is not yet supported"
libdir <- getLibdir
env <- runGhc (Just libdir) $ do
_targets <- initSession opts
getSession
initDynLinker env
newHscEnvEq env
loadSession :: FilePath -> IO (FilePath -> Action HscEnvEq)
loadSession dir = do
cradleLoc <- memoIO $ \v -> do
res <- findCradle v
-- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
-- try and normalise that
-- e.g. see https://github.com/digital-asset/ghcide/issues/126
res' <- traverse makeAbsolute res
return $ normalise <$> res'
session <- memoIO $ \file -> do
c <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file
cradleToSession c
return $ \file -> liftIO $ session =<< cradleLoc file
-- | Memoize an IO function, with the characteristics:
--
-- * If multiple people ask for a result simultaneously, make sure you only compute it once.
--
-- * If there are exceptions, repeatedly reraise them.
--
-- * If the caller is aborted (async exception) finish computing it anyway.
memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b)
memoIO op = do
ref <- newVar Map.empty
return $ \k -> join $ mask_ $ modifyVar ref $ \mp ->
case Map.lookup k mp of
Nothing -> do
res <- onceFork $ op k
return (Map.insert k res mp, res)
Just res -> return (mp, res)