2020-11-03 13:29:59 -08:00
import LambdaCalculus
2019-12-11 18:29:28 -08:00
import LambdaCalculus.Parser
import Test.Tasty
import Test.Tasty.HUnit
2019-12-11 19:21:54 -08:00
2020-11-02 15:59:35 -08:00
-- These are terms which have complex reduction steps and
-- are likely to catch bugs in the substitution function, if there are any.
-- However, they don't have any particular computational *meaning*,
-- so the names for them are somewhat arbitrary.
-- This should evaluate to `y y`.
2019-12-11 18:29:28 -08:00
dfi :: Expression
dfi = Application d ( Application f i )
2021-03-05 19:04:06 -08:00
where
d = Abstraction " x " $ Application ( Variable " x " ) ( Variable " x " )
f = Abstraction " f " $ Application ( Variable " f " ) ( Application ( Variable " f " ) ( Variable " y " ) )
i = Abstraction " x " $ Variable " x "
2019-12-11 18:29:28 -08:00
2020-11-02 15:59:35 -08:00
-- This should evalaute to `y`.
2019-12-11 18:29:28 -08:00
ttttt :: Expression
ttttt = Application ( Application ( Application f t ) ( Abstraction " x " ( Variable " x " ) ) ) ( Variable " y " )
2021-03-05 19:04:06 -08:00
where
t = Abstraction " f " $ Abstraction " x " $
2019-12-11 18:29:28 -08:00
Application ( Variable " f " ) ( Application ( Variable " f " ) ( Variable " x " ) )
2021-03-05 19:04:06 -08:00
f = Abstraction " T " $ Abstraction " f " $ Abstraction " x " $
2019-12-11 18:29:28 -08:00
Application ( Application
( Application ( Variable " T " )
( Application ( Variable " T " )
( Application ( Variable " T " )
( Application ( Variable " T " )
( Variable " T " ) ) ) ) )
( Variable " f " ) )
( Variable " x " )
2021-03-05 23:38:21 -08:00
-- | A simple divergent expression.
omega :: Expression
omega = Application x x
where x = Abstraction " x " ( Application ( Variable " x " ) ( Variable " x " ) )
cc1 :: Expression
cc1 = Application ( Variable " callcc " ) ( Abstraction " k " ( Application omega ( Application ( Variable " k " ) ( Variable " z " ) ) ) )
cc2 :: Expression
cc2 = Application ( Variable " y " ) ( Application ( Variable " callcc " ) ( Abstraction " k " ( Application ( Variable " z " ) ( Application ( Variable " k " ) ( Variable " x " ) ) ) ) )
2019-12-11 18:29:28 -08:00
main :: IO ()
main = defaultMain $
testGroup " Tests "
[ testGroup " Evaluator tests "
2021-03-05 23:38:21 -08:00
[ testCase " capture test 1: DFI " $ eval dfi @?= Application ( Variable " y " ) ( Variable " y " )
, testCase " capture test 2: ttttt " $ eval ttttt @?= Variable " y "
, testCase " invoking a continuation replaces the current continuation " $ eval cc1 @?= Variable " z "
, testCase " callcc actually captures the current continuation " $ eval cc2 @?= Application ( Variable " y " ) ( Variable " x " )
2019-12-11 18:29:28 -08:00
]
, testGroup " Parser tests "
[ testGroup " Unit tests "
2020-11-02 15:59:35 -08:00
[ testCase " identity " $ parseExpression " \ \ x.x " @?= Right ( Abstraction " x " $ Variable " x " )
, testCase " unary application " $ parseExpression " (x) " @?= Right ( Variable " x " )
2019-12-11 18:29:28 -08:00
, testCase " application shorthand " $ parseExpression " a b c d " @?= Right ( Application ( Application ( Application ( Variable " a " ) ( Variable " b " ) ) ( Variable " c " ) ) ( Variable " d " ) )
2020-11-02 15:59:35 -08:00
, testCase " let " $ parseExpression " let x = \ \ y.y in x " @?= Right ( Application ( Abstraction " x " ( Variable " x " ) ) ( Abstraction " y " ( Variable " y " ) ) )
2020-11-03 11:33:35 -08:00
, testCase " multi-let " $ parseExpression " let x = y; y = z in x y " @?= Right ( Application ( Abstraction " x " ( Application ( Abstraction " y " ( Application ( Variable " x " ) ( Variable " y " ) ) ) ( Variable " z " ) ) ) ( Variable " y " ) )
2020-11-02 15:59:35 -08:00
, testCase " ttttt " $ parseExpression " ( \ \ T f x.(T (T (T (T T)))) f x) ( \ \ f x.f (f x)) ( \ \ x.x) y "
2019-12-11 18:29:28 -08:00
@?= Right ttttt
2020-11-02 15:59:35 -08:00
, testGroup " Redundant whitespace "
[ testCase " around variable " $ parseExpression " x " @?= Right ( Variable " x " )
, testCase " around lambda " $ parseExpression " \ \ x y . x " @?= Right ( Abstraction " x " $ Abstraction " y " $ Variable " x " )
, testCase " around application " $ parseExpression " ( x (y ) ) " @?= Right ( Application ( Variable " x " ) ( Variable " y " ) )
, testCase " around let " $ parseExpression " let x=(y)in x " @?= Right ( Application ( Abstraction " x " ( Variable " x " ) ) ( Variable " y " ) )
]
2019-12-11 18:29:28 -08:00
]
]
]