diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index a229137fa..b78f7189b 100644 --- a/haskell-ide-engine.cabal +++ b/haskell-ide-engine.cabal @@ -245,6 +245,8 @@ test-suite plugin-dispatcher-test main-is: Main.hs build-depends: base , data-default + , directory + , filepath , haskell-ide-engine , haskell-lsp-types , hie-plugin-api @@ -287,7 +289,7 @@ test-suite func-test , data-default , directory , filepath - , lsp-test >= 0.9.0.0 + , lsp-test >= 0.10.0.0 , haskell-ide-engine , haskell-lsp-types == 0.19.* , haskell-lsp == 0.19.* diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index 103500145..92039aa39 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -17,19 +17,20 @@ import Distribution.Helper (Package, projectPackages, pUnits, import Distribution.Helper.Discover (findProjects, getDefaultDistDir) import Data.Char (toLower) import Data.Function ((&)) -import Data.List (isPrefixOf, isInfixOf) +import Data.List (isPrefixOf, isInfixOf, sortOn, find) import qualified Data.List.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty) import qualified Data.Map as M -import Data.List (sortOn, find) import Data.Maybe (listToMaybe, mapMaybe, isJust) import Data.Ord (Down(..)) import Data.String (IsString(..)) +import qualified Data.Text as T import Data.Foldable (toList) -import Control.Exception (IOException, try) +import Control.Exception import System.FilePath import System.Directory (getCurrentDirectory, canonicalizePath, findExecutable) import System.Exit +import System.Process (readCreateProcessWithExitCode, shell) -- | Find the cradle that the given File belongs to. -- @@ -57,6 +58,98 @@ isStackCradle = (`elem` ["stack", "Cabal-Helper-Stack", "Cabal-Helper-Stack-None . BIOS.actionName . BIOS.cradleOptsProg + -- | Check if the given cradle is a cabal cradle. +-- This might be used to determine the GHC version to use on the project. +-- If it is a stack-cradle, we have to use `stack path --compiler-exe` +-- otherwise we may ask `ghc` directly what version it is. +isCabalCradle :: Cradle -> Bool +isCabalCradle = + (`elem` + ["cabal" + , "Cabal-Helper-Cabal-V1" + , "Cabal-Helper-Cabal-V2" + , "Cabal-Helper-Cabal-V1-Dir" + , "Cabal-Helper-Cabal-V2-Dir" + , "Cabal-Helper-Cabal-None" + ] + ) + . BIOS.actionName + . BIOS.cradleOptsProg + +-- | Execute @ghc@ that is based on the given cradle. +-- Output must be a single line. If an error is raised, e.g. the command +-- failed, a @Nothing@ is returned. +-- The exact error is written to logs. +-- +-- E.g. for a stack cradle, we use `stack ghc` and for a cabal cradle +-- we are taking the @ghc@ that is on the path. +execProjectGhc :: Cradle -> [String] -> IO (Maybe String) +execProjectGhc crdl args = do + isStackInstalled <- isJust <$> findExecutable "stack" + -- isCabalInstalled <- isJust <$> findExecutable "cabal" + ghcOutput <- if isStackCradle crdl && isStackInstalled + then do + logm "Use Stack GHC" + catch (Just <$> tryCommand stackCmd) $ \(_ :: IOException) -> do + errorm $ "Command `" ++ stackCmd ++"` failed." + execWithGhc + -- The command `cabal v2-exec -v0 ghc` only works if the project has been + -- built already. + -- This command must work though before the project is build. + -- Therefore, fallback to "ghc" on the path. + -- + -- else if isCabalCradle crdl && isCabalInstalled then do + -- let cmd = "cabal v2-exec -v0 ghc -- " ++ unwords args + -- catch (Just <$> tryCommand cmd) $ \(_ ::IOException) -> do + -- errorm $ "Command `" ++ cmd ++ "` failed." + -- return Nothing + else do + logm "Use Plain GHC" + execWithGhc + debugm $ "GHC Output: \"" ++ show ghcOutput ++ "\"" + return ghcOutput + where + stackCmd = "stack ghc -- " ++ unwords args + plainCmd = "ghc " ++ unwords args + + execWithGhc = + catch (Just <$> tryCommand plainCmd) $ \(_ :: IOException) -> do + errorm $ "Command `" ++ plainCmd ++"` failed." + return Nothing + +tryCommand :: String -> IO String +tryCommand cmd = do + (code, sout, serr) <- readCreateProcessWithExitCode (shell cmd) "" + case code of + ExitFailure e -> do + let errmsg = concat + [ "`" + , cmd + , "`: Exit failure: " + , show e + , ", stdout: " + , sout + , ", stderr: " + , serr + ] + errorm errmsg + throwIO $ userError errmsg + + ExitSuccess -> return $ T.unpack . T.strip . head . T.lines $ T.pack sout + + +-- | Get the directory of the libdir based on the project ghc. +getProjectGhcLibDir :: Cradle -> IO (Maybe FilePath) +getProjectGhcLibDir crdl = + execProjectGhc crdl ["--print-libdir"] >>= \case + Nothing -> do + logm "Could not obtain the libdir." + return Nothing + mlibdir -> return mlibdir + + -- --------------------------------------------------------------------- + + {- | Finds a Cabal v2-project, Cabal v1-project or a Stack project relative to the given FilePath. Cabal v2-project and Stack have priority over Cabal v1-project. diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs index 007f02ad1..a7d293d9d 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs @@ -120,9 +120,8 @@ import Data.Typeable ( TypeRep ) import System.Directory import GhcMonad -import qualified HIE.Bios.Ghc.Api as BIOS import GHC.Generics -import GHC ( HscEnv ) +import GHC ( HscEnv, runGhcT ) import Exception import Haskell.Ide.Engine.Compat @@ -345,10 +344,10 @@ getDiagnosticProvidersConfig c = Map.fromList [("applyrefact",hlintOn c) type IdeGhcM = GhcT IdeM -- | Run an IdeGhcM with Cradle found from the current directory -runIdeGhcM :: IdePlugins -> Maybe (Core.LspFuncs Config) -> TVar IdeState -> IdeGhcM a -> IO a -runIdeGhcM plugins mlf stateVar f = do +runIdeGhcM :: Maybe FilePath -> IdePlugins -> Maybe (Core.LspFuncs Config) -> TVar IdeState -> IdeGhcM a -> IO a +runIdeGhcM mlibdir plugins mlf stateVar f = do env <- IdeEnv <$> pure mlf <*> getProcessID <*> pure plugins - flip runReaderT stateVar $ flip runReaderT env $ BIOS.withGhcT f + flip runReaderT stateVar $ flip runReaderT env $ runGhcT mlibdir f -- | A computation that is deferred until the module is cached. -- Note that the module may not typecheck, in which case 'UriCacheFailed' is passed diff --git a/hie-plugin-api/hie-plugin-api.cabal b/hie-plugin-api/hie-plugin-api.cabal index 7df3ad352..32f2a2d42 100644 --- a/hie-plugin-api/hie-plugin-api.cabal +++ b/hie-plugin-api/hie-plugin-api.cabal @@ -56,6 +56,7 @@ library , unliftio , monad-control , mtl + , process , stm , syb , text diff --git a/src/Haskell/Ide/Engine/Scheduler.hs b/src/Haskell/Ide/Engine/Scheduler.hs index a94787487..ec2d59b52 100644 --- a/src/Haskell/Ide/Engine/Scheduler.hs +++ b/src/Haskell/Ide/Engine/Scheduler.hs @@ -41,7 +41,9 @@ import qualified Language.Haskell.LSP.Core as Core import qualified Language.Haskell.LSP.Types as J import GhcMonad +import qualified HIE.Bios.Types as Bios import Haskell.Ide.Engine.GhcModuleCache +import qualified Haskell.Ide.Engine.Cradle as Bios import Haskell.Ide.Engine.Config import qualified Haskell.Ide.Engine.Channel as Channel import Haskell.Ide.Engine.PluginsIdeMonads @@ -143,8 +145,11 @@ runScheduler -- ^ A handler to run the requests' callback in your monad of choosing. -> Maybe (Core.LspFuncs Config) -- ^ The LspFuncs provided by haskell-lsp, if using LSP. + -> Maybe Bios.Cradle + -- ^ Context in which the ghc thread is executed. + -- Neccessary to obtain the libdir, for example. -> IO () -runScheduler Scheduler {..} errorHandler callbackHandler mlf = do +runScheduler Scheduler {..} errorHandler callbackHandler mlf mcrdl = do let dEnv = DispatcherEnv { cancelReqsTVar = requestsToCancel , wipReqsTVar = requestsInProgress @@ -158,7 +163,11 @@ runScheduler Scheduler {..} errorHandler callbackHandler mlf = do stateVar <- STM.newTVarIO initialState - let runGhcDisp = runIdeGhcM plugins mlf stateVar $ + mlibdir <- case mcrdl of + Nothing -> return Nothing + Just crdl -> Bios.getProjectGhcLibDir crdl + + let runGhcDisp = runIdeGhcM mlibdir plugins mlf stateVar $ ghcDispatcher dEnv errorHandler callbackHandler ghcChanOut runIdeDisp = runIdeM plugins mlf stateVar $ ideDispatcher dEnv errorHandler callbackHandler ideChanOut diff --git a/src/Haskell/Ide/Engine/Server.hs b/src/Haskell/Ide/Engine/Server.hs index 9e4d51af9..c8f11f8f0 100644 --- a/src/Haskell/Ide/Engine/Server.hs +++ b/src/Haskell/Ide/Engine/Server.hs @@ -38,7 +38,8 @@ import qualified Data.SortedList as SL import qualified Data.Text as T import Data.Text.Encoding import qualified Data.Yaml as Yaml -import Haskell.Ide.Engine.Cradle (findLocalCradle, cradleDisplay) +import Haskell.Ide.Engine.Cradle (findLocalCradle, cradleDisplay + , isCabalCradle) import Haskell.Ide.Engine.Config import qualified Haskell.Ide.Engine.Ghc as HIE import Haskell.Ide.Engine.CodeActions @@ -151,12 +152,64 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do (Debounce.forMonoid $ react . dispatchDiagnostics) (Debounce.def { Debounce.delay = debounceDuration, Debounce.alwaysResetTimer = True }) + + let lspRootDir = Core.rootPath lf + currentDir <- liftIO getCurrentDirectory + + -- Check for mismatching GHC versions + let dummyCradleFile = fromMaybe currentDir lspRootDir "File.hs" + debugm $ "Dummy Cradle file result: " ++ dummyCradleFile + cradleRes <- liftIO $ E.try (findLocalCradle dummyCradleFile) + let sf = Core.sendFunc lf + + case cradleRes of + Right cradle -> do + projGhcVersion <- liftIO $ getProjectGhcVersion cradle + when (projGhcVersion /= hieGhcVersion) $ do + let msg = T.pack $ "Mismatching GHC versions: " ++ cradleDisplay cradle ++ + " is " ++ projGhcVersion ++ ", HIE is " ++ hieGhcVersion + ++ "\nYou may want to use hie-wrapper. Check the README for more information" + sf $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning msg + sf $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning msg + + -- Check cabal is installed + when (isCabalCradle cradle) $ do + hasCabal <- liftIO checkCabalInstall + unless hasCabal $ do + let cabalMsg = T.pack "cabal-install is not installed. Check the README for more information" + sf $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning cabalMsg + sf $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning cabalMsg + + Left (e :: Yaml.ParseException) -> do + logm $ "Failed to parse `hie.yaml`: " ++ show e + sf $ NotShowMessage $ fmServerShowMessageNotification J.MtError ("Couldn't parse hie.yaml: \n" <> T.pack (show e)) + + let mcradle = case cradleRes of + Left _ -> Nothing + Right c -> Just c + -- haskell lsp sets the current directory to the project root in the InitializeRequest -- We launch the dispatcher after that so that the default cradle is -- recognized properly by ghc-mod - flip labelThread "scheduler" =<< (forkIO $ Scheduler.runScheduler scheduler errorHandler callbackHandler (Just lf)) - flip labelThread "reactor" =<< (forkIO reactorFunc) - flip labelThread "diagnostics" =<< (forkIO $ diagnosticsQueue tr) + flip labelThread "scheduler" =<< + (forkIO ( + Scheduler.runScheduler scheduler errorHandler callbackHandler (Just lf) mcradle + `E.catch` \(e :: E.SomeException) -> + (errorm $ "Scheduler thread exited unexpectedly: " ++ show e) + )) + flip labelThread "reactor" =<< + (forkIO ( + reactorFunc + `E.catch` \(e :: E.SomeException) -> + (errorm $ "Reactor thread exited unexpectedly: " ++ show e) + )) + flip labelThread "diagnostics" =<< + (forkIO ( + diagnosticsQueue tr + `E.catch` \(e :: E.SomeException) -> + (errorm $ "Diagnostic thread exited unexpectedly: " ++ show e) + )) + return Nothing diagnosticProviders :: Map.Map DiagnosticTrigger [(PluginId,DiagnosticProviderFunc)] @@ -396,35 +449,6 @@ reactor inp diagIn = do reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtLog $ "Using hie version: " <> T.pack hieVersion - lspRootDir <- asksLspFuncs Core.rootPath - currentDir <- liftIO getCurrentDirectory - - -- Check for mismatching GHC versions - -- Ignore hie.yaml parse errors. They get reported in ModuleCache.hs - let parseErrorHandler (_ :: Yaml.ParseException) = return Nothing - dummyCradleFile = (fromMaybe currentDir lspRootDir) "File.hs" - cradleRes <- liftIO $ E.catch (Just <$> findLocalCradle dummyCradleFile) parseErrorHandler - - case cradleRes of - Just cradle -> do - projGhcVersion <- liftIO $ getProjectGhcVersion cradle - when (projGhcVersion /= hieGhcVersion) $ do - let msg = T.pack $ "Mismatching GHC versions: " ++ cradleDisplay cradle ++ - " is " ++ projGhcVersion ++ ", HIE is " ++ hieGhcVersion - ++ "\nYou may want to use hie-wrapper. Check the README for more information" - reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning msg - reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning msg - - -- Check cabal is installed - -- TODO: only do this check if its a cabal cradle - hasCabal <- liftIO checkCabalInstall - unless hasCabal $ do - let cabalMsg = T.pack "cabal-install is not installed. Check the README for more information" - reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning cabalMsg - reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning cabalMsg - - Nothing -> return () - renv <- ask let hreq = GReq tn "init-hoogle" Nothing Nothing Nothing callback Nothing $ IdeResultOk <$> Hoogle.initializeHoogleDb callback Nothing = flip runReaderT renv $ diff --git a/src/Haskell/Ide/Engine/Version.hs b/src/Haskell/Ide/Engine/Version.hs index d81df88cf..f7f1c4e3d 100644 --- a/src/Haskell/Ide/Engine/Version.hs +++ b/src/Haskell/Ide/Engine/Version.hs @@ -1,25 +1,21 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -- | Information and display strings for HIE's version -- and the current project's version module Haskell.Ide.Engine.Version where -import Control.Exception import Data.Maybe import Development.GitRev (gitCommitCount) import Distribution.System (buildArch) import Distribution.Text (display) import Options.Applicative.Simple (simpleVersion) -import Haskell.Ide.Engine.Cradle (isStackCradle) -import qualified HIE.Bios.Types as BIOS +import Haskell.Ide.Engine.Cradle (execProjectGhc) +import qualified HIE.Bios.Types as Bios import qualified Paths_haskell_ide_engine as Meta -import qualified System.Log.Logger as L -import qualified Data.Text as T -import qualified Data.Versions as V import System.Directory import System.Info -import System.Process hieVersion :: String hieVersion = @@ -39,55 +35,18 @@ hieVersion = hieGhcDisplayVersion :: String hieGhcDisplayVersion = compilerName ++ "-" ++ VERSION_ghc -getProjectGhcVersion :: BIOS.Cradle -> IO String -getProjectGhcVersion crdl = do - isStackInstalled <- isJust <$> findExecutable "stack" - if isStackCradle crdl && isStackInstalled - then do - L.infoM "hie" "Using stack GHC version" - catch (tryCommand "stack ghc -- --numeric-version") $ \e -> do - L.errorM "hie" $ show (e :: SomeException) - L.infoM "hie" "Couldn't find stack version, falling back to plain GHC" - getGhcVersion - else do - L.infoM "hie" "Using plain GHC version" - getGhcVersion +getProjectGhcVersion :: Bios.Cradle -> IO String +getProjectGhcVersion crdl = + fmap + (fromMaybe "No System GHC Found.") + (execProjectGhc crdl ["--numeric-version"]) - where - getGhcVersion = do - isGhcInstalled <- isJust <$> findExecutable "ghc" - if isGhcInstalled - then tryCommand "ghc --numeric-version" - else return "No System GHC found" - - -tryCommand :: String -> IO String -tryCommand cmd = - init <$> readCreateProcess (shell cmd) "" hieGhcVersion :: String hieGhcVersion = VERSION_ghc -- --------------------------------------------------------------------- -getStackVersion :: IO (Maybe V.Version) -getStackVersion = do - isStackInstalled <- isJust <$> findExecutable "stack" - if isStackInstalled - then do - versionStr <- tryCommand "stack --numeric-version" - case V.version (T.pack versionStr) of - Left _err -> return Nothing - Right v -> return (Just v) - else return Nothing - -stack193Version :: V.Version -stack193Version = case V.version "1.9.3" of - Left err -> error $ "stack193Version:err=" ++ show err - Right v -> v - --- --------------------------------------------------------------------- - checkCabalInstall :: IO Bool checkCabalInstall = isJust <$> findExecutable "cabal" diff --git a/stack-8.4.2.yaml b/stack-8.4.2.yaml index 3e8454872..96526db47 100644 --- a/stack-8.4.2.yaml +++ b/stack-8.4.2.yaml @@ -28,7 +28,7 @@ extra-deps: - hoogle-5.0.17.11 - hsimport-0.11.0 - hslogger-1.3.1.0 -- lsp-test-0.9.0.0 +- lsp-test-0.10.0.0 - monad-dijkstra-0.1.1.2 - network-3.1.1.1 # for hslogger - network-bsd-2.8.1.0 # for hslogger @@ -53,6 +53,7 @@ extra-deps: - file-embed-0.0.11@sha256:77bb3b1dc219ccd682706b1d3dfbc5bf2db5beb1af6c108ed9e0f5b4d58a5a0a,1325 - libyaml-0.1.1.0@sha256:b3fcd8c44622c75e054c2267f3fec39a58a311748000310cbc8257a4683d3f02,2090 - unordered-containers-0.2.10.0@sha256:5e9b095a9283d9e2f064fec73a81a6b6ea0b7fda3f219a8175785d2d2a3de204 +- parser-combinators-1.2.1@sha256:16c3490e007ec10b1255a2b36fb483d000156d555269107131241d9e0fa96412,1788 flags: haskell-ide-engine: diff --git a/stack-8.4.3.yaml b/stack-8.4.3.yaml index 93fbc062f..d94aa9c75 100644 --- a/stack-8.4.3.yaml +++ b/stack-8.4.3.yaml @@ -28,7 +28,7 @@ extra-deps: - hoogle-5.0.17.11 - hsimport-0.11.0 - hslogger-1.3.1.0 -- lsp-test-0.9.0.0 +- lsp-test-0.10.0.0 - monad-dijkstra-0.1.1.2 - network-3.1.1.1 # for hslogger - network-bsd-2.8.1.0 # for hslogger @@ -51,6 +51,7 @@ extra-deps: - file-embed-0.0.11@sha256:77bb3b1dc219ccd682706b1d3dfbc5bf2db5beb1af6c108ed9e0f5b4d58a5a0a,1325 - libyaml-0.1.1.0@sha256:b3fcd8c44622c75e054c2267f3fec39a58a311748000310cbc8257a4683d3f02,2090 - unordered-containers-0.2.10.0@sha256:5e9b095a9283d9e2f064fec73a81a6b6ea0b7fda3f219a8175785d2d2a3de204 +- parser-combinators-1.2.1@sha256:16c3490e007ec10b1255a2b36fb483d000156d555269107131241d9e0fa96412,1788 flags: haskell-ide-engine: diff --git a/stack-8.4.4.yaml b/stack-8.4.4.yaml index 4773450cf..6fbc933f3 100644 --- a/stack-8.4.4.yaml +++ b/stack-8.4.4.yaml @@ -27,7 +27,7 @@ extra-deps: - hoogle-5.0.17.11 - hsimport-0.11.0 - hslogger-1.3.1.0 -- lsp-test-0.9.0.0 +- lsp-test-0.10.0.0 - monad-dijkstra-0.1.1.2 - network-3.1.1.1 # for hslogger - network-bsd-2.8.1.0 # for hslogger @@ -50,6 +50,7 @@ extra-deps: - unordered-containers-0.2.10.0@sha256:5e9b095a9283d9e2f064fec73a81a6b6ea0b7fda3f219a8175785d2d2a3de204 - file-embed-0.0.11@sha256:77bb3b1dc219ccd682706b1d3dfbc5bf2db5beb1af6c108ed9e0f5b4d58a5a0a,1325 - libyaml-0.1.1.0@sha256:b3fcd8c44622c75e054c2267f3fec39a58a311748000310cbc8257a4683d3f02,2090 +- parser-combinators-1.2.1@sha256:16c3490e007ec10b1255a2b36fb483d000156d555269107131241d9e0fa96412,1788 flags: haskell-ide-engine: diff --git a/stack-8.6.1.yaml b/stack-8.6.1.yaml index 8ccd97963..6be262b40 100644 --- a/stack-8.6.1.yaml +++ b/stack-8.6.1.yaml @@ -30,7 +30,7 @@ extra-deps: - hlint-2.2.4 - hoogle-5.0.17.11 - hsimport-0.11.0 -- lsp-test-0.9.0.0 +- lsp-test-0.10.0.0 - monad-dijkstra-0.1.1.2 - monad-memo-0.4.1 - monoid-subclasses-0.4.6.1 @@ -49,6 +49,7 @@ extra-deps: - yaml-0.11.1.2@sha256:cbc4ddb233c564967aad27ee47c1cd8fd6a06b9183353e76fe66c9be7c9dfd76 - libyaml-0.1.1.0@sha256:b3fcd8c44622c75e054c2267f3fec39a58a311748000310cbc8257a4683d3f02,2090 - unordered-containers-0.2.10.0@sha256:5e9b095a9283d9e2f064fec73a81a6b6ea0b7fda3f219a8175785d2d2a3de204 +- parser-combinators-1.2.1@sha256:16c3490e007ec10b1255a2b36fb483d000156d555269107131241d9e0fa96412,1788 flags: haskell-ide-engine: diff --git a/stack-8.6.2.yaml b/stack-8.6.2.yaml index 2fd3d7bef..a5396645b 100644 --- a/stack-8.6.2.yaml +++ b/stack-8.6.2.yaml @@ -26,7 +26,7 @@ extra-deps: - hlint-2.2.4 - hoogle-5.0.17.11 - hsimport-0.11.0 -- lsp-test-0.9.0.0 +- lsp-test-0.10.0.0 - monad-dijkstra-0.1.1.2 - monad-memo-0.4.1 - multistate-0.8.0.1 @@ -43,6 +43,7 @@ extra-deps: - yaml-0.11.1.2@sha256:cbc4ddb233c564967aad27ee47c1cd8fd6a06b9183353e76fe66c9be7c9dfd76 - libyaml-0.1.1.0@sha256:b3fcd8c44622c75e054c2267f3fec39a58a311748000310cbc8257a4683d3f02,2090 - unordered-containers-0.2.10.0@sha256:5e9b095a9283d9e2f064fec73a81a6b6ea0b7fda3f219a8175785d2d2a3de204 +- parser-combinators-1.2.1@sha256:16c3490e007ec10b1255a2b36fb483d000156d555269107131241d9e0fa96412,1788 flags: haskell-ide-engine: diff --git a/stack-8.6.3.yaml b/stack-8.6.3.yaml index 588f4aa31..ff9cc24cb 100644 --- a/stack-8.6.3.yaml +++ b/stack-8.6.3.yaml @@ -24,7 +24,7 @@ extra-deps: - hlint-2.2.4 - hoogle-5.0.17.11 - hsimport-0.11.0 -- lsp-test-0.9.0.0 +- lsp-test-0.10.0.0 - monad-dijkstra-0.1.1.2 - monad-memo-0.4.1 - multistate-0.8.0.1 @@ -39,6 +39,7 @@ extra-deps: - unix-compat-0.5.2@sha256:16763f1fae4a25abf61ac6195eb530ce838474bd04d86c7d353340aee8716bbb - yaml-0.11.1.2@sha256:cbc4ddb233c564967aad27ee47c1cd8fd6a06b9183353e76fe66c9be7c9dfd76 - unordered-containers-0.2.10.0@sha256:5e9b095a9283d9e2f064fec73a81a6b6ea0b7fda3f219a8175785d2d2a3de204 +- parser-combinators-1.2.1@sha256:16c3490e007ec10b1255a2b36fb483d000156d555269107131241d9e0fa96412,1788 flags: haskell-ide-engine: diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index e590488b7..e95ca6b34 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -23,7 +23,7 @@ extra-deps: - hlint-2.2.4 - hoogle-5.0.17.11 - hsimport-0.11.0 -- lsp-test-0.9.0.0 +- lsp-test-0.10.0.0 - monad-dijkstra-0.1.1.2@rev:1 - monad-memo-0.4.1 - multistate-0.8.0.1 @@ -37,6 +37,7 @@ extra-deps: - unix-compat-0.5.2@sha256:16763f1fae4a25abf61ac6195eb530ce838474bd04d86c7d353340aee8716bbb - yaml-0.11.1.2@sha256:cbc4ddb233c564967aad27ee47c1cd8fd6a06b9183353e76fe66c9be7c9dfd76 - unordered-containers-0.2.10.0@sha256:5e9b095a9283d9e2f064fec73a81a6b6ea0b7fda3f219a8175785d2d2a3de204 +- parser-combinators-1.2.1@sha256:16c3490e007ec10b1255a2b36fb483d000156d555269107131241d9e0fa96412,1788 flags: diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 4e9052e19..f099e1ef1 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -23,11 +23,12 @@ extra-deps: - hlint-2.2.4 - hsimport-0.11.0 - hoogle-5.0.17.11 -- lsp-test-0.9.0.0 +- lsp-test-0.10.0.0 - monad-dijkstra-0.1.1.2@rev:1 - syz-0.2.0.0 - temporary-1.2.1.1 - clock-0.7.2 +- parser-combinators-1.2.1@sha256:16c3490e007ec10b1255a2b36fb483d000156d555269107131241d9e0fa96412,1788 flags: haskell-ide-engine: diff --git a/stack.yaml b/stack.yaml index 0a1737345..58ea2bb03 100644 --- a/stack.yaml +++ b/stack.yaml @@ -22,7 +22,7 @@ extra-deps: - hie-bios-0.3.2 - hlint-2.2.4 - hsimport-0.11.0 -- lsp-test-0.9.0.0 +- lsp-test-0.10.0.0 - monad-dijkstra-0.1.1.2@rev:1 - syz-0.2.0.0 - temporary-1.2.1.1 @@ -31,6 +31,7 @@ extra-deps: - extra-1.6.18 - unix-compat-0.5.2 - yaml-0.11.1.2 +- parser-combinators-1.2.1@sha256:16c3490e007ec10b1255a2b36fb483d000156d555269107131241d9e0fa96412,1788 flags: haskell-ide-engine: diff --git a/test/dispatcher/Main.hs b/test/dispatcher/Main.hs index da674919b..712d296c7 100644 --- a/test/dispatcher/Main.hs +++ b/test/dispatcher/Main.hs @@ -14,6 +14,7 @@ import Data.Default import GHC ( TypecheckedModule ) import GHC.Generics import Haskell.Ide.Engine.Ghc +import qualified Haskell.Ide.Engine.Cradle as Bios import Haskell.Ide.Engine.MonadTypes import Haskell.Ide.Engine.PluginUtils import Haskell.Ide.Engine.Scheduler @@ -26,7 +27,7 @@ import System.FilePath import Test.Hspec import Test.Hspec.Runner -import System.IO +import System.IO -- --------------------------------------------------------------------- -- plugins @@ -70,6 +71,10 @@ startServer :: IO (Scheduler IO, TChan LogVal, ThreadId) startServer = do scheduler <- newScheduler plugins testOptions logChan <- newTChanIO + -- This is correct because we set the working directory to + -- "test/testdata" in the function set-up. + cwd <- getCurrentDirectory + crdl <- Bios.findLocalCradle (cwd "File.hs") dispatcher <- forkIO $ do flushStackEnvironment runScheduler @@ -77,6 +82,7 @@ startServer = do (\lid errCode e -> logToChan logChan ("received an error", Left (lid, errCode, e))) (\g x -> g x) def + (Just crdl) return (scheduler, logChan, dispatcher) @@ -126,6 +132,7 @@ instance ToJSON Cached where funcSpec :: Spec funcSpec = describe "functional dispatch" $ do + -- required to not kill the 'findLocalCradle' logic in 'startServer'. runIO $ setCurrentDirectory "test/testdata" (scheduler, logChan, dispatcher) <- runIO startServer diff --git a/test/functional/HieBiosSpec.hs b/test/functional/HieBiosSpec.hs index 2a8213253..71f8e1936 100644 --- a/test/functional/HieBiosSpec.hs +++ b/test/functional/HieBiosSpec.hs @@ -20,15 +20,14 @@ spec = beforeAll_ (writeFile (hieBiosErrorPath "hie.yaml") "") $ do _ <- openDoc "Main.hs" "haskell" _ <- count 2 waitForDiagnostics return () - + it "reports errors in hie.yaml" $ runSession hieCommand fullCaps hieBiosErrorPath $ do _ <- openDoc "Foo.hs" "haskell" _ <- skipManyTill loggingNotification (satisfy isMessage) return () - + where hieBiosErrorPath = "test/testdata/hieBiosError" - + isMessage (NotShowMessage (NotificationMessage _ _ (ShowMessageParams MtError s))) = "Couldn't parse hie.yaml" `T.isInfixOf` s isMessage _ = False - \ No newline at end of file diff --git a/test/plugin-dispatcher/Main.hs b/test/plugin-dispatcher/Main.hs index e06d84e4b..8367c4669 100644 --- a/test/plugin-dispatcher/Main.hs +++ b/test/plugin-dispatcher/Main.hs @@ -7,6 +7,7 @@ import Control.Concurrent.STM.TChan import Control.Monad.STM import qualified Data.Text as T import Data.Default +import qualified Haskell.Ide.Engine.Cradle as Bios import Haskell.Ide.Engine.MonadTypes import Haskell.Ide.Engine.Scheduler import Haskell.Ide.Engine.Types @@ -14,6 +15,8 @@ import Language.Haskell.LSP.Types import TestUtils import Test.Hspec import Test.Hspec.Runner +import System.Directory (getCurrentDirectory) +import System.FilePath -- --------------------------------------------------------------------- @@ -42,10 +45,14 @@ newPluginSpec = do let makeReq = sendRequest scheduler + cwd <- getCurrentDirectory + crdl <- Bios.findLocalCradle (cwd "test" "testdata" "File.hs") + pid <- forkIO $ runScheduler scheduler (\_ _ _ -> return ()) (\f x -> f x) def + (Just crdl) updateDocument scheduler (filePathToUri "test") 3 sendRequest scheduler req0 diff --git a/test/unit/ApplyRefactPluginSpec.hs b/test/unit/ApplyRefactPluginSpec.hs index 3a7e6f004..f13c2a7f0 100644 --- a/test/unit/ApplyRefactPluginSpec.hs +++ b/test/unit/ApplyRefactPluginSpec.hs @@ -35,8 +35,8 @@ testPlugins = pluginDescToIdePlugins [applyRefactDescriptor "applyrefact"] applyRefactSpec :: Spec applyRefactSpec = do describe "apply-refact plugin commands" $ do - applyRefactPath <- runIO $ filePathToUri <$> makeAbsolute "./test/testdata/ApplyRefact.hs" - + applyRefactFp <- runIO $ makeAbsolute "./test/testdata/ApplyRefact.hs" + let applyRefactPath = filePathToUri applyRefactFp -- --------------------------------- it "applies one hint only" $ do @@ -48,7 +48,7 @@ applyRefactSpec = do res = IdeResultOk $ WorkspaceEdit (Just $ H.singleton applyRefactPath textEdits) Nothing - testCommand testPlugins act "applyrefact" "applyOne" arg res + testCommand testPlugins applyRefactFp act "applyrefact" "applyOne" arg res -- --------------------------------- @@ -61,7 +61,7 @@ applyRefactSpec = do res = IdeResultOk $ WorkspaceEdit (Just $ H.singleton applyRefactPath textEdits) Nothing - testCommand testPlugins act "applyrefact" "applyAll" arg res + testCommand testPlugins applyRefactFp act "applyrefact" "applyAll" arg res -- --------------------------------- @@ -85,7 +85,7 @@ applyRefactSpec = do "Redundant bracket\nFound:\n (x + 1)\nWhy not:\n x + 1\n" Nothing ]} - runIGM testPlugins act `shouldReturn` res + runIGM testPlugins applyRefactFp act `shouldReturn` res -- --------------------------------- @@ -105,15 +105,15 @@ applyRefactSpec = do , _source = Just "hlint" , _message = T.pack filePathNoUri <> ":13:24: error:\n Operator applied to too few arguments: +\n data instance Sing (z :: (a :~: b)) where\n> SRefl :: Sing Refl +\n\n" , _relatedInformation = Nothing }]} - runIGM testPlugins act `shouldReturn` res + runIGM testPlugins applyRefactFp act `shouldReturn` res -- --------------------------------- it "respects hlint pragmas in the source file" $ do - filePath <- filePathToUri <$> makeAbsolute "./test/testdata/HlintPragma.hs" - + fp <- makeAbsolute "./test/testdata/HlintPragma.hs" + let filePath = filePathToUri fp let req = lint filePath - r <- runIGM testPlugins req + r <- runIGM testPlugins fp req r `shouldBe` (IdeResultOk (PublishDiagnosticsParams @@ -132,10 +132,11 @@ applyRefactSpec = do -- --------------------------------- it "respects hlint config files in project root dir" $ do - filePath <- filePathToUri <$> makeAbsolute "./test/testdata/HlintPragma.hs" + fp <- makeAbsolute "./test/testdata/HlintPragma.hs" + let filePath = filePathToUri fp let req = lint filePath - r <- withCurrentDirectory "./test/testdata" $ runIGM testPlugins req + r <- withCurrentDirectory "./test/testdata" $ runIGM testPlugins fp req r `shouldBe` (IdeResultOk (PublishDiagnosticsParams @@ -148,11 +149,11 @@ applyRefactSpec = do -- --------------------------------- it "reports error without crash" $ do - filePath <- filePathToUri <$> makeAbsolute "./test/testdata/ApplyRefactError.hs" - + fp <- makeAbsolute "./test/testdata/ApplyRefactError.hs" + let filePath = filePathToUri fp let req = applyAllCmd filePath isExpectedError (IdeResultFail (IdeError PluginError err _)) = "Illegal symbol '.' in type" `T.isInfixOf` err isExpectedError _ = False - r <- withCurrentDirectory "./test/testdata" $ runIGM testPlugins req + r <- withCurrentDirectory "./test/testdata" $ runIGM testPlugins fp req r `shouldSatisfy` isExpectedError diff --git a/test/unit/ContextSpec.hs b/test/unit/ContextSpec.hs index bb911083d..722325098 100644 --- a/test/unit/ContextSpec.hs +++ b/test/unit/ContextSpec.hs @@ -23,7 +23,7 @@ spec = describe "Context of different cursor positions" $ do fp <- makeAbsolute "./ExampleContext.hs" let arg = filePathToUri fp let res = IdeResultOk (Nothing :: Maybe Context) - actual <- runSingle (IdePlugins mempty) $ do + actual <- runSingle (IdePlugins mempty) fp $ do _ <- setTypecheckedModule arg return $ IdeResultOk Nothing @@ -243,7 +243,7 @@ spec = describe "Context of different cursor positions" $ do getContextAt :: FilePath -> Position -> IO (IdeResult (Maybe Context)) getContextAt fp pos = do let arg = filePathToUri fp - runSingle (IdePlugins mempty) $ do + runSingle (IdePlugins mempty) fp $ do _ <- setTypecheckedModule arg pluginGetFile "getContext: " arg $ \fp_ -> ifCachedModuleAndData fp_ (IdeResultOk Nothing) $ \tm _ () -> diff --git a/test/unit/ExtensibleStateSpec.hs b/test/unit/ExtensibleStateSpec.hs index 9e673790c..3e8489c54 100644 --- a/test/unit/ExtensibleStateSpec.hs +++ b/test/unit/ExtensibleStateSpec.hs @@ -6,6 +6,8 @@ import Data.Typeable import Haskell.Ide.Engine.MonadTypes import Haskell.Ide.Engine.MonadFunctions import TestUtils +import System.Directory +import System.FilePath import Test.Hspec @@ -20,7 +22,9 @@ extensibleStateSpec :: Spec extensibleStateSpec = describe "stores and retrieves in the state" $ it "stores the first one" $ do - r <- runIGM testPlugins $ do + cwd <- getCurrentDirectory + let fp = cwd "test" "testdata" "File.hs" + r <- runIGM testPlugins fp $ do r1 <- makeRequest "test" "cmd1" () r2 <- makeRequest "test" "cmd2" () return (r1,r2) diff --git a/test/unit/GenericPluginSpec.hs b/test/unit/GenericPluginSpec.hs index 00360503b..2fb58a7d2 100644 --- a/test/unit/GenericPluginSpec.hs +++ b/test/unit/GenericPluginSpec.hs @@ -39,7 +39,7 @@ ghcmodSpec = fp <- makeAbsolute "./FileWithWarning.hs" let act = setTypecheckedModule arg arg = filePathToUri fp - IdeResultOk (_,env) <- runSingle testPlugins act + IdeResultOk (_,env) <- runSingle testPlugins fp act case env of [] -> return () [s] -> T.unpack s `shouldStartWith` "Loaded package environment from" @@ -54,8 +54,7 @@ ghcmodSpec = (Just "bios") "Variable not in scope: x" Nothing - - runIGM testPlugins (setTypecheckedModule arg) `shouldReturn` res + runIGM testPlugins fp (setTypecheckedModule arg) `shouldReturn` res -- --------------------------------- @@ -97,7 +96,7 @@ ghcmodSpec = , (Range (toPos (5,1)) (toPos (5,14)), "Int -> Int") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, find function type" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "HaReRename.hs" @@ -110,7 +109,7 @@ ghcmodSpec = [ (Range (toPos (2, 8)) (toPos (2,16)), "String -> IO ()") , (Range (toPos (2, 1)) (toPos (2,24)), "IO ()") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, no type at location" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "HaReRename.hs" @@ -120,7 +119,7 @@ ghcmodSpec = liftToGhc $ newTypeCmd (toPos (1,1)) uri arg = TP False uri (toPos (1,1)) res = IdeResultOk [] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, simple" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -133,7 +132,7 @@ ghcmodSpec = [ (Range (toPos (6, 16)) (toPos (6,17)), "Int") , (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, sum type pattern match, just" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -147,7 +146,7 @@ ghcmodSpec = , (Range (toPos (6, 5)) (toPos (6, 13)), "Maybe Int") , (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, sum type pattern match, just value" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -162,7 +161,7 @@ ghcmodSpec = , (Range (toPos (6, 5)) (toPos (6, 13)), "Maybe Int") , (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, sum type pattern match, nothing" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -175,7 +174,7 @@ ghcmodSpec = [ (Range (toPos (7, 5)) (toPos (7, 12)), "Maybe Int") , (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, sum type pattern match, nothing, literal" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -188,7 +187,7 @@ ghcmodSpec = [ (Range (toPos (7, 15)) (toPos (7, 16)), "Int") , (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, variable matching" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -201,7 +200,7 @@ ghcmodSpec = [ (Range (toPos (10, 5)) (toPos (10, 6)), "Maybe Int") , (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, case expr" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -215,7 +214,7 @@ ghcmodSpec = , (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int") , (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, case expr match, just" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -229,7 +228,7 @@ ghcmodSpec = , (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int") , (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, case expr match, just value" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -244,7 +243,7 @@ ghcmodSpec = , (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int") , (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, infix operator" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -258,7 +257,7 @@ ghcmodSpec = , (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int") , (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, case expr match, nothing" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -272,7 +271,7 @@ ghcmodSpec = , (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int") , (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, do bind expr result " $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -285,7 +284,7 @@ ghcmodSpec = [ (Range (toPos (16, 5)) (toPos (16, 6)), "Int") , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, do bind expr" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -298,7 +297,7 @@ ghcmodSpec = [ (Range (toPos (16, 10)) (toPos (16, 11)), "Maybe Int") , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, let binding function, return func" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -312,7 +311,7 @@ ghcmodSpec = , (Range (toPos (17, 9)) (toPos (17, 28)), "Maybe Int") , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, let binding function, return param" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -326,7 +325,7 @@ ghcmodSpec = , (Range (toPos (17, 9)) (toPos (17, 28)), "Maybe Int") , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, let binding function, function type" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -339,7 +338,7 @@ ghcmodSpec = [ (Range (toPos (17, 9)) (toPos (17, 28)), "Maybe Int") , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, do expr, function type" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -352,7 +351,7 @@ ghcmodSpec = [ (Range (toPos (18, 10)) (toPos (18, 11)), "Maybe Int") , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, let binding function, do expr bind for local func" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -365,7 +364,7 @@ ghcmodSpec = [ (Range (toPos (18, 5)) (toPos (18, 6)), "Int") , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, function type" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -377,7 +376,7 @@ ghcmodSpec = res = IdeResultOk [ (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, function parameter" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -390,7 +389,7 @@ ghcmodSpec = [ (Range (toPos (22, 10)) (toPos (22, 11)), "a -> a") , (Range (toPos (22, 1)) (toPos (22, 19)), "(a -> a) -> a -> a") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, function composition" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -404,7 +403,7 @@ ghcmodSpec = , (Range (toPos (25, 20)) (toPos (25, 29)), "a -> c") , (Range (toPos (25, 1)) (toPos (25, 34)), "(b -> c) -> (a -> b) -> a -> c") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, let binding, function composition" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -417,7 +416,7 @@ ghcmodSpec = [ (Range (toPos (25, 20)) (toPos (25, 29)), "a -> c") , (Range (toPos (25, 1)) (toPos (25, 34)), "(b -> c) -> (a -> b) -> a -> c") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, let binding, type of function" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -430,7 +429,7 @@ ghcmodSpec = [ (Range (toPos (25, 33)) (toPos (25, 34)), "a -> c") , (Range (toPos (25, 1)) (toPos (25, 34)), "(b -> c) -> (a -> b) -> a -> c") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, function type composition" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -442,7 +441,7 @@ ghcmodSpec = res = IdeResultOk [ (Range (toPos (25, 1)) (toPos (25, 34)), "(b -> c) -> (a -> b) -> a -> c") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, infix operator" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -455,7 +454,7 @@ ghcmodSpec = [ (Range (toPos (28, 25)) (toPos (28, 28)), "(a -> b) -> IO a -> IO b") , (Range (toPos (28, 1)) (toPos (28, 35)), "(a -> b) -> IO a -> IO b") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, constructor" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -467,7 +466,7 @@ ghcmodSpec = res = IdeResultOk [ -- (Range (toPos (31, 7)) (toPos (31, 12)), "Int -> Test") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, deriving clause Show type" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -482,7 +481,7 @@ ghcmodSpec = , (Range (toPos (33, 15)) (toPos (33, 19)), "Test -> String") , (Range (toPos (33, 15)) (toPos (33, 19)), "[Test] -> ShowS") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, deriving clause Eq type" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" @@ -496,7 +495,7 @@ ghcmodSpec = , (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool") , (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res -- ---------------------------------------------------------------------------- it "runs the type command with an absolute path from another folder, correct params" $ do @@ -515,7 +514,7 @@ ghcmodSpec = [(Range (toPos (5,9)) (toPos (5,10)), "Int") , (Range (toPos (5,1)) (toPos (5,14)), "Int -> Int") ] - testCommand testPlugins act "generic" "type" arg res + testCommand testPlugins fp act "generic" "type" arg res -- --------------------------------- diff --git a/test/unit/HooglePluginSpec.hs b/test/unit/HooglePluginSpec.hs index f399ecdcd..dcc2edd82 100644 --- a/test/unit/HooglePluginSpec.hs +++ b/test/unit/HooglePluginSpec.hs @@ -3,11 +3,13 @@ module HooglePluginSpec where import Control.Monad +import Control.Monad.IO.Class import Data.Maybe import Haskell.Ide.Engine.MonadTypes import Haskell.Ide.Engine.Support.Hoogle import Hoogle import System.Directory +import System.FilePath import Test.Hspec import TestUtils @@ -26,7 +28,9 @@ testPlugins :: IdePlugins testPlugins = pluginDescToIdePlugins [] dispatchRequestP :: IdeGhcM a -> IO a -dispatchRequestP = runIGM testPlugins +dispatchRequestP act = do + cwd <- liftIO $ getCurrentDirectory + runIGM testPlugins (cwd "test" "testdata" "File.hs") act -- --------------------------------------------------------------------- diff --git a/test/unit/PackagePluginSpec.hs b/test/unit/PackagePluginSpec.hs index 9108ff753..ee6fd7201 100644 --- a/test/unit/PackagePluginSpec.hs +++ b/test/unit/PackagePluginSpec.hs @@ -86,7 +86,7 @@ packageSpec = do ] res = IdeResultOk $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing - testCommand testPlugins act "package" "add" args res + testCommand testPlugins fp act "package" "add" args res it "Add package to .cabal to library component" $ withCurrentDirectory (testdata "cabal-lib") @@ -120,7 +120,7 @@ packageSpec = do ] res = IdeResultOk $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing - testCommand testPlugins act "package" "add" args res + testCommand testPlugins fp act "package" "add" args res it "Adds package to package.yaml to executable component" @@ -159,7 +159,7 @@ packageSpec = do , "description: Please see the README on GitHub at \n" ] ] - testCommand testPlugins act "package" "add" args res + testCommand testPlugins fp act "package" "add" args res it "Add package to package.yaml to library component" $ withCurrentDirectory (testdata "hpack-lib") @@ -192,7 +192,7 @@ packageSpec = do , "description: Please see the README on GitHub at \n" ] ] - testCommand testPlugins act "package" "add" args res + testCommand testPlugins fp act "package" "add" args res it "Do nothing on NoPackage" $ withCurrentDirectory (testdata "invalid") @@ -207,4 +207,4 @@ packageSpec = do "No package.yaml or .cabal found" Json.Null ) - testCommand testPlugins act "package" "add" args res + testCommand testPlugins fp act "package" "add" args res diff --git a/test/utils/TestUtils.hs b/test/utils/TestUtils.hs index b1edb382c..cf5f9d6c1 100644 --- a/test/utils/TestUtils.hs +++ b/test/utils/TestUtils.hs @@ -31,6 +31,7 @@ import Data.Maybe -- import qualified GhcMod.Types as GM import qualified Language.Haskell.LSP.Core as Core import Haskell.Ide.Engine.MonadTypes +import qualified Haskell.Ide.Engine.Cradle as Bios import System.Directory import System.Environment import System.FilePath @@ -51,30 +52,32 @@ testOptions = HIE.defaultOptions { cradleOptsVerbosity = Verbose } testCommand :: (ToJSON a, Typeable b, ToJSON b, Show b, Eq b) - => IdePlugins -> IdeGhcM (IdeResult b) -> PluginId -> CommandId -> a -> IdeResult b -> IO () -testCommand testPlugins act plugin cmd arg res = do + => IdePlugins -> FilePath -> IdeGhcM (IdeResult b) -> PluginId -> CommandId -> a -> IdeResult b -> IO () +testCommand testPlugins fp act plugin cmd arg res = do flushStackEnvironment - (newApiRes, oldApiRes) <- runIGM testPlugins $ do + (newApiRes, oldApiRes) <- runIGM testPlugins fp $ do new <- act old <- makeRequest plugin cmd arg return (new, old) newApiRes `shouldBe` res fmap fromDynJSON oldApiRes `shouldBe` fmap Just res -runSingle :: IdePlugins -> IdeGhcM (IdeResult b) -> IO (IdeResult b) -runSingle testPlugins act = runIGM testPlugins act +runSingle :: IdePlugins -> FilePath -> IdeGhcM (IdeResult b) -> IO (IdeResult b) +runSingle testPlugins fp act = runIGM testPlugins fp act runSingleReq :: ToJSON a - => IdePlugins -> PluginId -> CommandId -> a -> IO (IdeResult DynamicJSON) -runSingleReq testPlugins plugin com arg = runIGM testPlugins (makeRequest plugin com arg) + => IdePlugins -> FilePath -> PluginId -> CommandId -> a -> IO (IdeResult DynamicJSON) +runSingleReq testPlugins fp plugin com arg = runIGM testPlugins fp (makeRequest plugin com arg) makeRequest :: ToJSON a => PluginId -> CommandId -> a -> IdeGhcM (IdeResult DynamicJSON) makeRequest plugin com arg = runPluginCommand plugin com (toJSON arg) -runIGM :: IdePlugins -> IdeGhcM a -> IO a -runIGM testPlugins f = do +runIGM :: IdePlugins -> FilePath -> IdeGhcM a -> IO a +runIGM testPlugins fp f = do stateVar <- newTVarIO $ IdeState emptyModuleCache Map.empty Map.empty Nothing - runIdeGhcM testPlugins Nothing stateVar f + crdl <- Bios.findLocalCradle fp + mlibdir <- Bios.getProjectGhcLibDir crdl + runIdeGhcM mlibdir testPlugins Nothing stateVar f withFileLogging :: FilePath -> IO a -> IO a withFileLogging logFile f = do