-- 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 Development.IDE.Plugin import Development.IDE.Plugin.Completions as Completions import Development.IDE.Plugin.CodeAction as CodeAction 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 let plugins = Completions.plugin <> CodeAction.plugin 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 ghcide WITHOUT the --lsp option!" runLanguageServer def (pluginHandler plugins) $ \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 caps (mainRule >> pluginRules plugins >> 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 <- expandFiles (argFiles ++ ["." | null argFiles]) -- LSP works with absolute file paths, so try and behave similarly files <- nubOrd <$> mapM canonicalizePath files 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 let options = (defaultIdeOptions $ return $ return . grab) { optShakeProfiling = argsShakeProfiling } ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) options 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 a -> 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)