ansiform-0.9.0.5: test/Spec.hs
-- | Small regression suite for the pure core of the library.
module Main where
import Control.Monad (unless)
import Data.List (isInfixOf)
import Data.Maybe (isJust, isNothing)
import GHC.IO.Handle (hDuplicate, hDuplicateTo)
import System.Directory (getTemporaryDirectory, removeFile)
import System.Exit (exitFailure)
import System.IO (hClose, hFlush, hPutStr, hSeek, openTempFile,
readFile', SeekMode (AbsoluteSeek), stdin, stdout)
import Ansiform
main :: IO ()
main = do
results <- sequence
[ test "Number caps negative values"
(unNumber (formNumber (-7)) == 0)
, test "Number keeps positive values"
(unNumber (formNumber 12) == 12)
, test "Number addition"
(unNumber (3 + 4 :: Number) == 7)
, test "Number subtraction caps at zero"
(unNumber (2 - 5 :: Number) == 0)
, test "Number checked subtraction rejects negative results"
(subtractNumberMaybe 2 5 == Nothing
&& subtractNumberMaybe 5 2 == Just 3)
, test "Number explicit subtraction caps at zero"
(unNumber (subtractNumber 2 5) == 0)
, test "Number negation caps at zero"
(unNumber (negate (5 :: Number)) == 0)
, test "Number signum"
(unNumber (signum (0 :: Number)) == 0
&& unNumber (signum (5 :: Number)) == 1)
, test "Balanced block table is accepted"
(isJust (tableBlocks header [row]))
, test "Unbalanced block table is rejected"
(isNothing (tableBlocks header [[blockSimple "only" styleDefault]]))
, test "Balanced simple table is accepted"
(isJust (tableSimple header styleDefault [["a", "b"]]))
, test "Unbalanced simple table is rejected"
(isNothing (tableSimple header styleDefault [["a"]]))
, test "Balanced group table is accepted"
(isJust (tableGroups [balancedGroup, otherBalancedGroup]))
, test "Unbalanced group table is rejected"
(isNothing (tableGroups [balancedGroup, shortGroup]))
, test "Items are stripped of non-printable characters"
(let out = sampleShow 0 (item "a\tb\nc" styleDefault)
in "\"abc\"" `isInfixOf` out
&& not ("\\" `isInfixOf` out))
, test "Empty items are removed from blocks"
(let out = sampleShow 0 (block [ item "" styleDefault
, item "kept" styleDefault ])
in "kept" `isInfixOf` out
&& not ("\"\"" `isInfixOf` out))
, test "Composite block builder keeps its parts"
(let out = sampleShow 0 (blockEnum "01" "Item" blue)
in "01" `isInfixOf` out && "Item" `isInfixOf` out)
, test "Default theme provides readable accent and muted styles"
(themeAccent defaultTheme == bold cyan
&& themeDanger defaultTheme == bold red'
&& themeFooter defaultTheme == italic white
&& themeMuted defaultTheme == italic white)
, test "Theme record update changes a style"
(themeAccent (defaultTheme { themeAccent = bold magenta }) == bold magenta)
, test "Page amendment replaces the selected section"
(let replaced = amendPage' oldPage [newSection] 0
out = sampleShow 0 replaced
in "<Right>" `isInfixOf` out
&& not ("<Left>" `isInfixOf` out)
&& "<Center>" `isInfixOf` out)
, test "Display width of ASCII text"
(charWidth 'a' == 1 && textWidth "abc" == 3)
, test "Display width of wide characters"
(charWidth '漢' == 2 && textWidth "a漢" == 3)
, test "Display width of combining marks"
(charWidth '\x0301' == 0 && textWidth "e\x0301" == 1)
, test "Display width of emoji"
(charWidth '😀' == 2)
, test "Display width of emoji modifiers"
(charWidth '\x1F3FB' == 0)
, test "Display width of Hangul medial jamo"
(charWidth '\x1161' == 0)
, test "Display width of fullwidth forms"
(charWidth '\xFF21' == 2)
, test "Line editor inserts at the end"
(applyLineKey (LineInsert 'c') (LineState "ab" 2) == LineState "abc" 3)
, test "Line editor inserts in the middle"
(applyLineKey (LineInsert 'b') (LineState "ac" 1) == LineState "abc" 2)
, test "Line editor inserts at the start"
(applyLineKey (LineInsert 'a') (LineState "bc" 0) == LineState "abc" 1)
, test "Line editor backspace removes the previous character"
(applyLineKey LineBackspace (LineState "abc" 2) == LineState "ac" 1)
, test "Line editor backspace at the start is a no-op"
(applyLineKey LineBackspace (LineState "abc" 0) == LineState "abc" 0)
, test "Line editor delete removes the character at the cursor"
(applyLineKey LineDelete (LineState "abc" 1) == LineState "ac" 1)
, test "Line editor delete at the end is a no-op"
(applyLineKey LineDelete (LineState "abc" 3) == LineState "abc" 3)
, test "Line editor movement stops at the buffer boundaries"
(applyLineKey LineMoveLeft (LineState "ab" 0) == LineState "ab" 0
&& applyLineKey LineMoveRight (LineState "ab" 2) == LineState "ab" 2)
, test "Line editor moves home and end"
(lineCursor (applyLineKey LineMoveHome (LineState "ab" 2)) == 0
&& lineCursor (applyLineKey LineMoveEnd (LineState "ab" 0)) == 2)
, test "Line editor ignores non-printable characters"
(applyLineKey (LineInsert '\t') (LineState "a" 1) == LineState "a" 1)
, test "Line window shows text that fits"
(visibleLine 10 (LineState "abc" 3) == ("abc", 3))
, test "Line window scrolls to keep the cursor visible"
(visibleLine 5 (LineState "abcdef" 6) == ("cdef", 4))
, test "Line window keeps wide characters aligned"
(visibleLine 5 (LineState "漢漢漢" 3) == ("漢漢", 4))
, test "Line window keeps combining marks attached"
(visibleLine 5 (LineState "e\x0301x" 3) == ("e\x0301x", 2))
, test "Line window keeps the cursor at the start"
(visibleLine 5 (LineState "abcde" 0) == ("abcd", 0))
, test "Line window of an empty buffer"
(visibleLine 5 (LineState "" 0) == ("", 0))
, test "Prompt without an initial value has no buffer"
(promptInitial (promptAt 0 0 0) == Nothing)
, test "Prompt with an initial value removes non-printable characters"
(promptInitial (promptWithInitial 0 0 0 "a\tb\nc") == Just "abc")
, testIO "Render printer without styling" $ do
out <- renderPrinter (printerItem (item "plain" (bold red)))
(settings [neverColors])
return $ out == "plain\n"
, testIO "Page renders to a string" $ do
let p = page [section [printerLeft 0 (blockSimple "rendered" styleDefault)]]
out <- renderPage p (settings [width 20, neverColors])
return $ "rendered" `isInfixOf` out
, testIO "Formatted table aligns and truncates columns" $ do
let tbl = tableSimple
[ blockSimple "Name" styleDefault
, blockSimple "Age" styleDefault ]
styleDefault
[ ["Alexandra", "7"]
, ["Bo", "42"] ]
fmt = tableFormat
[ defaultColumnSpec { columnMaxWidth = Just 4
, columnEllipsis = EllipsisChar '.' }
, defaultColumnSpec { columnAlign = AlignRight } ]
out <- renderPrinter (printerTableFormat fmt 0 0 tbl)
(settings [width 30, neverColors])
return $ all (`isInfixOf` out) ["Ale.", "Bo ", " 7", " 42"]
, testIO "Formatted table centers columns" $ do
let tbl = tableSimple
[ blockSimple "X" styleDefault ]
styleDefault
[ ["ab"], ["abcd"] ]
fmt = tableFormat
[ defaultColumnSpec { columnAlign = AlignCenter } ]
out <- renderPrinter (printerTableFormat fmt 0 0 tbl)
(settings [width 20, neverColors])
return $ " ab " `isInfixOf` out
, testIO "Bordered table draws a box" $ do
let tbl = tableSimple
[ blockSimple "A" styleDefault
, blockSimple "B" styleDefault ]
styleDefault
[ ["x", "y"] ]
out <- renderPrinter
(printerTableBordered BordersLight defaultTableFormat 0 0 tbl)
(settings [width 40, neverColors])
return $ all (`isInfixOf` out) ["┌", "│", "└", "x", "y"]
, testIO "Bordered groups pad unequal columns" $ do
let tall = groupSimple (blockSimple "A" styleDefault)
[ blockSimple "1" styleDefault
, blockSimple "2" styleDefault ]
short = groupSimple (blockSimple "B" styleDefault) []
out <- renderPrinter
(printerGroupsBordered BordersAscii 0 0 [tall, short])
(settings [width 30, neverColors])
let outputLines = lines out
allSameWidth = case outputLines of
[] -> False
(firstLine:_) -> all ((== length firstLine) . length) outputLines
return $ length outputLines == 7 && allSameWidth
, testIO "BordersNone keeps tall tables in one borderless block" $ do
let long = replicate 10 'A'
tall = groupSimple (blockSimple long styleDefault)
[ blockSimple "1" styleDefault
, blockSimple "2" styleDefault ]
short = groupSimple (blockSimple "B" styleDefault) []
out <- renderPrinter
(printerGroupsBordered BordersNone 0 0 [tall, short])
(settings [width 15, neverColors])
let outputLines = lines out
allSameWidth = case outputLines of
[] -> False
(firstLine:_) -> all ((== length firstLine) . length) outputLines
return $ length outputLines == 3
&& allSameWidth
&& (long ++ " B") `isInfixOf` out
&& not (any (`elem` "+|") out)
, testIO "Form rejects a prompt outside the page" $ do
let p = page [section [printerLeft 0 (blockSimple "one" styleDefault)]]
prompt = promptAt 9 0 0
(result, _) <- captureStdout $ do
st <- start p (settings [neverColors])
(_, formResult) <- readForm p [prompt] st
return formResult
return $ result == Left (PromptOutsidePage prompt)
, testIO "Form reads prompts in order" $ do
let p = page [section
[ printerLeft 0 (blockSimple "first" styleDefault)
, printerLeft 0 (blockSimple "second" styleDefault) ]]
prompts = [promptAt 0 0 7, promptAt 0 1 8]
(result, _) <- withStdin "Ada\n42\n" $ captureStdout $ do
st <- start p (settings [neverColors])
(_, formResult) <- readForm p prompts st
return formResult
return $ result == Right ["Ada", "42"]
, testIO "Form ignores initial values when stdin is not a terminal" $ do
let p = page [section
[ printerLeft 0 (blockSimple "first" styleDefault)
, printerLeft 0 (blockSimple "second" styleDefault) ]]
prompts = [ promptWithInitial 0 0 7 "old"
, promptWithInitial 0 1 8 "note" ]
(result, _) <- withStdin "Ada\n42\n" $ captureStdout $ do
st <- start p (settings [neverColors])
(_, formResult) <- readForm p prompts st
return formResult
return $ result == Right ["Ada", "42"]
, testIO "Shortcut reader returns a plain key" $ do
result <- withStdin "x" readKeyPress
return $ result == Just 'x'
, testIO "Shortcut reader ignores arrow escape sequences" $ do
result <- withStdin "\ESC[Aq" readKeyPress
return $ result == Just 'q'
, testIO "Shortcut reader ignores application cursor sequences" $ do
result <- withStdin "\ESCOBr" readKeyPress
return $ result == Just 'r'
, testIO "Shortcut reader ignores parameterized sequences" $ do
result <- withStdin "\ESC[1;5Bz" readKeyPress
return $ result == Just 'z'
, testIO "Shortcut reader reports end of input" $ do
result <- withStdin "" readKeyPress
return $ result == Nothing
, testIO "Raw key reader returns escape sequence characters" $ do
result <- withStdin "\ESC[A" (sequence [readKey, readKey, readKey])
return $ result == [Just '\ESC', Just '[', Just 'A']
, testIO "Wide text wraps by display width" $ do
(_, out) <- captureStdout
$ runPrinter (settings [width 5, neverColors])
(printerParagraph 0 0 [blockSimple "漢漢 漢漢" styleDefault])
return $ length (filter (== '\n') out) == 2
, testIO "Styles are suppressed when colors are never" $ do
(_, out) <- captureStdout
$ runPrinter (settings [neverColors]) (printerItem (item "plain" (bold red)))
return $ '\ESC' `notElem` out && "plain" `isInfixOf` out
, testIO "Styles are emitted when colors are always" $ do
(_, out) <- captureStdout
$ runPrinter (settings [alwaysColors]) (printerItem (item "styled" (bold red)))
return $ '\ESC' `elem` out && "styled" `isInfixOf` out
]
unless (and results) exitFailure
putStrLn "All tests passed."
test :: String -> Bool -> IO Bool
test name passed = do
putStrLn ((if passed then "ok " else "FAIL ") ++ name)
return passed
testIO :: String -> IO Bool -> IO Bool
testIO name action = action >>= test name
-- Runs an action with stdout redirected to a temporary file and returns
-- the captured output.
captureStdout :: IO a -> IO (a, String)
captureStdout action = do
tmp <- getTemporaryDirectory
(path, handle) <- openTempFile tmp "ansiform-test-output"
original <- hDuplicate stdout
hDuplicateTo handle stdout
result <- action
hFlush stdout
hDuplicateTo original stdout
hClose original
hClose handle
output <- readFile' path
removeFile path
return (result, output)
-- Runs an action with stdin replaced by a temporary file containing the input.
withStdin :: String -> IO a -> IO a
withStdin input action = do
tmp <- getTemporaryDirectory
(path, handle) <- openTempFile tmp "ansiform-test-input"
hPutStr handle input
hFlush handle
hSeek handle AbsoluteSeek 0
original <- hDuplicate stdin
hDuplicateTo handle stdin
result <- action
hDuplicateTo original stdin
hClose original
hClose handle
removeFile path
return result
--------------------------------------------------------------------------------
-- Fixtures
--------------------------------------------------------------------------------
header :: [Block]
header = [ blockSimple "A" styleDefault
, blockSimple "B" styleDefault ]
row :: [Block]
row = [ blockSimple "1" styleDefault
, blockSimple "2" styleDefault ]
balancedGroup, otherBalancedGroup, shortGroup :: Group
balancedGroup = groupSimple (blockSimple "Header" styleDefault) [rowBlock]
otherBalancedGroup = groupSimple (blockSimple "Header" styleDefault) [rowBlock]
shortGroup = groupSimple (blockSimple "Header" styleDefault) []
rowBlock :: Block
rowBlock = blockSimple "value" styleDefault
oldPage :: Page
oldPage = page [ oldSection, keptSection ]
oldSection, keptSection, newSection :: Section
oldSection = section [ printerLeft 0 (blockSimple "old" styleDefault) ]
keptSection = section [ printerCenter 0 (blockSimple "kept" styleDefault) ]
newSection = section [ printerRight 0 (blockSimple "new" styleDefault) ]