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