[#56] Dump all the errors from different files

Problem: Currently, xrefcheck fails immediately after the first
observed error because `die` is used right in `markdownScanner` What
we want is dumping all the errors from different markdowns and then
print them as a final xrefcheck's result together with the broken
links. Also, despite the fact that in the `makeError` function we have
4 error messages, 2 of them are not reported, and the test case that
should check this only checks that at least one of the four files
throws an error.

Solution: Make xrefcheck to report all errors. Add `ScanError` type
and propagate errors to report all of them, rather than failing
immediately after the first error is detected.

CHANGES.md

@@ -46,6 +46,9 @@ Unreleased
   + Add a regex matching localhost links to the `ignoreRefs` field of the default config.
 * [#68](https://github.com/serokell/xrefcheck/pull/68)
   + Recognise manual HTML-anchors inside headers.
+* [#141](https://github.com/serokell/xrefcheck/pull/141)
+  + Dump all the errors from different files.
+  + Fix bug where no errors were reported about broken link annotation and unrecognised annotation.
 
 0.2
 ==========

package.yaml

@@ -107,6 +107,7 @@ library:
     - text-metrics
     - th-lift-instances
     - time
+    - transformers
     - universum
     - uri-bytestring
     - yaml
@@ -137,6 +138,7 @@ tests:
     dependencies:
       - case-insensitive
       - containers
+      - cmark-gfm
       - firefly
       - hspec
       - hspec-expectations

src/Xrefcheck/Command.hs

@@ -17,7 +17,7 @@ import Xrefcheck.CLI (Options (..), addTraversalOptions, addVerifyOptions, defau
 import Xrefcheck.Config (Config (..), ScannersConfig (..), defConfig, normaliseConfigFilePaths)
 import Xrefcheck.Core (Flavor (..))
 import Xrefcheck.Progress (allowRewrite)
-import Xrefcheck.Scan (FormatsSupport, gatherRepoInfo, specificFormatsSupport)
+import Xrefcheck.Scan (FormatsSupport, scanRepo, specificFormatsSupport, ScanResult (..))
 import Xrefcheck.Scanners.Markdown (markdownSupport)
 import Xrefcheck.System (askWithinCI)
 import Xrefcheck.Verify (verifyErrors, verifyRepo)
@@ -56,22 +56,33 @@ defaultAction Options{..} = do
     withinCI <- askWithinCI
     let showProgressBar = oShowProgressBar ?: not withinCI
 
-    repoInfo <- allowRewrite showProgressBar $ \rw -> do
+    (ScanResult scanErrs repoInfo) <- allowRewrite showProgressBar $ \rw -> do
       let fullConfig = addTraversalOptions (cTraversal config) oTraversalOptions
-      gatherRepoInfo rw (formats $ cScanners config) fullConfig oRoot
+      scanRepo rw (formats $ cScanners config) fullConfig oRoot
 
     when oVerbose $
       fmtLn $ "=== Repository data ===\n\n" <> indentF 2 (build repoInfo)
 
+    unless (null scanErrs) $ reportScanErrs scanErrs
+
     verifyRes <- allowRewrite showProgressBar $ \rw -> do
       let fullConfig = addVerifyOptions (cVerification config) oVerifyOptions
       verifyRepo rw fullConfig oMode oRoot repoInfo
 
     case verifyErrors verifyRes of
-      Nothing ->
-        fmtLn "All repository links are valid."
-      Just (toList -> errs) -> do
-        fmt $ "=== Invalid references found ===\n\n" <>
-              indentF 2 (blockListF' "➥ " build errs)
-        fmtLn $ "Invalid references dumped, " <> build (length errs) <> " in total."
+      Nothing | null scanErrs -> fmtLn "All repository links are valid."
+      Nothing -> exitFailure
+      Just (toList -> verifyErrs) -> do
+        fmt "\n\n"
+        reportVerifyErrs verifyErrs
         exitFailure
+  where
+    reportScanErrs errs = do
+      void . fmt $ "=== Scan errors found ===\n\n" <>
+        indentF 2 (blockListF' "➥ " build errs)
+      fmtLn $ "Scan errors dumped, " <> build (length errs) <> " in total."
+
+    reportVerifyErrs errs = do
+      void . fmt $ "=== Invalid references found ===\n\n" <>
+              indentF 2 (blockListF' "➥ " build errs)
+      fmtLn $ "Invalid references dumped, " <> build (length errs) <> " in total."

src/Xrefcheck/Scan.hs

@@ -11,9 +11,11 @@ module Xrefcheck.Scan
   , ScanAction
   , FormatsSupport
   , RepoInfo (..)
+  , ScanError (..)
+  , ScanResult (..)
 
   , normaliseTraversalConfigFilePaths
-  , gatherRepoInfo
+  , scanRepo
   , specificFormatsSupport
   ) where
 
@@ -22,6 +24,8 @@ import Universum
 import Data.Aeson.TH (deriveFromJSON)
 import Data.Foldable qualified as F
 import Data.Map qualified as M
+import Fmt (Buildable (..), (+|), (|+), nameF)
+import System.Console.Pretty (Pretty(..), Style (..))
 import System.Directory (doesDirectoryExist)
 import System.Directory.Tree qualified as Tree
 import System.FilePath (dropTrailingPathSeparator, takeDirectory, takeExtension, equalFilePath)
@@ -46,11 +50,28 @@ deriveFromJSON aesonConfigOption ''TraversalConfig
 type Extension = String
 
 -- | Way to parse a file.
-type ScanAction = FilePath -> IO FileInfo
+type ScanAction = FilePath -> IO (FileInfo, [ScanError])
 
 -- | All supported ways to parse a file.
 type FormatsSupport = Extension -> Maybe ScanAction
 
+data ScanResult = ScanResult
+  { srScanErrors :: [ScanError]
+  , srRepoInfo   :: RepoInfo
+  } deriving stock (Show)
+
+data ScanError = ScanError
+  { sePosition    :: Position
+  , seFile        :: FilePath
+  , seDescription :: Text
+  } deriving stock (Show, Eq)
+
+instance Buildable ScanError where
+  build ScanError{..} =
+    "In file " +| style Faint (style Bold seFile) |+ "\n"
+    +| nameF ("scan error " +| sePosition |+ "") mempty |+ "\n⛀  "
+    +| seDescription |+ "\n\n\n"
+
 specificFormatsSupport :: [([Extension], ScanAction)] -> FormatsSupport
 specificFormatsSupport formats = \ext -> M.lookup ext formatsMap
   where
@@ -60,22 +81,24 @@ specificFormatsSupport formats = \ext -> M.lookup ext formatsMap
         , extension <- extensions
         ]
 
-gatherRepoInfo
+scanRepo
   :: MonadIO m
-  => Rewrite -> FormatsSupport -> TraversalConfig -> FilePath -> m RepoInfo
-gatherRepoInfo rw formatsSupport config root = do
+  => Rewrite -> FormatsSupport -> TraversalConfig -> FilePath -> m ScanResult
+scanRepo rw formatsSupport config root = do
   putTextRewrite rw "Scanning repository..."
 
   when (not $ isDirectory root) $
     die $ "Repository's root does not seem to be a directory: " <> root
 
   _ Tree.:/ repoTree <- liftIO $ Tree.readDirectoryWithL processFile root
-  let fileInfos = map (first normaliseWithNoTrailing)
+  let (errs, fileInfos) = gatherScanErrs &&& gatherFileInfos
         $ dropSndMaybes . F.toList
         $ Tree.zipPaths $ location Tree.:/ repoTree
-  return $ RepoInfo (M.fromList fileInfos)
+  return . ScanResult errs $ RepoInfo (M.fromList fileInfos)
   where
     isDirectory = readingSystem . doesDirectoryExist
+    gatherScanErrs = foldMap (snd . snd)
+    gatherFileInfos = map (bimap normaliseWithNoTrailing fst)
 
     processFile file = do
       let ext = takeExtension file