[WIP] parallelising ghcide tests

ghcide/ghcide.cabal

@@ -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

ghcide/src/Development/IDE/Core/AbstractPath.hs

@@ -0,0 +1,11 @@
+module Development.IDE.Core.AbstractPath where
+
+import           System.FilePath
+
+data AbstractPath = RelativePath FilePath
+                    | AbsolutePath FilePath
+                    deriving (Show)
+
+mkAbstract :: FilePath -> AbstractPath
+mkAbstract x | isRelative x = RelativePath x
+             | otherwise = AbsolutePath x

ghcide/src/Development/IDE/Core/Service.hs

@@ -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 ()

ghcide/src/Development/IDE/Core/Shake.hs

@@ -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

haskell-language-server.cabal

@@ -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
@@ -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

plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs

@@ -11,8 +11,13 @@ where
 
 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
 import           Development.IDE                  hiding (getExtensions,
                                                    pluginHandlers)
 import           Development.IDE.Core.PluginUtils
@@ -26,8 +31,11 @@ import           Ide.Types                        hiding (Config)
 import           Language.Haskell.Stylish
 import           Language.LSP.Protocol.Types      as LSP
 import           System.Directory
+
 import           System.FilePath
 
+
+
 data Log
   = LogLanguageExtensionFromDynFlags
 
@@ -61,7 +69,7 @@ provider recorder ide _token typ contents fp _opts = do
     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
@@ -70,19 +78,61 @@ provider recorder ide _token typ contents fp _opts = do
       | 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 []
+
+          return $ config
+            { configLanguageExtensions = nub $
+              configLanguageExtensions config
+            }
+    where toStr (ext, True)  = show ext
+          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.