mirror of
https://github.com/haskell/ghcide.git
synced 2024-09-11 05:36:09 +03:00
Support multiple hie.yaml files (#127)
* Hack around https://github.com/mpickering/hie-bios/pull/56 - hie-bios expects files to really exist on disk * Fix getLocatedImportsRule to pass the file to the session * Add support for multiple simultaneous hie.yaml files. Also rewrites the user experience on setup to be less verbose. Also adds masking for GHC session construction. * HLint * Code review comments * Switch to the Strict map
This commit is contained in:
parent
37f19935e2
commit
60ed687de9
97
exe/Main.hs
97
exe/Main.hs
@ -39,6 +39,7 @@ import System.Exit
|
||||
import Paths_ghcide
|
||||
import Development.Shake hiding (Env)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
import GHC hiding (def)
|
||||
import qualified GHC.Paths
|
||||
@ -64,13 +65,12 @@ main = do
|
||||
|
||||
-- lock to avoid overlapping output on stdout
|
||||
lock <- newLock
|
||||
let logger = Logger $ \pri msg -> withLock lock $
|
||||
let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
|
||||
T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
|
||||
|
||||
whenJust argsCwd setCurrentDirectory
|
||||
|
||||
dir <- getCurrentDirectory
|
||||
hPutStrLn stderr dir
|
||||
|
||||
if argLSP then do
|
||||
t <- offsetTime
|
||||
@ -78,31 +78,43 @@ main = do
|
||||
runLanguageServer def def $ \event vfs caps -> do
|
||||
t <- t
|
||||
hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
|
||||
let options = (defaultIdeOptions $ loadEnvironment dir)
|
||||
-- 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 }
|
||||
initialise (mainRule >> action kick) event logger options vfs
|
||||
initialise (mainRule >> action kick) event (logger minBound) options vfs
|
||||
else do
|
||||
-- Note that this whole section needs to change once we have genuine
|
||||
-- multi environment support. Needs rewriting in terms of loadEnvironment.
|
||||
putStrLn "[1/6] Finding hie-bios cradle"
|
||||
cradle <- getCradle dir
|
||||
print cradle
|
||||
putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
|
||||
putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"
|
||||
|
||||
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 $ const $ return env) vfs
|
||||
|
||||
putStrLn "\n[4/6] Finding interesting files"
|
||||
putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir
|
||||
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 "\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 "\n[6/6] Loading interesting files"
|
||||
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 (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
|
||||
putStrLn $ "Files that worked: " ++ show (length worked)
|
||||
@ -137,8 +149,9 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
|
||||
withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,) diags
|
||||
showEvent lock e = withLock lock $ print e
|
||||
|
||||
newSession' :: Cradle -> IO HscEnvEq
|
||||
newSession' cradle = do
|
||||
|
||||
cradleToSession :: Cradle -> IO HscEnvEq
|
||||
cradleToSession cradle = do
|
||||
opts <- either throwIO return =<< getCompilerOptions "" cradle
|
||||
libdir <- getLibdir
|
||||
env <- runGhc (Just libdir) $ do
|
||||
@ -147,15 +160,33 @@ newSession' cradle = do
|
||||
initDynLinker env
|
||||
newHscEnvEq env
|
||||
|
||||
loadEnvironment :: FilePath -> IO (FilePath -> Action HscEnvEq)
|
||||
loadEnvironment dir = do
|
||||
res <- liftIO $ newSession' =<< getCradle dir
|
||||
return $ const $ return res
|
||||
|
||||
getCradle :: FilePath -> IO Cradle
|
||||
getCradle dir = do
|
||||
dir <- pure $ addTrailingPathSeparator dir
|
||||
mbYaml <- findCradle dir
|
||||
case mbYaml of
|
||||
Nothing -> loadImplicitCradle dir
|
||||
Just yaml -> loadCradle yaml
|
||||
loadSession :: FilePath -> IO (FilePath -> Action HscEnvEq)
|
||||
loadSession dir = do
|
||||
cradleLoc <- memoIO $ \v -> do
|
||||
res <- findCradle v
|
||||
-- Sometimes we get C: and sometimes we get c:, try and normalise that
|
||||
-- e.g. see https://github.com/digital-asset/ghcide/issues/126
|
||||
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)
|
||||
|
@ -171,6 +171,7 @@ test-suite ghcide-tests
|
||||
build-depends:
|
||||
base,
|
||||
containers,
|
||||
directory,
|
||||
extra,
|
||||
filepath,
|
||||
--------------------------------------------------------------
|
||||
|
@ -151,7 +151,7 @@ getLocatedImportsRule =
|
||||
pm <- use_ GetParsedModule file
|
||||
let ms = pm_mod_summary pm
|
||||
let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]
|
||||
env <- hscEnv <$> useNoFile_ GhcSession
|
||||
env <- hscEnv <$> use_ GhcSession file
|
||||
let dflags = addRelativeImport pm $ hsc_dflags env
|
||||
opt <- getIdeOptions
|
||||
(diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
|
||||
|
@ -17,6 +17,7 @@ import Language.Haskell.LSP.Types
|
||||
import Language.Haskell.LSP.Types.Capabilities
|
||||
import System.Environment.Blank (setEnv)
|
||||
import System.IO.Extra
|
||||
import System.Directory
|
||||
import Test.Tasty
|
||||
import Test.Tasty.HUnit
|
||||
|
||||
@ -609,6 +610,11 @@ pickActionWithTitle title actions = head
|
||||
run :: Session a -> IO a
|
||||
run s = withTempDir $ \dir -> do
|
||||
ghcideExe <- locateGhcideExecutable
|
||||
|
||||
-- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56
|
||||
-- since the package import test creates "Data/List.hs", which otherwise has no physical home
|
||||
createDirectoryIfMissing True $ dir ++ "/Data"
|
||||
|
||||
let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir]
|
||||
-- HIE calls getXgdDirectory which assumes that HOME is set.
|
||||
-- Only sets HOME if it wasn't already set.
|
||||
|
Loading…
Reference in New Issue
Block a user