mirror of
https://github.com/haskell/ghcide.git
synced 2024-12-16 22:52:41 +03:00
16873edb44
* Rename reportSeriousError to reportInternalError * Stop using logError for logging things that are warnings to the user, not errors by us * Rename logError * Sort the log fields properly * Delete tagAction from Logger * Strip down the pure logger * Delete unused pieces of the logger * A quick check suggests the call stack will be useful in approximately none of the callers of logging, so just remove it * When reporting an internal error, give as much detail as we can * Change our logger to be based on Priority values * HLint fixes * Rename makeNopLogger * In hie-core say what level of message you are setting * Delete the unused makeOneLogger * Make sure we can show messages floating around * If a notification/response handler throws an exception, report it upwards * Remove reportInternalError in favour of a general logging mechanism * Add missing dependencies * Just call fail for a dodgy error report * Add a FIXME * Make missing modules just an error
130 lines
4.5 KiB
Haskell
130 lines
4.5 KiB
Haskell
-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
|
-- SPDX-License-Identifier: Apache-2.0
|
|
|
|
module Main(main) where
|
|
|
|
import Arguments
|
|
import Data.Maybe
|
|
import Data.List.Extra
|
|
import System.FilePath
|
|
import Control.Concurrent.Extra
|
|
import Control.Monad.Extra
|
|
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 qualified Data.Text as T
|
|
import qualified Data.Text.IO as T
|
|
import Language.Haskell.LSP.Messages
|
|
import Development.IDE.LSP.LanguageServer
|
|
import System.Directory.Extra as IO
|
|
import System.Environment
|
|
import System.IO
|
|
import Development.Shake hiding (Env)
|
|
import qualified Data.Set as Set
|
|
|
|
-- import CmdLineParser
|
|
-- import DynFlags
|
|
-- import Panic
|
|
import GHC
|
|
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"
|
|
|
|
main :: IO ()
|
|
main = do
|
|
-- WARNING: If you write to stdout before runLanguageServer
|
|
-- then the language server will not work
|
|
hPutStrLn stderr "Starting hie-core"
|
|
Arguments{..} <- getArguments
|
|
|
|
-- lock to avoid overlapping output on stdout
|
|
lock <- newLock
|
|
let logger = Logger $ \pri msg -> withLock lock $
|
|
T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
|
|
|
|
whenJust argsCwd setCurrentDirectory
|
|
|
|
dir <- getCurrentDirectory
|
|
hPutStrLn stderr dir
|
|
|
|
if argLSP then do
|
|
t <- offsetTime
|
|
hPutStrLn stderr "Starting LSP server..."
|
|
runLanguageServer def def $ \event vfs -> do
|
|
t <- t
|
|
hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
|
|
let options = defaultIdeOptions $ liftIO $ newSession' =<< findCradle (dir <> "/")
|
|
initialise (mainRule >> action kick) event logger options vfs
|
|
else do
|
|
putStrLn "[1/6] Finding hie-bios cradle"
|
|
cradle <- findCradle (dir <> "/")
|
|
print cradle
|
|
|
|
putStrLn "\n[2/6] Converting Cradle to GHC session"
|
|
env <- newSession' cradle
|
|
|
|
putStrLn "\n[3/6] Initialising IDE session"
|
|
vfs <- makeVFSHandle
|
|
ide <- initialise mainRule (showEvent lock) logger (defaultIdeOptions $ return env) vfs
|
|
|
|
putStrLn "\n[4/6] Finding interesting files"
|
|
files <- nubOrd <$> expandFiles (argFiles ++ ["." | null argFiles])
|
|
putStrLn $ "Found " ++ show (length files) ++ " files"
|
|
|
|
putStrLn "\n[5/6] Setting interesting files"
|
|
setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files
|
|
|
|
putStrLn "\n[6/6] Loading interesting files"
|
|
results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files
|
|
let (worked, failed) = partition fst $ zip (map isJust results) files
|
|
putStrLn $ "Files that worked: " ++ show (length worked)
|
|
putStrLn $ "Files that failed: " ++ show (length failed)
|
|
putStr $ unlines $ map ((++) " * " . snd) failed
|
|
|
|
putStrLn "Done"
|
|
|
|
|
|
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,) diags
|
|
showEvent lock e = withLock lock $ print e
|
|
|
|
newSession' :: Cradle -> IO HscEnv
|
|
newSession' cradle = getLibdir >>= \libdir -> runGhc (Just libdir) $ do
|
|
initializeFlagsWithCradle "" cradle
|
|
getSession
|