926 lines
35 KiB
Haskell
926 lines
35 KiB
Haskell
module Main where
|
|
|
|
import Eval
|
|
import FileEval
|
|
import Lexer
|
|
import Parser
|
|
import REPL
|
|
import Research
|
|
import Wire
|
|
import ContentStore
|
|
|
|
import Control.Exception (evaluate, try, SomeException)
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import Data.Bits (xor)
|
|
import Data.List (isInfixOf)
|
|
import Data.Text (Text, unpack)
|
|
import Data.Word (Word8)
|
|
import Test.Tasty
|
|
import Test.Tasty.HUnit
|
|
import Text.Megaparsec (runParser)
|
|
|
|
import Data.ByteString (ByteString)
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
import Database.SQLite.Simple (close, Connection)
|
|
|
|
main :: IO ()
|
|
main = defaultMain tests
|
|
|
|
tricuTestString :: String -> String
|
|
tricuTestString s = show $ result (evalTricu Map.empty $ parseTricu s)
|
|
|
|
tests :: TestTree
|
|
tests = testGroup "Tricu Tests"
|
|
[ lexer
|
|
, parser
|
|
, simpleEvaluation
|
|
, lambdas
|
|
, providedLibraries
|
|
, fileEval
|
|
, modules
|
|
, demos
|
|
, decoding
|
|
, elimLambdaSingle
|
|
, stressElimLambda
|
|
, wireTests
|
|
]
|
|
|
|
lexer :: TestTree
|
|
lexer = testGroup "Lexer Tests"
|
|
[ testCase "Lex simple identifiers" $ do
|
|
let input = "x a b = a"
|
|
expect = Right [LIdentifier "x", LIdentifier "a", LIdentifier "b", LAssign, LIdentifier "a"]
|
|
runParser tricuLexer "" input @?= expect
|
|
|
|
, testCase "Lex Tree Calculus terms" $ do
|
|
let input = "t t t"
|
|
expect = Right [LKeywordT, LKeywordT, LKeywordT]
|
|
runParser tricuLexer "" input @?= expect
|
|
|
|
, testCase "Lex escaped characters in strings" $ do
|
|
let input = "\"hello\\nworld\""
|
|
expect = Right [LStringLiteral "hello\nworld"]
|
|
runParser tricuLexer "" input @?= expect
|
|
|
|
, testCase "Lex multiple escaped characters in strings" $ do
|
|
let input = "\"tab:\\t newline:\\n quote:\\\" backslash:\\\\\""
|
|
expect = Right [LStringLiteral "tab:\t newline:\n quote:\" backslash:\\"]
|
|
runParser tricuLexer "" input @?= expect
|
|
|
|
, testCase "Lex escaped characters in string literals" $ do
|
|
let input = "x = \"line1\\nline2\\tindented\""
|
|
expect = Right [LIdentifier "x", LAssign, LStringLiteral "line1\nline2\tindented"]
|
|
runParser tricuLexer "" input @?= expect
|
|
|
|
, testCase "Lex empty string with escape sequence" $ do
|
|
let input = "\"\\\"\""
|
|
expect = Right [LStringLiteral "\""]
|
|
runParser tricuLexer "" input @?= expect
|
|
|
|
, testCase "Lex mixed literals" $ do
|
|
let input = "t \"string\" 42"
|
|
expect = Right [LKeywordT, LStringLiteral "string", LIntegerLiteral 42]
|
|
runParser tricuLexer "" input @?= expect
|
|
|
|
, testCase "Lex invalid token" $ do
|
|
let input = "&invalid"
|
|
case runParser tricuLexer "" input of
|
|
Left _ -> return ()
|
|
Right _ -> assertFailure "Expected lexer to fail on invalid token"
|
|
|
|
, testCase "Drop trailing whitespace in definitions" $ do
|
|
let input = "x = 5 "
|
|
expect = [LIdentifier "x",LAssign,LIntegerLiteral 5]
|
|
case (runParser tricuLexer "" input) of
|
|
Left _ -> assertFailure "Failed to lex input"
|
|
Right i -> i @?= expect
|
|
|
|
, testCase "Error when using invalid characters in identifiers" $ do
|
|
case (runParser tricuLexer "" "!result = 5") of
|
|
Left _ -> return ()
|
|
Right _ -> assertFailure "Expected failure when trying to assign the value of !result"
|
|
]
|
|
|
|
parser :: TestTree
|
|
parser = testGroup "Parser Tests"
|
|
[ testCase "Error when assigning a value to T" $ do
|
|
let tokens = lexTricu "t = x"
|
|
case parseSingleExpr tokens of
|
|
Left _ -> return ()
|
|
Right _ -> assertFailure "Expected failure when trying to assign the value of T"
|
|
|
|
, testCase "Parse function definitions" $ do
|
|
let input = "x = (a b c : a)"
|
|
expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a" Nothing))))
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse nested Tree Calculus terms" $ do
|
|
let input = "t (t t) t"
|
|
expect = SApp (SApp TLeaf (SApp TLeaf TLeaf)) TLeaf
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse sequential Tree Calculus terms" $ do
|
|
let input = "t t t"
|
|
expect = SApp (SApp TLeaf TLeaf) TLeaf
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse mixed list literals" $ do
|
|
let input = "[t (\"hello\") t]"
|
|
expect = SList [TLeaf, SStr "hello", TLeaf]
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse function with applications" $ do
|
|
let input = "f = (x : t x)"
|
|
expect = SDef "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x" Nothing)))
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse nested lists" $ do
|
|
let input = "[t [(t t)]]"
|
|
expect = SList [TLeaf,SList [SApp TLeaf TLeaf]]
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse complex parentheses" $ do
|
|
let input = "t (t t (t t))"
|
|
expect = SApp TLeaf (SApp (SApp TLeaf TLeaf) (SApp TLeaf TLeaf))
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse empty list" $ do
|
|
let input = "[]"
|
|
expect = SList []
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse multiple nested lists" $ do
|
|
let input = "[[t t] [t (t t)]]"
|
|
expect = SList [SList [TLeaf,TLeaf],SList [TLeaf,SApp TLeaf TLeaf]]
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse whitespace variance" $ do
|
|
let input1 = "[t t]"
|
|
let input2 = "[ t t ]"
|
|
expect = SList [TLeaf, TLeaf]
|
|
parseSingle input1 @?= expect
|
|
parseSingle input2 @?= expect
|
|
|
|
, testCase "Parse string in list" $ do
|
|
let input = "[(\"hello\")]"
|
|
expect = SList [SStr "hello"]
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse parentheses inside list" $ do
|
|
let input = "[t (t t)]"
|
|
expect = SList [TLeaf,SApp TLeaf TLeaf]
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse nested parentheses in function body" $ do
|
|
let input = "f = (x : t (t (t t)))"
|
|
expect = SDef "f" [] (SLambda ["x"] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))))
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse lambda abstractions" $ do
|
|
let input = "(a : a)"
|
|
expect = (SLambda ["a"] (SVar "a" Nothing))
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse multiple arguments to lambda abstractions" $ do
|
|
let input = "x = (a b : a)"
|
|
expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a" Nothing)))
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Grouping T terms with parentheses in function application" $ do
|
|
let input = "x = (a : a)\nx (t)"
|
|
expect = [SDef "x" [] (SLambda ["a"] (SVar "a" Nothing)),SApp (SVar "x" Nothing) TLeaf]
|
|
parseTricu input @?= expect
|
|
|
|
, testCase "Comments 1" $ do
|
|
let input = "(t) (t) -- (t)"
|
|
expect = [SApp TLeaf TLeaf]
|
|
parseTricu input @?= expect
|
|
|
|
, testCase "Comments 2" $ do
|
|
let input = "(t) -- (t) -- (t)"
|
|
expect = [TLeaf]
|
|
parseTricu input @?= expect
|
|
]
|
|
|
|
simpleEvaluation :: TestTree
|
|
simpleEvaluation = testGroup "Evaluation Tests"
|
|
[ testCase "Evaluate single Leaf" $ do
|
|
let input = "t"
|
|
let ast = parseSingle input
|
|
(result $ evalSingle Map.empty ast) @?= Leaf
|
|
|
|
, testCase "Evaluate single Stem" $ do
|
|
let input = "t t"
|
|
let ast = parseSingle input
|
|
(result $ evalSingle Map.empty ast) @?= Stem Leaf
|
|
|
|
, testCase "Evaluate single Fork" $ do
|
|
let input = "t t t"
|
|
let ast = parseSingle input
|
|
(result $ evalSingle Map.empty ast) @?= Fork Leaf Leaf
|
|
|
|
, testCase "Evaluate nested Fork and Stem" $ do
|
|
let input = "t (t t) t"
|
|
let ast = parseSingle input
|
|
(result $ evalSingle Map.empty ast) @?= Fork (Stem Leaf) Leaf
|
|
|
|
, testCase "Evaluate `not` function" $ do
|
|
let input = "t (t (t t) (t t t)) t"
|
|
let ast = parseSingle input
|
|
(result $ evalSingle Map.empty ast) @?=
|
|
Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
|
|
|
|
, testCase "Environment updates with definitions" $ do
|
|
let input = "x = t\ny = x"
|
|
env = evalTricu Map.empty (parseTricu input)
|
|
Map.lookup "x" env @?= Just Leaf
|
|
Map.lookup "y" env @?= Just Leaf
|
|
|
|
, testCase "Variable substitution" $ do
|
|
let input = "x = t t\ny = t x\ny"
|
|
env = evalTricu Map.empty (parseTricu input)
|
|
(result env) @?= Stem (Stem Leaf)
|
|
|
|
, testCase "Multiline input evaluation" $ do
|
|
let input = "x = t\ny = t t\nx"
|
|
env = evalTricu Map.empty (parseTricu input)
|
|
(result env) @?= Leaf
|
|
|
|
, testCase "Evaluate string literal" $ do
|
|
let input = "\"hello\""
|
|
let ast = parseSingle input
|
|
(result $ evalSingle Map.empty ast) @?= ofString "hello"
|
|
|
|
, testCase "Evaluate list literal" $ do
|
|
let input = "[t (t t)]"
|
|
let ast = parseSingle input
|
|
(result $ evalSingle Map.empty ast) @?= ofList [Leaf, Stem Leaf]
|
|
|
|
, testCase "Evaluate empty list" $ do
|
|
let input = "[]"
|
|
let ast = parseSingle input
|
|
(result $ evalSingle Map.empty ast) @?= ofList []
|
|
|
|
, testCase "Evaluate variable dependency chain" $ do
|
|
let input = "x = t (t t)\n \
|
|
\ y = x\n \
|
|
\ z = y\n \
|
|
\ variablewithamuchlongername = z\n \
|
|
\ variablewithamuchlongername"
|
|
env = evalTricu Map.empty (parseTricu input)
|
|
(result env) @?= (Stem (Stem Leaf))
|
|
|
|
|
|
, testCase "Immutable definitions" $ do
|
|
let input = "x = t t\nx = t\nx"
|
|
env = evalTricu Map.empty (parseTricu input)
|
|
result <- try (evaluate (tricuTestString input)) :: IO (Either SomeException String)
|
|
case result of
|
|
Left _ -> return ()
|
|
Right _ -> assertFailure "Expected evaluation error"
|
|
|
|
|
|
, testCase "Apply identity to Boolean Not" $ do
|
|
let not = "(t (t (t t) (t t t)) t)"
|
|
let input = "x = (a : a)\nx " ++ not
|
|
env = evalTricu Map.empty (parseTricu input)
|
|
result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
|
|
]
|
|
|
|
lambdas :: TestTree
|
|
lambdas = testGroup "Lambda Evaluation Tests"
|
|
[ testCase "Lambda Identity Function" $ do
|
|
let input = "id = (x : x)\nid t"
|
|
tricuTestString input @?= "Leaf"
|
|
|
|
, testCase "Lambda Constant Function (K combinator)" $ do
|
|
let input = "k = (x y : x)\nk t (t t)"
|
|
tricuTestString input @?= "Leaf"
|
|
|
|
, testCase "Lambda Application with Variable" $ do
|
|
let input = "id = (x : x)\nval = t t\nid val"
|
|
tricuTestString input @?= "Stem Leaf"
|
|
|
|
, testCase "Lambda Application with Multiple Arguments" $ do
|
|
let input = "apply = (f x y : f x y)\nk = (a b : a)\napply k t (t t)"
|
|
tricuTestString input @?= "Leaf"
|
|
|
|
, testCase "Nested Lambda Application" $ do
|
|
let input = "apply = (f x y : f x y)\nid = (x : x)\napply (f x : f x) id t"
|
|
tricuTestString input @?= "Leaf"
|
|
|
|
, testCase "Lambda with a complex body" $ do
|
|
let input = "f = (x : t (t x))\nf t"
|
|
tricuTestString input @?= "Stem (Stem Leaf)"
|
|
|
|
, testCase "Lambda returning a function" $ do
|
|
let input = "f = (x : (y : x))\ng = f t\ng (t t)"
|
|
tricuTestString input @?= "Leaf"
|
|
|
|
, testCase "Lambda with Shadowing" $ do
|
|
let input = "f = (x : (x : x))\nf t (t t)"
|
|
tricuTestString input @?= "Stem Leaf"
|
|
|
|
, testCase "Lambda returning another lambda" $ do
|
|
let input = "k = (x : (y : x))\nk_app = k t\nk_app (t t)"
|
|
tricuTestString input @?= "Leaf"
|
|
|
|
, testCase "Lambda with free variables" $ do
|
|
let input = "y = t t\nf = (x : y)\nf t"
|
|
tricuTestString input @?= "Stem Leaf"
|
|
|
|
, testCase "SKI Composition" $ do
|
|
let input = "s = (x y z : x z (y z))\nk = (x y : x)\ni = (x : x)\ncomp = s k i\ncomp t (t t)"
|
|
tricuTestString input @?= "Stem (Stem Leaf)"
|
|
|
|
, testCase "Lambda with multiple parameters and application" $ do
|
|
let input = "f = (a b c : t a b c)\nf t (t t) (t t t)"
|
|
tricuTestString input @?= "Stem Leaf"
|
|
|
|
, testCase "Lambda with nested application in the body" $ do
|
|
let input = "f = (x : t (t (t x)))\nf t"
|
|
tricuTestString input @?= "Stem (Stem (Stem Leaf))"
|
|
|
|
, testCase "Lambda returning a function and applying it" $ do
|
|
let input = "f = (x : (y : t x y))\ng = f t\ng (t t)"
|
|
tricuTestString input @?= "Fork Leaf (Stem Leaf)"
|
|
|
|
, testCase "Lambda applying a variable" $ do
|
|
let input = "id = (x : x)\na = t t\nid a"
|
|
tricuTestString input @?= "Stem Leaf"
|
|
|
|
, testCase "Nested lambda abstractions in the same expression" $ do
|
|
let input = "f = (x : (y : x y))\ng = (z : z)\nf g t"
|
|
tricuTestString input @?= "Leaf"
|
|
|
|
, testCase "Lambda applied to string literal" $ do
|
|
let input = "f = (x : x)\nf \"hello\""
|
|
tricuTestString input @?= "Fork (Fork Leaf (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) Leaf))))"
|
|
|
|
|
|
, testCase "Lambda applied to integer literal" $ do
|
|
let input = "f = (x : x)\nf 42"
|
|
tricuTestString input @?= "Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) Leaf)))))"
|
|
|
|
, testCase "Lambda applied to list literal" $ do
|
|
let input = "f = (x : x)\nf [t (t t)]"
|
|
tricuTestString input @?= "Fork Leaf (Fork (Stem Leaf) Leaf)"
|
|
|
|
, testCase "Lambda containing list literal" $ do
|
|
let input = "(a : [(a)]) 1"
|
|
tricuTestString input @?= "Fork (Fork (Stem Leaf) Leaf) Leaf"
|
|
]
|
|
|
|
providedLibraries :: TestTree
|
|
providedLibraries = testGroup "Library Tests"
|
|
[ testCase "Triage test Leaf" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "test t"
|
|
env = decodeResult $ result $ evalTricu library (parseTricu input)
|
|
env @?= "\"Leaf\""
|
|
|
|
, testCase "Triage test (Stem Leaf)" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "test (t t)"
|
|
env = decodeResult $ result $ evalTricu library (parseTricu input)
|
|
env @?= "\"Stem\""
|
|
|
|
, testCase "Triage test (Fork Leaf Leaf)" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "test (t t t)"
|
|
env = decodeResult $ result $ evalTricu library (parseTricu input)
|
|
env @?= "\"Fork\""
|
|
|
|
, testCase "Boolean NOT: true" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "not? true"
|
|
env = result $ evalTricu library (parseTricu input)
|
|
env @?= Leaf
|
|
|
|
, testCase "Boolean NOT: false" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "not? false"
|
|
env = result $ evalTricu library (parseTricu input)
|
|
env @?= Stem Leaf
|
|
|
|
|
|
, testCase "Boolean AND TF" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "and? (t t) (t)"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= Leaf
|
|
|
|
, testCase "Boolean AND FT" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "and? (t) (t t)"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= Leaf
|
|
|
|
, testCase "Boolean AND FF" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "and? (t) (t)"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= Leaf
|
|
|
|
, testCase "Boolean AND TT" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "and? (t t) (t t)"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= Stem Leaf
|
|
|
|
, testCase "List head" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "head [(t) (t t) (t t t)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= Leaf
|
|
|
|
, testCase "List tail" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "head (tail (tail [(t) (t t) (t t t)]))"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= Fork Leaf Leaf
|
|
|
|
, testCase "List map" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "head (tail (map (a : (t t t)) [(t) (t) (t)]))"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= Fork Leaf Leaf
|
|
|
|
, testCase "Empty list check" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "emptyList? []"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= Stem Leaf
|
|
|
|
, testCase "Non-empty list check" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "not? (emptyList? [(1) (2) (3)])"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= Stem Leaf
|
|
|
|
, testCase "Concatenate strings" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "append \"Hello, \" \"world!\""
|
|
env = decodeResult $ result $ evalTricu library (parseTricu input)
|
|
env @?= "\"Hello, world!\""
|
|
|
|
, testCase "Verifying Equality" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "equal? (t t t) (t t t)"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= Stem Leaf
|
|
]
|
|
|
|
fileEval :: TestTree
|
|
fileEval = testGroup "File evaluation tests"
|
|
[ testCase "Forks" $ do
|
|
res <- liftIO $ evaluateFileResult "./test/fork.tri"
|
|
res @?= Fork Leaf Leaf
|
|
|
|
, testCase "File ends with comment" $ do
|
|
res <- liftIO $ evaluateFileResult "./test/comments-1.tri"
|
|
res @?= Fork (Stem Leaf) Leaf
|
|
|
|
, testCase "Mapping and Equality" $ do
|
|
library <- liftIO $ evaluateFile "./lib/list.tri"
|
|
fEnv <- liftIO $ evaluateFileWithContext library "./test/map.tri"
|
|
(mainResult fEnv) @?= Stem Leaf
|
|
|
|
, testCase "Eval and decoding string" $ do
|
|
library <- liftIO $ evaluateFile "./lib/list.tri"
|
|
res <- liftIO $ evaluateFileWithContext library "./test/string.tri"
|
|
decodeResult (result res) @?= "\"String test!\""
|
|
]
|
|
|
|
modules :: TestTree
|
|
modules = testGroup "Test modules"
|
|
[ testCase "Detect cyclic dependencies" $ do
|
|
result <- try (liftIO $ evaluateFileResult "./test/cycle-1.tri") :: IO (Either SomeException T)
|
|
case result of
|
|
Left e -> do
|
|
let errorMsg = show e
|
|
if "Encountered cyclic import" `isInfixOf` errorMsg
|
|
then return ()
|
|
else assertFailure $ "Unexpected error: " ++ errorMsg
|
|
Right _ -> assertFailure "Expected cyclic dependencies"
|
|
, testCase "Module imports and namespacing" $ do
|
|
res <- liftIO $ evaluateFileResult "./test/namespace-A.tri"
|
|
res @?= Leaf
|
|
, testCase "Multiple imports" $ do
|
|
res <- liftIO $ evaluateFileResult "./test/vars-A.tri"
|
|
res @?= Leaf
|
|
, testCase "Error on unresolved variable" $ do
|
|
result <- try (liftIO $ evaluateFileResult "./test/unresolved-A.tri") :: IO (Either SomeException T)
|
|
case result of
|
|
Left e -> do
|
|
let errorMsg = show e
|
|
if "undefinedVar" `isInfixOf` errorMsg
|
|
then return ()
|
|
else assertFailure $ "Unexpected error: " ++ errorMsg
|
|
Right _ -> assertFailure "Expected unresolved variable error"
|
|
, testCase "Multi-level imports" $ do
|
|
res <- liftIO $ evaluateFileResult "./test/multi-level-A.tri"
|
|
res @?= Leaf
|
|
, testCase "Lambda expression namespaces" $ do
|
|
res <- liftIO $ evaluateFileResult "./test/lambda-A.tri"
|
|
res @?= Leaf
|
|
, testCase "Local namespace import chain" $ do
|
|
res <- liftIO $ evaluateFileResult "./test/local-ns/1.tri"
|
|
res @?= Fork (Stem Leaf) (Fork (Stem Leaf) Leaf)
|
|
]
|
|
|
|
|
|
-- All of our demo tests are also module tests
|
|
demos :: TestTree
|
|
demos = testGroup "Test provided demo functionality"
|
|
[ testCase "Structural equality demo" $ do
|
|
res <- liftIO $ evaluateFileResult "./demos/equality.tri"
|
|
decodeResult res @?= "t t"
|
|
, testCase "Convert values back to source code demo" $ do
|
|
res <- liftIO $ evaluateFileResult "./demos/toSource.tri"
|
|
decodeResult res @?= "\"(t (t (t t) (t t t)) (t t (t t t)))\""
|
|
, testCase "Determining the size of functions" $ do
|
|
res <- liftIO $ evaluateFileResult "./demos/size.tri"
|
|
decodeResult res @?= "321"
|
|
, testCase "Level Order Traversal demo" $ do
|
|
res <- liftIO $ evaluateFileResult "./demos/levelOrderTraversal.tri"
|
|
decodeResult res @?= "\"\n1 \n2 3 \n4 5 6 7 \n8 11 10 9 12 \""
|
|
]
|
|
|
|
decoding :: TestTree
|
|
decoding = testGroup "Decoding Tests"
|
|
[ testCase "Decode Leaf" $ do
|
|
decodeResult Leaf @?= "t"
|
|
|
|
, testCase "Decode list of non-ASCII numbers" $ do
|
|
let input = ofList [ofNumber 1, ofNumber 14, ofNumber 6]
|
|
decodeResult input @?= "[1, 14, 6]"
|
|
|
|
, testCase "Decode list of ASCII numbers as a string" $ do
|
|
let input = ofList [ofNumber 97, ofNumber 98, ofNumber 99]
|
|
decodeResult input @?= "\"abc\""
|
|
|
|
, testCase "Decode small number" $ do
|
|
decodeResult (ofNumber 42) @?= "42"
|
|
|
|
, testCase "Decode large number" $ do
|
|
decodeResult (ofNumber 9999) @?= "9999"
|
|
|
|
, testCase "Decode string in list" $ do
|
|
let input = ofList [ofString "hello", ofString "world"]
|
|
decodeResult input @?= "[\"hello\", \"world\"]"
|
|
|
|
, testCase "Decode mixed list with strings" $ do
|
|
let input = ofList [ofString "hello", ofNumber 42, ofString "world"]
|
|
decodeResult input @?= "[\"hello\", 42, \"world\"]"
|
|
|
|
, testCase "Decode nested lists with strings" $ do
|
|
let input = ofList [ofList [ofString "nested"], ofString "string"]
|
|
decodeResult input @?= "[[\"nested\"], \"string\"]"
|
|
]
|
|
|
|
elimLambdaSingle :: TestTree
|
|
elimLambdaSingle = testCase "elimLambda preserves eval, fires eta, and SDef binds" $ do
|
|
-- 1) eta reduction, purely structural and parsed from source
|
|
let [etaIn] = parseTricu "x : f x"
|
|
[fRef ] = parseTricu "f"
|
|
elimLambda etaIn @?= fRef
|
|
|
|
-- 2) SDef binds its own name and parameters
|
|
let [defFXY] = parseTricu "f x y : f x"
|
|
fv = freeVars defFXY
|
|
assertBool "f should be bound in SDef" ("f" `Set.notMember` fv)
|
|
assertBool "x should be bound in SDef" ("x" `Set.notMember` fv)
|
|
assertBool "y should be bound in SDef" ("y" `Set.notMember` fv)
|
|
|
|
-- 3) semantics preserved on a small program that exercises compose and triage
|
|
let src =
|
|
unlines
|
|
[ "false = t"
|
|
, "_ = t"
|
|
, "true = t t"
|
|
, "id = a : a"
|
|
, "const = a b : a"
|
|
, "compose = f g x : f (g x)"
|
|
, "triage = leaf stem fork : t (t leaf stem) fork"
|
|
, "test = triage \"Leaf\" (_ : \"Stem\") (_ _ : \"Fork\")"
|
|
, "main = compose id id test"
|
|
]
|
|
prog = parseTricu src
|
|
progElim = map elimLambda prog
|
|
evalBefore = result (evalTricu Map.empty prog)
|
|
evalAfter = result (evalTricu Map.empty progElim)
|
|
evalAfter @?= evalBefore
|
|
|
|
stressElimLambda :: TestTree
|
|
stressElimLambda = testCase "stress elimLambda on wide list under deep curried lambda" $ do
|
|
let numVars = 200
|
|
numBody = 800
|
|
vars = [ "x" ++ show i | i <- [1..numVars] ]
|
|
body = "(" ++ unwords (replicate numBody "t") ++ ")"
|
|
etaOne = "h : f h"
|
|
etaTwo = "k : id k"
|
|
defId = "id = a : a"
|
|
lambda = unwords vars ++ " : " ++ body
|
|
src = unlines
|
|
[ defId
|
|
, etaOne
|
|
, "compose = f g x : f (g x)"
|
|
, "f = t t"
|
|
, etaTwo
|
|
, lambda
|
|
, "main = compose id id (" ++ head vars ++ " : f " ++ head vars ++ ")"
|
|
]
|
|
prog = parseTricu src
|
|
|
|
let out = map elimLambda prog
|
|
let noLambda term = case term of
|
|
SLambda _ _ -> False
|
|
SApp f g -> noLambda f && noLambda g
|
|
SList xs -> all noLambda xs
|
|
TFork l r -> noLambda l && noLambda r
|
|
TStem u -> noLambda u
|
|
_ -> True
|
|
|
|
assertBool "all lambdas eliminated" (all noLambda out)
|
|
|
|
let before = result (evalTricu Map.empty prog)
|
|
after = result (evalTricu Map.empty out)
|
|
after @?= before
|
|
|
|
-- --------------------------------------------------------------------------
|
|
-- Wire module tests
|
|
-- --------------------------------------------------------------------------
|
|
|
|
-- | Helper: create a temporary file-backed DB, store a term, return the
|
|
-- connection and the term (so callers can compare after round-trip).
|
|
storeTermInTempDB :: String -> IO (Connection, Text, T)
|
|
storeTermInTempDB src = do
|
|
conn <- newContentStore
|
|
let asts = parseTricu src
|
|
finalEnv = evalTricu Map.empty asts
|
|
term = result finalEnv
|
|
-- storeMerkleNodes returns MerkleHash as Text; storeTerm expects [String]
|
|
_ <- storeTerm conn [] term
|
|
return (conn, hashTerm term, term)
|
|
|
|
-- | Load a term from a DB by its stored hash Text.
|
|
loadTermByHash :: Connection -> Text -> IO T
|
|
loadTermByHash conn h = do
|
|
maybeTerm <- loadTree conn h
|
|
case maybeTerm of
|
|
Just t -> return t
|
|
Nothing -> errorWithoutStackTrace $ "hash not found in store: " ++ Data.Text.unpack h
|
|
|
|
-- | Flip one byte in a ByteString at the given index.
|
|
corruptByte :: ByteString -> Int -> ByteString
|
|
corruptByte bs i = BS.take i bs <> BS.pack [(BS.index bs i `xor` 0x01)] <> BS.drop (i + 1) bs
|
|
|
|
wireTests :: TestTree
|
|
wireTests = testGroup "Wire Tests"
|
|
[ testCase "Portable bundle: header and manifest declare Tree Calculus object format" $ do
|
|
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
|
|
[ "id = a : a"
|
|
, "main = id t"
|
|
]
|
|
wireData <- exportBundle srcConn [termHash]
|
|
BS.take 8 wireData @?= BS.pack [0x41, 0x52, 0x42, 0x4f, 0x52, 0x49, 0x58, 0x00]
|
|
case decodeBundle wireData of
|
|
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
|
Right bundle -> do
|
|
let manifest = bundleManifest bundle
|
|
tree = manifestTree manifest
|
|
hashSpec = treeNodeHash tree
|
|
runtime = manifestRuntime manifest
|
|
manifestSchema manifest @?= "arborix.bundle.manifest.v1"
|
|
manifestBundleType manifest @?= "tree-calculus-executable-object"
|
|
manifestClosure manifest @?= ClosureComplete
|
|
treeCalculus tree @?= "tree-calculus.v1"
|
|
treeNodePayload tree @?= "arborix.merkle.payload.v1"
|
|
nodeHashAlgorithm hashSpec @?= "sha256"
|
|
nodeHashDomain hashSpec @?= "arborix.merkle.node.v1"
|
|
runtimeSemantics runtime @?= "tree-calculus.v1"
|
|
runtimeAbi runtime @?= "arborix.abi.tree.v1"
|
|
runtimeCapabilities runtime @?= []
|
|
bundleRoots bundle @?= [termHash]
|
|
map exportRoot (manifestExports manifest) @?= [termHash]
|
|
close srcConn
|
|
|
|
, testCase "Portable bundle: named exports are manifest aliases for Merkle roots" $ do
|
|
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
|
|
[ "validateEmail = a : a"
|
|
, "main = validateEmail t"
|
|
]
|
|
wireData <- exportNamedBundle srcConn [("validateEmail", termHash)]
|
|
case decodeBundle wireData of
|
|
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
|
Right bundle -> do
|
|
bundleRoots bundle @?= [termHash]
|
|
case manifestExports (bundleManifest bundle) of
|
|
[exported] -> do
|
|
exportName exported @?= "validateEmail"
|
|
exportRoot exported @?= termHash
|
|
exportKind exported @?= "term"
|
|
exportAbi exported @?= "arborix.abi.tree.v1"
|
|
exports -> assertFailure $ "Expected one export, got: " ++ show exports
|
|
close srcConn
|
|
|
|
, testCase "Portable bundle: renaming an export changes bundle bytes but not tree identity" $ do
|
|
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
|
|
[ "f = a : a"
|
|
, "main = f t"
|
|
]
|
|
mainBundleData <- exportNamedBundle srcConn [("main", termHash)]
|
|
renamedBundleData <- exportNamedBundle srcConn [("validate", termHash)]
|
|
assertBool "Renaming an export should change the manifest/bundle bytes"
|
|
(mainBundleData /= renamedBundleData)
|
|
case (decodeBundle mainBundleData, decodeBundle renamedBundleData) of
|
|
(Right mainBundle, Right renamedBundle) -> do
|
|
bundleRoots mainBundle @?= [termHash]
|
|
bundleRoots renamedBundle @?= [termHash]
|
|
map exportRoot (manifestExports $ bundleManifest mainBundle)
|
|
@?= map exportRoot (manifestExports $ bundleManifest renamedBundle)
|
|
map exportName (manifestExports $ bundleManifest mainBundle) @?= ["main"]
|
|
map exportName (manifestExports $ bundleManifest renamedBundle) @?= ["validate"]
|
|
(Left err, _) -> assertFailure $ "decodeBundle main failed: " ++ err
|
|
(_, Left err) -> assertFailure $ "decodeBundle renamed failed: " ++ err
|
|
close srcConn
|
|
|
|
, testCase "Portable bundle: exact byte export is deterministic" $ do
|
|
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
|
|
[ "x = t t"
|
|
, "main = t x"
|
|
]
|
|
first <- exportBundle srcConn [termHash]
|
|
second <- exportBundle srcConn [termHash]
|
|
first @?= second
|
|
close srcConn
|
|
|
|
, testCase "Portable bundle: raw section tampering is rejected by digest verification" $ do
|
|
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
|
|
[ "x = t"
|
|
, "main = t x"
|
|
]
|
|
wireData <- exportBundle srcConn [termHash]
|
|
let tampered = corruptByte wireData (BS.length wireData - 1)
|
|
case decodeBundle tampered of
|
|
Left err -> assertBool ("Expected section digest mismatch, got: " ++ err)
|
|
("digest mismatch" `isInfixOf` err)
|
|
Right _ -> assertFailure "Expected decodeBundle to reject tampered section bytes"
|
|
close srcConn
|
|
|
|
, testCase "Portable bundle: unsupported manifest semantics are rejected" $ do
|
|
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
|
|
[ "x = t"
|
|
, "main = t x"
|
|
]
|
|
wireData <- exportBundle srcConn [termHash]
|
|
case decodeBundle wireData of
|
|
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
|
Right bundle -> do
|
|
let manifest = bundleManifest bundle
|
|
partialBundle = bundle
|
|
{ bundleManifest = manifest { manifestClosure = ClosurePartial }
|
|
, bundleManifestBytes = BS.empty
|
|
}
|
|
capabilityBundle = bundle
|
|
{ bundleManifest = manifest
|
|
{ manifestRuntime = (manifestRuntime manifest)
|
|
{ runtimeCapabilities = ["host.io"]
|
|
}
|
|
}
|
|
, bundleManifestBytes = BS.empty
|
|
}
|
|
wrongHashBundle = bundle
|
|
{ bundleManifest = manifest
|
|
{ manifestTree = (manifestTree manifest)
|
|
{ treeNodeHash = (treeNodeHash $ manifestTree manifest)
|
|
{ nodeHashAlgorithm = "blake3" }
|
|
}
|
|
}
|
|
, bundleManifestBytes = BS.empty
|
|
}
|
|
case verifyBundle partialBundle of
|
|
Left err -> assertBool ("Expected closure error, got: " ++ err) ("closure = complete" `isInfixOf` err)
|
|
Right () -> assertFailure "Expected partial closure to be rejected"
|
|
case verifyBundle capabilityBundle of
|
|
Left err -> assertBool ("Expected capability error, got: " ++ err) ("capabilities" `isInfixOf` err)
|
|
Right () -> assertFailure "Expected runtime capabilities to be rejected"
|
|
case verifyBundle wrongHashBundle of
|
|
Left err -> assertBool ("Expected hash algorithm error, got: " ++ err) ("node hash algorithm" `isInfixOf` err)
|
|
Right () -> assertFailure "Expected unsupported node hash algorithm to be rejected"
|
|
close srcConn
|
|
|
|
, testCase "Portable bundle: import registers manifest export names in fresh content store" $ do
|
|
(srcConn, termHash, originalTerm) <- storeTermInTempDB $ unlines
|
|
[ "validateEmail = a : a"
|
|
, "main = validateEmail t"
|
|
]
|
|
wireData <- exportNamedBundle srcConn [("validateEmail", termHash)]
|
|
dstConn <- newContentStore
|
|
_ <- importBundle dstConn wireData
|
|
loadedByHash <- loadTermByHash dstConn termHash
|
|
loadedByName <- loadTerm dstConn "validateEmail"
|
|
loadedByHash @?= originalTerm
|
|
loadedByName @?= Just originalTerm
|
|
close srcConn
|
|
close dstConn
|
|
|
|
, testCase "Round-trip: store, export, import, load" $ do
|
|
-- Store a term
|
|
(srcConn, termHash, originalTerm) <- storeTermInTempDB $ unlines
|
|
[ "x = t"
|
|
, "y = t x"
|
|
, "z = t y"
|
|
, "main = z"
|
|
]
|
|
-- Export by root hash
|
|
wireData <- exportBundle srcConn [termHash]
|
|
-- Import into a fresh DB
|
|
dstConn <- newContentStore
|
|
_ <- importBundle dstConn wireData
|
|
-- Load the term back and compare
|
|
loadedTerm <- loadTermByHash dstConn termHash
|
|
loadedTerm @?= originalTerm
|
|
-- Cleanup
|
|
close srcConn
|
|
close dstConn
|
|
|
|
, testCase "Round-trip: evaluate from original, export, import, load root" $ do
|
|
(srcConn, termHash, originalTerm) <- storeTermInTempDB $ unlines
|
|
[ "add = a b : t (t a) b"
|
|
, "val = add (t t) (t)"
|
|
, "main = val"
|
|
]
|
|
-- Export
|
|
wireData <- exportBundle srcConn [termHash]
|
|
-- Import into fresh DB
|
|
dstConn <- newContentStore
|
|
_ <- importBundle dstConn wireData
|
|
-- Load the root term by hash and compare
|
|
loadedTerm <- loadTermByHash dstConn termHash
|
|
loadedTerm @?= originalTerm
|
|
close srcConn
|
|
close dstConn
|
|
|
|
, testCase "Negative: corrupt payload byte causes import to fail" $ do
|
|
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
|
|
[ "x = t"
|
|
, "y = t x"
|
|
, "z = t y"
|
|
, "main = z"
|
|
]
|
|
wireData <- exportBundle srcConn [termHash]
|
|
-- Decode, mutate one node's payload byte, re-encode
|
|
case decodeBundle wireData of
|
|
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
|
Right bundle -> do
|
|
let (h, payload) =
|
|
head
|
|
[ (h', p)
|
|
| (h', p) <- Map.toList (bundleNodes bundle)
|
|
, BS.length p > 0
|
|
]
|
|
payload' = BS.pack [(BS.head payload `xor` 0x01)] <> BS.tail payload
|
|
bundle' = bundle { bundleNodes = Map.insert h payload' (bundleNodes bundle) }
|
|
wireData' = encodeBundle bundle'
|
|
dstConn <- newContentStore
|
|
result <- try (importBundle dstConn wireData') :: IO (Either SomeException [MerkleHash])
|
|
case result of
|
|
Left e ->
|
|
assertBool ("Expected hash mismatch or invalid payload, got: " ++ show e)
|
|
$ "mismatch" `isInfixOf` show e || "invalid" `isInfixOf` show e
|
|
Right _ ->
|
|
assertFailure "Expected import to fail on corrupted payload"
|
|
close dstConn
|
|
close srcConn
|
|
|
|
, testCase "Negative: missing child node causes import to fail" $ do
|
|
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
|
|
[ "x = t"
|
|
, "y = t x"
|
|
, "z = t y"
|
|
, "main = z"
|
|
]
|
|
wireData <- exportBundle srcConn [termHash]
|
|
-- Decode, remove a node, re-encode
|
|
case decodeBundle wireData of
|
|
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
|
Right bundle -> do
|
|
let nodeList = Map.toList (bundleNodes bundle)
|
|
trimmed = Map.fromList (tail nodeList)
|
|
newBundle = bundle { bundleNodes = trimmed }
|
|
newWire = encodeBundle newBundle
|
|
dstConn <- newContentStore
|
|
result <- try (importBundle dstConn newWire) :: IO (Either SomeException [MerkleHash])
|
|
case result of
|
|
Left e ->
|
|
assertBool ("Expected verify error, got: " ++ show e) True
|
|
Right _ ->
|
|
assertFailure "Expected import to fail on missing child node"
|
|
close dstConn
|
|
close srcConn
|
|
]
|