From 59297eaf4fa409ec98d19a8438cf077db44a3859 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 1 May 2021 15:42:11 +0200 Subject: [PATCH] Add major CLI mode for printing the cradle type Adds test-case for proving that wrapper and hls report the same cradle type for a project. --- exe/Wrapper.hs | 33 ++++++++++++------- haskell-language-server.cabal | 3 +- src/Ide/Arguments.hs | 12 +++++++ src/Ide/Main.hs | 7 ++++ test/wrapper/Main.hs | 19 ++++++++++- .../dist-newstyle/.gitkeep | 0 .../stack-with-dist-newstyle.cabal | 6 ++++ .../stack-with-dist-newstyle/stack.yaml | 2 ++ 8 files changed, 69 insertions(+), 13 deletions(-) create mode 100644 test/wrapper/testdata/stack-with-dist-newstyle/dist-newstyle/.gitkeep create mode 100644 test/wrapper/testdata/stack-with-dist-newstyle/stack-with-dist-newstyle.cabal create mode 100644 test/wrapper/testdata/stack-with-dist-newstyle/stack.yaml diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index e1ae4a8a1b5..5c7256e07d4 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -7,6 +7,7 @@ import Control.Monad.Extra import Data.Default import Data.Foldable import Data.List +import Data.Void import qualified Development.IDE.Session as Session import qualified HIE.Bios.Environment as HieBios import HIE.Bios.Types @@ -42,6 +43,9 @@ main = do VersionMode PrintNumericVersion -> putStrLn haskellLanguageServerNumericVersion + BiosMode PrintCradleType -> + print =<< findProjectCradle + _ -> launchHaskellLanguageServer args launchHaskellLanguageServer :: Arguments -> IO () @@ -51,18 +55,11 @@ launchHaskellLanguageServer parsedArgs = do _ -> pure () d <- getCurrentDirectory + + -- search for the project cradle type + cradle <- findProjectCradle - let initialFp = (d "a") - -- Get the cabal directory from the cradle - 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!" - - cradle <- Session.loadCradle def hieYaml d - + -- Get the root directory from the cradle setCurrentDirectory $ cradleRootDir cradle case parsedArgs of @@ -135,3 +132,17 @@ getRuntimeGhcVersion' cradle = do Nothing -> die $ "Cradle requires " ++ exe ++ " but couldn't find it" ++ "\n" ++ show cradle + +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/haskell-language-server.cabal b/haskell-language-server.cabal index bbe15bd12a5..9ff10ced7df 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -440,7 +440,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/src/Ide/Arguments.hs b/src/Ide/Arguments.hs index 7104e1d55e8..4863c8edc1b 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 acf22e28e40..0c54145a800 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 576471b9e3c..97fa1004886 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 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 00000000000..e69de29bb2d 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 00000000000..ed06c519c82 --- /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 00000000000..2e36266ac1a --- /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