Skip to content

[WIP] parallelising ghcide tests #4364

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Closed
wants to merge 2 commits into from
Closed
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions ghcide/ghcide.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -129,6 +129,7 @@ library
exposed-modules:
Control.Concurrent.Strict
Development.IDE
Development.IDE.Core.AbstractPath
Development.IDE.Core.Actions
Development.IDE.Core.Compile
Development.IDE.Core.Debouncer
Expand Down
11 changes: 11 additions & 0 deletions ghcide/src/Development/IDE/Core/AbstractPath.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,11 @@
module Development.IDE.Core.AbstractPath where

Check warning on line 1 in ghcide/src/Development/IDE/Core/AbstractPath.hs

View workflow job for this annotation

GitHub Actions / Hlint check run

Warning in module Development.IDE.Core.AbstractPath: Use module export list ▫︎ Found: "module Development.IDE.Core.AbstractPath where" ▫︎ Perhaps: "module Development.IDE.Core.AbstractPath (\n module Development.IDE.Core.AbstractPath\n ) where" ▫︎ Note: an explicit list is usually better

import System.FilePath

data AbstractPath = RelativePath FilePath
| AbsolutePath FilePath
deriving (Show)

mkAbstract :: FilePath -> AbstractPath
mkAbstract x | isRelative x = RelativePath x
| otherwise = AbsolutePath x
2 changes: 1 addition & 1 deletion ghcide/src/Development/IDE/Core/Service.hs
Original file line number Diff line number Diff line change
Expand Up @@ -93,7 +93,7 @@ initialise recorder defaultConfig plugins mainRule lspEnv debouncer options with
ofInterestRules (cmapWithPrio LogOfInterest recorder)
fileExistsRules (cmapWithPrio LogFileExists recorder) lspEnv
mainRule)
rootDir


-- | Shutdown the Compiler Service.
shutdown :: IdeState -> IO ()
Expand Down
5 changes: 1 addition & 4 deletions ghcide/src/Development/IDE/Core/Shake.hs
Original file line number Diff line number Diff line change
Expand Up @@ -649,14 +649,11 @@ shakeOpen :: Recorder (WithPriority Log)
-> ShakeOptions
-> Monitoring
-> Rules ()
-> FilePath
-- ^ Root directory, this one might be picking up from `LanguageContextEnv`'s `resRootPath`
-- , see Note [Root Directory]
-> IO IdeState
shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
shakeProfileDir (IdeReportProgress reportProgress)
ideTesting
withHieDb threadQueue opts monitoring rules rootDir = mdo
withHieDb threadQueue opts monitoring rules = mdo
-- see Note [Serializing runs in separate thread]
let indexQueue = tIndexQueue threadQueue
restartQueue = tRestartQueue threadQueue
Expand Down
2 changes: 2 additions & 0 deletions haskell-language-server.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -1578,6 +1578,7 @@ library hls-stylish-haskell-plugin
hs-source-dirs: plugins/hls-stylish-haskell-plugin/src
build-depends:
, base >=4.12 && <5
, bytestring
, directory
, filepath
, ghc-boot-th
Expand All @@ -1587,6 +1588,7 @@ library hls-stylish-haskell-plugin
, mtl
, stylish-haskell ^>=0.12 || ^>=0.13 || ^>=0.14
, text
, yaml


test-suite hls-stylish-haskell-plugin-tests
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -11,8 +11,13 @@

import Control.Monad.Except (throwError)
import Control.Monad.IO.Class
import Data.ByteString as B
import Data.List (inits, nub)
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Data.Yaml
import Debug.Trace

Check warning on line 20 in plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs

View workflow job for this annotation

GitHub Actions / flags (9.6, ubuntu-latest)

The import of ‘Debug.Trace’ is redundant

Check warning on line 20 in plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs

View workflow job for this annotation

GitHub Actions / test (9.6, macOS-latest, false)

The import of ‘Debug.Trace’ is redundant

Check warning on line 20 in plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs

View workflow job for this annotation

GitHub Actions / test (9.6, ubuntu-latest, true)

The import of ‘Debug.Trace’ is redundant

Check warning on line 20 in plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs

View workflow job for this annotation

GitHub Actions / test (9.6, windows-latest, true)

The import of ‘Debug.Trace’ is redundant
import Development.IDE hiding (getExtensions,
pluginHandlers)
import Development.IDE.Core.PluginUtils
Expand All @@ -26,8 +31,11 @@
import Language.Haskell.Stylish
import Language.LSP.Protocol.Types as LSP
import System.Directory

import System.FilePath



data Log
= LogLanguageExtensionFromDynFlags

Expand Down Expand Up @@ -61,7 +69,7 @@
Right new -> pure $ LSP.InL [TextEdit range new]
where
getMergedConfig dyn config
| null (configLanguageExtensions config)
| Prelude.null (configLanguageExtensions config)
= do
logWith recorder Info LogLanguageExtensionFromDynFlags
pure
Expand All @@ -70,19 +78,61 @@
| otherwise
= pure config

getExtensions = map showExtension . Util.toList . extensionFlags
getExtensions = Prelude.map showExtension . Util.toList . extensionFlags

showExtension Cpp = "CPP"
showExtension other = show other

-- | taken and refactored from stylish-haskell which uses getCurrentDirectory
-- https://hackage.haskell.org/package/stylish-haskell-0.14.6.0/docs/src/Language.Haskell.Stylish.Config.html#configFilePath
-- https://github.com/haskell/haskell-language-server/issues/4234#issuecomment-2191571281
ancestors :: FilePath -> [FilePath]
ancestors = Prelude.map joinPath . Prelude.reverse . Prelude.dropWhile Prelude.null . Data.List.inits . splitPath

configFileName :: String
configFileName = ".stylish-haskell.yaml"

configFilePathMT :: Verbose -> FilePath -> IO (Maybe FilePath)
configFilePathMT verbose currentDir = do
configPath <- getXdgDirectory XdgConfig "stylish-haskell"
home <- getHomeDirectory
search verbose $
[d </> configFileName | d <- ancestors currentDir] ++
[configPath </> "config.yaml", home </> configFileName]

search :: Verbose -> [FilePath] -> IO (Maybe FilePath)
search _ [] = return Nothing
search verbose (f : fs) = do
-- TODO Maybe catch an error here, dir might be unreadable
exists <- doesFileExist f
verbose $ f ++ if exists then " exists" else " does not exist"
if exists then return (Just f) else search verbose fs

loadConfigMT :: Verbose -> FilePath -> IO Config
loadConfigMT verbose currentDir = do
mbFp <- configFilePathMT verbose currentDir
verbose $ "Loading configuration at " ++ fromMaybe "<embedded>" mbFp
bytes <- maybe (return defaultConfigBytes) B.readFile mbFp
case decodeEither' bytes of
Left exception -> error $ prettyPrintParseException exception
Right config -> do
-- | TODO
cabalLanguageExtensions <- pure []

Check warning on line 120 in plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs

View workflow job for this annotation

GitHub Actions / flags (9.6, ubuntu-latest)

Defined but not used: ‘cabalLanguageExtensions’

Check warning on line 120 in plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs

View workflow job for this annotation

GitHub Actions / test (9.6, macOS-latest, false)

Defined but not used: ‘cabalLanguageExtensions’

Check warning on line 120 in plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs

View workflow job for this annotation

GitHub Actions / test (9.6, ubuntu-latest, true)

Defined but not used: ‘cabalLanguageExtensions’

Check warning on line 120 in plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs

View workflow job for this annotation

GitHub Actions / test (9.6, windows-latest, true)

Defined but not used: ‘cabalLanguageExtensions’

return $ config
{ configLanguageExtensions = nub $
configLanguageExtensions config
}
where toStr (ext, True) = show ext

Check warning on line 126 in plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs

View workflow job for this annotation

GitHub Actions / flags (9.6, ubuntu-latest)

Defined but not used: ‘toStr’

Check warning on line 126 in plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs

View workflow job for this annotation

GitHub Actions / test (9.6, macOS-latest, false)

Defined but not used: ‘toStr’

Check warning on line 126 in plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs

View workflow job for this annotation

GitHub Actions / test (9.6, ubuntu-latest, true)

Defined but not used: ‘toStr’
toStr (ext, False) = "No" ++ show ext



-- | Recursively search in every directory of the given filepath for .stylish-haskell.yaml.
-- If no such file has been found, return default config.
loadConfigFrom :: FilePath -> IO Config
loadConfigFrom file = do
currDir <- getCurrentDirectory
setCurrentDirectory (takeDirectory file)
config <- loadConfig (makeVerbose False) Nothing
setCurrentDirectory currDir
config <- loadConfigMT (makeVerbose True) (takeDirectory file)
pure config

-- | Run stylish-haskell on the given text with the given configuration.
Expand Down
Loading