Merge pull request #204 from serokell/Sorokin-Anton/#201-nyan-interpo…

…lation

[#201] Use nyan-interpolation for building error messages

package.yaml

@@ -39,6 +39,7 @@ default-extensions:
   - NamedFieldPuns
   - NoImplicitPrelude
   - OverloadedStrings
+  - QuasiQuotes
   - RankNTypes
   - RecordWildCards
   - ScopedTypeVariables
@@ -111,6 +112,7 @@ library:
     - uri-bytestring
     - yaml
     - reflection
+    - nyan-interpolation
 
 executables:
   xrefcheck:

src/Xrefcheck/CLI.hs

@@ -32,6 +32,7 @@ import Options.Applicative
   progDesc, short, strOption, switch, value)
 import Options.Applicative.Help.Pretty (Doc, displayS, fill, fillSep, indent, renderPretty, text)
 import Options.Applicative.Help.Pretty qualified as Pretty
+import Text.Interpolation.Nyan
 
 import Paths_xrefcheck (version)
 import Xrefcheck.Config (NetworkingConfig, NetworkingConfig' (..))
@@ -44,10 +45,12 @@ modeReadM :: ReadM VerifyMode
 modeReadM = eitherReader $ \s ->
   case find (\mi -> miName mi == s) modes of
     Just mi -> Right $ miMode mi
-    Nothing -> Left . mconcat $ intersperse "\n"
-      [ "Unknown mode " <> show s <> "."
-      , "Allowed values: " <> mconcat (intersperse ", " $ map (show . miName) modes)
-      ]
+    Nothing -> Left
+      [int||
+      Unknown mode #s{s}.
+      Allowed values: #{intercalate ", " $ map (show . miName) modes}.
+      |]
+
 
 data ModeInfo = ModeInfo
   { miName :: String
@@ -126,8 +129,10 @@ repoTypeReadM = eitherReader $ \name ->
     allRepoTypesNamed =
       allRepoTypes <&> \ty -> (toString $ T.toLower (show ty), ty)
     failureText name =
-      "Unknown repository type: " <> show name <> "\n\
-      \Expected one of: " <> mconcat (intersperse ", " $ map show allRepoTypes)
+      [int||
+      Unknown repository type: #s{name}
+      Expected one of: #{intercalate ", " $ map show allRepoTypes}.
+      |]
     allRepoTypes = allFlavors
 
 optionsParser :: Parser Options
@@ -136,11 +141,13 @@ optionsParser = do
     short 'c' <>
     long "config" <>
     metavar "FILEPATH" <>
-    help ("Path to configuration file. \
-          \If not specified, tries to read config from one of " <>
-          (mconcat . intersperse ", " $ map show defaultConfigPaths) <> ". \
-          \If none of these files exist, default configuration is used."
-         )
+    help
+      [int||
+      Path to configuration file. \
+      If not specified, tries to read config from one of \
+      #{intercalate ", " $ map show defaultConfigPaths}. \
+      If none of these files exist, default configuration is used.
+      |]
   oRoot <- filepathOption $
     short 'r' <>
     long "root" <>
@@ -208,14 +215,16 @@ dumpConfigOptions = hsubparser $
   where
     parser = DumpConfig <$> repoTypeOption <*> outputOption
 
-    allRepoTypes = "(" <> intercalate " | " (map (show @String) allFlavors) <> ")"
-
     repoTypeOption =
       option repoTypeReadM $
       short 't' <>
       long "type" <>
       metavar "REPOSITORY TYPE" <>
-      help ("Git repository type. Can be " <> allRepoTypes <> ". Case insensitive.")
+      help [int||
+      Git repository type. \
+      Can be (#{intercalate " | " $ map show allFlavors}). \
+      Case insensitive.
+      |]
 
     outputOption =
       filepathOption $

src/Xrefcheck/Command.hs

@@ -14,6 +14,7 @@ import Data.Yaml (decodeFileEither, prettyPrintParseException)
 import Fmt (blockListF', build, fmt, fmtLn, indentF)
 import System.Console.Pretty (supportsPretty)
 import System.Directory (doesFileExist)
+import Text.Interpolation.Nyan
 
 import Xrefcheck.CLI (Options (..), addExclusionOptions, addNetworkingOptions, defaultConfigPaths)
 import Xrefcheck.Config
@@ -57,8 +58,10 @@ defaultAction Options{..} = do
           Just configPath -> readConfig configPath
           Nothing -> do
             hPutStrLn @Text stderr
-              "Configuration file not found, using default config \
-              \for GitHub repositories\n"
+              [int||
+              Configuration file not found, using default config \
+              for GitHub repositories
+              |]
             pure $ defConfig GitHub
 
     withinCI <- askWithinCI
@@ -69,7 +72,11 @@ defaultAction Options{..} = do
       scanRepo rw (formats $ cScanners config) fullConfig oRoot
 
     when oVerbose $
-      fmtLn $ "=== Repository data ===\n\n" <> indentF 2 (build repoInfo)
+      fmt [int||
+      === Repository data ===
+
+      #{indentF 2 (build repoInfo)}
+      |]
 
     unless (null scanErrs) . reportScanErrs $ sortBy (compare `on` seFile) scanErrs
 
@@ -86,12 +93,18 @@ defaultAction Options{..} = do
         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."
+    reportScanErrs errs = fmt
+      [int||
+      === Scan errors found ===
+
+      #{indentF 2 (blockListF' "➥ " build errs)}\
+      Scan errors dumped, #{length errs} in total.
+      |]
+
+    reportVerifyErrs errs = fmt
+      [int||
+      === Invalid references found ===
+
+      #{indentF 2 (blockListF' "➥ " build errs)}\
+      Invalid references dumped, #{length errs} in total.
+      |]

src/Xrefcheck/Config.hs

@@ -20,6 +20,7 @@ import Data.Yaml (FromJSON (..), decodeEither', prettyPrintParseException, withT
 import Instances.TH.Lift ()
 import Text.Regex.TDFA qualified as R
 import Text.Regex.TDFA.ByteString ()
+import Text.Interpolation.Nyan
 
 import Time (KnownRatName, Second, Time (..), unitsP)
 
@@ -133,15 +134,19 @@ fillHoles allReplacements rawConfig =
             case getReplacement key of
               Left replacement -> [leadingSpaces, replacement]
               Right _ -> error $
-                "Key " <> showBs key <> " requires replacement with an item, \
-                \but list was given"
+                [int||
+                Key #{showBs key} requires replacement with an item, \
+                but list was given"
+                |]
 
       | Just [_wholeMatch, leadingChars, key] <-
           R.getAllTextSubmatches <$> (holeListRegex `R.matchM` holeLine) ->
             case getReplacement key of
               Left _ -> error $
-                "Key " <> showBs key <> " requires replacement with a list, \
-                \but an item was given"
+                [int||
+                Key #{showBs key} requires replacement with a list, \
+                but an item was given"
+                |]
               Right [] ->
                 ["[]"]
               Right replacements@(_ : _) ->

src/Xrefcheck/Config/Default.hs

@@ -3,8 +3,6 @@
  - SPDX-License-Identifier: MPL-2.0
  -}
 
-{-# LANGUAGE QuasiQuotes #-}
-
 module Xrefcheck.Config.Default where
 
 import Universum

src/Xrefcheck/Core.hs

@@ -15,17 +15,18 @@ import Control.Lens (makeLenses)
 import Data.Aeson (FromJSON (..), withText)
 import Data.Char (isAlphaNum)
 import Data.Char qualified as C
+import Data.DList (DList)
+import Data.DList qualified as DList
 import Data.Default (Default (..))
 import Data.List qualified as L
 import Data.Map qualified as M
 import Data.Reflection (Given)
 import Data.Text qualified as T
-import Fmt (Buildable (..), blockListF, blockListF', nameF, (+|), (|+))
+import Fmt (Buildable (..), blockListF, blockListF', indentF)
 import System.FilePath (isPathSeparator, pathSeparator)
+import Text.Interpolation.Nyan
 import Time (Second, Time)
 
-import Data.DList (DList)
-import Data.DList qualified as DList
 import Xrefcheck.Progress
 import Xrefcheck.Util
 
@@ -142,14 +143,12 @@ instance NFData FileInfo
 
 instance Given ColorMode => Buildable Reference where
   build Reference{..} =
-    nameF ("reference " +| paren (build loc) |+ " " +| rPos |+ "") $
-      blockListF
-      [ "text: " <> show rName
-      , "link: " <> build rLink
-      , "anchor: " <> build (rAnchor ?: styleIfNeeded Faint "-")
-      ]
-    where
-      loc = locationType rLink
+    [int||
+    reference #{paren . build $ locationType rLink} #{rPos}:
+      - text: #s{rName}
+      - link: #{rLink}
+      - anchor: #{rAnchor ?: styleIfNeeded Faint "-"}
+    |]
 
 instance Given ColorMode => Buildable AnchorType where
   build = styleIfNeeded Faint . \case
@@ -167,23 +166,29 @@ instance Given ColorMode => Buildable AnchorType where
         n -> error "Bad header level: " <> show n
 
 instance Given ColorMode => Buildable Anchor where
-  build (Anchor t a p) = a |+ " (" +| t |+ ") " +| p |+ ""
+  build Anchor{..} =
+    [int||
+    #{aName} (#{aType}) #{aPos}
+    |]
 
 instance Given ColorMode => Buildable FileInfo where
-  build FileInfo{..} = blockListF
-    [ nameF "references" $ blockListF _fiReferences
-    , nameF "anchors" $ blockListF _fiAnchors
-    ]
+  build FileInfo{..} =
+    [int||
+    - references:
+    #{indentF 4 $ blockListF _fiReferences}\
+    - anchors:
+    #{indentF 4 $ blockListF _fiAnchors}\
+    |]
 
 instance Given ColorMode => Buildable RepoInfo where
   build (RepoInfo m _) =
     blockListF' "⮚" buildFileReport (mapMaybe sequence $ M.toList m)
     where
-      buildFileReport (name, info) = mconcat
-        [ colorIfNeeded Cyan $ fromString name <> ":\n"
-        , build info
-        , "\n"
-        ]
+      buildFileReport (name, info) =
+        [int||
+        #{colorIfNeeded Cyan $ name}:
+        #{info}
+        |]
 
 -----------------------------------------------------------
 -- Analysing

src/Xrefcheck/Orphans.hs

@@ -13,9 +13,10 @@ import Universum
 
 import Data.ByteString.Char8 qualified as C
 
-import Fmt (Buildable (..), unlinesF, (+|), (|+))
+import Fmt (Buildable (..))
 import Network.FTP.Client
   (FTPException (..), FTPMessage (..), FTPResponse (..), ResponseStatus (..))
+import Text.Interpolation.Nyan
 import Text.URI (RText, unRText)
 import URI.ByteString (SchemaError (..), URIParseError (..))
 
@@ -33,10 +34,11 @@ instance Buildable FTPMessage where
     )
 
 instance Buildable FTPResponse where
-  build FTPResponse{..} = unlinesF
-    [ frStatus |+ " (" +| frCode |+ "):"
-    , build frMessage
-    ]
+  build FTPResponse{..} =
+    [int||
+    #{frStatus} (#{frCode}):
+    #{frMessage}
+    |]
 
 instance Buildable FTPException where
   build (BadProtocolResponseException _) = "Raw FTP exception"

src/Xrefcheck/Scan.hs

@@ -34,11 +34,12 @@ import Data.Aeson (FromJSON (..), genericParseJSON, withText)
 import Data.List qualified as L
 import Data.Map qualified as M
 import Data.Reflection (Given)
-import Fmt (Buildable (..), nameF, (+|), (|+))
+import Fmt (Buildable (..))
 import System.Directory (doesDirectoryExist)
 import System.FilePath
   (dropTrailingPathSeparator, equalFilePath, splitDirectories, takeDirectory, takeExtension, (</>))
 import System.Process (cwd, readCreateProcess, shell)
+import Text.Interpolation.Nyan
 import Text.Regex.TDFA.Common (CompOption (..), ExecOption (..), Regex)
 import Text.Regex.TDFA.Text qualified as R
 
@@ -93,10 +94,14 @@ data ScanError = ScanError
   } deriving stock (Show, Eq)
 
 instance Given ColorMode => Buildable ScanError where
-  build ScanError{..} =
-    "In file " +| styleIfNeeded Faint (styleIfNeeded Bold seFile) |+ "\n"
-    +| nameF ("scan error " +| sePosition |+ "") mempty |+ "\n⛀  "
-    +| seDescription |+ "\n\n\n"
+  build ScanError{..} = [int||
+    In file #{styleIfNeeded Faint (styleIfNeeded Bold seFile)}
+    scan error #{sePosition}:
+
+    ⛀  #{seDescription}
+
+
+    |]
 
 data ScanErrorDescription
   = LinkErr
@@ -107,13 +112,13 @@ data ScanErrorDescription
 
 instance Buildable ScanErrorDescription where
   build = \case
-    LinkErr -> "Expected a LINK after \"ignore link\" annotation"
-    FileErr -> "Annotation \"ignore all\" must be at the top of \
-      \markdown or right after comments at the top"
-    ParagraphErr txt -> "Expected a PARAGRAPH after \
-          \\"ignore paragraph\" annotation, but found " +| txt |+ ""
-    UnrecognisedErr txt ->  "Unrecognised option \"" +| txt |+ "\" perhaps you meant \
-          \<\"ignore link\"|\"ignore paragraph\"|\"ignore all\"> "
+    LinkErr -> [int||Expected a LINK after "ignore link" annotation|]
+    FileErr -> [int||Annotation "ignore all" must be at the top of \
+                     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">|]
 
 specificFormatsSupport :: [([Extension], ScanAction)] -> FormatsSupport
 specificFormatsSupport formats = \ext -> M.lookup ext formatsMap

src/Xrefcheck/Scanners/Markdown.hs

@@ -29,7 +29,8 @@ import Data.DList qualified as DList
 import Data.Default (def)
 import Data.Text qualified as T
 import Data.Text.Lazy qualified as LT
-import Fmt (Buildable (..), blockListF, nameF, (+|), (|+))
+import Fmt (Buildable (..), blockListF, nameF)
+import Text.Interpolation.Nyan
 import Text.HTML.TagSoup
 
 import Xrefcheck.Core
@@ -56,11 +57,13 @@ toPosition = Position . \case
   Nothing -> Nothing
   Just PosInfo{..}
     | startLine == endLine -> Just $
-        startLine |+ ":" +| startColumn |+ "-" +| endColumn |+ ""
+        [int|s|
+        #{startLine}:#{startColumn}-#{endColumn}
+        |]
     | otherwise -> Just $
-        "" +|
-        startLine |+ ":" +| startColumn |+ " - " +|
-        endLine |+ ":" +| endColumn |+ ""
+        [int|s|
+        #{startLine}:#{startColumn}-#{endLine}:#{endColumn}
+        |]
 
 -- | Extract text from the topmost node.
 nodeExtractText :: Node -> Text