Unify session loading using implicit-hie (#1783)

* Unify session loading using implicit-hie

Make Wrapper and Session loader use the same logic to avoid
loading logic divergence.

Cleans up existing usages to use infrastructure in place.

* 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.

Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>

Author: fendor

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

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)

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:

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