sexpresso-1.1.0.0: test/SchemeR5RS_Unittests.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module SchemeR5RS_Unittests (
r5rsTestTree
)where
import Data.Void
import qualified Data.Text as T
import Data.Either
import Data.Bifunctor (first)
import Test.Tasty
import Test.Tasty.HUnit
import Text.Megaparsec
--import Text.Megaparsec.Char
import Data.SExpresso.SExpr
import Data.SExpresso.Parse
import Data.SExpresso.Language.SchemeR5RS as R5
type Parser = Parsec Void T.Text
pSExpr :: Parser [SExpr R5.SExprType R5.SchemeToken]
pSExpr = decode R5.sexpr
-- tparse parses the whole input
tparse :: Parser a -> T.Text -> Either String a
tparse p s = first errorBundlePretty $ parse (p <* eof) "" s
-- Runs a test that must succeed. Accepts the parser and
-- the string to parse and the expected value as tuple
okTest :: (Eq a, Show a) => Parser a -> (T.Text, a) -> TestTree
okTest p (str, expected) = testCase ("Should parse " ++ show str)
$ tparse p str @?= Right expected
okDatum :: (T.Text, [Datum]) -> TestTree
okDatum (t, d) = okTest (sexpr2Datum <$> pSExpr) (t, Right d)
-- Runs a test that must fail. Accepts the parser
-- and the string to parse
koTest :: Parser a -> T.Text -> TestTree
koTest p str = testCase ("Should not parse " ++ show str)
$ (isLeft $ tparse p str) @?
("Parsing must fail on " ++ show str)
koDatum :: T.Text -> TestTree
koDatum str = testCase ("Should not parse " ++ show str)
$ (isLeft $ (tparse pSExpr str >>= sexpr2Datum)) @?
("Parsing must fail on " ++ show str)
-- Tests about whitespace that must succeed (see okTest)
okWhitespace :: [(T.Text, ())]
okWhitespace = map (,()) [" ", "\t", "\n", "\r\n"]
-- Tests about comment that must succeed (see okTest)
okComment :: [(T.Text, ())]
okComment = map (,()) [";", ";hello world", ";hello\n", ";abcdef\r\n"]
okInterTokenSpace1 :: [(T.Text, ())]
okInterTokenSpace1 = okWhitespace
++ okComment
++ map (,()) [" ;comment\n ",
"\t\n;comment \n ",
"\n\n\n\n\n",
"\r\n;Hello World",
" ;comment\n ;comment"]
okInterTokenSpace :: [(T.Text, ())]
okInterTokenSpace = okInterTokenSpace1 ++ map (,()) [""]
okChar :: [(T.Text, Char)]
okChar = [("#\\t", 't'),
("#\\a", 'a'),
("#\\space", ' '),
("#\\newline", '\n'),
("#\\\n", '\n'),
("#\\ ", ' '),
("#\\\t", '\t')]
okBool :: [(T.Text, Bool)]
okBool = [("#t", True),
("#f", False)]
okIdentifier :: [(T.Text, T.Text)]
okIdentifier = map (\x -> (x,x)) ["foo", "x2", "!hot!", "+", "-", "...",
"helloWorld"]
okString :: [(T.Text, T.Text)]
okString = [("\"abc def ghi\"", "abc def ghi"),
("\"\"", ""),
("\"\n\"", "\n"),
("\" \"", " "),
("\"\t\"", "\t"),
(T.pack ['"','\\','\\','"'], "\\"),
(T.pack ['"','\\','"','"'], "\"")]
okNumber :: [(T.Text, SchemeNumber)]
okNumber = [("-1", SchemeNumber Exact $
CReal (SInteger Minus (UInteger 1))),
("-0", SchemeNumber Exact $
CReal (SInteger Minus (UInteger 0 ))),
("0", SchemeNumber Exact $
CReal (SInteger Plus (UInteger 0))),
("1", SchemeNumber Exact $
CReal (SInteger Plus (UInteger 1))),
("#e1", SchemeNumber Exact $
CReal (SInteger Plus (UInteger 1))),
("#i1", SchemeNumber Inexact $
CReal (SInteger Plus (UInteger 1))),
("#b1", SchemeNumber Exact $
CReal (SInteger Plus (UInteger 1))),
("#o1", SchemeNumber Exact $
CReal (SInteger Plus (UInteger 1))),
("#d1", SchemeNumber Exact $
CReal (SInteger Plus (UInteger 1))),
("#x1", SchemeNumber Exact $
CReal (SInteger Plus (UInteger 1))),
("#xa", SchemeNumber Exact $ CReal (SInteger Plus (UInteger 10))),
("#xb", SchemeNumber Exact $
CReal (SInteger Plus (UInteger 11))),
("#xc", SchemeNumber Exact $
CReal (SInteger Plus (UInteger 12))),
("#xd", SchemeNumber Exact $
CReal (SInteger Plus (UInteger 13))),
("#xe", SchemeNumber Exact $
CReal (SInteger Plus (UInteger 14))),
("#xf", SchemeNumber Exact $
CReal (SInteger Plus (UInteger 15))),
("-0001", SchemeNumber Exact $
CReal (SInteger Minus (UInteger 1))),
("-0000", SchemeNumber Exact $
CReal (SInteger Minus (UInteger 0))),
("0000", SchemeNumber Exact $
CReal (SInteger Plus (UInteger 0))),
("0001", SchemeNumber Exact $
CReal (SInteger Plus (UInteger 1))),
("-1#", SchemeNumber Inexact $
CReal (SInteger Minus (UIntPounds 1 1))),
("-0#", SchemeNumber Inexact $
CReal (SInteger Minus (UIntPounds 0 1))),
("0#", SchemeNumber Inexact $
CReal (SInteger Plus (UIntPounds 0 1))),
("1#", SchemeNumber Inexact $
CReal (SInteger Plus (UIntPounds 1 1))),
("-1###", SchemeNumber Inexact $
CReal (SInteger Minus (UIntPounds 1 3))),
("-0###", SchemeNumber Inexact $
CReal (SInteger Minus (UIntPounds 0 3))),
("0###", SchemeNumber Inexact $
CReal (SInteger Plus (UIntPounds 0 3))),
("1###", SchemeNumber Inexact $
CReal (SInteger Plus (UIntPounds 1 3))),
("-12345", SchemeNumber Exact $
CReal (SInteger Minus (UInteger 12345))),
("12345", SchemeNumber Exact $
CReal (SInteger Plus (UInteger 12345))),
("-12345/5", SchemeNumber Exact $
CReal (SRational Minus (UInteger 12345) (UInteger 5))),
("12345/5", SchemeNumber Exact $
CReal (SRational Plus (UInteger 12345) (UInteger 5))),
("-12345#/5", SchemeNumber Inexact $
CReal (SRational Minus (UIntPounds 12345 1) (UInteger 5))),
("12345/5##", SchemeNumber Inexact $
CReal (SRational Plus (UInteger 12345) (UIntPounds 5 2))),
("-12345##/5", SchemeNumber Inexact $
CReal (SRational Minus (UIntPounds 12345 2) (UInteger 5))),
("12345####/5#", SchemeNumber Inexact $
CReal (SRational Plus (UIntPounds 12345 4) (UIntPounds 5 1))),
("-12345.0", SchemeNumber Inexact $
CReal (SDecimal Minus (UInteger 12345) (UInteger 0) Nothing)),
(".0", SchemeNumber Inexact $
CReal (SDecimal Plus (UInteger 0) (UInteger 0) Nothing)),
("0.", SchemeNumber Inexact $
CReal (SDecimal Plus (UInteger 0) (UInteger 0) Nothing)),
("0.###", SchemeNumber Inexact $
CReal (SDecimal Plus (UInteger 0) (UPounds 3) Nothing)),
("-.569", SchemeNumber Inexact $
CReal (SDecimal Minus (UInteger 0) (UInteger 569) Nothing)),
("-245#.", SchemeNumber Inexact $
CReal (SDecimal Minus (UIntPounds 245 1) (UPounds 0) Nothing)),
("#e-.569", SchemeNumber Exact $
CReal (SDecimal Minus (UInteger 0) (UInteger 569) Nothing)),
("1e10", SchemeNumber Inexact $
CReal (SDecimal Plus (UInteger 1)
(UInteger 0)
(Just $ Suffix PDefault Plus 10))),
("1e-10", SchemeNumber Inexact $
CReal (SDecimal Plus (UInteger 1)
(UInteger 0)
(Just $ Suffix PDefault Minus 10))),
("1s10", SchemeNumber Inexact $
CReal (SDecimal Plus (UInteger 1)
(UInteger 0)
(Just $ Suffix PShort Plus 10))),
("1f10", SchemeNumber Inexact $
CReal (SDecimal Plus (UInteger 1)
(UInteger 0)
(Just $ Suffix PSingle Plus 10))),
("1d10", SchemeNumber Inexact $
CReal (SDecimal Plus (UInteger 1)
(UInteger 0)
(Just $ Suffix PDouble Plus 10))),
("1l10", SchemeNumber Inexact $
CReal (SDecimal Plus (UInteger 1)
(UInteger 0)
(Just $ Suffix PLong Plus 10))),
("1+i", SchemeNumber Exact $
CAbsolute (SInteger Plus (UInteger 1)) (SInteger Plus (UInteger 1))),
("1-i", SchemeNumber Exact $
CAbsolute (SInteger Plus (UInteger 1)) (SInteger Minus (UInteger 1))),
("0.5+i", SchemeNumber Inexact $
CAbsolute (SDecimal Plus (UInteger 0)
(UInteger 5)
Nothing) (SInteger Plus (UInteger 1))),
("-8i", SchemeNumber Exact $
CAbsolute (SInteger Plus (UInteger 0)) (SInteger Minus (UInteger 8))),
("-8.25i", SchemeNumber Inexact $
CAbsolute (SInteger Plus (UInteger 0)) (SDecimal Minus (UInteger 8)
(UInteger 25)
Nothing)),
("0@25", SchemeNumber Exact $
CAngle (SInteger Plus (UInteger 0)) (SInteger Plus (UInteger 25))),
("1/4@-25", SchemeNumber Exact $
CAngle (SRational Plus (UInteger 1) (UInteger 4)) (SInteger Minus (UInteger 25))),
("1#/4@-25##", SchemeNumber Inexact $
CAngle (SRational Plus (UIntPounds 1 1) (UInteger 4)) (SInteger Minus (UIntPounds 25 2)))]
-- Returns all the "ok..." series of tests except the one provided
-- as input. Since R5RS grammar is non ambiguous, a token parser should not be able
-- to parse the valid input of other token parser.
mkKoTest :: [T.Text] -> [T.Text]
mkKoTest goodStr =
let allTests = map fst okInterTokenSpace ++
map fst okChar ++
map fst okBool ++
map fst okIdentifier ++
map fst okString ++
map fst okNumber
in filter (not . (`elem` goodStr)) (alwaysBad ++ allTests)
-- Always bad string input
alwaysBad :: [T.Text]
alwaysBad = ["#", "#T", "#F", "#true", "#false"] ++
-- Ill formated number
["#b3", "#o9", "#da", "#xA", "#b1.1", "#o1.1", "#x1.1", "#b.1",
"#o.1", "#x.1", "123##.12"]
r5rsTestTree :: TestTree
r5rsTestTree = testGroup "Language/R5RS.hs" $ [
testGroup "whitespace" $
map (okTest R5.whitespace) okWhitespace ++
map (koTest R5.whitespace) (mkKoTest $ map fst okWhitespace),
testGroup "comment" $
map (okTest R5.comment) okComment ++
map (koTest R5.comment) (mkKoTest $ map fst okComment),
testGroup "interTokenSpace" $
map (okTest R5.interTokenSpace) okInterTokenSpace ++
map (koTest R5.interTokenSpace) (mkKoTest $ map fst okInterTokenSpace),
testGroup "interTokenSpace1" $
map (okTest R5.interTokenSpace1) okInterTokenSpace1 ++
map (koTest R5.interTokenSpace1) (mkKoTest $ map fst okInterTokenSpace1),
testGroup "character" $
map (okTest R5.character) okChar ++
map (koTest R5.character) (mkKoTest $ map fst okChar),
testGroup "boolean" $
map (okTest R5.boolean) okBool ++
map (koTest R5.boolean) (mkKoTest $ map fst okBool),
testGroup "identifier" $
map (okTest R5.identifier) okIdentifier ++
map (koTest R5.identifier) (mkKoTest $ map fst okIdentifier),
testGroup "string" $
map (okTest R5.stringParser) okString ++
map (koTest R5.stringParser) (mkKoTest $ map fst okString),
testGroup "number" $
map (okTest R5.number) okNumber ++
map (koTest R5.number) (mkKoTest $ map fst okNumber),
testGroup "datum" $
map okDatum (map (fmap ( (:[]) . DChar)) okChar) ++
map okDatum (map (fmap ( (:[]) . DBoolean)) okBool) ++
map okDatum (map (fmap ( (:[]) . DIdentifier)) okIdentifier) ++
map okDatum (map (fmap ( (:[]) . DString)) okString) ++
map okDatum (map (fmap ( (:[]) . DNumber)) okNumber) ++
map okDatum
[("(foo #\\a)", [DList [DIdentifier "foo", DChar 'a']]),
("(foo #\\a) \"hello\"", [DList [DIdentifier "foo", DChar 'a'], DString "hello"]),
("'foo", [DQuote (DIdentifier "foo")]),
("`foo", [DQuasiquote (DIdentifier "foo")]),
("`(foo ,a)", [DQuasiquote (DList [DIdentifier "foo", DComma (DIdentifier "a")])]),
("`(foo , a)", [DQuasiquote (DList [DIdentifier "foo", DComma (DIdentifier "a")])]),
("`(foo, a)", [DQuasiquote (DList [DIdentifier "foo", DComma (DIdentifier "a")])]),
("`(foo ,@a)", [DQuasiquote (DList [DIdentifier "foo", DCommaAt (DIdentifier "a")])]),
("`(foo ,@ a)", [DQuasiquote (DList [DIdentifier "foo", DCommaAt (DIdentifier "a")])]),
("`(foo,@ a)", [DQuasiquote (DList [DIdentifier "foo", DCommaAt (DIdentifier "a")])]),
("(foo . a)", [DDotList [DIdentifier "foo"] (DIdentifier "a")]),
("(foo a b c . d)",
[DDotList [DIdentifier "foo", DIdentifier "a", DIdentifier "b", DIdentifier "c"] (DIdentifier "d")])]
++
map koDatum ["(foo .)", "(foo ')", "(foo `)", "(foo ,)", "(foo ,@)", "(foo a b . c d)"]
]