Improve quality and information density of error message

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

@@ -13,14 +13,14 @@ import           Distribution.Helper (Package, projectPackages, pUnits,
                                       unChModuleName, Ex(..), ProjLoc(..),
                                       QueryEnv, mkQueryEnv, runQuery,
                                       Unit, unitInfo, uiComponents,
-                                      ChEntrypoint(..))
+                                      ChEntrypoint(..), UnitInfo(..))
 import           Distribution.Helper.Discover (findProjects, getDefaultDistDir)
 import           Data.Char (toLower)
 import           Data.Function ((&))
 import           Data.List (isPrefixOf, isInfixOf, sortOn, find)
 import qualified Data.List.NonEmpty as NonEmpty
 import           Data.List.NonEmpty (NonEmpty)
-import qualified Data.Map as M
+import qualified Data.Map as Map
 import           Data.Maybe (listToMaybe, mapMaybe, isJust)
 import           Data.Ord (Down(..))
 import           Data.String (IsString(..))
@@ -45,10 +45,13 @@ import           System.Process (readCreateProcessWithExitCode, shell)
 findLocalCradle :: FilePath -> IO Cradle
 findLocalCradle fp = do
   cradleConf <- BIOS.findCradle fp
-  case cradleConf of
-    Just yaml -> BIOS.loadCradle yaml
+  crdl <- case cradleConf of
+    Just yaml -> do
+      debugm $ "Found \"" ++ yaml ++ "\" for \"" ++ fp ++ "\""
+      BIOS.loadCradle yaml
     Nothing   -> cabalHelperCradle fp
-
+  logm $ "Module \"" ++ fp ++ "\" is loaded by Cradle: " ++ show crdl
+  return crdl
 -- | Check if the given cradle is a stack cradle.
 -- This might be used to determine the GHC version to use on the project.
 -- If it is a stack-cradle, we have to use `stack path --compiler-exe`
@@ -143,7 +146,7 @@ getProjectGhcLibDir :: Cradle -> IO (Maybe FilePath)
 getProjectGhcLibDir crdl =
   execProjectGhc crdl ["--print-libdir"] >>= \case
     Nothing -> do
-      logm "Could not obtain the libdir."
+      errorm "Could not obtain the libdir."
       return Nothing
     mlibdir -> return mlibdir
 
@@ -235,17 +238,20 @@ findCabalHelperEntryPoint fp = do
       supported (Ex ProjLocV1Dir {}) _ cabalInstalled = cabalInstalled
       supported (Ex ProjLocV1CabalFile {}) _ cabalInstalled = cabalInstalled
 
-      isStackProject (Ex ProjLocStackYaml {}) = True
-      isStackProject _ = False
+isStackProject :: Ex ProjLoc -> Bool
+isStackProject (Ex ProjLocStackYaml {}) = True
+isStackProject _ = False
 
-      isCabalV2FileProject (Ex ProjLocV2File {}) = True
-      isCabalV2FileProject _ = False
+isCabalV2FileProject :: Ex ProjLoc -> Bool
+isCabalV2FileProject (Ex ProjLocV2File {}) = True
+isCabalV2FileProject _ = False
 
-      isCabalProject (Ex ProjLocV1CabalFile {}) = True
-      isCabalProject (Ex ProjLocV1Dir {}) = True
-      isCabalProject (Ex ProjLocV2File {}) = True
-      isCabalProject (Ex ProjLocV2Dir {}) = True
-      isCabalProject _ = False
+isCabalProject :: Ex ProjLoc -> Bool
+isCabalProject (Ex ProjLocV1CabalFile {}) = True
+isCabalProject (Ex ProjLocV1Dir {}) = True
+isCabalProject (Ex ProjLocV2File {}) = True
+isCabalProject (Ex ProjLocV2Dir {}) = True
+isCabalProject _ = False
 
 {- | Given a FilePath, find the cradle the FilePath belongs to.
 
@@ -431,12 +437,13 @@ cabalHelperCradle file = do
                                 }
                }
     Just (Ex proj) -> do
+      logm $ "Cabal-Helper decided to use: " ++ show proj
       -- Find the root of the project based on project type.
       let root = projectRootDir proj
       -- Create a suffix for the cradle name.
       -- Purpose is mainly for easier debugging.
       let actionNameSuffix = projectSuffix proj
-      logm $ "Cabal-Helper dirs: " ++ show [root, file]
+      debugm $ "Cabal-Helper dirs: " ++ show [root, file]
       let dist_dir = getDefaultDistDir proj
       env <- mkQueryEnv proj dist_dir
       packages <- runQuery projectPackages env
@@ -472,6 +479,7 @@ cabalHelperCradle file = do
                        CradleAction { actionName =
                                         "Cabal-Helper-" ++ actionNameSuffix
                                     , runCradle = \_ fp -> cabalHelperAction
+                                        (Ex proj)
                                         env
                                         realPackage
                                         normalisedPackageLocation
@@ -493,26 +501,29 @@ cabalHelperCradle file = do
                                     else arg
           else arg
 
-      -- | cradle Action to query for the ComponentOptions that are needed
+      -- | Cradle Action to query for the ComponentOptions that are needed
       -- to load the given FilePath.
       -- This Function is not supposed to throw any exceptions and use
       -- 'CradleLoadResult' to indicate errors.
-      cabalHelperAction :: QueryEnv v -- ^ Query Env created by 'mkQueryEnv'
+      cabalHelperAction :: Ex ProjLoc -- ^ Project location, can be used
+                                      -- to present error build-tool
+                                      -- agnostic error messages.
+                        -> QueryEnv v -- ^ Query Env created by 'mkQueryEnv'
                                       -- with the appropriate 'distdir'
                         -> Package v -- ^ Package this cradle is part for.
                         -> FilePath -- ^ Root directory of the cradle
                                     -- this action belongs to.
                         -> FilePath -- ^ FilePath to load, expected to be an absolute path.
                         -> IO (CradleLoadResult ComponentOptions)
-      cabalHelperAction env package root fp = do
+      cabalHelperAction proj env package root fp = do
         -- Get all unit infos the given FilePath may belong to
         let units = pUnits package
         -- make the FilePath to load relative to the root of the cradle.
         let relativeFp = makeRelative root fp
         debugm $ "Relative Module FilePath: " ++ relativeFp
-        getComponent env (toList units) relativeFp
+        getComponent proj env (toList units) relativeFp
           >>= \case
-            Just comp -> do
+            Right comp -> do
               let fs' = getFlags comp
               let fs = map (fixImportDirs root) fs'
               let targets = getTargets comp relativeFp
@@ -524,11 +535,11 @@ cabalHelperCradle file = do
                   ComponentOptions { componentOptions = ghcOptions
                                    , componentDependencies = []
                                    }
-            Nothing   -> return
+            Left err   -> return
               $ CradleFail
               $ CradleError
                 (ExitFailure 2)
-                ["Could not obtain flags for " ++ fp]
+                err
 
 -- | Get the component the given FilePath most likely belongs to.
 -- Lazily ask units whether the given FilePath is part of one of their
@@ -538,25 +549,96 @@ cabalHelperCradle file = do
 -- The given FilePath must be relative to the Root of the project
 -- the given units belong to.
 getComponent
-  :: QueryEnv pt -> [Unit pt] -> FilePath -> IO (Maybe ChComponentInfo)
-getComponent _env [] _fp = return Nothing
-getComponent env (unit : units) fp =
-  try (runQuery (unitInfo unit) env) >>= \case
-    Left (e :: IOException) -> do
-      warningm $ "Catching and swallowing an IOException: " ++ show e
-      warningm
-        $  "The Exception was thrown in the context of finding"
-        ++ " a component for \""
-        ++ fp
-        ++ "\" in the unit: "
-        ++ show unit
-      getComponent env units fp
-    Right ui -> do
-      let components = M.elems (uiComponents ui)
-      debugm $ "Unit Info: " ++ show ui
-      case find (fp `partOfComponent`) components of
-        Nothing -> getComponent env units fp
-        comp    -> return comp
+  :: forall pt. Ex ProjLoc -> QueryEnv pt -> [Unit pt] -> FilePath -> IO (Either [String] ChComponentInfo)
+getComponent proj env unitCandidates fp = getComponent' [] [] unitCandidates >>=
+    \case
+      (tried, failed, Nothing) -> return (Left $ buildErrorMsg tried failed)
+      (_, _, Just comp) -> return (Right comp)
+  where
+    getComponent' :: [UnitInfo] -> [(Unit pt, IOException)] -> [Unit pt] -> IO ([UnitInfo], [(Unit pt, IOException)], Maybe ChComponentInfo)
+    getComponent' triedUnits failedUnits [] = return (triedUnits, failedUnits, Nothing)
+    getComponent' triedUnits failedUnits (unit : units) =
+      try (runQuery (unitInfo unit) env) >>= \case
+        Left (e :: IOException) -> do
+          warningm $ "Catching and swallowing an IOException: " ++ show e
+          warningm
+            $  "The Exception was thrown in the context of finding"
+            ++ " a component for \""
+            ++ fp
+            ++ "\" in the unit: "
+            ++ show unit
+          getComponent' triedUnits ((unit, e):failedUnits) units
+        Right ui -> do
+          let components = Map.elems (uiComponents ui)
+          debugm $ "Unit Info: " ++ show ui
+          case find (fp `partOfComponent`) components of
+            Nothing -> getComponent' (ui:triedUnits) failedUnits units
+            comp    -> return (triedUnits, failedUnits, comp)
+
+    buildErrorMsg :: [UnitInfo] -> [(Unit pt, IOException)] -> [String]
+    buildErrorMsg triedUnits failedUnits =
+        concat
+          [ [ "Could not obtain flags for: \"" ++ fp ++ "\"."
+            , ""
+            ]
+          , concat
+            [ concat
+              [ [ "This module was not part of any component we are aware of."
+                , ""
+                ]
+              , concatMap ppShowUnitInfo triedUnits
+              , [ ""
+                , ""
+                ]
+              , if isStackProject proj
+                  then stackSpecificInstructions
+                  else cabalSpecificInstructions
+              ]
+            | not (null triedUnits)
+            ]
+          , concat
+            [
+              [ "We could not build all components."
+              , "If one of these components exposes this Module, make sure they compile."
+              , "You can try to invoke the commands yourself."
+              , "The following commands failed:"
+              ]
+              ++ concatMap (ppShowIOException . snd) failedUnits
+            | not (null failedUnits)
+            ]
+        ]
+
+    stackSpecificInstructions :: [String]
+    stackSpecificInstructions =
+      [ "To expose a module, refer to:"
+      , "https://docs.haskellstack.org/en/stable/GUIDE/"
+      , "If you are using `package.yaml` then you don't have to manually expose modules."
+      , "Maybe you didn't set the source directories for your project correctly."
+      ]
+
+    cabalSpecificInstructions :: [String]
+    cabalSpecificInstructions =
+      [ "To expose a module, refer to:"
+      , "https://www.haskell.org/cabal/users-guide/developing-packages.html"
+      , ""
+      ]
+
+    ppShowUnitInfo :: UnitInfo -> [String]
+    ppShowUnitInfo u =
+      u
+      & uiComponents
+      & Map.toList
+      & map
+        (\(name, info) ->
+          "Component: " ++ show name ++ " with source directory: " ++ show (ciSourceDirs info)
+        )
+
+
+    ppShowIOException :: IOException -> [String]
+    ppShowIOException e =
+        [ ""
+        , show e
+        ]
 
 -- | Check whether the given FilePath is part of the Component.
 -- A FilePath is part of the Component if and only if:
@@ -771,4 +853,3 @@ cradleDisplay cradle = fromString result
       | "multi" `isInfixOf` name = "Multi Component project"
       | otherwise = "project"
     name = map toLower $ BIOS.actionName (BIOS.cradleOptsProg cradle)
-