Update tests to select libdir based on cradle

Author: fendor

haskell-ide-engine.cabal

@@ -245,6 +245,8 @@ test-suite plugin-dispatcher-test
   main-is:             Main.hs
   build-depends:       base
                      , data-default
+                     , directory
+                     , filepath
                      , haskell-ide-engine
                      , haskell-lsp-types
                      , hie-plugin-api

hie-plugin-api/Haskell/Ide/Engine/Cradle.hs

@@ -81,16 +81,26 @@ getProjectGhcPath :: Cradle -> IO (Maybe FilePath)
 getProjectGhcPath crdl = do
   isStackInstalled <- isJust <$> findExecutable "stack"
   isCabalInstalled <- isJust <$> findExecutable "cabal"
-  if isStackCradle crdl && isStackInstalled
+  ghcpath <- if isStackCradle crdl && isStackInstalled
     then
-      catch (Just <$> tryCommand "stack path --compiler-exe") $ \(_ :: IOException) ->
+      catch (Just <$> tryCommand "stack path --compiler-exe") $ \(_ :: IOException) -> do
+        errorm "Command `stack path --compiler-exe` failed."
         return Nothing
     else if isCabalCradle crdl && isCabalInstalled then do
-      Just ghcCabalVersion <- catch (Just <$> tryCommand "cabal v2-exec ghc -- --numeric-version") $ \(_ ::IOException) ->
+      ghcCabalVersion <- catch (Just <$> tryCommand "cabal v2-exec -v0 ghc -- --numeric-version") $ \(_ ::IOException) -> do
+        errorm "Command `cabal v2-exec -v0 ghc -- --numeric-version` failed."
         return Nothing
-      findExecutable ("ghc-" ++ ghcCabalVersion)
-    else
+      case ghcCabalVersion of
+        Just ghcNumericVersion -> do
+          let ghcVersion = "ghc-" ++ ghcNumericVersion
+          logm $ "Ghc Version to find: " ++ ghcVersion
+          findExecutable ghcVersion
+        Nothing -> return Nothing
+    else do
+      logm "Neither cabal nor stack project, look for ghc project."
       findExecutable "ghc"
+  logm $ "Found ghc path: " ++ show ghcpath
+  return ghcpath
 
 tryCommand :: String -> IO String
 tryCommand cmd =

src/Haskell/Ide/Engine/Server.hs

@@ -157,8 +157,11 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do
 
         -- Check for mismatching GHC versions
         -- Ignore hie.yaml parse errors. They get reported in ModuleCache.hs
-        let parseErrorHandler (_ :: Yaml.ParseException) = return Nothing
-            dummyCradleFile = (fromMaybe currentDir lspRootDir) </> "File.hs"
+        let parseErrorHandler (_ :: Yaml.ParseException) = do
+              logm "Caught a yaml parse exception"
+              return Nothing
+            dummyCradleFile = fromMaybe currentDir lspRootDir </> "File.hs"
+        logm $ "Dummy Cradle File: " ++ dummyCradleFile
         mcradle <- liftIO $ E.catch (Just <$> findLocalCradle dummyCradleFile) parseErrorHandler
 
         -- haskell lsp sets the current directory to the project root in the InitializeRequest
@@ -410,13 +413,12 @@ reactor inp diagIn = do
           currentDir <- liftIO getCurrentDirectory
 
           -- Check for mismatching GHC versions
-          -- Ignore hie.yaml parse errors. They get reported in ModuleCache.hs
-          let parseErrorHandler (_ :: Yaml.ParseException) = return Nothing
-              dummyCradleFile = (fromMaybe currentDir lspRootDir) </> "File.hs"
-          cradleRes <- liftIO $ E.catch (Just <$> findLocalCradle dummyCradleFile) parseErrorHandler
+          let dummyCradleFile = (fromMaybe currentDir lspRootDir) </> "File.hs"
+          logm $ "Dummy Cradle file result: " ++ dummyCradleFile
+          cradleRes <- liftIO $ E.try (findLocalCradle dummyCradleFile)
 
           case cradleRes of
-            Just cradle -> do
+            Right cradle -> do
               projGhcVersion <- liftIO $ getProjectGhcVersion cradle
               when (projGhcVersion /= hieGhcVersion) $ do
                 let msg = T.pack $ "Mismatching GHC versions: " ++ cradleDisplay cradle ++
@@ -433,7 +435,9 @@ reactor inp diagIn = do
                   reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning cabalMsg
                   reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning cabalMsg
 
-            Nothing -> return ()
+            Left (_ :: Yaml.ParseException) -> do
+              logm "Failed to parse it"
+              reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtError "Couldn't parse hie.yaml"
 
           renv <- ask
           let hreq = GReq tn "init-hoogle" Nothing Nothing Nothing callback Nothing $ IdeResultOk <$> Hoogle.initializeHoogleDb

test/dispatcher/Main.hs

@@ -14,6 +14,7 @@ import           Data.Default
 import           GHC                            ( TypecheckedModule )
 import           GHC.Generics
 import           Haskell.Ide.Engine.Ghc
+import qualified Haskell.Ide.Engine.Cradle as Bios
 import           Haskell.Ide.Engine.MonadTypes
 import           Haskell.Ide.Engine.PluginUtils
 import           Haskell.Ide.Engine.Scheduler
@@ -26,7 +27,7 @@ import           System.FilePath
 
 import           Test.Hspec
 import           Test.Hspec.Runner
-import System.IO
+import           System.IO
 
 -- ---------------------------------------------------------------------
 -- plugins
@@ -70,14 +71,18 @@ startServer :: IO (Scheduler IO, TChan LogVal, ThreadId)
 startServer = do
   scheduler <- newScheduler plugins testOptions
   logChan  <- newTChanIO
+  -- This is correct because we set the working directory to
+  -- "test/testdata" in the function set-up.
+  cwd <- getCurrentDirectory
+  crdl <- Bios.findLocalCradle (cwd </> "File.hs")
   dispatcher <- forkIO $ do
     flushStackEnvironment
     runScheduler
       scheduler
       (\lid errCode e -> logToChan logChan ("received an error", Left (lid, errCode, e)))
       (\g x -> g x)
       def
-      Nothing
+      (Just crdl)
 
   return (scheduler, logChan, dispatcher)
 
@@ -127,6 +132,7 @@ instance ToJSON   Cached where
 
 funcSpec :: Spec
 funcSpec = describe "functional dispatch" $ do
+    -- required to not kill the 'findLocalCradle' logic in 'startServer'.
     runIO $ setCurrentDirectory "test/testdata"
     (scheduler, logChan, dispatcher) <- runIO startServer
 

test/functional/HieBiosSpec.hs

@@ -20,15 +20,14 @@ spec = beforeAll_ (writeFile (hieBiosErrorPath </> "hie.yaml") "") $ do
       _ <- openDoc "Main.hs" "haskell"
       _ <- count 2 waitForDiagnostics
       return ()
-  
+
     it "reports errors in hie.yaml" $ runSession hieCommand fullCaps hieBiosErrorPath $ do
       _ <- openDoc "Foo.hs" "haskell"
       _ <- skipManyTill loggingNotification (satisfy isMessage)
       return ()
-  
+
   where hieBiosErrorPath = "test/testdata/hieBiosError"
-  
+
         isMessage (NotShowMessage (NotificationMessage _ _ (ShowMessageParams MtError s))) =
           "Couldn't parse hie.yaml" `T.isInfixOf` s
         isMessage _ = False
-        

test/plugin-dispatcher/Main.hs

@@ -7,13 +7,16 @@ import           Control.Concurrent.STM.TChan
 import           Control.Monad.STM
 import qualified Data.Text as T
 import           Data.Default
+import qualified Haskell.Ide.Engine.Cradle as Bios
 import           Haskell.Ide.Engine.MonadTypes
 import           Haskell.Ide.Engine.Scheduler
 import           Haskell.Ide.Engine.Types
 import           Language.Haskell.LSP.Types
 import           TestUtils
 import           Test.Hspec
 import           Test.Hspec.Runner
+import           System.Directory (getCurrentDirectory)
+import           System.FilePath
 
 -- ---------------------------------------------------------------------
 
@@ -42,11 +45,14 @@ newPluginSpec = do
 
       let makeReq = sendRequest scheduler
 
+      cwd <- getCurrentDirectory
+      crdl <- Bios.findLocalCradle (cwd </> "test" </> "testdata" </> "File.hs")
+
       pid <- forkIO $ runScheduler scheduler
                               (\_ _ _ -> return ())
                               (\f x -> f x)
                               def
-                              Nothing
+                              (Just crdl)
 
       updateDocument scheduler (filePathToUri "test") 3
       sendRequest scheduler req0

test/unit/ApplyRefactPluginSpec.hs

@@ -35,8 +35,8 @@ testPlugins = pluginDescToIdePlugins [applyRefactDescriptor "applyrefact"]
 applyRefactSpec :: Spec
 applyRefactSpec = do
   describe "apply-refact plugin commands" $ do
-    applyRefactPath  <- runIO $ filePathToUri <$> makeAbsolute "./test/testdata/ApplyRefact.hs"
-
+    applyRefactFp  <- runIO $ makeAbsolute "./test/testdata/ApplyRefact.hs"
+    let applyRefactPath = filePathToUri applyRefactFp
     -- ---------------------------------
 
     it "applies one hint only" $ do
@@ -48,7 +48,7 @@ applyRefactSpec = do
           res = IdeResultOk $ WorkspaceEdit
             (Just $ H.singleton applyRefactPath textEdits)
             Nothing
-      testCommand testPlugins act "applyrefact" "applyOne" arg res
+      testCommand testPlugins applyRefactFp act "applyrefact" "applyOne" arg res
 
     -- ---------------------------------
 
@@ -61,7 +61,7 @@ applyRefactSpec = do
           res = IdeResultOk $ WorkspaceEdit
             (Just $ H.singleton applyRefactPath textEdits)
             Nothing
-      testCommand testPlugins act "applyrefact" "applyAll" arg res
+      testCommand testPlugins applyRefactFp act "applyrefact" "applyAll" arg res
 
     -- ---------------------------------
 
@@ -85,7 +85,7 @@ applyRefactSpec = do
                             "Redundant bracket\nFound:\n  (x + 1)\nWhy not:\n  x + 1\n"
                             Nothing
                ]}
-      runIGM testPlugins act `shouldReturn` res
+      runIGM testPlugins applyRefactFp act `shouldReturn` res
 
     -- ---------------------------------
 
@@ -105,15 +105,15 @@ applyRefactSpec = do
                            , _source = Just "hlint"
                            , _message = T.pack filePathNoUri <> ":13:24: error:\n    Operator applied to too few arguments: +\n  data instance Sing (z :: (a :~: b)) where\n>     SRefl :: Sing Refl +\n\n"
                            , _relatedInformation = Nothing }]}
-      runIGM testPlugins act `shouldReturn` res
+      runIGM testPlugins applyRefactFp act `shouldReturn` res
 
     -- ---------------------------------
 
     it "respects hlint pragmas in the source file" $ do
-      filePath  <- filePathToUri <$> makeAbsolute "./test/testdata/HlintPragma.hs"
-
+      fp  <- makeAbsolute "./test/testdata/HlintPragma.hs"
+      let filePath = filePathToUri fp
       let req = lint filePath
-      r <- runIGM testPlugins req
+      r <- runIGM testPlugins fp req
       r `shouldBe`
         (IdeResultOk
            (PublishDiagnosticsParams
@@ -132,10 +132,11 @@ applyRefactSpec = do
     -- ---------------------------------
 
     it "respects hlint config files in project root dir" $ do
-      filePath  <- filePathToUri <$> makeAbsolute "./test/testdata/HlintPragma.hs"
+      fp  <- makeAbsolute "./test/testdata/HlintPragma.hs"
+      let filePath = filePathToUri fp
 
       let req = lint filePath
-      r <- withCurrentDirectory "./test/testdata" $ runIGM testPlugins req
+      r <- withCurrentDirectory "./test/testdata" $ runIGM testPlugins fp req
       r `shouldBe`
         (IdeResultOk
            (PublishDiagnosticsParams
@@ -148,11 +149,11 @@ applyRefactSpec = do
     -- ---------------------------------
 
     it "reports error without crash" $ do
-      filePath  <- filePathToUri <$> makeAbsolute "./test/testdata/ApplyRefactError.hs"
-
+      fp <- makeAbsolute "./test/testdata/ApplyRefactError.hs"
+      let filePath = filePathToUri fp
       let req = applyAllCmd filePath
           isExpectedError (IdeResultFail (IdeError PluginError err _)) =
               "Illegal symbol '.' in type" `T.isInfixOf` err
           isExpectedError _ = False
-      r <- withCurrentDirectory "./test/testdata" $ runIGM testPlugins req
+      r <- withCurrentDirectory "./test/testdata" $ runIGM testPlugins fp req
       r `shouldSatisfy` isExpectedError

test/unit/ContextSpec.hs

@@ -23,7 +23,7 @@ spec = describe "Context of different cursor positions" $ do
               fp <- makeAbsolute "./ExampleContext.hs"
               let arg = filePathToUri fp
               let res = IdeResultOk (Nothing :: Maybe Context)
-              actual <- runSingle (IdePlugins mempty) $ do
+              actual <- runSingle (IdePlugins mempty) fp $ do
                   _ <- setTypecheckedModule arg
                   return $ IdeResultOk Nothing
 
@@ -243,7 +243,7 @@ spec = describe "Context of different cursor positions" $ do
 getContextAt :: FilePath -> Position -> IO (IdeResult (Maybe Context))
 getContextAt fp pos = do
     let arg = filePathToUri fp
-    runSingle (IdePlugins mempty) $ do
+    runSingle (IdePlugins mempty) fp $ do
         _ <- setTypecheckedModule arg
         pluginGetFile "getContext: " arg $ \fp_ ->
             ifCachedModuleAndData fp_ (IdeResultOk Nothing) $ \tm _ () ->

test/unit/ExtensibleStateSpec.hs

@@ -6,6 +6,8 @@ import           Data.Typeable
 import           Haskell.Ide.Engine.MonadTypes
 import           Haskell.Ide.Engine.MonadFunctions
 import           TestUtils
+import           System.Directory
+import           System.FilePath
 
 import           Test.Hspec
 
@@ -20,7 +22,9 @@ extensibleStateSpec :: Spec
 extensibleStateSpec =
   describe "stores and retrieves in the state" $
     it "stores the first one" $ do
-      r <- runIGM testPlugins $ do
+      cwd <- getCurrentDirectory
+      let fp = cwd </> "test" </> "testdata" </> "File.hs"
+      r <- runIGM testPlugins fp $ do
           r1 <- makeRequest "test" "cmd1" ()
           r2 <- makeRequest "test" "cmd2" ()
           return (r1,r2)