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.

Author: fendor

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

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:

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

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

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"
+    matcher actualHlsCradle @? "HLS reported wrong project type"

test/wrapper/testdata/stack-with-dist-newstyle/dist-newstyle/.gitkeep

@@ -0,0 +1,6 @@
+cabal-version:      2.4
+name:               stack-with-dist-newstyle
+version:            0.1.0.0
+
+library
+    default-language: Haskell2010

test/wrapper/testdata/stack-with-dist-newstyle/stack-with-dist-newstyle.cabal

@@ -0,0 +1 @@
+# Empty stack.yaml, it does not matter for the test