2799 lines
126 KiB
Haskell
2799 lines
126 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.Char (digitToInt)
|
|
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
|
|
, byteMarshallingTests
|
|
, wireTests
|
|
, byteListUtilities
|
|
, binaryReaderTests
|
|
, manifestReadingTests
|
|
]
|
|
|
|
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
|
|
|
|
-- --------------------------------------------------------------------------
|
|
-- Byte marshalling tests
|
|
-- --------------------------------------------------------------------------
|
|
|
|
byteMarshallingTests :: TestTree
|
|
byteMarshallingTests = testGroup "Byte Marshalling Tests"
|
|
[ testCase "ofByte / toByte round-trip: 0" $ do
|
|
let w8 = (0 :: Word8)
|
|
toByte (ofByte w8) @?= Right w8
|
|
|
|
, testCase "ofByte / toByte round-trip: 1" $ do
|
|
let w8 = (1 :: Word8)
|
|
toByte (ofByte w8) @?= Right w8
|
|
|
|
, testCase "ofByte / toByte round-trip: 127" $ do
|
|
let w8 = (127 :: Word8)
|
|
toByte (ofByte w8) @?= Right w8
|
|
|
|
, testCase "ofByte / toByte round-trip: 128" $ do
|
|
let w8 = (128 :: Word8)
|
|
toByte (ofByte w8) @?= Right w8
|
|
|
|
, testCase "ofByte / toByte round-trip: 255" $ do
|
|
let w8 = (255 :: Word8)
|
|
toByte (ofByte w8) @?= Right w8
|
|
|
|
, testCase "toByte rejects value > 255" $ do
|
|
-- ofNumber 256 = Fork Leaf (Fork Leaf Leaf) — value 256
|
|
toByte (ofNumber 256) @?= Left "Byte value out of range: 256"
|
|
|
|
, testCase "toByte accepts Leaf" $ do
|
|
toByte (Leaf) @?= Right 0
|
|
|
|
, testCase "toByte rejects non-number tree" $ do
|
|
toByte (Stem Leaf) @?= Left "Invalid Tree Calculus number"
|
|
toByte (Stem (Stem Leaf)) @?= Left "Invalid Tree Calculus number"
|
|
|
|
, testCase "ofBytes / toBytes round-trip: empty ByteString" $ do
|
|
toBytes (ofBytes BS.empty) @?= Right BS.empty
|
|
|
|
, testCase "ofBytes / toBytes round-trip: [0x00]" $ do
|
|
toBytes (ofBytes (BS.pack [0x00])) @?= Right (BS.pack [0x00])
|
|
|
|
, testCase "ofBytes / toBytes round-trip: [0xff]" $ do
|
|
toBytes (ofBytes (BS.pack [0xff])) @?= Right (BS.pack [0xff])
|
|
|
|
, testCase "ofBytes / toBytes round-trip: mixed bytes" $ do
|
|
let bytes = BS.pack [0x00, 0x01, 0x7f, 0x80, 0xff, 0x41, 0x42, 0x43]
|
|
toBytes (ofBytes bytes) @?= Right bytes
|
|
|
|
, testCase "toBytes rejects non-list tree" $ do
|
|
-- Leaf is a valid list (empty), so this won't work.
|
|
-- Stem Leaf is not a list.
|
|
toBytes (Stem Leaf) @?= Left "Invalid Tree Calculus list"
|
|
|
|
, testCase "toBytes rejects list containing invalid byte (>255)" $ do
|
|
-- [ofNumber 256, ofNumber 1] — first element is > 255
|
|
let badList = ofList [ofNumber 256, ofNumber 1]
|
|
toBytes badList @?= Left "Byte value out of range: 256"
|
|
|
|
, testCase "nodePayloadToTreeBytes / treeBytesToNodePayload: Leaf payload" $ do
|
|
-- Leaf payload is 0x00 (1 byte)
|
|
let payload = BS.pack [0x00]
|
|
treeBytesToNodePayload (nodePayloadToTreeBytes payload) @?= Right payload
|
|
|
|
, testCase "nodePayloadToTreeBytes / treeBytesToNodePayload: Stem payload" $ do
|
|
-- Stem payload: 0x01 || 32-byte hash = 33 bytes
|
|
let payload = BS.pack (0x01 : replicate 32 0x42)
|
|
treeBytesToNodePayload (nodePayloadToTreeBytes payload) @?= Right payload
|
|
|
|
, testCase "nodePayloadToTreeBytes / treeBytesToNodePayload: Fork payload" $ do
|
|
-- Fork payload: 0x02 || 32-byte hash || 32-byte hash = 65 bytes
|
|
let payload = BS.pack (0x02 : replicate 64 0x42)
|
|
treeBytesToNodePayload (nodePayloadToTreeBytes payload) @?= Right payload
|
|
|
|
, testCase "hashToTreeBytes / treeBytesToHash round-trip" $ do
|
|
-- Use a known 32-byte hash (SHA256 of "")
|
|
let hashStr :: MerkleHash
|
|
hashStr = "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"
|
|
case hashToTreeBytes hashStr of
|
|
Left err -> assertFailure $ "hashToTreeBytes failed: " ++ err
|
|
Right tree -> treeBytesToHash tree @?= Right hashStr
|
|
|
|
, testCase "hashToTreeBytes rejects invalid hex hash" $ do
|
|
hashToTreeBytes "not-a-hash" @?= Left "Invalid hex MerkleHash"
|
|
|
|
, testCase "hashToTreeBytes rejects non-32-byte hash" $ do
|
|
-- "00" decodes to 1 byte, not 32
|
|
hashToTreeBytes "00" @?= Left "Hash raw bytes must be 32 bytes"
|
|
|
|
, testCase "treeBytesToHash rejects wrong byte count" $ do
|
|
-- Only 16 bytes, not 32
|
|
let t16 = ofBytes (BS.pack [0x41 | _ <- [1..16]])
|
|
treeBytesToHash t16 @?= Left "Expected exactly 32 byte elements for hash"
|
|
]
|
|
|
|
-- --------------------------------------------------------------------------
|
|
-- 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, 0x43, 0x58]
|
|
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 @?= "arboricx.bundle.manifest.v1"
|
|
manifestBundleType manifest @?= "tree-calculus-executable-object"
|
|
manifestClosure manifest @?= ClosureComplete
|
|
treeCalculus tree @?= "tree-calculus.v1"
|
|
treeNodePayload tree @?= "arboricx.merkle.payload.v1"
|
|
nodeHashAlgorithm hashSpec @?= "sha256"
|
|
nodeHashDomain hashSpec @?= "arboricx.merkle.node.v1"
|
|
runtimeSemantics runtime @?= "tree-calculus.v1"
|
|
runtimeAbi runtime @?= "arboricx.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 @?= "arboricx.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
|
|
]
|
|
|
|
-- --------------------------------------------------------------------------
|
|
-- Byte-list utility tests
|
|
-- Expected values built with canonical Haskell-side T constructors.
|
|
-- --------------------------------------------------------------------------
|
|
|
|
-- | Helpers for byte-list test expectations.
|
|
|
|
trueT :: T
|
|
trueT = Stem Leaf
|
|
|
|
falseT :: T
|
|
falseT = Leaf
|
|
|
|
nothingT :: T
|
|
nothingT = Leaf
|
|
|
|
justT :: T -> T
|
|
justT = Stem
|
|
|
|
pairT :: T -> T -> T
|
|
pairT = Fork
|
|
|
|
byteT :: Integer -> T
|
|
byteT = ofNumber
|
|
|
|
bytesT :: [Integer] -> T
|
|
bytesT = ofList . fmap byteT
|
|
|
|
bytesExpr :: [Integer] -> String
|
|
bytesExpr xs = "[" ++ unwords (map (\n -> "(" ++ show n ++ ")") xs) ++ "]"
|
|
|
|
u16 :: Integer -> [Integer]
|
|
u16 n = [0,n]
|
|
|
|
u32 :: Integer -> [Integer]
|
|
u32 n = [0,0,0,n]
|
|
|
|
u64 :: Integer -> [Integer]
|
|
u64 n = [0,0,0,0,0,0,0,n]
|
|
|
|
arboricxHeaderBytes :: Integer -> [Integer]
|
|
arboricxHeaderBytes sectionCount =
|
|
[65,82,66,79,82,73,67,88]
|
|
++ u16 1
|
|
++ u16 0
|
|
++ u32 sectionCount
|
|
++ u64 0
|
|
++ u64 32
|
|
|
|
sectionEntryBytes :: [Integer] -> Integer -> Integer -> [Integer]
|
|
sectionEntryBytes sectionType offset lengthBytes =
|
|
sectionType
|
|
++ u16 1
|
|
++ u16 1
|
|
++ u16 0
|
|
++ u16 1
|
|
++ u64 offset
|
|
++ u64 lengthBytes
|
|
++ replicate 32 0
|
|
|
|
manifestSectionIdBytes :: [Integer]
|
|
manifestSectionIdBytes = [0,0,0,1]
|
|
|
|
nodesSectionIdBytes :: [Integer]
|
|
nodesSectionIdBytes = [0,0,0,2]
|
|
|
|
hexTextBytes :: Text -> [Integer]
|
|
hexTextBytes h = go (unpack h)
|
|
where
|
|
go [] = []
|
|
go (a:b:rest) = toInteger (digitToInt a * 16 + digitToInt b) : go rest
|
|
go _ = error "odd-length hex text"
|
|
|
|
manifestEntryBytes :: Integer -> Integer -> [Integer]
|
|
manifestEntryBytes = sectionEntryBytes manifestSectionIdBytes
|
|
|
|
nodesEntryBytes :: Integer -> Integer -> [Integer]
|
|
nodesEntryBytes = sectionEntryBytes nodesSectionIdBytes
|
|
|
|
simpleContainerBytes :: [Integer] -> [Integer] -> [Integer]
|
|
simpleContainerBytes manifestBytes nodesBytes =
|
|
let manifestOffset = 152
|
|
nodesOffset = manifestOffset + fromIntegral (length manifestBytes)
|
|
in arboricxHeaderBytes 2
|
|
++ manifestEntryBytes manifestOffset (fromIntegral $ length manifestBytes)
|
|
++ nodesEntryBytes nodesOffset (fromIntegral $ length nodesBytes)
|
|
++ manifestBytes
|
|
++ nodesBytes
|
|
|
|
singleSectionContainerBytes :: [Integer] -> [Integer] -> [Integer]
|
|
singleSectionContainerBytes sectionType sectionBytes =
|
|
arboricxHeaderBytes 1
|
|
++ sectionEntryBytes sectionType 92 (fromIntegral $ length sectionBytes)
|
|
++ sectionBytes
|
|
|
|
arboricxHeaderT :: Integer -> T
|
|
arboricxHeaderT sectionCount =
|
|
pairT (bytesT [0,1])
|
|
(pairT (bytesT [0,0])
|
|
(pairT (bytesT $ u32 sectionCount)
|
|
(pairT (bytesT $ u64 0)
|
|
(bytesT $ u64 32))))
|
|
|
|
sectionRecordT :: [Integer] -> Integer -> Integer -> T
|
|
sectionRecordT sectionType offset lengthBytes =
|
|
pairT (bytesT sectionType)
|
|
(pairT (bytesT [0,1])
|
|
(pairT (bytesT [0,1])
|
|
(pairT (bytesT [0,0])
|
|
(pairT (bytesT [0,1])
|
|
(pairT (bytesT $ u64 offset)
|
|
(pairT (bytesT $ u64 lengthBytes)
|
|
(bytesT $ replicate 32 0)))))))
|
|
|
|
sectionRecordExpr :: [Integer] -> Integer -> Integer -> String
|
|
sectionRecordExpr sectionType offset lengthBytes =
|
|
"(pair " ++ bytesExpr sectionType
|
|
++ " (pair " ++ bytesExpr [0,1]
|
|
++ " (pair " ++ bytesExpr [0,1]
|
|
++ " (pair " ++ bytesExpr [0,0]
|
|
++ " (pair " ++ bytesExpr [0,1]
|
|
++ " (pair " ++ bytesExpr (u64 offset)
|
|
++ " (pair " ++ bytesExpr (u64 lengthBytes)
|
|
++ " " ++ bytesExpr (replicate 32 0)
|
|
++ ")))))))"
|
|
|
|
byteListUtilities :: TestTree
|
|
byteListUtilities = testGroup "Byte List Utility Tests"
|
|
[ testCase "isNil: empty list is nil" $ do
|
|
let input = "bytesNil? []"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "isNil: non-empty list is not nil" $ do
|
|
let input = "bytesNil? [(1)]"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= falseT
|
|
|
|
, testCase "head: empty list is nothing" $ do
|
|
let input = "bytesHead []"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= nothingT
|
|
|
|
, testCase "head: non-empty list returns first element" $ do
|
|
let input = "bytesHead [(1) (2)]"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= justT (byteT 1)
|
|
|
|
, testCase "tail: empty list is nothing" $ do
|
|
let input = "bytesTail []"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= nothingT
|
|
|
|
, testCase "tail: non-empty list returns rest" $ do
|
|
let input = "bytesTail [(1) (2)]"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= justT (bytesT [2])
|
|
|
|
, testCase "length: empty list is zero" $ do
|
|
let input = "bytesLength []"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= ofNumber 0
|
|
|
|
, testCase "length: single element list is one" $ do
|
|
let input = "bytesLength [(1)]"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= ofNumber 1
|
|
|
|
, testCase "length: three element list is three" $ do
|
|
let input = "bytesLength [(1) (2) (3)]"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= ofNumber 3
|
|
|
|
, testCase "append: empty ++ [1,2] = [1,2]" $ do
|
|
let input = "bytesAppend [] [(1) (2)]"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= bytesT [1,2]
|
|
|
|
, testCase "append: [1,2] ++ [3] = [1,2,3]" $ do
|
|
let input = "bytesAppend [(1) (2)] [(3)]"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= bytesT [1,2,3]
|
|
|
|
, testCase "append: [1,2] ++ empty = [1,2]" $ do
|
|
let input = "bytesAppend [(1) (2)] []"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= bytesT [1,2]
|
|
|
|
, testCase "take: take 0 any list = empty" $ do
|
|
let input = "bytesTake 0 [(1) (2) (3)]"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= bytesT []
|
|
|
|
, testCase "take: take 2 [1,2,3] = [1,2]" $ do
|
|
let input = "bytesTake 2 [(1) (2) (3)]"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= bytesT [1,2]
|
|
|
|
, testCase "take: take 5 [1,2] = [1,2] (overlong)" $ do
|
|
let input = "bytesTake 5 [(1) (2)]"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= bytesT [1,2]
|
|
|
|
, testCase "drop: drop 0 any list = list" $ do
|
|
let input = "bytesDrop 0 [(1) (2) (3)]"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= bytesT [1,2,3]
|
|
|
|
, testCase "drop: drop 2 [1,2,3] = [3]" $ do
|
|
let input = "bytesDrop 2 [(1) (2) (3)]"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= bytesT [3]
|
|
|
|
, testCase "drop: drop 5 [1,2] = empty (overlong)" $ do
|
|
let input = "bytesDrop 5 [(1) (2)]"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= bytesT []
|
|
|
|
, testCase "splitAt: splitAt 0 [1,2] = pair [] [1,2]" $ do
|
|
let input = "bytesSplitAt 0 [(1) (2)]"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= pairT (bytesT []) (bytesT [1,2])
|
|
|
|
, testCase "splitAt: splitAt 2 [1,2,3] = pair [1,2] [3]" $ do
|
|
let input = "bytesSplitAt 2 [(1) (2) (3)]"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= pairT (bytesT [1,2]) (bytesT [3])
|
|
|
|
, testCase "splitAt: splitAt 5 [1,2] = pair [1,2] []" $ do
|
|
let input = "bytesSplitAt 5 [(1) (2)]"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= pairT (bytesT [1,2]) (bytesT [])
|
|
|
|
, testCase "byteEq: equal bytes are equal" $ do
|
|
let input = "byteEq? 1 1"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "byteEq: unequal bytes are not equal" $ do
|
|
let input = "byteEq? 1 2"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= falseT
|
|
|
|
, testCase "bytesEq: empty == empty" $ do
|
|
let input = "bytesEq? [] []"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "bytesEq: empty != [1]" $ do
|
|
let input = "bytesEq? [] [(1)]"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= falseT
|
|
|
|
, testCase "bytesEq: [1] != empty" $ do
|
|
let input = "bytesEq? [(1)] []"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= falseT
|
|
|
|
, testCase "bytesEq: equal lists are equal" $ do
|
|
let input = "bytesEq? [(1) (2) (3)] [(1) (2) (3)]"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "bytesEq: different last element" $ do
|
|
let input = "bytesEq? [(1) (2) (3)] [(1) (2) (4)]"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= falseT
|
|
|
|
, testCase "bytesEq: different lengths" $ do
|
|
let input = "bytesEq? [(1) (2)] [(1) (2) (3)]"
|
|
library <- evaluateFile "./lib/bytes.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= falseT
|
|
]
|
|
|
|
-- --------------------------------------------------------------------------
|
|
-- Binary reader tests (binary.tri)
|
|
-- --------------------------------------------------------------------------
|
|
okT :: T -> T -> T
|
|
okT value rest = pairT trueT (pairT value rest)
|
|
|
|
errT :: T -> T -> T
|
|
errT code rest = pairT falseT (pairT code rest)
|
|
|
|
eofT :: T
|
|
eofT = byteT 1
|
|
|
|
unitT :: T
|
|
unitT = Leaf
|
|
|
|
unexpectedBytesT :: T
|
|
unexpectedBytesT = byteT 2
|
|
|
|
unexpectedByteT :: T
|
|
unexpectedByteT = byteT 3
|
|
|
|
missingSectionT :: T
|
|
missingSectionT = byteT 4
|
|
|
|
unsupportedVersionT :: T
|
|
unsupportedVersionT = byteT 5
|
|
|
|
duplicateSectionT :: T
|
|
duplicateSectionT = byteT 6
|
|
|
|
duplicateNodeT :: T
|
|
duplicateNodeT = byteT 7
|
|
|
|
invalidNodePayloadT :: T
|
|
invalidNodePayloadT = byteT 8
|
|
|
|
missingNodeT :: T
|
|
missingNodeT = byteT 9
|
|
|
|
binaryReaderTests :: TestTree
|
|
binaryReaderTests = testGroup "Binary Reader Tests"
|
|
[ testCase "readU8: empty input returns err" $ do
|
|
let input = "readU8 []"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [])
|
|
|
|
, testCase "readU8: single byte returns ok" $ do
|
|
let input = "readU8 [(7)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (byteT 7) (bytesT [])
|
|
|
|
, testCase "readU8: multi-byte returns first byte and rest" $ do
|
|
let input = "readU8 [(7) (8)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (byteT 7) (bytesT [8])
|
|
|
|
, testCase "readBytes 0: returns ok with empty bytes and original input" $ do
|
|
let input = "readBytes 0 [(1) (2)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (bytesT []) (bytesT [1,2])
|
|
|
|
, testCase "readBytes 2: exact read returns ok with taken and rest" $ do
|
|
let input = "readBytes 2 [(1) (2) (3)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (bytesT [1,2]) (bytesT [3])
|
|
|
|
, testCase "readBytes 3: exact read with no remainder" $ do
|
|
let input = "readBytes 3 [(1) (2) (3)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (bytesT [1,2,3]) (bytesT [])
|
|
|
|
, testCase "readBytes 5: overlong read returns err preserving input" $ do
|
|
let input = "readBytes 5 [(1) (2)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [1,2])
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Binary Result Matcher Tests
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "matchResult: ok branch returns value" $ do
|
|
let input = "matchResult (code rest : 0) (value rest : value) (ok 7 [])"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= byteT 7
|
|
|
|
, testCase "matchResult: err branch returns code" $ do
|
|
let input = "matchResult (code rest : code) (value rest : 0) (err 1 [])"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= byteT 1
|
|
|
|
, testCase "matchResult: ok branch receives rest" $ do
|
|
let input = "matchResult (code rest : []) (value rest : rest) (ok 7 [(8)])"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= bytesT [8]
|
|
|
|
, testCase "matchResult: err branch receives rest" $ do
|
|
let input = "matchResult (code rest : rest) (value rest : []) (err 1 [(7) (8)])"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= bytesT [7,8]
|
|
|
|
, testCase "matchResult: transforms readU8 ok result" $ do
|
|
let input = "matchResult (code rest : code) (value rest : value) (readU8 [(7) (8)])"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= byteT 7
|
|
|
|
, testCase "matchResult: transforms readU8 err result" $ do
|
|
let input = "matchResult (code rest : code) (value rest : value) (readU8 [])"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= byteT 1
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Binary expectBytes Tests
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "expectBytes: empty expected matches and preserves input" $ do
|
|
let input = "expectBytes [] [(1) (2)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT unitT (bytesT [1,2])
|
|
|
|
, testCase "expectBytes: single byte consumed, rest preserved" $ do
|
|
let input = "expectBytes [(1)] [(1) (2)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT unitT (bytesT [2])
|
|
|
|
, testCase "expectBytes: exact match with trailing data" $ do
|
|
let input = "expectBytes [(1) (2)] [(1) (2) (3)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT unitT (bytesT [3])
|
|
|
|
, testCase "expectBytes: mismatch returns err with original input" $ do
|
|
let input = "expectBytes [(1) (2)] [(1) (3)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT unexpectedBytesT (bytesT [1,3])
|
|
|
|
, testCase "expectBytes: overlong expected returns errEof with original input" $ do
|
|
let input = "expectBytes [(1) (2) (3)] [(1) (2)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [1,2])
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Binary expectU8 Tests
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "expectU8: matches and preserves rest" $ do
|
|
let input = "expectU8 7 [(7) (8)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT unitT (bytesT [8])
|
|
|
|
, testCase "expectU8: mismatch returns err with original input" $ do
|
|
let input = "expectU8 7 [(8)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT unexpectedByteT (bytesT [8])
|
|
|
|
, testCase "expectU8: empty input returns errEof with original input" $ do
|
|
let input = "expectU8 7 []"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [])
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Binary fixed-size readers (read2 / read4)
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "read2: reads two bytes and preserves rest" $ do
|
|
let input = "read2 [(1) (2) (3)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (bytesT [1,2]) (bytesT [3])
|
|
|
|
, testCase "read2: exact two-byte read" $ do
|
|
let input = "read2 [(1) (2)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (bytesT [1,2]) (bytesT [])
|
|
|
|
, testCase "read2: one byte returns EOF preserving input" $ do
|
|
let input = "read2 [(1)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [1])
|
|
|
|
, testCase "read2: empty input returns EOF" $ do
|
|
let input = "read2 []"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [])
|
|
|
|
, testCase "read4: reads four bytes and preserves rest" $ do
|
|
let input = "read4 [(1) (2) (3) (4) (5)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (bytesT [1,2,3,4]) (bytesT [5])
|
|
|
|
, testCase "read4: exact four-byte read" $ do
|
|
let input = "read4 [(1) (2) (3) (4)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (bytesT [1,2,3,4]) (bytesT [])
|
|
|
|
, testCase "read4: short input returns EOF preserving input" $ do
|
|
let input = "read4 [(1) (2) (3)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [1,2,3])
|
|
|
|
, testCase "read4: empty input returns EOF" $ do
|
|
let input = "read4 []"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [])
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Binary Result sequencing combinators (mapResult / bindResult)
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "mapResult: maps ok value and preserves rest" $ do
|
|
let input = "mapResult (x : bytesLength x) (ok [(1) (2)] [(3)])"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (ofNumber 2) (bytesT [3])
|
|
|
|
, testCase "mapResult: preserves err unchanged" $ do
|
|
let input = "mapResult (x : bytesLength x) (err 1 [(7)])"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [7])
|
|
|
|
, testCase "bindResult: ok invokes continuation" $ do
|
|
let input = "bindResult (ok 7 [(8)]) (value rest : ok rest [])"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (bytesT [8]) (bytesT [])
|
|
|
|
, testCase "bindResult: err skips continuation" $ do
|
|
let input = "bindResult (err 1 [(8)]) (value rest : ok value [])"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [8])
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Binary fixed-size byte readers with BE byte-swap naming
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "readU16BEBytes: reads two raw bytes" $ do
|
|
let input = "readU16BEBytes [(1) (2) (3)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (bytesT [1,2]) (bytesT [3])
|
|
|
|
, testCase "readU16BEBytes: short input EOF" $ do
|
|
let input = "readU16BEBytes [(1)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [1])
|
|
|
|
, testCase "readU32BEBytes: reads four raw bytes" $ do
|
|
let input = "readU32BEBytes [(1) (2) (3) (4) (5)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (bytesT [1,2,3,4]) (bytesT [5])
|
|
|
|
, testCase "readU32BEBytes: short input EOF" $ do
|
|
let input = "readU32BEBytes [(1) (2) (3)]"
|
|
library <- evaluateFile "./lib/binary.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [1,2,3])
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Arboricx magic recognition
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "readArboricxMagic: accepts magic and preserves rest" $ do
|
|
let input = "readArboricxMagic ((append arboricxMagic) [(1) (2)])"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT unitT (bytesT [1,2])
|
|
|
|
, testCase "readArboricxMagic: rejects wrong magic preserving input" $ do
|
|
let input = "readArboricxMagic [(65) (83) (66) (79) (82) (73) (67) (88) (1) (9)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT unexpectedBytesT (bytesT [65,83,66,79,82,73,67,88,1,9])
|
|
|
|
, testCase "readArboricxMagic: short input returns EOF preserving input" $ do
|
|
let input = "readArboricxMagic [(65) (82) (66) (79)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [65,82,66,79])
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Arboricx header parsing
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "readArboricxHeader: parses portable header" $ do
|
|
let input = "readArboricxHeader " ++ bytesExpr (arboricxHeaderBytes 0)
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (arboricxHeaderT 0) (bytesT [])
|
|
|
|
, testCase "readArboricxHeader: preserves trailing bytes" $ do
|
|
let input = "readArboricxHeader " ++ bytesExpr (arboricxHeaderBytes 0 ++ [9,8])
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (arboricxHeaderT 0) (bytesT [9,8])
|
|
|
|
, testCase "readArboricxHeader: short input returns EOF preserving input" $ do
|
|
let input = "readArboricxHeader [(65) (82)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [65,82])
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Arboricx section directory record parsing
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "readSectionRecord: parses portable section entry" $ do
|
|
let input = "readSectionRecord " ++ bytesExpr (nodesEntryBytes 16 32)
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (sectionRecordT nodesSectionIdBytes 16 32) (bytesT [])
|
|
|
|
, testCase "readSectionRecord: preserves trailing bytes" $ do
|
|
let input = "readSectionRecord " ++ bytesExpr (nodesEntryBytes 16 32 ++ [9,8])
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (sectionRecordT nodesSectionIdBytes 16 32) (bytesT [9,8])
|
|
|
|
, testCase "readSectionRecord: empty input returns EOF" $ do
|
|
let input = "readSectionRecord []"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [])
|
|
|
|
, testCase "readSectionRecord: short section id returns EOF preserving input" $ do
|
|
let input = "readSectionRecord [(0)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [0])
|
|
|
|
, testCase "readSectionRecord: missing section version returns EOF preserving unread bytes" $ do
|
|
let input = "readSectionRecord [(0) (2)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [0,2])
|
|
|
|
, testCase "readSectionRecord: short section version returns EOF preserving unread bytes" $ do
|
|
let input = "readSectionRecord [(0) (2) (0) (0) (0)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [0])
|
|
|
|
, testCase "readSectionRecord: missing length returns EOF preserving unread length bytes" $ do
|
|
let input = "readSectionRecord [(0) (2) (0) (0) (0) (16)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [])
|
|
|
|
, testCase "readSectionRecord: short section flags returns EOF preserving unread bytes" $ do
|
|
let input = "readSectionRecord [(0) (2) (0) (0) (0) (16) (0) (0) (0)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [0])
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Arboricx section directory parsing
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "readSectionDirectory: zero records preserves input" $ do
|
|
let input = "readSectionDirectory 0 [(9) (8)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (ofList []) (bytesT [9,8])
|
|
|
|
, testCase "readSectionDirectory: reads requested records and preserves trailing bytes" $ do
|
|
let input = "readSectionDirectory 2 " ++ bytesExpr (manifestEntryBytes 10 20 ++ nodesEntryBytes 30 40 ++ [9])
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT
|
|
(ofList
|
|
[ sectionRecordT manifestSectionIdBytes 10 20
|
|
, sectionRecordT nodesSectionIdBytes 30 40
|
|
])
|
|
(bytesT [9])
|
|
|
|
, testCase "readSectionDirectory: truncated record returns EOF" $ do
|
|
let input = "readSectionDirectory 2 [(0) (1) (0) (0) (0) (10) (0) (0) (0) (20) (0) (2) (0) (0)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [0,0])
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Arboricx section lookup and raw byte slicing
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "lookupSectionRecord: finds record by raw section id" $ do
|
|
let input = "lookupSectionRecord " ++ bytesExpr nodesSectionIdBytes ++ " [(" ++ "pair " ++ bytesExpr manifestSectionIdBytes ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr [0,0] ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr (u64 10) ++ " (pair " ++ bytesExpr (u64 20) ++ " " ++ bytesExpr (replicate 32 0) ++ "))))))" ++ ") (" ++ "pair " ++ bytesExpr nodesSectionIdBytes ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr [0,0] ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr (u64 30) ++ " (pair " ++ bytesExpr (u64 40) ++ " " ++ bytesExpr (replicate 32 0) ++ "))))))" ++ ")]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= justT (sectionRecordT nodesSectionIdBytes 30 40)
|
|
|
|
, testCase "lookupSectionRecord: missing section id returns nothing" $ do
|
|
let input = "lookupSectionRecord " ++ bytesExpr [0,0,0,3] ++ " [(" ++ "pair " ++ bytesExpr manifestSectionIdBytes ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr [0,0] ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr (u64 10) ++ " (pair " ++ bytesExpr (u64 20) ++ " " ++ bytesExpr (replicate 32 0) ++ "))))))" ++ ") (" ++ "pair " ++ bytesExpr nodesSectionIdBytes ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr [0,0] ++ " (pair " ++ bytesExpr [0,1] ++ " (pair " ++ bytesExpr (u64 30) ++ " (pair " ++ bytesExpr (u64 40) ++ " " ++ bytesExpr (replicate 32 0) ++ "))))))" ++ ")]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= nothingT
|
|
|
|
, testCase "byteSlice: extracts requested byte range" $ do
|
|
let input = "byteSlice 2 3 [(10) (11) (12) (13) (14) (15)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= bytesT [12,13,14]
|
|
|
|
, testCase "byteSlice: overlong length returns remaining bytes" $ do
|
|
let input = "byteSlice 4 9 [(10) (11) (12) (13) (14) (15)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= bytesT [14,15]
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Arboricx minimal container parsing foundation
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "u32BEBytesToNat: decodes zero" $ do
|
|
let input = "u32BEBytesToNat [(0) (0) (0) (0)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= ofNumber 0
|
|
|
|
, testCase "u32BEBytesToNat: decodes small section count" $ do
|
|
let input = "u32BEBytesToNat [(0) (0) (0) (2)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= ofNumber 2
|
|
|
|
, testCase "u64BEBytesToNat: decodes small node count" $ do
|
|
let input = "u64BEBytesToNat [(0) (0) (0) (0) (0) (0) (0) (2)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= ofNumber 2
|
|
|
|
, testCase "u64BEBytesToNat: decodes fixture-scale offset" $ do
|
|
let input = "u64BEBytesToNat [(0) (0) (0) (0) (0) (0) (3) (214)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= ofNumber 982
|
|
|
|
, testCase "readArboricxContainer: reads header directory and preserves payload" $ do
|
|
let input = "readArboricxContainer " ++ bytesExpr (simpleContainerBytes [101,102,103] [201,202,203,204])
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT
|
|
(pairT
|
|
(arboricxHeaderT 2)
|
|
(ofList
|
|
[ sectionRecordT manifestSectionIdBytes 152 3
|
|
, sectionRecordT nodesSectionIdBytes 155 4
|
|
]))
|
|
(bytesT [101,102,103,201,202,203,204])
|
|
|
|
, testCase "readArboricxContainer: truncated directory returns EOF" $ do
|
|
let input = "readArboricxContainer " ++ bytesExpr (arboricxHeaderBytes 1 ++ [0,0])
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [0,0])
|
|
|
|
, testCase "readArboricxContainer: rejects unsupported major version" $ do
|
|
let badHeader = [65,82,66,79,82,73,67,88] ++ u16 2 ++ u16 0 ++ u32 0 ++ u64 0 ++ u64 32
|
|
input = "readArboricxContainer " ++ bytesExpr badHeader
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT unsupportedVersionT (bytesT [])
|
|
|
|
, testCase "readArboricxContainer: rejects unsupported minor version" $ do
|
|
let badHeader = [65,82,66,79,82,73,67,88] ++ u16 1 ++ u16 1 ++ u32 0 ++ u64 0 ++ u64 32
|
|
input = "readArboricxContainer " ++ bytesExpr badHeader
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT unsupportedVersionT (bytesT [])
|
|
|
|
, testCase "readArboricxContainer: rejects duplicate section ids" $ do
|
|
let input = "readArboricxContainer " ++ bytesExpr (arboricxHeaderBytes 2 ++ manifestEntryBytes 152 1 ++ manifestEntryBytes 153 1 ++ [9])
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT duplicateSectionT (bytesT [9])
|
|
|
|
, testCase "extractSectionBytes: uses raw offset and length fields" $ do
|
|
let input = "extractSectionBytes " ++ sectionRecordExpr nodesSectionIdBytes 3 4 ++ " " ++ bytesExpr [10,11,12,13,14,15,16,17]
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= bytesT [13,14,15,16]
|
|
|
|
, testCase "lookupSectionBytes: finds section and extracts raw bytes" $ do
|
|
let input = "lookupSectionBytes " ++ bytesExpr nodesSectionIdBytes ++ " [" ++ sectionRecordExpr manifestSectionIdBytes 1 2 ++ " " ++ sectionRecordExpr nodesSectionIdBytes 4 3 ++ "] " ++ bytesExpr [10,11,12,13,14,15,16,17]
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= justT (bytesT [14,15,16])
|
|
|
|
, testCase "lookupSectionBytes: missing section returns nothing" $ do
|
|
let input = "lookupSectionBytes " ++ bytesExpr [0,0,0,3] ++ " [" ++ sectionRecordExpr manifestSectionIdBytes 1 2 ++ " " ++ sectionRecordExpr nodesSectionIdBytes 4 3 ++ "] " ++ bytesExpr [10,11,12,13,14,15,16,17]
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= nothingT
|
|
|
|
, testCase "extractSectionBytesResult: rejects out-of-bounds section" $ do
|
|
let input = "extractSectionBytesResult " ++ sectionRecordExpr nodesSectionIdBytes 6 4 ++ " " ++ bytesExpr [10,11,12,13,14,15,16,17] ++ " []"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [])
|
|
|
|
, testCase "readArboricxSectionBytes: extracts requested section from container" $ do
|
|
let input = "readArboricxSectionBytes " ++ bytesExpr nodesSectionIdBytes ++ " " ++ bytesExpr (simpleContainerBytes [101,102,103] [201,202,203,204])
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (bytesT [201,202,203,204]) (bytesT [101,102,103,201,202,203,204])
|
|
|
|
, testCase "readArboricxSectionBytes: missing section returns missing-section err" $ do
|
|
let input = "readArboricxSectionBytes " ++ bytesExpr nodesSectionIdBytes ++ " " ++ bytesExpr (singleSectionContainerBytes manifestSectionIdBytes [101,102,103])
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT missingSectionT (bytesT [101,102,103])
|
|
|
|
, testCase "readArboricxRequiredSections: extracts manifest and nodes bytes" $ do
|
|
let input = "readArboricxRequiredSections " ++ bytesExpr (simpleContainerBytes [101,102,103] [201,202,203,204])
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT
|
|
(pairT (bytesT [101,102,103]) (bytesT [201,202,203,204]))
|
|
(bytesT [101,102,103,201,202,203,204])
|
|
|
|
, testCase "readArboricxRequiredSections: missing nodes section returns missing-section err" $ do
|
|
let input = "readArboricxRequiredSections " ++ bytesExpr (singleSectionContainerBytes manifestSectionIdBytes [101,102,103])
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT missingSectionT (bytesT [101,102,103])
|
|
|
|
, testCase "readArboricxRequiredSections: out-of-bounds section returns EOF" $ do
|
|
let manifestBytes = [101,102,103]
|
|
nodesBytes = [201,202,203,204]
|
|
badContainer = arboricxHeaderBytes 2 ++ manifestEntryBytes 152 3 ++ nodesEntryBytes 155 9 ++ manifestBytes ++ nodesBytes
|
|
input = "readArboricxRequiredSections " ++ bytesExpr badContainer
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [101,102,103,201,202,203,204])
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Arboricx raw nodes section parsing
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "readNodeRecord: parses hash length and raw payload" $ do
|
|
let input = "readNodeRecord [(1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (0) (0) (0) (3) (101) (102) (103) (9)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT
|
|
(pairT (bytesT [1..32])
|
|
(pairT (bytesT [0,0,0,3])
|
|
(bytesT [101,102,103])))
|
|
(bytesT [9])
|
|
|
|
, testCase "readNodeRecord: truncated payload returns EOF preserving unread payload" $ do
|
|
let input = "readNodeRecord [(1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (0) (0) (0) (3) (101) (102)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [101,102])
|
|
|
|
, testCase "readNodesSection: parses node count and records" $ do
|
|
let input = "readNodesSection [(0) (0) (0) (0) (0) (0) (0) (1) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (0) (0) (0) (1) (0) (9)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT
|
|
(pairT (bytesT [0,0,0,0,0,0,0,1])
|
|
(ofList
|
|
[ pairT (bytesT [1..32])
|
|
(pairT (bytesT [0,0,0,1])
|
|
(bytesT [0]))
|
|
]))
|
|
(bytesT [9])
|
|
|
|
, testCase "readNodesSectionComplete: rejects trailing bytes inside nodes section" $ do
|
|
let input = "readNodesSectionComplete [(0) (0) (0) (0) (0) (0) (0) (0) (9)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT unexpectedBytesT (bytesT [9])
|
|
|
|
, testCase "readNodesSection: rejects duplicate node hashes" $ do
|
|
let input = "readNodesSection [(0) (0) (0) (0) (0) (0) (0) (2) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (0) (0) (0) (1) (0) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (0) (0) (0) (1) (0) (9)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT duplicateNodeT (bytesT [9])
|
|
|
|
, testCase "nodePayloadValid?: accepts leaf stem and fork payload shapes" $ do
|
|
let input = "[(nodePayloadValid? [(0)]) (nodePayloadValid? [(1) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32)]) (nodePayloadValid? [(2) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64)])]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= ofList [trueT, trueT, trueT]
|
|
|
|
, testCase "nodePayloadValid?: rejects invalid payload shapes" $ do
|
|
let input = "[(nodePayloadValid? []) (nodePayloadValid? [(9)]) (nodePayloadValid? [(1) (1)]) (nodePayloadValid? [(2) (1) (2)])]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= ofList [falseT, falseT, falseT, falseT]
|
|
|
|
, testCase "node payload child accessors expose raw hashes" $ do
|
|
let input = "[(nodePayloadStemChildHash [(1) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32)]) (nodePayloadForkLeftHash [(2) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64)]) (nodePayloadForkRightHash [(2) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64)])]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= ofList [bytesT [1..32], bytesT [1..32], bytesT [33..64]]
|
|
|
|
, testCase "lookupNodeRecord: finds record by raw node hash" $ do
|
|
let input = "lookupNodeRecord [(33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64)] [(pair [(1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32)] (pair [(0) (0) (0) (1)] [(0)])) (pair [(33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64)] (pair [(0) (0) (0) (1)] [(0)]))]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= justT
|
|
(pairT (bytesT [33..64])
|
|
(pairT (bytesT [0,0,0,1])
|
|
(bytesT [0])))
|
|
|
|
, testCase "nodeRecordChildHashes: extracts stem and fork references" $ do
|
|
let input = "[(nodeRecordChildHashes (pair [(1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32)] (pair [(0) (0) (0) (33)] [(1) (33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64)]))) (nodeRecordChildHashes (pair [(1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32)] (pair [(0) (0) (0) (65)] [(2) (33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64) (65) (66) (67) (68) (69) (70) (71) (72) (73) (74) (75) (76) (77) (78) (79) (80) (81) (82) (83) (84) (85) (86) (87) (88) (89) (90) (91) (92) (93) (94) (95) (96)])))]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= ofList
|
|
[ ofList [bytesT [33..64]]
|
|
, ofList [bytesT [33..64], bytesT [65..96]]
|
|
]
|
|
|
|
, testCase "readNodesSection: rejects invalid node payload shape" $ do
|
|
let input = "readNodesSection [(0) (0) (0) (0) (0) (0) (0) (1) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (0) (0) (0) (1) (9)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT invalidNodePayloadT (bytesT [])
|
|
|
|
, testCase "readNodesSection: rejects missing child node" $ do
|
|
let input = "readNodesSection [(0) (0) (0) (0) (0) (0) (0) (1) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (0) (0) (0) (33) (1) (33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64) (9)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT missingNodeT (bytesT [9])
|
|
|
|
, testCase "readArboricxNodesSection: extracts and parses raw nodes section" $ do
|
|
let nodesBytes = u64 1 ++ [1..32] ++ u32 1 ++ [0]
|
|
input = "readArboricxNodesSection " ++ bytesExpr (simpleContainerBytes [101,102,103] nodesBytes)
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT
|
|
(pairT (bytesT [0,0,0,0,0,0,0,1])
|
|
(ofList
|
|
[ pairT (bytesT [1..32])
|
|
(pairT (bytesT [0,0,0,1])
|
|
(bytesT [0]))
|
|
]))
|
|
(bytesT ([101,102,103] ++ nodesBytes))
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Arboricx node DAG reconstruction
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "nodeHashToTree: reconstructs leaf node" $ do
|
|
let input = "nodeHashToTree [(1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32)] [(pair [(1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32)] (pair [(0) (0) (0) (1)] [(0)]))]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT Leaf Leaf
|
|
|
|
, testCase "nodeHashToTree: reconstructs stem node" $ do
|
|
let input = "nodeHashToTree [(33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64)] [(pair [(1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32)] (pair [(0) (0) (0) (1)] [(0)])) (pair [(33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64)] (pair [(0) (0) (0) (33)] [(1) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32)]))]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (Stem Leaf) Leaf
|
|
|
|
, testCase "nodeHashToTree: reconstructs fork node" $ do
|
|
let input = "nodeHashToTree [(65) (66) (67) (68) (69) (70) (71) (72) (73) (74) (75) (76) (77) (78) (79) (80) (81) (82) (83) (84) (85) (86) (87) (88) (89) (90) (91) (92) (93) (94) (95) (96)] [(pair [(1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32)] (pair [(0) (0) (0) (1)] [(0)])) (pair [(33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64)] (pair [(0) (0) (0) (1)] [(0)])) (pair [(65) (66) (67) (68) (69) (70) (71) (72) (73) (74) (75) (76) (77) (78) (79) (80) (81) (82) (83) (84) (85) (86) (87) (88) (89) (90) (91) (92) (93) (94) (95) (96)] (pair [(0) (0) (0) (65)] [(2) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) (11) (12) (13) (14) (15) (16) (17) (18) (19) (20) (21) (22) (23) (24) (25) (26) (27) (28) (29) (30) (31) (32) (33) (34) (35) (36) (37) (38) (39) (40) (41) (42) (43) (44) (45) (46) (47) (48) (49) (50) (51) (52) (53) (54) (55) (56) (57) (58) (59) (60) (61) (62) (63) (64)]))]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (Fork Leaf Leaf) Leaf
|
|
|
|
, testCase "readArboricxTreeFromHash: reconstructs tree from bundle bytes" $ do
|
|
let nodesBytes = u64 1 ++ [1..32] ++ u32 1 ++ [0]
|
|
input = "readArboricxTreeFromHash " ++ bytesExpr [1..32] ++ " " ++ bytesExpr (simpleContainerBytes [101,102,103] nodesBytes)
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT Leaf (bytesT ([101,102,103] ++ nodesBytes))
|
|
|
|
, testCase "readArboricxExecutableFromHash: alias reconstructs tree" $ do
|
|
let nodesBytes = u64 1 ++ [1..32] ++ u32 1 ++ [0]
|
|
input = "readArboricxExecutableFromHash " ++ bytesExpr [1..32] ++ " " ++ bytesExpr (simpleContainerBytes [101,102,103] nodesBytes)
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT Leaf (bytesT ([101,102,103] ++ nodesBytes))
|
|
|
|
, testCase "readArboricxNodesSection: reads id fixture bundle" $ do
|
|
fixtureBytes <- BS.readFile "test/fixtures/id.arboricx"
|
|
case decodeBundle fixtureBytes of
|
|
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
|
Right _ -> do
|
|
let input = "matchResult (code rest : code) (nodes rest : 0) (readArboricxNodesSection "
|
|
++ bytesExpr (map toInteger $ BS.unpack fixtureBytes)
|
|
++ ")"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= ofNumber 0
|
|
|
|
, testCase "readArboricxNodesSection: reads notQ fixture bundle" $ do
|
|
fixtureBytes <- BS.readFile "test/fixtures/notQ.arboricx"
|
|
case decodeBundle fixtureBytes of
|
|
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
|
Right _ -> do
|
|
let input = "matchResult (code rest : code) (nodes rest : 0) (readArboricxNodesSection "
|
|
++ bytesExpr (map toInteger $ BS.unpack fixtureBytes)
|
|
++ ")"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= ofNumber 0
|
|
|
|
, testCase "readArboricxNodesSection: reads map fixture bundle" $ do
|
|
fixtureBytes <- BS.readFile "test/fixtures/map.arboricx"
|
|
case decodeBundle fixtureBytes of
|
|
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
|
Right _ -> do
|
|
let input = "matchResult (code rest : code) (nodes rest : 0) (readArboricxNodesSection "
|
|
++ bytesExpr (map toInteger $ BS.unpack fixtureBytes)
|
|
++ ")"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= ofNumber 0
|
|
|
|
, testCase "readArboricxExecutableFromHash: reconstructs id fixture root" $ do
|
|
fixtureBytes <- BS.readFile "test/fixtures/id.arboricx"
|
|
case decodeBundle fixtureBytes of
|
|
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
|
Right bundle -> case bundleRoots bundle of
|
|
[] -> assertFailure "fixture has no roots"
|
|
(rootHash:_) -> do
|
|
let input = "matchResult (code rest : code) (tree rest : 0) (readArboricxExecutableFromHash "
|
|
++ bytesExpr (hexTextBytes rootHash)
|
|
++ " "
|
|
++ bytesExpr (map toInteger $ BS.unpack fixtureBytes)
|
|
++ ")"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= ofNumber 0
|
|
|
|
, testCase "readArboricxExecutableFromHash: reconstructs notQ fixture root" $ do
|
|
fixtureBytes <- BS.readFile "test/fixtures/notQ.arboricx"
|
|
case decodeBundle fixtureBytes of
|
|
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
|
Right bundle -> case bundleRoots bundle of
|
|
[] -> assertFailure "fixture has no roots"
|
|
(rootHash:_) -> do
|
|
let input = "matchResult (code rest : code) (tree rest : 0) (readArboricxExecutableFromHash "
|
|
++ bytesExpr (hexTextBytes rootHash)
|
|
++ " "
|
|
++ bytesExpr (map toInteger $ BS.unpack fixtureBytes)
|
|
++ ")"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= ofNumber 0
|
|
|
|
, testCase "readArboricxExecutableFromHash: reconstructs map fixture root" $ do
|
|
fixtureBytes <- BS.readFile "test/fixtures/map.arboricx"
|
|
case decodeBundle fixtureBytes of
|
|
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
|
Right bundle -> case bundleRoots bundle of
|
|
[] -> assertFailure "fixture has no roots"
|
|
(rootHash:_) -> do
|
|
let input = "matchResult (code rest : code) (tree rest : 0) (readArboricxExecutableFromHash "
|
|
++ bytesExpr (hexTextBytes rootHash)
|
|
++ " "
|
|
++ bytesExpr (map toInteger $ BS.unpack fixtureBytes)
|
|
++ ")"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= ofNumber 0
|
|
|
|
, testCase "readArboricxExecutableFromHash: executes id fixture root" $ do
|
|
fixtureBytes <- BS.readFile "test/fixtures/id.arboricx"
|
|
case decodeBundle fixtureBytes of
|
|
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
|
Right bundle -> case bundleRoots bundle of
|
|
[] -> assertFailure "fixture has no roots"
|
|
(rootHash:_) -> do
|
|
let input = "matchResult (code rest : code) (tree rest : tree 42) (readArboricxExecutableFromHash "
|
|
++ bytesExpr (hexTextBytes rootHash)
|
|
++ " "
|
|
++ bytesExpr (map toInteger $ BS.unpack fixtureBytes)
|
|
++ ")"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= ofNumber 42
|
|
|
|
, testCase "readArboricxExecutableFromHash: executes notQ fixture on true" $ do
|
|
fixtureBytes <- BS.readFile "test/fixtures/notQ.arboricx"
|
|
case decodeBundle fixtureBytes of
|
|
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
|
Right bundle -> case bundleRoots bundle of
|
|
[] -> assertFailure "fixture has no roots"
|
|
(rootHash:_) -> do
|
|
let input = "matchResult (code rest : code) (tree rest : tree true) (readArboricxExecutableFromHash "
|
|
++ bytesExpr (hexTextBytes rootHash)
|
|
++ " "
|
|
++ bytesExpr (map toInteger $ BS.unpack fixtureBytes)
|
|
++ ")"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= falseT
|
|
|
|
, testCase "readArboricxExecutableFromHash: executes notQ fixture on false" $ do
|
|
fixtureBytes <- BS.readFile "test/fixtures/notQ.arboricx"
|
|
case decodeBundle fixtureBytes of
|
|
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
|
Right bundle -> case bundleRoots bundle of
|
|
[] -> assertFailure "fixture has no roots"
|
|
(rootHash:_) -> do
|
|
let input = "matchResult (code rest : code) (tree rest : tree false) (readArboricxExecutableFromHash "
|
|
++ bytesExpr (hexTextBytes rootHash)
|
|
++ " "
|
|
++ bytesExpr (map toInteger $ BS.unpack fixtureBytes)
|
|
++ ")"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "readArboricxExecutableFromHash: executes map fixture root" $ do
|
|
fixtureBytes <- BS.readFile "test/fixtures/map.arboricx"
|
|
case decodeBundle fixtureBytes of
|
|
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
|
Right bundle -> case bundleRoots bundle of
|
|
[] -> assertFailure "fixture has no roots"
|
|
(rootHash:_) -> do
|
|
let input = "matchResult (code rest : code) (tree rest : head (tail (tree (a : (t t t)) [(t) (t) (t)]))) (readArboricxExecutableFromHash "
|
|
++ bytesExpr (hexTextBytes rootHash)
|
|
++ " "
|
|
++ bytesExpr (map toInteger $ BS.unpack fixtureBytes)
|
|
++ ")"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= Fork Leaf Leaf
|
|
]
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Manifest reading tests (Steps 1-9)
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
-- Build a minimal manifest:
|
|
-- magic "ARBMNFST" (8) + version 1.0 (4) +
|
|
-- schema "arboricx.bundle.manifest.v1" (4+27=31) +
|
|
-- bundleType "tree-calculus-executable-object" (4+31=35) +
|
|
-- treeCalculus "tree-calculus.v1" (4+16=20) +
|
|
-- treeHashAlgorithm "sha256" (4+6=10) +
|
|
-- treeHashDomain "arboricx.merkle.node.v1" (4+23=27) +
|
|
-- treeNodePayload "arboricx.merkle.payload.v1" (4+26=30) +
|
|
-- runtimeSemantics "tree-calculus.v1" (4+16=20) +
|
|
-- runtimeEvaluation "normal-order" (4+12=16) +
|
|
-- runtimeAbi "arboricx.abi.tree.v1" (4+20=24) +
|
|
-- capabilityCount 0 (4) +
|
|
-- closure 0 (1) +
|
|
-- rootCount 1 (4) +
|
|
-- root: hash (32) + role "default" (4+7=11) = 43 +
|
|
-- exportCount 1 (4) +
|
|
-- export: name "term" (4+4=8) + root (32) + kind "term" (4+4=8) + abi "arboricx.abi.tree.v1" (4+20=24) = 72 +
|
|
-- Total core = 8+4+31+35+20+10+27+30+20+16+24+4+1+4+43+4+72 = 378 bytes
|
|
|
|
minimalManifestCoreBytes :: [Integer]
|
|
minimalManifestCoreBytes = [65,82,66,77,78,70,83,84] -- ARBMNFST magic
|
|
++ u16 1 ++ u16 0 -- version 1.0
|
|
++ lengthPrefixed "arboricx.bundle.manifest.v1" -- schema
|
|
++ lengthPrefixed "tree-calculus-executable-object" -- bundleType
|
|
++ lengthPrefixed "tree-calculus.v1" -- treeCalculus
|
|
++ lengthPrefixed "sha256" -- treeHashAlgorithm
|
|
++ lengthPrefixed "arboricx.merkle.node.v1" -- treeHashDomain
|
|
++ lengthPrefixed "arboricx.merkle.payload.v1" -- treeNodePayload
|
|
++ lengthPrefixed "tree-calculus.v1" -- runtimeSemantics
|
|
++ lengthPrefixed "normal-order" -- runtimeEvaluation
|
|
++ lengthPrefixed "arboricx.abi.tree.v1" -- runtimeAbi
|
|
++ u32 0 -- 0 capabilities
|
|
++ [0] -- closure complete
|
|
++ u32 1 -- 1 root
|
|
++ replicate 32 0 -- placeholder root hash
|
|
++ lengthPrefixed "default" -- root role
|
|
++ u32 1 -- 1 export
|
|
++ lengthPrefixed "term" -- export name
|
|
++ replicate 32 0 -- placeholder export root hash
|
|
++ lengthPrefixed "term" -- export kind
|
|
++ lengthPrefixed "arboricx.abi.tree.v1" -- export abi
|
|
|
|
lengthPrefixed :: String -> [Integer]
|
|
lengthPrefixed s = u32 (fromIntegral (length s)) ++ map (fromIntegral . fromEnum) s
|
|
|
|
-- Full manifest: core + 0 metadata + 0 extension = core + u32(0) + u32(0)
|
|
fullMinimalManifestBytes :: [Integer]
|
|
fullMinimalManifestBytes = minimalManifestCoreBytes ++ u32 0 ++ u32 0
|
|
|
|
-- Create TLV list with two entries:
|
|
-- tag 1 (package), value "my-pkg", then tag 2 (version), value "1.0"
|
|
-- then "rest" bytes
|
|
|
|
tlvForTagAndValue :: Integer -> String -> [Integer]
|
|
tlvForTagAndValue tag val =
|
|
u16 (fromIntegral tag) ++ lengthPrefixed val
|
|
|
|
-- Build a pair of (tag, value) TLV
|
|
makeTLVPair :: Integer -> String -> String
|
|
makeTLVPair tag val =
|
|
"[(pair " ++ bytesExpr [0, fromIntegral tag] ++ " "
|
|
++ bytesExpr (map (fromIntegral . fromEnum) val) ++ ")]"
|
|
|
|
exportEntryExpr :: String -> [Integer] -> String -> String -> String
|
|
exportEntryExpr name rootHashBytes kind abi =
|
|
"(pair " ++ bytesExpr (map (fromIntegral . fromEnum) name) ++ " "
|
|
++ "(pair " ++ bytesExpr rootHashBytes ++ " "
|
|
++ "(pair " ++ bytesExpr (map (fromIntegral . fromEnum) kind) ++ " "
|
|
++ bytesExpr (map (fromIntegral . fromEnum) abi) ++ ")))"
|
|
|
|
-- Build list of export entries for the test
|
|
singleExportExpr :: String
|
|
singleExportExpr =
|
|
"[" ++ exportEntryExpr "main" (replicate 32 0) "term" "arboricx.abi.tree.v1" ++ "]"
|
|
|
|
multiExportExpr :: String
|
|
multiExportExpr =
|
|
"["
|
|
++ exportEntryExpr "main" (replicate 32 0) "term" "arboricx.abi.tree.v1"
|
|
-- ++ ", "
|
|
++ exportEntryExpr "test" (replicate 32 1) "term" "arboricx.abi.tree.v1"
|
|
++ "]"
|
|
|
|
-- Helper to build a minimal valid manifest core
|
|
-- Returns a tricu expression representing the parsed core structure
|
|
buildValidCoreExpr :: String
|
|
buildValidCoreExpr =
|
|
"(pair "
|
|
++ bytesExpr (map (fromIntegral . fromEnum) "arboricx.bundle.manifest.v1") ++ " " -- schema
|
|
++ "(pair "
|
|
++ bytesExpr (map (fromIntegral . fromEnum) "tree-calculus-executable-object") ++ " " -- bundleType
|
|
++ "(pair "
|
|
++ bytesExpr (map (fromIntegral . fromEnum) "tree-calculus.v1") ++ " " -- treeCalculus
|
|
++ "(pair "
|
|
++ bytesExpr (map (fromIntegral . fromEnum) "sha256") ++ " " -- treeHashAlgorithm
|
|
++ "(pair "
|
|
++ bytesExpr (map (fromIntegral . fromEnum) "arboricx.merkle.node.v1") ++ " " -- treeHashDomain
|
|
++ "(pair "
|
|
++ bytesExpr (map (fromIntegral . fromEnum) "arboricx.merkle.payload.v1") ++ " " -- treeNodePayload
|
|
++ "(pair "
|
|
++ bytesExpr (map (fromIntegral . fromEnum) "tree-calculus.v1") ++ " " -- runtimeSemantics
|
|
++ "(pair "
|
|
++ bytesExpr (map (fromIntegral . fromEnum) "normal-order") ++ " " -- runtimeEvaluation
|
|
++ "(pair "
|
|
++ bytesExpr (map (fromIntegral . fromEnum) "arboricx.abi.tree.v1") ++ " " -- runtimeAbi
|
|
++ "(pair "
|
|
++ "[] " -- capabilities
|
|
++ "(pair "
|
|
++ "0 " -- closure
|
|
++ "(pair "
|
|
++ "[(pair " ++ bytesExpr (replicate 32 0) ++ " "
|
|
++ bytesExpr (map (fromIntegral . fromEnum) "default") ++ ")" -- roots (1 root)
|
|
++ "] "
|
|
++ "[(pair "
|
|
++ bytesExpr (map (fromIntegral . fromEnum) "term") ++ " "
|
|
++ "(pair " ++ bytesExpr (replicate 32 0) ++ " "
|
|
++ "(pair "
|
|
++ bytesExpr (map (fromIntegral . fromEnum) "term") ++ " "
|
|
++ bytesExpr (map (fromIntegral . fromEnum) "arboricx.abi.tree.v1") ++ ")))" -- exports (1 export)
|
|
++ "])"
|
|
++ "]"
|
|
++ "]"
|
|
++ "]"
|
|
++ "]"
|
|
++ "]"
|
|
++ "]"
|
|
++ "]"
|
|
++ "]"
|
|
++ "]"
|
|
++ "]"
|
|
++ "]"
|
|
++ "]"
|
|
++ ")"
|
|
|
|
-- Build a tricu expression that extracts a specific manifest field from
|
|
-- readArboricxBundle result and returns it as a byte-list T value.
|
|
-- The Haskell test then uses toString to convert it to a String.
|
|
extractManifestField :: ByteString -> String -> String
|
|
extractManifestField fixtureBytes fieldName =
|
|
"matchResult "
|
|
++ " (errCode rest : errCode) "
|
|
++ " (bundleResult rest : "
|
|
++ " matchPair "
|
|
++ " (validCore metadataWithExtensions : "
|
|
++ " " ++ fieldName ++ " validCore) "
|
|
++ " bundleResult) "
|
|
++ " (readArboricxBundle " ++ bytesExpr (map toInteger $ BS.unpack fixtureBytes) ++ ")"
|
|
|
|
manifestReadingTests :: TestTree
|
|
manifestReadingTests = testGroup "Manifest Reading Tests"
|
|
[
|
|
-- ------------------------------------------------------------------------
|
|
-- Step 1: readManifestMagic
|
|
-- ------------------------------------------------------------------------
|
|
testCase "readManifestMagic: accepts correct manifest magic and preserves rest" $ do
|
|
let input = "readManifestMagic ((append arboricxManifestMagic) [(1) (2)])"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT unitT (bytesT [1,2])
|
|
|
|
, testCase "readManifestMagic: rejects wrong magic" $ do
|
|
let input = "readManifestMagic [(65) (83) (66) (77) (78) (70) (83) (84)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT unexpectedBytesT (bytesT [65,83,66,77,78,70,83,84])
|
|
|
|
, testCase "readManifestMagic: short input returns EOF" $ do
|
|
let input = "readManifestMagic [(65) (82) (66) (77)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [65,82,66,77])
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Step 2: readLengthPrefixedString
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "readLengthPrefixedString: reads a 5-byte string" $ do
|
|
let input = "readLengthPrefixedString [(0) (0) (0) (5) (104) (101) (108) (108) (111) (99) (111) (110) (116) (101) (114)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (bytesT [104,101,108,108,111]) (bytesT [99,111,110,116,101,114])
|
|
|
|
, testCase "readLengthPrefixedString: reads an empty string" $ do
|
|
let input = "readLengthPrefixedString [(0) (0) (0) (0) (97) (98)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (bytesT []) (bytesT [97,98])
|
|
|
|
, testCase "readLengthPrefixedString: short payload returns EOF" $ do
|
|
let input = "readLengthPrefixedString [(0) (0) (0) (5) (104) (101) (108)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [104,101,108])
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Step 3: readManifestCore (construct a minimal valid manifest)
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "readManifestCore: reads a minimal valid manifest core" $ do
|
|
let input = "readManifestCore " ++ bytesExpr minimalManifestCoreBytes
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let actualResult = result env
|
|
case actualResult of
|
|
(Fork Leaf Leaf) -> assertFailure "should be ok, not t"
|
|
(Fork _ (Fork _ rest)) -> return () -- ok case: pair true (pair value rest)
|
|
_ -> assertFailure $ "expected ok result, got: " ++ show actualResult
|
|
|
|
, testCase "readManifestCore: returns error on wrong magic" $ do
|
|
let badMagic = [65,83,66,77,78,70,83,84] ++ (drop 8 minimalManifestCoreBytes)
|
|
let input = "readManifestCore " ++ bytesExpr badMagic
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let actualResult = result env
|
|
case actualResult of
|
|
(Fork falseT _) -> return () -- err case: pair false (pair code rest)
|
|
_ -> assertFailure $ "expected err result, got: " ++ show actualResult
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Step 4: TLV reader
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "readTLV: reads a metadata TLV entry" $ do
|
|
-- tag = u16 1 = [(0)(1)], length = u32 3 = [(0)(0)(0)(3)], value = "foo" = [102,111,111]
|
|
let input = "readTLV [(0) (1) (0) (0) (0) (3) (102) (111) (111) (99) (111) (110) (116) (114) (101) (115) (116)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let actualResult = result env
|
|
case actualResult of
|
|
(Fork _ (Fork _ rest)) -> do
|
|
-- ok case: verify the value pair
|
|
let value = case result env of
|
|
(Fork _ (Fork val _)) -> case val of
|
|
(Fork tagVal _) -> tagVal
|
|
_ -> Leaf
|
|
return ()
|
|
_ -> assertFailure $ "expected ok result, got: " ++ show actualResult
|
|
|
|
, testCase "readTLV: returns EOF on empty input" $ do
|
|
let input = "readTLV []"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [])
|
|
|
|
, testCase "readTLV: returns EOF on short tag" $ do
|
|
let input = "readTLV [(0)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= errT eofT (bytesT [0])
|
|
|
|
, testCase "readTLVList: reads zero TLV entries" $ do
|
|
let input = "readTLVList 0 [(1) (2) (3)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT (ofList []) (bytesT [1,2,3])
|
|
|
|
, testCase "readTLVList: reads one TLV entry and preserves rest" $ do
|
|
-- tag=1, len=3, value="foo"
|
|
let input = "readTLVList 1 [(0) (1) (0) (0) (0) (3) (102) (111) (111) (99) (111) (110) (116) (114) (101) (115) (116)]"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let actualResult = result env
|
|
case actualResult of
|
|
(Fork _ (Fork _ rest)) -> do
|
|
-- ok: value is list with one TLV, rest should be [(99)...]
|
|
return ()
|
|
_ -> assertFailure $ "expected ok result, got: " ++ show actualResult
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Step 5: readManifest (full parser)
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "readManifest: parses a minimal manifest with no metadata" $ do
|
|
let input = "readManifest " ++ bytesExpr fullMinimalManifestBytes
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let actualResult = result env
|
|
case actualResult of
|
|
(Fork _ (Fork _ _)) -> return () -- ok result
|
|
_ -> assertFailure $ "expected ok result, got: " ++ show actualResult
|
|
|
|
, testCase "readManifest: preserves trailing extension bytes" $ do
|
|
let input = "readManifest (append " ++ bytesExpr fullMinimalManifestBytes ++ " [(99) (111) (110) (116) (101) (110) (116) (101) (114)])"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let actualResult = result env
|
|
case actualResult of
|
|
(Fork trueTag (Fork _ _)) | trueTag == trueT -> return ()
|
|
_ -> assertFailure $ "expected ok result, got: " ++ show actualResult
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Step 6: lookupMetadata
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "lookupMetadata: finds metadata by tag" $ do
|
|
let tlv1 = makeTLVPair 1 "my-pkg"
|
|
let tlv2 = makeTLVPair 2 "1.0"
|
|
let input = "lookupMetadata (" ++ tlv1 ++ ") " ++ bytesExpr [(0), (1)]
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= justT (bytesT [109,121,45,112,107,103])
|
|
|
|
, testCase "lookupMetadata: returns nothing for unknown tag" $ do
|
|
let tlv1 = makeTLVPair 1 "my-pkg"
|
|
let input = "lookupMetadata " ++ tlv1 ++ " " ++ bytesExpr [(0), (2)]
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= nothingT
|
|
|
|
, testCase "lookupMetadata: returns nothing for empty list" $ do
|
|
let input = "lookupMetadata [] " ++ bytesExpr [(0), (1)]
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= nothingT
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Step 7: Export selection
|
|
-- ------------------------------------------------------------------------
|
|
|
|
-- Build export entry: (pair name (pair rootHash (pair kind abi)))
|
|
-- Test: select export by explicit name ("main")
|
|
, testCase "selectExport: finds export by explicit name" $ do
|
|
let input = "selectExport " ++ multiExportExpr ++ " " ++ bytesExpr (map (fromIntegral . fromEnum) "main")
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let actualResult = result env
|
|
case actualResult of
|
|
(Fork _ (Fork _ _)) -> return () -- ok result
|
|
_ -> assertFailure $ "expected ok result, got: " ++ show actualResult
|
|
|
|
-- Test: selectExport prefers "main" when no explicit name
|
|
, testCase "selectExport: selects 'main' when no explicit name and 'main' exists" $ do
|
|
let input = "selectExport " ++ multiExportExpr ++ " " ++ bytesExpr []
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let actualResult = result env
|
|
case actualResult of
|
|
(Fork _ (Fork _ _)) -> return () -- ok result
|
|
_ -> assertFailure $ "expected ok result, got: " ++ show actualResult
|
|
|
|
-- Test: selectExport selects single export when only one exists
|
|
, testCase "selectExport: auto-selects single export" $ do
|
|
let input = "selectExport " ++ singleExportExpr ++ " " ++ bytesExpr []
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let actualResult = result env
|
|
case actualResult of
|
|
(Fork _ (Fork _ _)) -> return () -- ok result
|
|
_ -> assertFailure $ "expected ok result, got: " ++ show actualResult
|
|
|
|
-- Test: getExportNames lists all export names
|
|
, testCase "getExportNames: returns list of all export names" $ do
|
|
let input = "getExportNames " ++ multiExportExpr
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let actualResult = result env
|
|
-- Should return a list of two byte strings
|
|
case actualResult of
|
|
(Fork (Fork _ _) (Fork (Fork _ _) _)) -> return () -- list with 2 items
|
|
_ -> assertFailure $ "expected list of 2 items, got: " ++ show actualResult
|
|
|
|
-- Test: selectExport errors when multiple exports but no "main" and no explicit name
|
|
, testCase "selectExport: errors with multiple exports but no 'main'" $ do
|
|
let multiNoMain =
|
|
"["
|
|
++ exportEntryExpr "validate" (replicate 32 0) "term" "arboricx.abi.tree.v1"
|
|
++ " "
|
|
++ exportEntryExpr "test" (replicate 32 1) "term" "arboricx.abi.tree.v1"
|
|
++ "]"
|
|
let input = "selectExport " ++ multiNoMain ++ " " ++ bytesExpr []
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let actualResult = result env
|
|
case actualResult of
|
|
(Fork falseT _) -> return () -- err result
|
|
_ -> assertFailure $ "expected err result, got: " ++ show actualResult
|
|
|
|
-- Test: selectExportOpt works with Just bytes (explicit name given)
|
|
, testCase "selectExportOpt: selects by explicit name when given" $ do
|
|
let input = "selectExportOpt " ++ multiExportExpr ++ " " ++ bytesExpr (map (fromIntegral . fromEnum) "validate")
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let actualResult = result env
|
|
case actualResult of
|
|
(Fork _ (Fork _ _)) -> return () -- ok result
|
|
_ -> assertFailure $ "expected ok result, got: " ++ show actualResult
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Step 8: validateManifestCore
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "validateManifestCore: passes on valid core" $ do
|
|
let input = "matchResult (code rest : err code rest) (core rest : validateManifestCore core " ++ bytesExpr [(1), (2)] ++ ") (readManifestCore " ++ bytesExpr minimalManifestCoreBytes ++ ")"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let actualResult = result env
|
|
case actualResult of
|
|
(Fork trueTag (Fork _ rest)) | trueTag == trueT -> rest @?= bytesT [1,2]
|
|
_ -> assertFailure $ "expected ok result, got: " ++ show actualResult
|
|
|
|
, testCase "validateManifestCore: fails on wrong schema" $ do
|
|
let badCoreBytes = take 16 minimalManifestCoreBytes ++ map (fromIntegral . fromEnum) "z" ++ drop 17 minimalManifestCoreBytes
|
|
let input = "matchResult (code rest : err code rest) (core rest : validateManifestCore core " ++ bytesExpr [] ++ ") (readManifestCore " ++ bytesExpr badCoreBytes ++ ")"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let actualResult = result env
|
|
case actualResult of
|
|
(Fork falseTag _) | falseTag == falseT -> return ()
|
|
_ -> assertFailure $ "expected err result, got: " ++ show actualResult
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Step 9: readArboricxBundle (end-to-end with real fixture)
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "readArboricxBundle: parses id.arboricx fixture" $ do
|
|
fixtureBytes <- BS.readFile "test/fixtures/id.arboricx"
|
|
case decodeBundle fixtureBytes of
|
|
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
|
Right bundle -> do
|
|
let manifestBytes = bundleManifestBytes bundle
|
|
-- The manifest section should be parseable
|
|
let input = "readManifest " ++ bytesExpr (map toInteger (BS.unpack manifestBytes))
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let actualResult = result env
|
|
case actualResult of
|
|
(Fork trueTag (Fork _ _)) | trueTag == trueT -> return ()
|
|
_ -> assertFailure $ "readManifest failed on id.arboricx manifest: " ++ show actualResult
|
|
|
|
, testCase "readArboricxBundle: end-to-end bundle parse" $ do
|
|
fixtureBytes <- BS.readFile "test/fixtures/id.arboricx"
|
|
let input = "readArboricxBundle " ++ bytesExpr (map toInteger (BS.unpack fixtureBytes))
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let actualResult = result env
|
|
case actualResult of
|
|
(Fork _ (Fork _ _)) -> return () -- ok: (pair validManifest afterManifest)
|
|
_ -> assertFailure $ "readArboricxBundle failed: " ++ show actualResult
|
|
|
|
, testCase "readArboricxBundle: rejects bundle with wrong manifest core" $ do
|
|
fixtureBytes <- BS.readFile "test/fixtures/id.arboricx"
|
|
-- Modify a byte in the manifest section to invalidate it
|
|
-- The manifest starts at offset 152 in the bundle (from header dirOffset=32)
|
|
-- Section directory: 2 entries * 60 = 120 bytes, starting at offset 32
|
|
-- Manifest entry at directory offset 32: type(4) + version(2) + flags(2) + compression(2) + digestAlg(2) + offset(8) + length(8) + digest(32) = 60
|
|
-- Manifest offset = 32 + 60 = 92
|
|
-- The manifest itself starts at offset 152 (0x98)
|
|
-- Change byte at position 152+8 = 160 from 'a' (97) to 'z' (122) to break the schema string
|
|
let bs = map toInteger (BS.unpack fixtureBytes)
|
|
let modifiedBs = take 160 bs ++ [122] ++ drop 161 bs
|
|
let input = "readArboricxBundle " ++ bytesExpr modifiedBs
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let actualResult = result env
|
|
case actualResult of
|
|
(Fork falseT _) -> return () -- err result (validation failure)
|
|
_ -> assertFailure $ "expected err result, got: " ++ show actualResult
|
|
|
|
-- ------------------------------------------------------------------------
|
|
-- Comprehensive end-to-end: extract manifest fields and verify as strings
|
|
-- ------------------------------------------------------------------------
|
|
|
|
, testCase "readArboricxBundle: extracts and validates manifest schema" $ do
|
|
fixtureBytes <- BS.readFile "test/fixtures/id.arboricx"
|
|
let input = extractManifestField fixtureBytes "manifestSchema"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let schemaT = result env
|
|
toString schemaT @?= Right "arboricx.bundle.manifest.v1"
|
|
|
|
, testCase "readArboricxBundle: extracts and validates bundleType" $ do
|
|
fixtureBytes <- BS.readFile "test/fixtures/id.arboricx"
|
|
let input = extractManifestField fixtureBytes "manifestBundleType"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let bundleTypeT = result env
|
|
toString bundleTypeT @?= Right "tree-calculus-executable-object"
|
|
|
|
, testCase "readArboricxBundle: extracts and validates runtime evaluation" $ do
|
|
fixtureBytes <- BS.readFile "test/fixtures/id.arboricx"
|
|
let input = extractManifestField fixtureBytes "manifestRuntimeEvaluation"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let evalT = result env
|
|
toString evalT @?= Right "normal-order"
|
|
|
|
, testCase "readArboricxBundle: extracts and validates runtime ABI" $ do
|
|
fixtureBytes <- BS.readFile "test/fixtures/id.arboricx"
|
|
let input = extractManifestField fixtureBytes "manifestRuntimeAbi"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let abiT = result env
|
|
toString abiT @?= Right "arboricx.abi.tree.v1"
|
|
|
|
, testCase "readArboricxBundle: extracts and validates root names" $ do
|
|
fixtureBytes <- BS.readFile "test/fixtures/id.arboricx"
|
|
let input = "matchResult "
|
|
++ " (errCode rest : errCode) "
|
|
++ " (bundleResult rest : "
|
|
++ " matchPair "
|
|
++ " (validCore metadataWithExtensions : "
|
|
++ " matchList "
|
|
++ " (err 99 t) " -- empty roots
|
|
++ " (rootEntry rest : "
|
|
++ " matchPair "
|
|
++ " (_ roleField : roleField) "
|
|
++ " rootEntry) "
|
|
++ " (manifestRoots validCore)) "
|
|
++ " bundleResult) "
|
|
++ " (readArboricxBundle " ++ bytesExpr (map toInteger $ BS.unpack fixtureBytes) ++ ")"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let rootRoleT = result env
|
|
-- Should find at least one root with a role (either "default" or "root")
|
|
case toString rootRoleT of
|
|
Right role -> assertBool "root role should be 'default' or 'root'"
|
|
(role == "default" || role == "root")
|
|
Left err -> assertFailure $ "failed to extract root role: " ++ err
|
|
|
|
, testCase "readArboricxBundle: extracts and validates closure" $ do
|
|
fixtureBytes <- BS.readFile "test/fixtures/id.arboricx"
|
|
let input = "matchResult "
|
|
++ " (errCode rest : errCode) "
|
|
++ " (bundleResult rest : "
|
|
++ " matchPair "
|
|
++ " (validCore metadataWithExtensions : "
|
|
++ " matchPair "
|
|
++ " (closure _ : closure) "
|
|
++ " (manifestClosureByte validCore)) "
|
|
++ " bundleResult) "
|
|
++ " (readArboricxBundle " ++ bytesExpr (map toInteger $ BS.unpack fixtureBytes) ++ ")"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let closureT = result env
|
|
case toNumber closureT of
|
|
Right 0 -> return ()
|
|
Right n -> assertFailure $ "closure should be 0, got " ++ show n
|
|
Left err -> assertFailure $ "failed to extract closure: " ++ err
|
|
|
|
, testCase "readArboricxBundle: extracts and validates hash algorithm" $ do
|
|
fixtureBytes <- BS.readFile "test/fixtures/id.arboricx"
|
|
let input = extractManifestField fixtureBytes "manifestTreeHashAlgorithm"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
let algoT = result env
|
|
toString algoT @?= Right "sha256"
|
|
|
|
, testCase "readArboricxExecutable: reconstructs default export tree" $ do
|
|
(srcConn, termHash, originalTerm) <- storeTermInTempDB $ unlines
|
|
[ "main = t t" ]
|
|
wireData <- exportBundle srcConn [termHash]
|
|
let input = "matchResult "
|
|
++ " (code rest : err code rest) "
|
|
++ " (tree rest : ok tree []) "
|
|
++ " (readArboricxExecutable " ++ bytesExpr (map toInteger $ BS.unpack wireData) ++ ")"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
result env @?= okT originalTerm (bytesT [])
|
|
close srcConn
|
|
|
|
, testCase "readArboricxExecutableByName: selects named export" $ do
|
|
srcConn <- newContentStore
|
|
let parsed = parseTricu $ unlines
|
|
[ "leaf = t"
|
|
, "stem = t t"
|
|
, "main = stem"
|
|
]
|
|
env = evalTricu Map.empty parsed
|
|
leafTerm = maybe (error "leaf missing") id (Map.lookup "leaf" env)
|
|
stemTerm = maybe (error "stem missing") id (Map.lookup "stem" env)
|
|
leafHash <- storeTerm srcConn ["leaf"] leafTerm
|
|
stemHash <- storeTerm srcConn ["stem"] stemTerm
|
|
wireData <- exportNamedBundle srcConn [("leaf", leafHash), ("stem", stemHash)]
|
|
let input = "matchResult "
|
|
++ " (code rest : err code rest) "
|
|
++ " (tree rest : ok tree []) "
|
|
++ " (readArboricxExecutableByName " ++ bytesExpr (map (fromIntegral . fromEnum) "stem") ++ " " ++ bytesExpr (map toInteger $ BS.unpack wireData) ++ ")"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let resultEnv = evalTricu library (parseTricu input)
|
|
result resultEnv @?= okT stemTerm (bytesT [])
|
|
close srcConn
|
|
|
|
, testCase "runArboricx: applies host-provided argument to default export" $ do
|
|
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
|
|
[ "main = (x : x)" ]
|
|
wireData <- exportBundle srcConn [termHash]
|
|
let input = "matchResult "
|
|
++ " (code rest : err code rest) "
|
|
++ " (value rest : value) "
|
|
++ " (runArboricx " ++ bytesExpr (map toInteger $ BS.unpack wireData) ++ " \"hello\")"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
toString (result env) @?= Right "hello"
|
|
close srcConn
|
|
|
|
, testCase "runArboricxArgs: applies host-provided argument list in order" $ do
|
|
(srcConn, termHash, _) <- storeTermInTempDB $ unlines
|
|
[ "main = (x y : x)" ]
|
|
wireData <- exportBundle srcConn [termHash]
|
|
let input = "matchResult "
|
|
++ " (code rest : err code rest) "
|
|
++ " (value rest : value) "
|
|
++ " (runArboricxArgs " ++ bytesExpr (map toInteger $ BS.unpack wireData) ++ " [(\"left\") (\"right\")])"
|
|
library <- evaluateFile "./lib/arboricx.tri"
|
|
let env = evalTricu library (parseTricu input)
|
|
toString (result env) @?= Right "left"
|
|
close srcConn
|
|
]
|