diff --git a/.hlint.yaml b/.hlint.yaml index 46e3711..2229dcd 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -110,3 +110,15 @@ name: "Avoid style function that ignore ColorMode" lhs: 'System.Console.Pretty.style' rhs: 'Xrefcheck.Util.Colorize.styleIfNeeded' +- warn: + name: "Avoid functions that generate extra trailing newlines/whitespaces" + lhs: 'Fmt.indentF' + rhs: 'Xrefcheck.Util.Interpolate.interpolateIndentF' +- warn: + name: "Avoid functions that generate extra trailing newlines/whitespaces" + lhs: 'Fmt.blockListF' + rhs: 'Xrefcheck.Util.Interpolate.interpolateBlockListF' +- warn: + name: "Avoid functions that generate extra trailing newlines/whitespaces" + lhs: "Fmt.blockListF'" + rhs: "Xrefcheck.Util.Interpolate.interpolateBlockListF'" diff --git a/package.yaml b/package.yaml index 625c5d6..623b1b6 100644 --- a/package.yaml +++ b/package.yaml @@ -146,7 +146,6 @@ tests: - xrefcheck - bytestring - directory - - fmt - http-types - o-clock - regex-tdfa @@ -159,6 +158,7 @@ tests: - uri-bytestring - yaml - reflection + - nyan-interpolation ftp-tests: main: Main.hs diff --git a/src/Xrefcheck/Command.hs b/src/Xrefcheck/Command.hs index b00efc6..2ed868c 100644 --- a/src/Xrefcheck/Command.hs +++ b/src/Xrefcheck/Command.hs @@ -11,7 +11,7 @@ import Universum import Data.Reflection (give) import Data.Yaml (decodeFileEither, prettyPrintParseException) -import Fmt (blockListF', build, fmt, fmtLn, indentF) +import Fmt (build, fmt, fmtLn) import System.Console.Pretty (supportsPretty) import System.Directory (doesFileExist) import Text.Interpolation.Nyan @@ -75,10 +75,10 @@ defaultAction Options{..} = do fmt [int|| === Repository data === - #{indentF 2 (build repoInfo)}\ + #{interpolateIndentF 2 (build repoInfo)} |] - unless (null scanErrs) . reportScanErrs $ sortBy (compare `on` seFile) scanErrs + whenJust (nonEmpty $ sortBy (compare `on` seFile) scanErrs) $ reportScanErrs verifyRes <- allowRewrite showProgressBar $ \rw -> do let fullConfig = config @@ -88,7 +88,7 @@ defaultAction Options{..} = do case verifyErrors verifyRes of Nothing | null scanErrs -> fmtLn "All repository links are valid." Nothing -> exitFailure - Just (toList -> verifyErrs) -> do + Just verifyErrs -> do unless (null scanErrs) $ fmt "\n" reportVerifyErrs verifyErrs exitFailure @@ -97,7 +97,7 @@ defaultAction Options{..} = do [int|| === Scan errors found === - #{indentF 2 (blockListF' "➥ " build errs)}\ + #{interpolateIndentF 2 (interpolateBlockListF' "➥ " build errs)} Scan errors dumped, #{length errs} in total. |] @@ -105,6 +105,6 @@ defaultAction Options{..} = do [int|| === Invalid references found === - #{indentF 2 (blockListF' "➥ " build errs)}\ + #{interpolateIndentF 2 (interpolateBlockListF' "➥ " build errs)} Invalid references dumped, #{length errs} in total. |] diff --git a/src/Xrefcheck/Config.hs b/src/Xrefcheck/Config.hs index f1c099c..f755fd2 100644 --- a/src/Xrefcheck/Config.hs +++ b/src/Xrefcheck/Config.hs @@ -18,9 +18,9 @@ import Data.ByteString qualified as BS import Data.Map qualified as Map import Data.Yaml (FromJSON (..), decodeEither', prettyPrintParseException, withText) import Instances.TH.Lift () +import Text.Interpolation.Nyan import Text.Regex.TDFA qualified as R import Text.Regex.TDFA.ByteString () -import Text.Interpolation.Nyan import Time (KnownRatName, Second, Time (..), unitsP) diff --git a/src/Xrefcheck/Core.hs b/src/Xrefcheck/Core.hs index 5930449..265d04e 100644 --- a/src/Xrefcheck/Core.hs +++ b/src/Xrefcheck/Core.hs @@ -15,14 +15,13 @@ import Control.Lens (makeLenses) import Data.Aeson (FromJSON (..), withText) import Data.Char (isAlphaNum) import Data.Char qualified as C +import Data.Default (Default (..)) 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', indentF) +import Fmt (Buildable (..)) import System.FilePath (isPathSeparator, pathSeparator) import Text.Interpolation.Nyan import Time (Second, Time) @@ -146,7 +145,7 @@ instance Given ColorMode => Buildable Reference where [int|| reference #{paren . build $ locationType rLink} #{rPos}: - text: #s{rName} - - link: #{rLink} + - link: #{if null rLink then "-" else rLink} - anchor: #{rAnchor ?: styleIfNeeded Faint "-"} |] @@ -175,20 +174,21 @@ instance Given ColorMode => Buildable FileInfo where build FileInfo{..} = [int|| - references: - #{indentF 4 $ blockListF _fiReferences}\ + #{ interpolateIndentF 4 $ maybe "none" interpolateBlockListF (nonEmpty _fiReferences) } - anchors: - #{indentF 4 $ blockListF _fiAnchors}\ + #{ interpolateIndentF 4 $ maybe "none" interpolateBlockListF (nonEmpty _fiAnchors) } |] instance Given ColorMode => Buildable RepoInfo where - build (RepoInfo m _) = - blockListF' "⮚" buildFileReport (mapMaybe sequence $ M.toList m) + build (RepoInfo (nonEmpty . mapMaybe sequence . toPairs -> Just m) _) = + interpolateBlockListF' "⮚" buildFileReport m where buildFileReport (name, info) = [int|| #{colorIfNeeded Cyan $ name}: #{info} |] + build _ = "No scannable files found." ----------------------------------------------------------- -- Analysing diff --git a/src/Xrefcheck/Scanners/Markdown.hs b/src/Xrefcheck/Scanners/Markdown.hs index 33b0fdd..5c7e4d1 100644 --- a/src/Xrefcheck/Scanners/Markdown.hs +++ b/src/Xrefcheck/Scanners/Markdown.hs @@ -25,13 +25,13 @@ import Control.Lens (_Just, makeLenses, makeLensesFor, (.=)) import Control.Monad.Trans.Writer.CPS (Writer, runWriter, tell) import Data.Aeson (FromJSON (..), genericParseJSON) import Data.ByteString.Lazy qualified as BSL -import Data.DList qualified as DList import Data.Default (def) +import Data.DList qualified as DList import Data.Text qualified as T import Data.Text.Lazy qualified as LT -import Fmt (Buildable (..), blockListF, nameF) -import Text.Interpolation.Nyan +import Fmt (Buildable (..), nameF) import Text.HTML.TagSoup +import Text.Interpolation.Nyan import Xrefcheck.Core import Xrefcheck.Scan @@ -50,7 +50,8 @@ defGithubMdConfig = MarkdownConfig } instance Buildable Node where - build (Node _mpos ty subs) = nameF (show ty) $ blockListF subs + build (Node _mpos ty mSubs) = nameF (show ty) $ + maybe "[]" interpolateBlockListF (nonEmpty mSubs) toPosition :: Maybe PosInfo -> Position toPosition = Position . \case diff --git a/src/Xrefcheck/Util.hs b/src/Xrefcheck/Util.hs index 19811d8..0b83771 100644 --- a/src/Xrefcheck/Util.hs +++ b/src/Xrefcheck/Util.hs @@ -13,6 +13,7 @@ module Xrefcheck.Util , posixTimeToTimeSecond , utcTimeToTimeSecond , module Xrefcheck.Util.Colorize + , module Xrefcheck.Util.Interpolate ) where import Universum @@ -30,6 +31,7 @@ import System.FilePath (dropTrailingPathSeparator, normalise) import Time (Second, Time (..), sec) import Xrefcheck.Util.Colorize +import Xrefcheck.Util.Interpolate paren :: Builder -> Builder paren a diff --git a/src/Xrefcheck/Util/Interpolate.hs b/src/Xrefcheck/Util/Interpolate.hs new file mode 100644 index 0000000..3afaf21 --- /dev/null +++ b/src/Xrefcheck/Util/Interpolate.hs @@ -0,0 +1,81 @@ +{- SPDX-FileCopyrightText: 2018-2019 Serokell + - + - SPDX-License-Identifier: MPL-2.0 + -} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +module Xrefcheck.Util.Interpolate + ( -- $notes + interpolateIndentF + , interpolateBlockListF + , interpolateBlockListF' + ) + where + +import Universum + +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Builder (fromLazyText, toLazyText) +import Fmt (Buildable, Builder, blockListF, blockListF', indentF) + +{- $notes +The `blockListF` and `indentF` frunctions from @fmt@ add a trailing newline, which makes them unsuitable for string interpolation. +Consider this case: +> [int|| +> aaa +> #{indentF 2 "bbb"} +> ccc +> |] +One would reasonably expect this to produce: +> aaa +> bbb +> ccc +But, in reality, it produces: +> aaa +> bbb +> +> ccc +This module introduces versions of these functions that do not produce a trailing newline +and can therefore be safely used in string interpolation. +-} + +{-# HLINT ignore "Avoid functions that generate extra trailing newlines/whitespaces" #-} + +-- | Like @Fmt.indentF@, but strips trailing spaces and does not add a trailing newline. +-- +-- >>> import Fmt +-- >>> indentF 2 "a\n\nb" +-- " a\n \n b\n" +-- +-- >>> interpolateIndentF 2 "a\n\nb" +-- " a\n\n b" +interpolateIndentF :: HasCallStack => Int -> Builder -> Builder +interpolateIndentF n b = (case TL.last (toLazyText b) of + '\n' -> id + _ -> stripLastNewline) $ stripTrailingSpaces $ indentF n b + -- strips newline added by indentF + +-- | Like @Fmt.blockListF'@, but strips trailing spaces and does not add a trailing newline. +interpolateBlockListF' :: HasCallStack => Text -> (a -> Builder) -> NonEmpty a -> Builder +interpolateBlockListF' = stripLastNewline . stripTrailingSpaces ... blockListF' + +-- | Like @Fmt.blockListF@, but strips trailing spaces and does not add a trailing newline. +interpolateBlockListF :: HasCallStack => Buildable a => NonEmpty a -> Builder +interpolateBlockListF = stripLastNewline . stripTrailingSpaces . blockListF + +-- remove trailing whitespace from all lines. +-- Note: output always ends with newline (adds trailing newline if there wasn't one). +stripTrailingSpaces :: Builder -> Builder +stripTrailingSpaces + = fromLazyText + . TL.unlines + . map (TL.stripEnd) + . TL.lines + . toLazyText + +stripLastNewline :: HasCallStack => Builder -> Builder +stripLastNewline + = fromLazyText + . fromMaybe (error "stripLastNewline: expected newline to strip") + . TL.stripSuffix "\n" + . toLazyText diff --git a/src/Xrefcheck/Verify.hs b/src/Xrefcheck/Verify.hs index 19d6dd2..e7ebacd 100644 --- a/src/Xrefcheck/Verify.hs +++ b/src/Xrefcheck/Verify.hs @@ -45,7 +45,7 @@ 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 (..), indentF, listF, maybeF, nameF, blockListF) +import Fmt (Buildable (..), maybeF, nameF) import GHC.Exts qualified as Exts import GHC.Read (Read (readPrec)) import Network.FTP.Client @@ -88,9 +88,6 @@ newtype VerifyResult e = VerifyResult [e] deriving newtype instance Semigroup (VerifyResult e) deriving newtype instance Monoid (VerifyResult e) -instance Buildable e => Buildable (VerifyResult e) where - build vr = maybe "ok" listF (verifyErrors vr) - verifyOk :: VerifyResult e -> Bool verifyOk (VerifyResult errors) = null errors @@ -151,25 +148,25 @@ instance Given ColorMode => Buildable VerifyError where #{file} |] - AnchorDoesNotExist anchor similar - | null similar -> + AnchorDoesNotExist anchor similar -> case nonEmpty similar of + Nothing -> [int|| ⛀ Anchor '#{anchor}' is not present |] - | otherwise -> + Just otherAnchors -> [int|| ⛀ Anchor '#{anchor}' is not present, did you mean: - #{indentF 4 $ blockListF similar}\ + #{interpolateIndentF 4 $ interpolateBlockListF otherAnchors} |] AmbiguousAnchorRef file anchor fileAnchors -> [int|| ⛀ Ambiguous reference to anchor '#{anchor}' - In file #{file} - It could refer to either: - #{indentF 4 $ blockListF fileAnchors} - Use of ambiguous anchors is discouraged because the target - can change silently while the document containing it evolves. + In file #{file} + It could refer to either: + #{interpolateIndentF 4 $ interpolateBlockListF fileAnchors} + Use of ambiguous anchors is discouraged because the target + can change silently while the document containing it evolves. |] ExternalResourceInvalidUri err -> @@ -180,7 +177,7 @@ instance Given ColorMode => Buildable VerifyError where ExternalResourceUriConversionError err -> [int|| ⛂ Invalid URI - #{indentF 4 . build $ displayException err} + #{interpolateIndentF 4 . build $ displayException err} |] ExternalResourceInvalidUrl Nothing -> diff --git a/tests/Test/Xrefcheck/TooManyRequestsSpec.hs b/tests/Test/Xrefcheck/TooManyRequestsSpec.hs index cf1073e..5ffede2 100644 --- a/tests/Test/Xrefcheck/TooManyRequestsSpec.hs +++ b/tests/Test/Xrefcheck/TooManyRequestsSpec.hs @@ -13,11 +13,11 @@ import Data.CaseInsensitive qualified as CI import Data.Map qualified as M import Data.Time (addUTCTime, defaultTimeLocale, formatTime, getCurrentTime, rfc822DateFormat) import Data.Time.Clock.POSIX (getPOSIXTime) -import Fmt (indentF, pretty, unlinesF) import Network.HTTP.Types (Status (..), ok200, serviceUnavailable503, tooManyRequests429) import Network.HTTP.Types.Header (hRetryAfter) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, testCase, (@?=)) +import Text.Interpolation.Nyan import Time (sec, (-:-)) import Web.Firefly (ToResponse (toResponse), getMethod, route, run) @@ -162,18 +162,20 @@ test_tooManyRequests = testGroup "429 response tests" checkLinkAndProgressWithServer mock link progress vrExpectation = E.bracket (forkIO mock) killThread $ \_ -> do (result, progRes) <- verifyLink link - flip assertBool (result == vrExpectation) . pretty $ unlinesF - [ "Verification results differ: expected" - , indentF 2 (show vrExpectation) - , "but got" - , indentF 2 (show result) - ] - flip assertBool (progRes `progEquiv` progress) . pretty $ unlinesF - [ "Expected the progress bar state to be" - , indentF 2 (show progress) - , "but got" - , indentF 2 (show progRes) - ] + flip assertBool (result == vrExpectation) $ + [int|| + Verification results differ: expected + #{interpolateIndentF 2 (show vrExpectation)} + but got + #{interpolateIndentF 2 (show result)} + |] + flip assertBool (progRes `progEquiv` progress) $ + [int|| + Expected the progress bar state to be + #{interpolateIndentF 2 (show progress)} + but got + #{interpolateIndentF 2 (show progRes)} + |] where -- | Check whether the two @Progress@ values are equal up to similarity of their essential -- components, ignoring the comparison of @pTaskTimestamp@s, which is done to prevent test diff --git a/tests/Test/Xrefcheck/TrailingSlashSpec.hs b/tests/Test/Xrefcheck/TrailingSlashSpec.hs index e3f8bfe..a16e2d9 100644 --- a/tests/Test/Xrefcheck/TrailingSlashSpec.hs +++ b/tests/Test/Xrefcheck/TrailingSlashSpec.hs @@ -7,16 +7,17 @@ module Test.Xrefcheck.TrailingSlashSpec where import Universum -import Fmt (blockListF, pretty, unlinesF) import System.Directory (doesFileExist) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase) +import Text.Interpolation.Nyan import Xrefcheck.Config import Xrefcheck.Core import Xrefcheck.Progress import Xrefcheck.Scan import Xrefcheck.Scanners.Markdown +import Xrefcheck.Util test_slash :: TestTree test_slash = testGroup "Trailing forward slash detection" $ @@ -33,12 +34,12 @@ test_slash = testGroup "Trailing forward slash detection" $ return $ if predicate then Right () else Left filePath) - if null nonExistentFiles - then pass - else assertFailure $ pretty $ unlinesF - [ "Expected all filepaths to be valid, but these filepaths do not exist:" - , blockListF nonExistentFiles - ] + whenJust (nonEmpty nonExistentFiles) $ \files -> + assertFailure + [int|| + Expected all filepaths to be valid, but these filepaths do not exist: + #{interpolateBlockListF files} + |] where roots :: [FilePath] roots = diff --git a/tests/golden/check-anchors/check-anchors.bats b/tests/golden/check-anchors/check-anchors.bats index 7afe79e..fa59f1e 100644 --- a/tests/golden/check-anchors/check-anchors.bats +++ b/tests/golden/check-anchors/check-anchors.bats @@ -17,18 +17,17 @@ assert_diff - <