sifflet-2.3.0: tests/Testing/Unit/ToSchemeTests.hs
-- | Testing for Language.Sifflet.Export.ToScheme
module Testing.Unit.ToSchemeTests
(tests, runU, testExpr, testExampleDef, ted
, t6, mt0, mt1, mt2, t7, t8
, test', testf')
where
import Test.HUnit
import Data.Number.Sifflet
import Language.Sifflet.Export.ToScheme
import Language.Sifflet.Expr
import Language.Sifflet.Examples
import Text.Sifflet.Repr
import Text.Sifflet.Pretty
import Testing.TestUtil (utestloop)
-- | Test expr labels
labels :: [String]
labels = ["undefined", "symbol foo", "False", "True",
"char c", "if True then 7 else 88",
"nested list"]
-- | Test expressions
exprs :: [Expr]
exprs = [EUndefined
, ESymbol (Symbol "foo")
, EBool False
, EBool True
, EChar 'c'
, EIf (EBool True)
(ENumber (Exact 7))
(ENumber (Exact 88))
, EList [EBool True,
EChar 'x',
ENumber (Exact 35),
ENumber (Inexact 4.6),
EString "cozy",
EList [],
EList [EBool False,
EChar 'y',
EString "",
EList []]]
]
-- | Corresponding S-expressions
sexprs :: [SExpr]
sexprs = [SAtom (SSymbol "*sifflet-undefined*")
, SAtom (SSymbol "foo")
, SAtom (SBool False)
, SAtom (SBool True)
, SAtom (SChar 'c')
, SList [SAtom (SSymbol "if"),
SAtom (SBool True),
SAtom (SInt 7),
SAtom (SInt 88)]
, SList [SAtom (SSymbol "list"),
SAtom (SBool True),
SAtom (SChar 'x'),
SAtom (SInt 35),
SAtom (SFloat 4.6),
SAtom (SString "cozy"),
SList [SAtom (SSymbol "list")],
SList [SAtom (SSymbol "list"),
SAtom (SBool False),
SAtom (SChar 'y'),
SAtom (SString ""),
SList [SAtom (SSymbol "list")]]]
]
-- | Corresponding repr strings
reprStrings :: [String]
reprStrings =
["*sifflet-undefined*"
, "foo"
, "#f"
, "#t"
, "'c'"
, "(if #t 7 88)"
, "(list #t 'x' 35 4.6 \"cozy\" (list) (list #f 'y' \"\" (list)))"
]
-- | Corresponding pretty strings
pretties :: [String]
pretties = ["*sifflet-undefined*"
, "foo"
, "#f"
, "#t"
, "'c'"
, "(if #t 7 88)"
, concat [ "(list #t"
, "\n 'x'"
, "\n 35"
, "\n 4.6"
, "\n \"cozy\""
, "\n (list)"
, "\n (list #f"
, "\n 'y'"
, "\n \"\""
, "\n (list)))"
]
]
moreLabels :: [String]
moreLabels = ["empty list"
, "flat list"
, "nested list"
, "if expr"
, "list expression with evaluation"
, "list expression without evaluation"
]
eint :: Integer -> Expr
eint n = ENumber (Exact n)
moreExprs :: [Expr]
moreExprs = [EList []
, EList [eint 1
, EBool False
, EString "thunder"]
, EList [EList [eint 1, eint 2]
, EList [eint 3, eint 4, eint 5]
, EList []
, EList [eint 6, eint 7]]
, let sa = ESymbol (Symbol "a")
sb = ESymbol (Symbol "b")
in EIf (ECall (Symbol ">") [sa, sb])
(ECall (Symbol "+") [sa, eint 5])
(ECall (Symbol "-") [sb, eint 20])
, EList [ENumber (Exact 6), ENumber (Exact 7)]
]
morePretties :: [String]
morePretties = ["(list)"
, "(list 1 #f \"thunder\")"
, concat [ "(list (list 1 2)"
, "\n (list 3 4 5)"
, "\n (list)"
, "\n (list 6 7))"
]
, concat [ "(if (> a b)"
, "\n (+ a 5)"
, "\n (- b 20))"
]
, "(list 6 7)"
]
sexprTests :: [Test]
sexprTests = map (makeTestCase "exprToSExpr" exprToSExpr)
(zip3 exprs sexprs labels)
reprTests :: [Test]
reprTests = map (makeTestCase "exprToSchemeRepr" exprToSchemeRepr)
(zip3 exprs reprStrings labels)
prettyTests :: [Test]
prettyTests = map (makeTestCase "exprToSchemePretty" exprToSchemePretty)
(zip3 exprs pretties labels)
morePrettyTests :: [Test]
morePrettyTests = map (makeTestCase "exprToSchemePretty" exprToSchemePretty)
(zip3 moreExprs morePretties moreLabels)
makeTestCase :: (Eq a, Show a) =>
String -> (Expr -> a) -> (Expr, a, String) -> Test
makeTestCase fname f (expr, result, label) =
TestCase (assertEqual (fname ++ " " ++ label) result (f expr))
-- | Test for function definition
makeDefTest :: SchemeOptions -> (String, String) -> Test
makeDefTest options (name, result) =
let f = envGetFunction exampleEnv name
sdef = defToSExpr options (functionToDef f)
in TestCase (assertEqual ("define " ++ name)
result
(pretty sdef))
-- Tests of function definition using lambda expressions
defTests1 :: [Test]
defTests1 = map (makeDefTest (SchemeOptions {defineWithLambda = True}))
(zip defTestNames1 defTestResults1)
defTestNames1 :: [String]
defTestNames1 = ["bonus2"]
defTestResults1 :: [String]
defTestResults1 = [concat [ "(define bonus2"
, "\n (lambda (salesA salesB)"
, "\n (bonus1 (grossProfit salesA salesB))))"]]
-- | Tests of function definition with default Scheme options (no lambda)
defTests2 :: [Test]
defTests2 = map (makeDefTest (SchemeOptions {defineWithLambda = False}))
(zip defTestNames2 defTestResults2)
defTestNames2 :: [String]
defTestNames2 = ["grossProfit"
, "fact"
, "rmul"
, "fib1"
, "length"
]
defTestResults2 :: [String]
defTestResults2 = [concat ["(define (grossProfit salesA salesB)"
, "\n (+ (* 0.12 salesA)"
, "\n (* 0.25 salesB)))"
]
, concat ["(define (fact n)"
, "\n (if (zero? n)"
, "\n 1"
, "\n (* n"
, "\n (fact (sifflet-sub1 n)))))"
]
, concat ["(define (rmul m n)"
, "\n (if (zero? n)"
, "\n 0"
, "\n (+ m"
, "\n (rmul m"
, "\n (sifflet-sub1 n)))))"
]
, concat ["(define (fib1 n)"
, "\n (if (equal? n 1)"
, "\n 1"
, "\n (if (equal? n 2)"
, "\n 1"
, "\n (+ (fib1 (- n 2))"
, "\n (fib1 (- n 1))))))"
]
, concat ["(define (length xs)"
, "\n (if (null? xs)"
, "\n 0"
, "\n (+ 1"
, "\n (length (cdr xs)))))"
]
]
tests :: Test
tests = TestList $ concat [sexprTests
, reprTests
, prettyTests
, morePrettyTests
, defTests1
, defTests2
]
runU :: IO ()
runU = utestloop tests
putLabeledString :: String -> String -> IO ()
putLabeledString label string = putStrLn (label ++ ": " ++ string)
testExpr :: Expr -> IO ()
testExpr expr =
let pls = putLabeledString
in pls "Expr" (show expr) >>
pls "SExpr" (show (exprToSExpr expr)) >>
pls "Repr" (exprToSchemeRepr expr) >>
pls "Pretty" ("\n" ++ exprToSchemePretty expr)
testExampleDef :: String -> IO ()
testExampleDef name =
let f = envGetFunction exampleEnv name
def = functionToDef f
sdef = defToSExpr defaultSchemeOptions def
pls = putLabeledString
plss label thing = pls label (show thing)
in pls "Name" name >>
plss "Value" f >> -- ???
plss "SExpr" sdef >>
pls "Repr" (repr sdef) >>
pls "Pretty" ("\n" ++ pretty sdef)
ted :: String -> IO ()
ted = testExampleDef
t6, mt0, mt1, mt2 :: IO ()
t6 = testExpr (exprs !! 6)
mt0 = testExpr (moreExprs !! 0)
mt1 = testExpr (moreExprs !! 1)
mt2 = testExpr (moreExprs !! 2)
e7 :: Expr
e7 = EList [EList [eint 1, eint 2]
, EList [EList [eint 3
, EList [eint 4, eint 5]
, EList []
, EList [eint 6
, EList [eint 7, eint 8]
, eint 9
]
, eint 10
]
, EList [eint 11, eint 12, eint 13
, EList [eint 14, eint 15]
]
]
]
t7 :: IO ()
t7 = testExpr e7
e8 :: Expr
e8 = let sym name = ESymbol (Symbol name)
in EList [sym "cat"
, EList [sym "dog", sym "mouse"]
, EList [sym "broccoli"
, EList [sym "potatoes"
, sym "catsup"
, sym "mustard"
]
]
]
t8 :: IO ()
t8 = testExpr e8
test' :: Expr -> IO ()
test' expr =
let pls = putLabeledString
sexpr = exprToSExpr expr
in pls "Expr" (show expr) >>
pls "SExpr" (show sexpr) >>
pls "Repr" (repr sexpr) >>
pls "Pretty" ("\n" ++ pretty sexpr)
testf' :: String -> IO ()
testf' name =
let f = envGetFunction exampleEnv name
def = functionToDef f
sdef = defToSExpr defaultSchemeOptions def
pls = putLabeledString
plss label thing = pls label (show thing)
in pls "Name" name >>
plss "Value" f >> -- ???
plss "SExpr" sdef >>
pls "Repr" (repr sdef) >>
pls "Pretty" ("\n" ++ pretty sdef)