{- This file is part of irc-fun-color.
-
- Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
{-# LANGUAGE OverloadedStrings #-}
import Data.List (findIndex)
import Data.Monoid ((<>))
import Data.Text (Text, pack)
import Data.Text.IO (putStrLn)
import Network.IRC.Fun.Color
import Prelude hiding (putStrLn)
import System.Exit (exitFailure)
cases :: [(StyledText, Text, Text)]
cases =
[ ( Green #> "hello beautiful world"
, "\ETX3hello beautiful world\ETX"
, "hello beautiful world"
)
, ( Bold #> "hello beautiful world"
, "\STXhello beautiful world\STX"
, "hello beautiful world"
)
, ( Green #> ("hello " <> Underline #> "beautiful" <> " world")
, "\ETX3hello \ETX\US\ETX3beautiful\ETX\US\ETX3 world\ETX"
, "hello beautiful world"
)
, ( Red `fgBg` Gray #> "hello beautiful world"
, "\ETX4,14hello beautiful world\ETX"
, "hello beautiful world"
)
, ( ("hello " <> Red #> Underline #> "beautiful" <> " world") <# bg Blue
, "\ETX,12hello \ETX\US\ETX4,12beautiful\ETX\US\ETX,12 world\ETX"
, "hello beautiful world"
)
, ( Lime `fgBg` Black #> (Bold #> "A" <> Reverse #> "B" <> Italic #> "C")
, "\STX\ETX9,1A\ETX\STX\SYN\ETX9,1B\ETX\SYN\GS\ETX9,1C\ETX\GS"
, "ABC"
)
, ( Bold #> Underline #> Purple `fgBg` White #> "hello beautiful world"
, "\US\STX\ETX6,0hello beautiful world\ETX\STX\US"
, "hello beautiful world"
)
]
results :: [(Bool, Text, Bool, Text)]
results = map f cases
where
f (styled, encoded, stripped) =
let e = encode styled
s = strip styled
in (e == encoded, e, s == stripped, s)
showt :: Show a => a -> Text
showt = pack . show
failure :: Maybe (Int, Bool, StyledText, Text, Text)
failure = do
loc <- findIndex (\ (e, _, s, _) -> not (e && s)) results
case (cases !! loc, results !! loc) of
((styled, encoded, _), (False, e, _, _)) ->
Just (loc + 1, True, styled, encoded, e)
((styled, _, stripped), (_, _, False, s)) ->
Just (loc + 1, False, styled, stripped, s)
_ -> error "Test impl error"
putFailure :: Int -> Bool -> StyledText -> Text -> Text -> IO ()
putFailure n enc styled expected got = do
putStrLn $ "TEST " <> showt n <> " FAILED:"
putStrLn $ (if enc then "encode " else "strip ") <> showt styled
putStrLn $ "Expected: " <> showt expected
putStrLn $ "Got: " <> showt got
main :: IO ()
main =
case failure of
Nothing -> putStrLn "ALL TESTS PASSED"
Just (n, b, ss, e, s) -> putFailure n b ss e s >> exitFailure