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:

hls-test-utils/src/Test/Hls/Util.hs

@@ -29,6 +29,7 @@ module Test.Hls.Util
     , waitForDiagnosticsFromSource
     , waitForDiagnosticsFromSourceWithTimeout
     , withCurrentDirectoryInTmp
+    , withCurrentDirectoryInTmp'
   )
 where
 
@@ -269,30 +270,54 @@ 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
       let srcFp = src </> file
           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

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' [".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

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,2 @@
+# specific version does not matter
+resolver: ghc-8.10.4