Add test-case for error message

Author: VeryMilkyJoe

ghcide/session-loader/Development/IDE/Session/Diagnostics.hs

@@ -1,18 +1,27 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric  #-}
+
 module Development.IDE.Session.Diagnostics where
+import           Control.Applicative
 import           Control.Monad
 import qualified Data.Aeson                        as Aeson
-import           Data.Char                         (isLower)
 import           Data.List
-import           Data.List.Extra                   (dropPrefix, split)
+import           Data.List.Extra                   (split)
 import           Data.Maybe
 import qualified Data.Text                         as T
-import qualified Data.Vector                       as Vector
 import           Development.IDE.Types.Diagnostics
 import           Development.IDE.Types.Location
+import           GHC.Generics
 import qualified HIE.Bios.Cradle                   as HieBios
 import           HIE.Bios.Types                    hiding (Log)
 import           System.FilePath
-import Control.Applicative
+
+data CradleErrorDetails =
+  CradleErrorDetails
+    { cabalProjectFiles :: [FilePath]
+    -- ^ files related to the cradle error
+    -- i.e. .cabal, cabal.project, etc.
+    } deriving (Show, Eq, Ord, Read, Generic, Aeson.ToJSON, Aeson.FromJSON)
 
 {- | Takes a cradle error, the corresponding cradle and the file path where
   the cradle error occurred (of the file we attempted to load).
@@ -22,7 +31,7 @@ renderCradleError :: CradleError -> Cradle a -> NormalizedFilePath -> FileDiagno
 renderCradleError (CradleError deps _ec ms) cradle nfp
   | HieBios.isCabalCradle cradle =
       let (fp, showDiag, diag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage in
-        (fp, showDiag, diag{_data_ = Just (Aeson.Array $ Vector.fromList $ map (Aeson.String . T.pack) absDeps)})
+        (fp, showDiag, diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}})
   | otherwise = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage
   where
     absDeps = fmap (cradleRootDir cradle </>) deps
@@ -33,7 +42,7 @@ renderCradleError (CradleError deps _ec ms) cradle nfp
 
     mkUnknownModuleMessage :: Maybe [String]
     mkUnknownModuleMessage
-      | any (isInfixOf "Error: cabal: Failed extracting script block:") ms = Just $ unknownModuleMessage (fromNormalizedFilePath nfp) Nothing
+      | any (isInfixOf "Error: cabal: Failed extracting script block:") ms = Just $ unknownModuleMessage (fromNormalizedFilePath nfp)
       | otherwise = Nothing
 
     fileMissingMessage :: Maybe [String]
@@ -79,20 +88,18 @@ parseMultiCradleErr ms = do
 
 multiCradleErrMessage :: MultiCradleErr -> [String]
 multiCradleErrMessage e =
-    unknownModuleMessage moduleFileName (Just moduleName)
+    unknownModuleMessage (mcFilePath e)
     <> [""]
     <> map prefix (mcPrefixes e)
   where
-    localFilePath f = dropWhile (==pathSeparator) $ dropPrefix (mcPwd e) f
-    moduleFileName = localFilePath $ mcFilePath e
-    moduleName = intercalate "." $ map dropExtension $ dropWhile isSourceFolder $ splitDirectories moduleFileName
-    isSourceFolder p = all isLower $ take 1 p
     prefix (f, r) = f <> " - " <> r
 
-unknownModuleMessage :: String -> Maybe String -> [String]
-unknownModuleMessage moduleFileName moduleNameM =
+unknownModuleMessage :: String -> [String]
+unknownModuleMessage moduleFileName =
   [ "Loading the module '" <> moduleFileName <> "' failed."
+  , ""
   , "It may not be listed in your .cabal file!"
-  , "Perhaps you need to add `"<> fromMaybe (takeFileName moduleFileName) moduleNameM <> "` to other-modules or exposed-modules."
+  , "Perhaps you need to add `"<> dropExtension (takeFileName moduleFileName) <> "` to other-modules or exposed-modules."
+  , ""
   , "For more information, visit: https://cabal.readthedocs.io/en/3.4/developing-packages.html#modules-included-in-the-package"
   ]

test/functional/FunctionalBadProject.hs

@@ -2,37 +2,27 @@
 
 module FunctionalBadProject (tests) where
 
--- import           Control.Lens hiding (List)
--- import           Control.Monad.IO.Class
--- import qualified Data.Text as T
--- import           Language.LSP.Test hiding (message)
--- import           Language.LSP.Types as LSP
--- import           Language.LSP.Types.Lens as LSP hiding (contents, error )
+import           Control.Lens
+import qualified Data.Text                  as T
+import qualified Language.LSP.Protocol.Lens as L
 import           Test.Hls
+import           Test.Hls.Command
+
 
--- ---------------------------------------------------------------------
--- TODO: Currently this can not succeed, since such an error is thrown in "runActionWithContext" which
--- can produce diagnostics at the moment. Needs more investigation
--- TODO: @fendor: Add issue link here
---
 tests :: TestTree
-tests = testGroup "behaviour on malformed projects" [
-    testCase "no test executed" $ True @?= True
+tests = testGroup "behaviour on malformed projects"
+    [ testCase "Missing module diagnostic" $ do
+        runSession hlsCommand fullCaps "test/testdata/missingModuleTest/missingModule/" $ do
+            doc <- openDoc "src/MyLib.hs" "haskell"
+            [diag] <- waitForDiagnosticsFrom doc
+            liftIO $ assertBool "missing module name" $ "MyLib" `T.isInfixOf` (diag ^. L.message)
+            liftIO $ assertBool  "module missing context" $ "may not be listed" `T.isInfixOf` (diag ^. L.message)
+    , testCase "Missing module diagnostic - no matching prefix" $ do
+        runSession hlsCommand fullCaps "test/testdata/missingModuleTest/noPrefixMatch/" $ do
+            doc <- openDoc "app/Other.hs" "haskell"
+            [diag] <- waitForDiagnosticsFrom doc
+            liftIO $ assertBool "missing module name" $
+                "Other" `T.isInfixOf` (diag ^. L.message)
+            liftIO $ assertBool  "hie-bios message" $
+                "Cabal {component = Just \"exe:testExe\"}" `T.isInfixOf` (diag ^. L.message)
     ]
-
-    -- testCase "deals with cabal file with unsatisfiable dependency" $
-    --     runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata/badProjects/cabal" $ do
-    --         _doc <- openDoc "Foo.hs" "haskell"
-
-    --         diags@(d:_) <- waitForDiagnosticsSource "bios"
-    --         -- liftIO $ show diags @?= ""
-    --         -- liftIO $ putStrLn $ show diags
-    --         -- liftIO $ putStrLn "a"
-    --         liftIO $ do
-    --             length diags @?= 1
-    --             d ^. range @?= Range (Position 0 0) (Position 1 0)
-    --             d ^. severity @?= (Just DsError)
-    --             d ^. code @?= Nothing
-    --             d ^. source @?= Just "bios"
-    --             d ^. message @?=
-    --                 (T.pack "readCreateProcess: stack \"build\" \"--only-configure\" \".\" (exit 1): failed\n")

test/testdata/missingModuleTest/missingModule/cabal.project

@@ -0,0 +1 @@
+packages: ./

test/testdata/missingModuleTest/missingModule/missingModule.cabal

@@ -0,0 +1,10 @@
+cabal-version: 3.4
+name:          missingModule
+version:       0.1.0.0
+build-type:    Simple
+
+library
+  hs-source-dirs:   ./src/
+  exposed-modules:
+  build-depends:    base
+  default-language: Haskell2010

test/testdata/missingModuleTest/missingModule/src/MyLib.hs

@@ -0,0 +1,5 @@
+module MyLib where
+
+someFunc :: IO ()
+someFunc = do
+    putStrLn "someFunc"

test/testdata/missingModuleTest/noPrefixMatch/app/Main.hs

@@ -0,0 +1,4 @@
+
+main :: IO ()
+main = do
+  putStrLn "someFunc"

test/testdata/missingModuleTest/noPrefixMatch/app/Other.hs

@@ -0,0 +1 @@
+module Other where

test/testdata/missingModuleTest/noPrefixMatch/cabal.project

@@ -0,0 +1 @@
+packages: ./

test/testdata/missingModuleTest/noPrefixMatch/noPrefixMatch.cabal

@@ -0,0 +1,9 @@
+cabal-version: 3.4
+name:          noPrefixMatch
+version:       0.1.0.0
+build-type:    Simple
+
+executable testExe
+  main-is:        Main.hs
+  hs-source-dirs: app
+  build-depends:  base