StripTrailingSpace.hs

{-# LANGUAGE OverloadedStrings #-}

module StripTrailingSpace (testStripTrailingSpace) where



import           Data.Text (Text)
import qualified Data.Text as T

import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.Util.StackMachine

import Test.Tasty
import Test.Tasty.HUnit

box :: Text -> Text
box singleLine = unlines'
    [ "┌─" <> T.replicate (T.length singleLine) "─" <> "─┐"
    , "│ " <> singleLine <> " │"
    , "└─" <> T.replicate (T.length singleLine) "─" <> "─┘"
    ]

bbox :: Text -> Text
bbox singleLine = unlines'
    [ "╔═" <> T.replicate (T.length singleLine) "═" <> "═╗"
    , "║ " <> singleLine <> " ║"
    , "╚═" <> T.replicate (T.length singleLine) "═" <> "═╝"
    ]

testStripTrailingSpace :: TestTree
testStripTrailingSpace = testGroup "Stripping trailing space"
    [ testCase "No trailing space"
               (testStripping "No trailing space at all")
    , testCase "Single trailing space character"
               (testStripping ("Single trailing character" <> " "))
    , testCase "Space character inside"
               (testStripping ("Space character" <> " " <> "inside"))
    , testCase "Obvious trailing spaces"
               (testStripping ("Obvious trailing space" <> "   "))
    , testCase "Multiple spaces inside"
               (testStripping ("Multiple spaces" <> "    " <> "inside"))
    , testCase "Whitespace inside text"
               (testStripping ("Whitespace inside text   "))
    , testCase "Indented blank line"
               (testStripping (nest 4 (vcat ["Indented blank line", "", "<end>"])))
    , testCase "Multiple indented blank lines"
               (testStripping (nest 4 (vcat ["Indented blank lines", "", "", "", "<end>"])))
    , testCase "Annotation"
               (testStripping (annotate () "Annotation with trailing space   "))
    , testCase "Document with annotation"
               (testStripping ("Here comes an" <> annotate () "annotation   " <> "and some trailing space again  " <> "  "))
    , testCase "Nested annotations"
               (testStripping ("A " <> annotate () ("nested   " <> annotate () "annotation ") <> "and some trailing space again  " <> "  "))
    , testCase "Stress test"
               (testStripping (nest 4 (vcat ["Stress test", "", "" <> annotate () "hello ", "", "world " <> "   ", annotate () "", "", "end"])))
    ]

testStripping :: Doc ann -> Assertion
testStripping doc = case hasTrailingWhitespace (render removeTrailingWhitespace doc) of
    False -> pure ()
    True  -> (assertFailure . T.unpack . T.unlines)
        [ bbox "Input is not stripped correctly!"
        , ""
        , box "Rendered/stripped:"
        , (revealSpaces . render removeTrailingWhitespace) doc
        , ""
        , box "Rendered/unstripped:"
        , (revealSpaces . render id) doc
        , ""
        , box "Rendered/unstripped, later stripped via Text API:"
        , (revealSpaces . removeTrailingSpaceText . render id) doc ]
  where

    render :: (SimpleDocStream ann -> SimpleDocStream ann) -> Doc ann -> Text
    render f = renderSimplyDecorated id (const "<ann>") (const "</ann>") . f . layoutPretty defaultLayoutOptions

    removeTrailingSpaceText :: Text -> Text
    removeTrailingSpaceText = unlines' . map T.stripEnd . T.lines

    hasTrailingWhitespace :: Text -> Bool
    hasTrailingWhitespace x = removeTrailingSpaceText x /= x

    revealSpaces :: Text -> Text
    revealSpaces = T.map (\x -> if x == ' ' then '␣' else x)

-- Text.unlines appends a trailing whitespace, so T.unlines . T.lines /= id
unlines' :: [Text] -> Text
unlines' = T.intercalate (T.singleton '\n')