[#226] Change output formatting

Problem: multiple issues with the CLI output

1. In the --help output, metavars GLOB_PATTERN and REPOSITORY_TYPE
   used spaces instead of underscores. Variables typically don't
   contain spaces in their names, so it looked confusing.
2. Incorrect or unintuitive coloring of the output. For example,
   filenames were dim even though they're important and should
   stand out, the report of success wasn't green, error messages
   weren't red, etc.
3. Excessive indentation and empty lines that made it difficult to
   visually parse the error report. Also the use of the exotic '➥'
   character that looks bad in many font configurations.
4. Filenames and line numbers were far apart, making it impossible
   to Ctrl+Click to jump to the source of the error.
5. In case of connection failure, the output was too verbose and
   platform-dependent.

Solution:

1. Adjust the pretty-printing functions and update test output.
2. Extend VerifyError with a constructor for connection failures.

CHANGES.md

@@ -56,6 +56,8 @@ Unreleased
   + Now Xrefcheck is able to follow relative redirects.
 * [#262](https://github.com/serokell/xrefcheck/pull/262)
   + Now Xrefcheck includes a scanner that verifies the repository symlinks.
+* [#307](https://github.com/serokell/xrefcheck/pull/307)
+  + The output of Xrefcheck is now more legible.
 
 0.2.2
 ==========

package.yaml

@@ -93,6 +93,7 @@ library:
     - filepath
     - fmt
     - ftp-client
+    - crypton-connection
     - Glob
     - http-client
     - http-types

src/Xrefcheck/CLI.hs

@@ -208,7 +208,7 @@ exclusionOptionsParser :: Parser ExclusionOptions
 exclusionOptionsParser = do
   eoIgnore <- many . globOption $
     long "ignore" <>
-    metavar "GLOB PATTERN" <>
+    metavar "GLOB_PATTERN" <>
     help "Ignore these files. References to them will fail verification,\
          \ and references from them will not be verified.\
          \ Glob patterns that contain wildcards MUST be enclosed\
@@ -237,7 +237,7 @@ dumpConfigOptions = hsubparser $
       option repoTypeReadM $
       short 't' <>
       long "type" <>
-      metavar "REPOSITORY TYPE" <>
+      metavar "REPOSITORY_TYPE" <>
       help [int||
       Git repository type. \
       Can be (#{intercalate " | " $ map show allFlavors}). \

src/Xrefcheck/Command.hs

@@ -92,7 +92,8 @@ defaultAction Options{..} = do
       verifyRepo rw fullConfig oMode repoInfo
 
     case verifyErrors verifyRes of
-      Nothing | null scanErrs -> fmtLn "All repository links are valid."
+      Nothing | null scanErrs ->
+        fmtLn $ colorIfNeeded Green "All repository links are valid."
       Nothing -> exitFailure
       Just verifyErrs -> do
         unless (null scanErrs) $ fmt "\n"

src/Xrefcheck/Core.hs

@@ -63,10 +63,8 @@ instance FromJSON Flavor where
 newtype Position = Position (Maybe Text)
   deriving stock (Show, Eq, Generic)
 
-instance Given ColorMode => Buildable Position where
-  build (Position pos) = case pos of
-    Nothing -> ""
-    Just p  -> styleIfNeeded Faint $ "at src:" <> build p
+instance Buildable Position where
+  build (Position pos) = maybe "" build pos
 
 -- | Full info about a reference.
 data Reference = Reference
@@ -274,7 +272,7 @@ instance Given ColorMode => Buildable Reference where
 instance Given ColorMode => Buildable AnchorType where
   build = styleIfNeeded Faint . \case
     HeaderAnchor l -> colorIfNeeded Green ("header " <> headerLevelToRoman l)
-    HandAnchor -> colorIfNeeded Yellow "hand made"
+    HandAnchor -> colorIfNeeded Yellow "handmade"
     BiblioAnchor -> colorIfNeeded Cyan "biblio"
     where
       headerLevelToRoman = \case

src/Xrefcheck/Scan.hs

@@ -37,7 +37,7 @@ import Control.Lens (_1, makeLensesWith, (%~))
 import Data.Aeson (FromJSON (..), genericParseJSON, withText)
 import Data.Map qualified as M
 import Data.Reflection (Given)
-import Fmt (Buildable (..), fmt)
+import Fmt (Buildable (..), Builder, fmtLn)
 import System.Directory (doesDirectoryExist, pathIsSymbolicLink)
 import System.Process (cwd, readCreateProcess, shell)
 import Text.Interpolation.Nyan
@@ -120,23 +120,20 @@ mkGatherScanError seFile ScanError{sePosition, seDescription} = ScanError
   , seDescription
   }
 
-instance Given ColorMode => Buildable (ScanError 'Gather) where
-  build ScanError{..} = [int||
-    In file #{styleIfNeeded Faint (styleIfNeeded Bold seFile)}
-    scan error #{sePosition}:
-
-    #{seDescription}
-
-    |]
+pprScanErr :: Given ColorMode => ScanError 'Gather -> Builder
+pprScanErr ScanError{..} = hdr <> "\n" <> interpolateIndentF 2 msg <> "\n"
+  where
+    hdr, msg :: Builder
+    hdr =
+      styleIfNeeded Bold (build seFile <> ":" <> build sePosition <> ": ") <>
+      colorIfNeeded Red "scan error:"
+    msg = build seDescription
 
 reportScanErrs :: Given ColorMode => NonEmpty (ScanError 'Gather) -> IO ()
-reportScanErrs errs = fmt
-  [int||
-  === Scan errors found ===
-
-  #{interpolateIndentF 2 (interpolateBlockListF' "➥ " build errs)}
-  Scan errors dumped, #{length errs} in total.
-  |]
+reportScanErrs errs = do
+  traverse_ (fmtLn . pprScanErr) errs
+  fmtLn $ colorIfNeeded Red $
+    "Scan errors dumped, " <> build (length errs) <> " in total."
 
 data ScanErrorDescription
   = LinkErr
@@ -152,8 +149,8 @@ instance Buildable ScanErrorDescription where
                      markdown or right after comments at the top|]
     ParagraphErr txt -> [int||Expected a PARAGRAPH after \
                               "ignore paragraph" annotation, but found #{txt}|]
-    UnrecognisedErr txt -> [int||Unrecognised option "#{txt}" perhaps you meant \
-                                 <"ignore link"|"ignore paragraph"|"ignore all">|]
+    UnrecognisedErr txt -> [int||Unrecognised option "#{txt}"
+                                 Perhaps you meant <"ignore link"|"ignore paragraph"|"ignore all">|]
 
 firstFileSupport :: [FileSupport] -> FileSupport
 firstFileSupport fs isSymlink =

src/Xrefcheck/Verify.hs

@@ -46,9 +46,10 @@ import Data.Text.Metrics (damerauLevenshteinNorm)
 import Data.Time (UTCTime, defaultTimeLocale, formatTime, readPTime, rfc822DateFormat)
 import Data.Time.Clock.POSIX (getPOSIXTime)
 import Data.Traversable (for)
-import Fmt (Buildable (..), Builder, fmt, maybeF, nameF)
+import Fmt (Buildable (..), Builder, fmt, fmtLn, maybeF, nameF)
 import GHC.Exts qualified as Exts
 import GHC.Read (Read (readPrec))
+import Network.Connection qualified as N.C
 import Network.FTP.Client
   (FTPException (..), FTPResponse (..), ResponseStatus (..), login, nlst, size, withFTP, withFTPS)
 import Network.HTTP.Client
@@ -107,13 +108,6 @@ data WithReferenceLoc a = WithReferenceLoc
   , wrlItem      :: a
   }
 
-instance (Given ColorMode, Buildable a) => Buildable (WithReferenceLoc a) where
-  build WithReferenceLoc{..} = [int||
-    In file #{styleIfNeeded Faint (styleIfNeeded Bold wrlFile)}
-    bad #{wrlReference}
-    #{wrlItem}
-    |]
-
 -- | Contains a name of a domain, examples:
 -- @DomainName "github.com"@,
 -- @DomainName "localhost"@,
@@ -137,6 +131,7 @@ data VerifyError
   | ExternalFtpException FTPException
   | FtpEntryDoesNotExist FilePath
   | ExternalResourceSomeError Text
+  | ExternalResourceConnectionFailure
   | RedirectChainCycle RedirectChain
   | RedirectMissingLocation RedirectChain
   | RedirectChainLimit RedirectChain
@@ -147,8 +142,8 @@ data ResponseResult
   = RRDone
   | RRFollow Text
 
-instance Given ColorMode => Buildable VerifyError where
-  build = \case
+pprVerifyErr' :: Given ColorMode => VerifyError -> Builder
+pprVerifyErr' = \case
     LocalFileDoesNotExist file ->
       [int||
       File does not exist:
@@ -256,6 +251,11 @@ instance Given ColorMode => Buildable VerifyError where
       #{err}
       |]
 
+    ExternalResourceConnectionFailure ->
+      [int||
+      Connection failure
+      |]
+
     RedirectChainCycle chain ->
       [int||
       Cycle found in the following redirect chain:
@@ -304,15 +304,48 @@ incTotalCounter rc = rc {rcTotalRetries = rcTotalRetries rc + 1}
 incTimeoutCounter :: RetryCounter -> RetryCounter
 incTimeoutCounter rc = rc {rcTimeoutRetries = rcTimeoutRetries rc + 1}
 
+pprVerifyErr :: Given ColorMode => WithReferenceLoc VerifyError -> Builder
+pprVerifyErr wrl = hdr <> "\n" <> interpolateIndentF 2 msg
+  where
+    WithReferenceLoc{wrlFile, wrlReference, wrlItem} = wrl
+    Reference{rName, rInfo} = wrlReference
+
+    hdr, msg :: Builder
+    hdr =
+      styleIfNeeded Bold (build wrlFile <> ":" <> build (rPos wrlReference) <> ": ") <>
+      colorIfNeeded Red "bad reference:"
+    msg =
+      "The reference to " <> show rName <> " failed verification.\n" <>
+      mconcat (map (\info -> "- " <> info <> "\n") ref_infos)  <>
+      pprVerifyErr' wrlItem
+
+    ref_infos :: [Builder]
+    ref_infos = case rInfo of
+      RIFile ReferenceInfoFile{..} ->
+        case rifLink of
+          FLLocal ->
+            case rifAnchor of
+              Nothing  -> []
+              Just anc -> ["anchor " <> paren (styleIfNeeded Faint "file-local") <> ": " <> build anc]
+          FLRelative link ->
+            ["link " <> paren (styleIfNeeded Faint "relative") <> ": " <> build link] ++
+            (case rifAnchor of
+              Nothing  -> []
+              Just anc -> ["anchor: " <> build anc])
+          FLAbsolute link ->
+            ["link " <> paren (styleIfNeeded Faint "absolute") <> ": " <> build link] ++
+            (case rifAnchor of
+              Nothing  -> []
+              Just anc -> ["anchor: " <> build anc])
+      RIExternal (ELUrl url) -> ["link " <> paren (styleIfNeeded Faint "external") <> ": " <> build url]
+      RIExternal (ELOther url) -> ["link: " <> build url]
+
 reportVerifyErrs
   :: Given ColorMode => NonEmpty (WithReferenceLoc VerifyError) -> IO ()
-reportVerifyErrs errs = fmt
-  [int||
-  === Invalid references found ===
-
-  #{interpolateIndentF 2 (interpolateBlockListF' "➥ " build errs)}
-  Invalid references dumped, #{length errs} in total.
-  |]
+reportVerifyErrs errs = do
+  traverse_ (fmtLn . pprVerifyErr) errs
+  fmtLn $ colorIfNeeded Red $
+    "Invalid references dumped, " <> build (length errs) <> " in total."
 
 data RetryAfter = Date UTCTime | Seconds (Time Second)
   deriving stock (Show, Eq)
@@ -708,7 +741,7 @@ checkExternalResource followed config@Config{..} link
       let maxTime = Time @Second $ unTime ncExternalRefCheckTimeout * timeoutFrac
 
       reqRes <- catch (liftIO (timeout maxTime $ reqLink $> RRDone)) $
-         (Just <$>) <$> interpretErrors uri
+         (Just <$>) <$> interpretHttpErrors uri
 
       case reqRes of
         Nothing -> throwError $ ExternalHttpTimeout $ extractHost uri
@@ -730,9 +763,13 @@ checkExternalResource followed config@Config{..} link
       , (405 ==) -- method mismatch
       ]
 
-    interpretErrors uri = \case
+    interpretHttpErrors :: URI -> Network.HTTP.Req.HttpException -> ExceptT VerifyError IO ResponseResult
+    interpretHttpErrors uri = \case
       JsonHttpException _ -> error "External link JSON parse exception"
-      VanillaHttpException err -> case err of
+      VanillaHttpException err -> interpretHttpErrors' uri err
+
+    interpretHttpErrors' :: URI -> Network.HTTP.Client.HttpException -> ExceptT VerifyError IO ResponseResult
+    interpretHttpErrors' uri = \case
         InvalidUrlException{} -> error "External link URL invalid exception"
         HttpExceptionRequest _ exc -> case exc of
           StatusCodeException resp _
@@ -765,6 +802,12 @@ checkExternalResource followed config@Config{..} link
               redirectLocation = fmap decodeUtf8
                 . lookup "Location"
                 $ responseHeaders resp
+
+          ConnectionFailure _ -> throwError ExternalResourceConnectionFailure
+          InternalException e
+            | Just (N.C.HostCannotConnect _ _) <- fromException e
+            -> throwError ExternalResourceConnectionFailure
+
           other -> throwError $ ExternalResourceSomeError $ show other
       where
         retryAfterInfo :: Response a -> Maybe RetryAfter

tests/golden/check-anchors/expected1.gold

@@ -1,32 +1,26 @@
-=== Invalid references found ===
+a.md:16:1-43: bad reference:
+  The reference to "ambiguous anchor in this file" failed verification.
+  - anchor (file-local): some-text
+  Ambiguous reference to anchor 'some-text'
+    In file a.md
+    It could refer to either:
+      - some-text (header I) 6:1-11
+      - some-text (header I) 8:1-15
+      - some-text (header II) 12:1-12
+    Use of ambiguous anchors is discouraged because the target
+    can change silently while the document containing it evolves.
 
-  ➥  In file a.md
-     bad reference (file-local) at src:16:1-43:
-       - text: "ambiguous anchor in this file"
-       - anchor: some-text
-
-     Ambiguous reference to anchor 'some-text'
-       In file a.md
-       It could refer to either:
-         - some-text (header I) at src:6:1-11
-         - some-text (header I) at src:8:1-15
-         - some-text (header II) at src:12:1-12
-       Use of ambiguous anchors is discouraged because the target
-       can change silently while the document containing it evolves.
-
-  ➥  In file b.md
-     bad reference (relative) at src:7:1-48:
-       - text: "ambiguous anchor in other file"
-       - link: a.md
-       - anchor: some-text
-
-     Ambiguous reference to anchor 'some-text'
-       In file a.md
-       It could refer to either:
-         - some-text (header I) at src:6:1-11
-         - some-text (header I) at src:8:1-15
-         - some-text (header II) at src:12:1-12
-       Use of ambiguous anchors is discouraged because the target
-       can change silently while the document containing it evolves.
+b.md:7:1-48: bad reference:
+  The reference to "ambiguous anchor in other file" failed verification.
+  - link (relative): a.md
+  - anchor: some-text
+  Ambiguous reference to anchor 'some-text'
+    In file a.md
+    It could refer to either:
+      - some-text (header I) 6:1-11
+      - some-text (header I) 8:1-15
+      - some-text (header II) 12:1-12
+    Use of ambiguous anchors is discouraged because the target
+    can change silently while the document containing it evolves.
 
 Invalid references dumped, 2 in total.

tests/golden/check-anchors/expected2.gold

@@ -1,27 +1,19 @@
-=== Invalid references found ===
+a.md:12:1-13: bad reference:
+  The reference to "broken" failed verification.
+  - anchor (file-local): h3
+  Anchor 'h3' is not present, did you mean:
+      - h1 (header I) 6:1-4
+      - h2 (header II) 8:1-5
 
-  ➥  In file a.md
-     bad reference (file-local) at src:12:1-13:
-       - text: "broken"
-       - anchor: h3
+a.md:14:1-18: bad reference:
+  The reference to "broken" failed verification.
+  - anchor (file-local): heading
+  Anchor 'heading' is not present, did you mean:
+      - the-heading (header I) 10:1-13
 
-     Anchor 'h3' is not present, did you mean:
-         - h1 (header I) at src:6:1-4
-         - h2 (header II) at src:8:1-5
-
-  ➥  In file a.md
-     bad reference (file-local) at src:14:1-18:
-       - text: "broken"
-       - anchor: heading
-
-     Anchor 'heading' is not present, did you mean:
-         - the-heading (header I) at src:10:1-13
-
-  ➥  In file a.md
-     bad reference (file-local) at src:16:1-31:
-       - text: "broken"
-       - anchor: really-unique-anchor
-
-     Anchor 'really-unique-anchor' is not present
+a.md:16:1-31: bad reference:
+  The reference to "broken" failed verification.
+  - anchor (file-local): really-unique-anchor
+  Anchor 'really-unique-anchor' is not present
 
 Invalid references dumped, 3 in total.