diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 8f5ff94b36..befeb01f55 100644 --- a/ghcide/ghcide.cabal +++ b/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 diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 1a14d2fe64..46e41072cd 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -34,14 +34,12 @@ import Data.Aeson hiding (Error) 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.Location 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 Data.HashSet (HashSet) 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 @@ -685,7 +683,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do 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 @@ -924,72 +922,6 @@ setCacheDirs recorder CacheDirs{..} dflags = do & 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]) diff --git a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs new file mode 100644 index 0000000000..5c46e2f2ae --- /dev/null +++ b/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" + ] diff --git a/test/functional/FunctionalBadProject.hs b/test/functional/FunctionalBadProject.hs index 6d4d68206f..16f1fd213d 100644 --- a/test/functional/FunctionalBadProject.hs +++ b/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") diff --git a/test/testdata/missingModuleTest/missingModule/cabal.project b/test/testdata/missingModuleTest/missingModule/cabal.project new file mode 100644 index 0000000000..6f920794c8 --- /dev/null +++ b/test/testdata/missingModuleTest/missingModule/cabal.project @@ -0,0 +1 @@ +packages: ./ diff --git a/test/testdata/missingModuleTest/missingModule/hie.yaml b/test/testdata/missingModuleTest/missingModule/hie.yaml new file mode 100644 index 0000000000..04cd24395e --- /dev/null +++ b/test/testdata/missingModuleTest/missingModule/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/test/testdata/missingModuleTest/missingModule/missingModule.cabal b/test/testdata/missingModuleTest/missingModule/missingModule.cabal new file mode 100644 index 0000000000..1f3e0a1d8c --- /dev/null +++ b/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 diff --git a/test/testdata/missingModuleTest/missingModule/src/MyLib.hs b/test/testdata/missingModuleTest/missingModule/src/MyLib.hs new file mode 100644 index 0000000000..3ced4fb33c --- /dev/null +++ b/test/testdata/missingModuleTest/missingModule/src/MyLib.hs @@ -0,0 +1,5 @@ +module MyLib where + +someFunc :: IO () +someFunc = do + putStrLn "someFunc" diff --git a/test/testdata/missingModuleTest/noPrefixMatch/app/Main.hs b/test/testdata/missingModuleTest/noPrefixMatch/app/Main.hs new file mode 100644 index 0000000000..da579930ec --- /dev/null +++ b/test/testdata/missingModuleTest/noPrefixMatch/app/Main.hs @@ -0,0 +1,4 @@ + +main :: IO () +main = do + putStrLn "someFunc" diff --git a/test/testdata/missingModuleTest/noPrefixMatch/app/Other.hs b/test/testdata/missingModuleTest/noPrefixMatch/app/Other.hs new file mode 100644 index 0000000000..159221bd25 --- /dev/null +++ b/test/testdata/missingModuleTest/noPrefixMatch/app/Other.hs @@ -0,0 +1 @@ +module Other where diff --git a/test/testdata/missingModuleTest/noPrefixMatch/cabal.project b/test/testdata/missingModuleTest/noPrefixMatch/cabal.project new file mode 100644 index 0000000000..6f920794c8 --- /dev/null +++ b/test/testdata/missingModuleTest/noPrefixMatch/cabal.project @@ -0,0 +1 @@ +packages: ./ diff --git a/test/testdata/missingModuleTest/noPrefixMatch/hie.yaml b/test/testdata/missingModuleTest/noPrefixMatch/hie.yaml new file mode 100644 index 0000000000..c9100beb9a --- /dev/null +++ b/test/testdata/missingModuleTest/noPrefixMatch/hie.yaml @@ -0,0 +1,4 @@ +cradle: + cabal: + - path: ./app/Main.hs + component: exe:testExe diff --git a/test/testdata/missingModuleTest/noPrefixMatch/noPrefixMatch.cabal b/test/testdata/missingModuleTest/noPrefixMatch/noPrefixMatch.cabal new file mode 100644 index 0000000000..491144c41d --- /dev/null +++ b/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