Add cradle dependencies to session loading errors

ghcide/ghcide.cabal

@@ -192,6 +192,7 @@ library
         Development.IDE.LSP.Outline
         Development.IDE.LSP.Server
         Development.IDE.Session
+        Development.IDE.Session.Diagnostics
         Development.IDE.Spans.Common
         Development.IDE.Spans.Documentation
         Development.IDE.Spans.AtPoint

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

@@ -34,14 +34,12 @@
 import           Data.Bifunctor
 import qualified Data.ByteString.Base16               as B16
 import qualified Data.ByteString.Char8                as B
-import           Data.Char                            (isLower)
 import           Data.Default
 import           Data.Either.Extra
 import           Data.Function
 import           Data.Hashable                        hiding (hash)
 import qualified Data.HashMap.Strict                  as HM
 import           Data.List
-import           Data.List.Extra                      (dropPrefix, split)
 import qualified Data.Map.Strict                      as Map
 import           Data.Maybe
 import           Data.Proxy
@@ -69,7 +67,6 @@
 import           Development.IDE.Types.Options
 import           GHC.Check
 import qualified HIE.Bios                             as HieBios
-import qualified HIE.Bios.Cradle                      as HieBios
 import           HIE.Bios.Environment                 hiding (getCacheDir)
 import           HIE.Bios.Types                       hiding (Log)
 import qualified HIE.Bios.Types                       as HieBios
@@ -103,6 +100,7 @@
 import qualified Data.HashSet                         as Set
 import           Database.SQLite.Simple
 import           Development.IDE.Core.Tracing         (withTrace)
+import           Development.IDE.Session.Diagnostics  (renderCradleError)
 import           Development.IDE.Types.Shake          (WithHieDb)
 import           HieDb.Create
 import           HieDb.Types
@@ -618,7 +616,7 @@
           void $ modifyVar' fileToFlags $
               Map.insert hieYaml (HM.fromList (concatMap toFlagsMap all_targets))
           void $ modifyVar' filesMap $
               flip HM.union (HM.fromList (zip (map fst $ concatMap toFlagsMap all_targets) (repeat hieYaml)))
 
           void $ extendKnownTargets all_targets
 
@@ -685,7 +683,7 @@
              Left err -> do
                dep_info <- getDependencyInfo (maybeToList hieYaml)
                let ncfp = toNormalizedFilePath' cfp
-               let res = (map (renderCradleError cradle ncfp) err, Nothing)
+               let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing)
                void $ modifyVar' fileToFlags $
                     Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info))
                void $ modifyVar' filesMap $ HM.insert ncfp hieYaml
@@ -822,7 +820,7 @@
          -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo))
 newComponentCache recorder exts cradlePath cfp hsc_env uids ci = do
     let df = componentDynFlags ci
     hscEnv' <-
 #if MIN_VERSION_ghc(9,3,0)
       -- Set up a multi component session with the other units on GHC 9.4
         Compat.initUnits (map snd uids) (hscSetFlags df hsc_env)
@@ -924,72 +922,6 @@
           & maybe id setHieDir hieCacheDir
           & maybe id setODir oCacheDir
 
-
-renderCradleError :: Cradle a -> NormalizedFilePath -> CradleError -> FileDiagnostic
-renderCradleError cradle nfp (CradleError _ _ec ms) =
-  ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage
-  where
-
-    userFriendlyMessage :: [String]
-    userFriendlyMessage
-      | HieBios.isCabalCradle cradle = fromMaybe ms fileMissingMessage
-      | otherwise = ms
-
-    fileMissingMessage :: Maybe [String]
-    fileMissingMessage =
-      multiCradleErrMessage <$> parseMultiCradleErr ms
-
--- | Information included in Multi Cradle error messages
-data MultiCradleErr = MultiCradleErr
-  { mcPwd      :: FilePath
-  , mcFilePath :: FilePath
-  , mcPrefixes :: [(FilePath, String)]
-  } deriving (Show)
-
--- | Attempt to parse a multi-cradle message
-parseMultiCradleErr :: [String] -> Maybe MultiCradleErr
-parseMultiCradleErr ms = do
-  _  <- lineAfter "Multi Cradle: "
-  wd <- lineAfter "pwd: "
-  fp <- lineAfter "filepath: "
-  ps <- prefixes
-  pure $ MultiCradleErr wd fp ps
-
-  where
-    lineAfter :: String -> Maybe String
-    lineAfter pre = listToMaybe $ mapMaybe (stripPrefix pre) ms
-
-    prefixes :: Maybe [(FilePath, String)]
-    prefixes = do
-      pure $ mapMaybe tuple ms
-
-    tuple :: String -> Maybe (String, String)
-    tuple line = do
-      line' <- surround '(' line ')'
-      [f, s] <- pure $ split (==',') line'
-      pure (f, s)
-
-    -- extracts the string surrounded by required characters
-    surround :: Char -> String -> Char -> Maybe String
-    surround start s end = do
-      guard (listToMaybe s == Just start)
-      guard (listToMaybe (reverse s) == Just end)
-      pure $ drop 1 $ take (length s - 1) s
-
-multiCradleErrMessage :: MultiCradleErr -> [String]
-multiCradleErrMessage e =
-    [ "Loading the module '" <> moduleFileName <> "' failed. It may not be listed in your .cabal file!"
-    , "Perhaps you need to add `"<> moduleName <> "` 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"
-    , ""
-    ] <> 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
-
 -- See Note [Multi Cradle Dependency Info]
 type DependencyInfo = Map.Map FilePath (Maybe UTCTime)
 type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo])

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

@@ -0,0 +1,106 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric  #-}
+
+module Development.IDE.Session.Diagnostics where
+import           Control.Applicative
+import           Control.Monad
+import qualified Data.Aeson                        as Aeson
+import           Data.List
+import           Data.List.Extra                   (split)
+import           Data.Maybe
+import qualified Data.Text                         as T
+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
+
+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).
+  Depicts the cradle error in a user-friendly way.
+-}
+renderCradleError :: CradleError -> Cradle a -> NormalizedFilePath -> FileDiagnostic
+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.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}})
+  | otherwise = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage
+  where
+    absDeps = fmap (cradleRootDir cradle </>) deps
+    userFriendlyMessage :: [String]
+    userFriendlyMessage
+      | HieBios.isCabalCradle cradle = fromMaybe ms $ fileMissingMessage <|> mkUnknownModuleMessage
+      | otherwise = ms
+
+    mkUnknownModuleMessage :: Maybe [String]
+    mkUnknownModuleMessage
+      | any (isInfixOf "Failed extracting script block:") ms =
+          Just $ unknownModuleMessage (fromNormalizedFilePath nfp)
+      | otherwise = Nothing
+
+    fileMissingMessage :: Maybe [String]
+    fileMissingMessage =
+      multiCradleErrMessage <$> parseMultiCradleErr ms
+
+-- | Information included in Multi Cradle error messages
+data MultiCradleErr = MultiCradleErr
+  { mcPwd      :: FilePath
+  , mcFilePath :: FilePath
+  , mcPrefixes :: [(FilePath, String)]
+  } deriving (Show)
+
+-- | Attempt to parse a multi-cradle message
+parseMultiCradleErr :: [String] -> Maybe MultiCradleErr
+parseMultiCradleErr ms = do
+  _  <- lineAfter "Multi Cradle: "
+  wd <- lineAfter "pwd: "
+  fp <- lineAfter "filepath: "
+  ps <- prefixes
+  pure $ MultiCradleErr wd fp ps
+
+  where
+    lineAfter :: String -> Maybe String
+    lineAfter pre = listToMaybe $ mapMaybe (stripPrefix pre) ms
+
+    prefixes :: Maybe [(FilePath, String)]
+    prefixes = do
+      pure $ mapMaybe tuple ms
+
+    tuple :: String -> Maybe (String, String)
+    tuple line = do
+      line' <- surround '(' line ')'
+      [f, s] <- pure $ split (==',') line'
+      pure (f, s)
+
+    -- extracts the string surrounded by required characters
+    surround :: Char -> String -> Char -> Maybe String
+    surround start s end = do
+      guard (listToMaybe s == Just start)
+      guard (listToMaybe (reverse s) == Just end)
+      pure $ drop 1 $ take (length s - 1) s
+
+multiCradleErrMessage :: MultiCradleErr -> [String]
+multiCradleErrMessage e =
+    unknownModuleMessage (mcFilePath e)
+    <> [""]
+    <> map prefix (mcPrefixes e)
+  where
+    prefix (f, r) = f <> " - " <> r
+
+unknownModuleMessage :: String -> [String]
+unknownModuleMessage moduleFileName =
+  [ "Loading the module '" <> moduleFileName <> "' failed."
+  , ""
+  , "It may not be listed in your .cabal file!"
+  , "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/hie.yaml

@@ -0,0 +1,2 @@
+cradle:
+  cabal:

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/hie.yaml

@@ -0,0 +1,4 @@
+cradle:
+  cabal:
+    - path: ./app/Main.hs
+      component: exe:testExe

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