2019-12-11 18:29:28 -08:00
import Data.Char ( isAlpha )
2019-12-11 19:21:54 -08:00
import qualified Data.Text as T
2019-12-11 18:29:28 -08:00
import Generic.Random ( genericArbitraryRec , uniform )
2020-11-03 13:29:59 -08:00
import LambdaCalculus
2019-12-11 18:29:28 -08:00
import LambdaCalculus.Parser
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
2019-12-11 19:21:54 -08:00
import TextShow ( showt )
2019-12-11 18:29:28 -08:00
instance Arbitrary Expression where
arbitrary = genericArbitraryRec uniform
2019-12-11 19:21:54 -08:00
instance Arbitrary T . Text where
arbitrary = T . pack <$> listOf1 ( elements $ [ 'A' .. 'Z' ] ++ [ 'a' .. 'z' ] )
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 " )
prop_parseExpression_inverse :: Expression -> Bool
2019-12-11 19:21:54 -08:00
prop_parseExpression_inverse expr = Right expr == parseExpression ( showt expr )
2019-12-11 18:29:28 -08:00
main :: IO ()
main = defaultMain $
testGroup " Tests "
[ testGroup " Evaluator tests "
[ testCase " DFI " $ eagerEval dfi @?= Application ( Variable " y " ) ( Variable " y " )
, testCase " ttttt " $ eagerEval ttttt @?= Variable " y "
]
, 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
]
, testProperty " parseExpression is the left inverse of show " prop_parseExpression_inverse
]
]