Skip to content

Commit

Permalink
Add major CLI mode for printing the cradle type
Browse files Browse the repository at this point in the history
Adds test-case for proving that wrapper and hls report the
same cradle type for a project.
  • Loading branch information
fendor committed May 2, 2021
1 parent c2a998a commit b1ed0eb
Show file tree
Hide file tree
Showing 9 changed files with 103 additions and 22 deletions.
33 changes: 22 additions & 11 deletions exe/Wrapper.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -42,6 +43,9 @@ main = do
VersionMode PrintNumericVersion ->
putStrLn haskellLanguageServerNumericVersion

BiosMode PrintCradleType ->
print =<< findProjectCradle

_ -> launchHaskellLanguageServer args

launchHaskellLanguageServer :: Arguments -> IO ()
Expand All @@ -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
Expand Down Expand Up @@ -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
3 changes: 2 additions & 1 deletion haskell-language-server.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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:
Expand Down
43 changes: 34 additions & 9 deletions hls-test-utils/src/Test/Hls/Util.hs
Original file line number Diff line number Diff line change
Expand Up @@ -29,6 +29,7 @@ module Test.Hls.Util
, waitForDiagnosticsFromSource
, waitForDiagnosticsFromSourceWithTimeout
, withCurrentDirectoryInTmp
, withCurrentDirectoryInTmp'
)
where

Expand Down Expand Up @@ -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
Expand Down
12 changes: 12 additions & 0 deletions src/Ide/Arguments.hs
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,7 @@ module Ide.Arguments
( Arguments(..)
, GhcideArguments(..)
, PrintVersion(..)
, BiosAction(..)
, getArguments
, haskellLanguageServerVersion
, haskellLanguageServerNumericVersion
Expand All @@ -27,6 +28,7 @@ import System.Environment
data Arguments
= VersionMode PrintVersion
| ProbeToolsMode
| BiosMode BiosAction
| Ghcide GhcideArguments
| VSCodeExtensionSchemaMode
| DefaultConfigurationMode
Expand All @@ -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)
Expand All @@ -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
Expand Down
7 changes: 7 additions & 0 deletions src/Ide/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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))
Expand Down Expand Up @@ -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
Expand Down
19 changes: 18 additions & 1 deletion test/wrapper/Main.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
import Data.List.Extra (trimEnd)
import Data.List.Extra (trimEnd, isInfixOf)
import Data.Maybe
import System.Environment
import System.Process
Expand All @@ -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
Expand All @@ -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
Empty file.
Original file line number Diff line number Diff line change
@@ -0,0 +1,6 @@
cabal-version: 2.4
name: stack-with-dist-newstyle
version: 0.1.0.0

library
default-language: Haskell2010
2 changes: 2 additions & 0 deletions test/wrapper/testdata/stack-with-dist-newstyle/stack.yaml
Original file line number Diff line number Diff line change
@@ -0,0 +1,2 @@
# specific version does not matter
resolver: ghc-8.10.4

0 comments on commit b1ed0eb

Please sign in to comment.