diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index baa7d99764..5c7256e07d 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -8,9 +8,8 @@ import Data.Default import Data.Foldable import Data.List import Data.Void -import Development.IDE.Session (findCradle) -import HIE.Bios hiding (findCradle) -import HIE.Bios.Environment +import qualified Development.IDE.Session as Session +import qualified HIE.Bios.Environment as HieBios import HIE.Bios.Types import Ide.Arguments import Ide.Version @@ -44,6 +43,9 @@ main = do VersionMode PrintNumericVersion -> putStrLn haskellLanguageServerNumericVersion + BiosMode PrintCradleType -> + print =<< findProjectCradle + _ -> launchHaskellLanguageServer args launchHaskellLanguageServer :: Arguments -> IO () @@ -53,9 +55,11 @@ launchHaskellLanguageServer parsedArgs = do _ -> pure () d <- getCurrentDirectory + + -- search for the project cradle type + cradle <- findProjectCradle - -- Get the cabal directory from the cradle - cradle <- findLocalCradle (d "a") + -- Get the root directory from the cradle setCurrentDirectory $ cradleRootDir cradle case parsedArgs of @@ -114,7 +118,7 @@ getRuntimeGhcVersion' cradle = do Direct -> checkToolExists "ghc" _ -> pure () - ghcVersionRes <- getRuntimeGhcVersion cradle + ghcVersionRes <- HieBios.getRuntimeGhcVersion cradle case ghcVersionRes of CradleSuccess ver -> do return ver @@ -129,23 +133,16 @@ getRuntimeGhcVersion' cradle = do die $ "Cradle requires " ++ exe ++ " but couldn't find it" ++ "\n" ++ show cradle --- | Find the cradle that the given File belongs to. --- --- First looks for a "hie.yaml" file in the directory of the file --- or one of its parents. If this file is found, the cradle --- is read from the config. If this config does not comply to the "hie.yaml" --- specification, an error is raised. --- --- If no "hie.yaml" can be found, the implicit config is used. --- The implicit config uses different heuristics to determine the type --- of the project that may or may not be accurate. -findLocalCradle :: FilePath -> IO (Cradle Void) -findLocalCradle fp = do - cradleConf <- findCradle def fp - crdl <- case cradleConf of - Just yaml -> do - hPutStrLn stderr $ "Found \"" ++ yaml ++ "\" for \"" ++ fp ++ "\"" - loadCradle yaml - Nothing -> loadImplicitCradle fp - hPutStrLn stderr $ "Module \"" ++ fp ++ "\" is loaded by Cradle: " ++ show crdl - return crdl +findProjectCradle :: IO (Cradle Void) +findProjectCradle = do + d <- getCurrentDirectory + + let initialFp = (d "a") + hieYaml <- Session.findCradle def initialFp + + -- Some log messages + case hieYaml of + Just yaml -> hPutStrLn stderr $ "Found \"" ++ yaml ++ "\" for \"" ++ initialFp ++ "\"" + Nothing -> hPutStrLn stderr "No 'hie.yaml' found. Try to discover the project type!" + + Session.loadCradle def hieYaml d \ No newline at end of file diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index ac1efb21a8..4ccbe0fa93 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -47,6 +47,7 @@ import Development.IDE.GHC.Compat hiding (Target, TargetFile, TargetModule) import qualified Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Util +import Development.IDE.Graph (Action) import Development.IDE.Session.VersionCheck import Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports @@ -55,7 +56,6 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq, import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Types.Options -import Development.IDE.Graph (Action) import GHC.Check import qualified HIE.Bios as HieBios import HIE.Bios.Environment hiding (getCacheDir) @@ -84,12 +84,10 @@ import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TQueue import qualified Data.HashSet as Set import Database.SQLite.Simple -import HIE.Bios.Cradle (yamlConfig) +import GHC.LanguageExtensions (Extension (EmptyCase)) import HieDb.Create import HieDb.Types import HieDb.Utils -import Maybes (MaybeT (runMaybeT)) -import GHC.LanguageExtensions (Extension(EmptyCase)) -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String @@ -99,15 +97,18 @@ data CacheDirs = CacheDirs { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath} data SessionLoadingOptions = SessionLoadingOptions - { findCradle :: FilePath -> IO (Maybe FilePath) - , loadCradle :: FilePath -> IO (HieBios.Cradle Void) + { findCradle :: FilePath -> IO (Maybe FilePath) + -- | Load the cradle with an optional 'hie.yaml' location. + -- If a 'hie.yaml' is given, use it to load the cradle. + -- Otherwise, use the provided project root directory to determine the cradle type. + , loadCradle :: Maybe FilePath -> FilePath -> IO (HieBios.Cradle Void) -- | Given the project name and a set of command line flags, -- return the path for storing generated GHC artifacts, -- or 'Nothing' to respect the cradle setting - , getCacheDirs :: String -> [String] -> IO CacheDirs + , getCacheDirs :: String -> [String] -> IO CacheDirs -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags' - , getInitialGhcLibDir :: IO (Maybe LibDir) - , fakeUid :: InstalledUnitId + , getInitialGhcLibDir :: IO (Maybe LibDir) + , fakeUid :: InstalledUnitId -- ^ unit id used to tag the internal component built by ghcide -- To reuse external interface files the unit ids must match, -- thus make sure to build them with `--this-unit-id` set to the @@ -117,17 +118,39 @@ data SessionLoadingOptions = SessionLoadingOptions instance Default SessionLoadingOptions where def = SessionLoadingOptions {findCradle = HieBios.findCradle - ,loadCradle = HieBios.loadCradle + ,loadCradle = loadWithImplicitCradle ,getCacheDirs = getCacheDirsDefault ,getInitialGhcLibDir = getInitialGhcLibDirDefault ,fakeUid = toInstalledUnitId (stringToUnitId "main") } +-- | Find the cradle for a given 'hie.yaml' configuration. +-- +-- If a 'hie.yaml' is given, the cradle is read from the config. +-- If this config does not comply to the "hie.yaml" +-- specification, an error is raised. +-- +-- If no location for "hie.yaml" is provided, the implicit config is used +-- using the provided root directory for discovering the project. +-- The implicit config uses different heuristics to determine the type +-- of the project that may or may not be accurate. +loadWithImplicitCradle :: Maybe FilePath + -- ^ Optional 'hie.yaml' location. Will be used if given. + -> FilePath + -- ^ Root directory of the project. Required as a fallback + -- if no 'hie.yaml' location is given. + -> IO (HieBios.Cradle Void) +loadWithImplicitCradle mHieYaml rootDir = do + crdl <- case mHieYaml of + Just yaml -> HieBios.loadCradle yaml + Nothing -> loadImplicitHieCradle $ addTrailingPathSeparator rootDir + return crdl + getInitialGhcLibDirDefault :: IO (Maybe LibDir) getInitialGhcLibDirDefault = do dir <- IO.getCurrentDirectory - hieYaml <- runMaybeT $ yamlConfig dir - cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) HieBios.loadCradle hieYaml + hieYaml <- findCradle def dir + cradle <- loadCradle def hieYaml dir hPutStrLn stderr $ "setInitialDynFlags cradle: " ++ show cradle libDirRes <- getRuntimeGhcLibDir cradle case libDirRes of @@ -399,7 +422,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do when (isNothing hieYaml) $ logWarning logger $ implicitCradleWarning lfp - cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) loadCradle hieYaml + cradle <- loadCradle hieYaml dir when optTesting $ mRunLspT lspEnv $ sendNotification (SCustomMethod "ghcide/cradle/loaded") (toJSON cfp) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index c920fe1f47..a7099e77b3 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -439,7 +439,8 @@ test-suite func-test test-suite wrapper-test type: exitcode-stdio-1.0 build-tool-depends: - haskell-language-server:haskell-language-server-wrapper -any + haskell-language-server:haskell-language-server-wrapper -any, + haskell-language-server:haskell-language-server -any default-language: Haskell2010 build-depends: diff --git a/hls-test-utils/src/Test/Hls/Util.hs b/hls-test-utils/src/Test/Hls/Util.hs index b01a003a1d..ec4769100b 100644 --- a/hls-test-utils/src/Test/Hls/Util.hs +++ b/hls-test-utils/src/Test/Hls/Util.hs @@ -29,6 +29,7 @@ module Test.Hls.Util , waitForDiagnosticsFromSource , waitForDiagnosticsFromSourceWithTimeout , withCurrentDirectoryInTmp + , withCurrentDirectoryInTmp' ) where @@ -269,20 +270,45 @@ flushStackEnvironment = do -- | Like 'withCurrentDirectory', but will copy the directory over to the system -- temporary directory first to avoid haskell-language-server's source tree from --- interfering with the cradle +-- interfering with the cradle. +-- +-- Ignores directories containing build artefacts to avoid interference and +-- provide reproducible test-behaviour. withCurrentDirectoryInTmp :: FilePath -> IO a -> IO a withCurrentDirectoryInTmp dir f = - withTempCopy dir $ \newDir -> + withTempCopy ignored dir $ \newDir -> + withCurrentDirectory newDir f + where + ignored = ["dist", "dist-newstyle", ".stack-work"] + + +-- | Like 'withCurrentDirectory', but will copy the directory over to the system +-- temporary directory first to avoid haskell-language-server's source tree from +-- interfering with the cradle. +-- +-- You may specify directories to ignore, but should be careful to maintain reproducibility. +withCurrentDirectoryInTmp' :: [FilePath] -> FilePath -> IO a -> IO a +withCurrentDirectoryInTmp' ignored dir f = + withTempCopy ignored dir $ \newDir -> withCurrentDirectory newDir f -withTempCopy :: FilePath -> (FilePath -> IO a) -> IO a -withTempCopy srcDir f = do +-- | Example call: @withTempCopy ignored src f@ +-- +-- Copy directory 'src' to into a temporary directory ignoring any directories +-- (and files) that are listed in 'ignored'. Pass the temporary directory +-- containing the copied sources to the continuation. +withTempCopy :: [FilePath] -> FilePath -> (FilePath -> IO a) -> IO a +withTempCopy ignored srcDir f = do withSystemTempDirectory "hls-test" $ \newDir -> do - copyDir srcDir newDir + copyDir ignored srcDir newDir f newDir -copyDir :: FilePath -> FilePath -> IO () -copyDir src dst = do +-- | Example call: @copyDir ignored src dst@ +-- +-- Copy directory 'src' to 'dst' ignoring any directories (and files) +-- that are listed in 'ignored'. +copyDir :: [FilePath] -> FilePath -> FilePath -> IO () +copyDir ignored src dst = do cnts <- listDirectory src forM_ cnts $ \file -> do unless (file `elem` ignored) $ do @@ -290,9 +316,8 @@ copyDir src dst = do dstFp = dst file isDir <- doesDirectoryExist srcFp if isDir - then createDirectory dstFp >> copyDir srcFp dstFp + then createDirectory dstFp >> copyDir ignored srcFp dstFp else copyFile srcFp dstFp - where ignored = ["dist", "dist-newstyle", ".stack-work"] fromAction :: (Command |? CodeAction) -> CodeAction fromAction (InR action) = action diff --git a/src/Ide/Arguments.hs b/src/Ide/Arguments.hs index 7104e1d55e..4863c8edc1 100644 --- a/src/Ide/Arguments.hs +++ b/src/Ide/Arguments.hs @@ -10,6 +10,7 @@ module Ide.Arguments ( Arguments(..) , GhcideArguments(..) , PrintVersion(..) + , BiosAction(..) , getArguments , haskellLanguageServerVersion , haskellLanguageServerNumericVersion @@ -27,6 +28,7 @@ import System.Environment data Arguments = VersionMode PrintVersion | ProbeToolsMode + | BiosMode BiosAction | Ghcide GhcideArguments | VSCodeExtensionSchemaMode | DefaultConfigurationMode @@ -50,12 +52,17 @@ data PrintVersion | PrintNumericVersion deriving (Show, Eq, Ord) +data BiosAction + = PrintCradleType + deriving (Show, Eq, Ord) + getArguments :: String -> IO Arguments getArguments exeName = execParser opts where opts = info (( VersionMode <$> printVersionParser exeName <|> probeToolsParser exeName + <|> BiosMode <$> biosParser <|> Ghcide <$> arguments <|> vsCodeExtensionSchemaModeParser <|> defaultConfigurationModeParser) @@ -72,6 +79,11 @@ printVersionParser exeName = flag' PrintNumericVersion (long "numeric-version" <> help ("Show numeric version of " ++ exeName)) +biosParser :: Parser BiosAction +biosParser = + flag' PrintCradleType + (long "print-cradle" <> help "Print the project cradle type") + probeToolsParser :: String -> Parser Arguments probeToolsParser exeName = flag' ProbeToolsMode diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index acf22e28e4..0c54145a80 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -17,6 +17,7 @@ import qualified Data.Text as T import Development.IDE.Core.Rules import Development.IDE.Main (isLSP) import qualified Development.IDE.Main as Main +import qualified Development.IDE.Session as Session import Development.IDE.Types.Logger as G import qualified Development.IDE.Types.Options as Ghcide import Development.IDE.Graph (ShakeOptions (shakeThreads)) @@ -50,6 +51,12 @@ defaultMain args idePlugins = do VersionMode PrintNumericVersion -> putStrLn haskellLanguageServerNumericVersion + BiosMode PrintCradleType -> do + dir <- IO.getCurrentDirectory + hieYaml <- Session.findCradle def dir + cradle <- Session.loadCradle def hieYaml dir + print cradle + Ghcide ghcideArgs -> do {- see WARNING above -} hPutStrLn stderr hlsVer diff --git a/test/wrapper/Main.hs b/test/wrapper/Main.hs index 576471b9e3..0b1f9cdf8d 100644 --- a/test/wrapper/Main.hs +++ b/test/wrapper/Main.hs @@ -1,4 +1,4 @@ -import Data.List.Extra (trimEnd) +import Data.List.Extra (trimEnd, isInfixOf) import Data.Maybe import System.Environment import System.Process @@ -18,6 +18,11 @@ projectGhcVersionTests = testGroup "--project-ghc-version" , testCase "cabal with global ghc" $ do ghcVer <- trimEnd <$> readProcess "ghc" ["--numeric-version"] "" testDir "test/wrapper/testdata/cabal-cur-ver" ghcVer + , testCase "stack with existing cabal build artifact" $ do + -- Should report cabal as existing build artifacts are more important than + -- the existence of 'stack.yaml' + testProjectType "test/wrapper/testdata/stack-with-dist-newstyle" + ("cradleOptsProg = CradleAction: Cabal" `isInfixOf`) ] testDir :: FilePath -> String -> Assertion @@ -27,3 +32,15 @@ testDir dir expectedVer = <$> lookupEnv "HLS_WRAPPER_TEST_EXE" actualVer <- trimEnd <$> readProcess testExe ["--project-ghc-version"] "" actualVer @?= expectedVer + +testProjectType :: FilePath -> (String -> Bool) -> Assertion +testProjectType dir matcher = + withCurrentDirectoryInTmp' [".stack-work", "dist"] dir $ do + wrapperTestExe <- fromMaybe "haskell-language-server-wrapper" + <$> lookupEnv "HLS_WRAPPER_TEST_EXE" + hlsTestExe <- fromMaybe "haskell-language-server" + <$> lookupEnv "HLS_TEST_EXE" + actualWrapperCradle <- trimEnd <$> readProcess wrapperTestExe ["--print-cradle"] "" + actualHlsCradle <- trimEnd <$> readProcess hlsTestExe ["--print-cradle"] "" + matcher actualWrapperCradle @? "Wrapper reported wrong project type: " ++ actualWrapperCradle + matcher actualHlsCradle @? "HLS reported wrong project type: " ++ actualHlsCradle \ No newline at end of file diff --git a/test/wrapper/testdata/stack-with-dist-newstyle/dist-newstyle/.gitkeep b/test/wrapper/testdata/stack-with-dist-newstyle/dist-newstyle/.gitkeep new file mode 100644 index 0000000000..e69de29bb2 diff --git a/test/wrapper/testdata/stack-with-dist-newstyle/stack-with-dist-newstyle.cabal b/test/wrapper/testdata/stack-with-dist-newstyle/stack-with-dist-newstyle.cabal new file mode 100644 index 0000000000..ed06c519c8 --- /dev/null +++ b/test/wrapper/testdata/stack-with-dist-newstyle/stack-with-dist-newstyle.cabal @@ -0,0 +1,6 @@ +cabal-version: 2.4 +name: stack-with-dist-newstyle +version: 0.1.0.0 + +library + default-language: Haskell2010 diff --git a/test/wrapper/testdata/stack-with-dist-newstyle/stack.yaml b/test/wrapper/testdata/stack-with-dist-newstyle/stack.yaml new file mode 100644 index 0000000000..2e36266ac1 --- /dev/null +++ b/test/wrapper/testdata/stack-with-dist-newstyle/stack.yaml @@ -0,0 +1,2 @@ +# specific version does not matter +resolver: ghc-8.10.4 \ No newline at end of file