1313 lines
50 KiB
Haskell
1313 lines
50 KiB
Haskell
module Main where
|
|
|
|
import Eval
|
|
import FileEval
|
|
import Lexer
|
|
import Parser
|
|
import REPL
|
|
import Research
|
|
import Wire
|
|
import ContentStore
|
|
import IODriver
|
|
|
|
import Control.Exception (evaluate, try, SomeException)
|
|
import Control.Monad (forM_)
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import System.IO.Temp (withSystemTempDirectory)
|
|
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.Sequence as Seq
|
|
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
|
|
, tricuReaderTests
|
|
, byteListUtilities
|
|
, ioDriverTests
|
|
]
|
|
|
|
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
|
|
|
|
wireTests :: TestTree
|
|
wireTests = testGroup "Wire Tests"
|
|
[ testCase "Indexed bundle: header and manifest declare indexed format" $ do
|
|
let term = result $ evalTricu Map.empty $ parseTricu "id = a : a\nmain = id t"
|
|
bundle = buildBundle [("main", term)]
|
|
wireData = encodeBundle bundle
|
|
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 decoded -> do
|
|
let manifest = bundleManifest decoded
|
|
tree = manifestTree manifest
|
|
hashSpec = treeNodeHash tree
|
|
manifestSchema manifest @?= "arboricx.bundle.manifest.v1"
|
|
manifestBundleType manifest @?= "tree-calculus-executable-object"
|
|
manifestClosure manifest @?= ClosureComplete
|
|
treeCalculus tree @?= "tree-calculus.v1"
|
|
treeNodePayload tree @?= "arboricx.indexed.payload.v1"
|
|
nodeHashAlgorithm hashSpec @?= "indexed"
|
|
nodeHashDomain hashSpec @?= "arboricx.indexed.node.v1"
|
|
bundleRoots decoded @?= bundleRoots bundle
|
|
case manifestExports manifest of
|
|
[exported] -> do
|
|
exportName exported @?= "main"
|
|
exportRoot exported @?= head (bundleRoots bundle)
|
|
exportKind exported @?= "term"
|
|
exportAbi exported @?= "arboricx.abi.tree.v1"
|
|
exports -> assertFailure $ "Expected one export, got: " ++ show exports
|
|
|
|
, testCase "Indexed bundle: deterministic encoding" $ do
|
|
let term = result $ evalTricu Map.empty $ parseTricu "x = t t\nmain = t x"
|
|
bundle1 = buildBundle [("main", term)]
|
|
bundle2 = buildBundle [("main", term)]
|
|
encodeBundle bundle1 @?= encodeBundle bundle2
|
|
|
|
, testCase "Indexed bundle: renaming export changes bytes" $ do
|
|
let term = result $ evalTricu Map.empty $ parseTricu "f = a : a\nmain = f t"
|
|
mainBundle = buildBundle [("main", term)]
|
|
renamedBundle = buildBundle [("validate", term)]
|
|
encodeBundle mainBundle /= encodeBundle renamedBundle @? "different export names should produce different bytes"
|
|
-- But nodes are identical
|
|
bundleNodes mainBundle @?= bundleNodes renamedBundle
|
|
|
|
, testCase "Indexed bundle: verify rejects out-of-bounds root" $ do
|
|
let term = Leaf
|
|
bundle = buildBundle [("main", term)]
|
|
badBundle = bundle { bundleRoots = [99] }
|
|
case verifyBundle badBundle of
|
|
Left err -> assertBool ("Expected bounds error, got: " ++ err) ("out of bounds" `isInfixOf` err)
|
|
Right () -> assertFailure "Expected out-of-bounds root to be rejected"
|
|
|
|
, testCase "Indexed bundle: verify rejects out-of-bounds child index" $ do
|
|
let bundle = Bundle
|
|
{ bundleVersion = 1000
|
|
, bundleRoots = [1]
|
|
, bundleNodes = Seq.fromList [BNLeaf, BNStem 99]
|
|
, bundleManifest = (bundleManifest $ buildBundle [("main", Leaf)])
|
|
{ manifestRoots = [BundleRoot 1 "default"]
|
|
, manifestExports = [BundleExport "main" 1 "term" "arboricx.abi.tree.v1"]
|
|
}
|
|
, bundleManifestBytes = BS.empty
|
|
}
|
|
case verifyBundle bundle of
|
|
Left err -> assertBool ("Expected bounds error, got: " ++ err) ("references child 99" `isInfixOf` err)
|
|
Right () -> assertFailure "Expected out-of-bounds child to be rejected"
|
|
|
|
, testCase "Indexed bundle: verify rejects acyclic (forward reference)" $ do
|
|
let bundle = Bundle
|
|
{ bundleVersion = 1000
|
|
, bundleRoots = [1]
|
|
, bundleNodes = Seq.fromList [BNStem 1, BNLeaf] -- index 0 refers to 1 (forward)
|
|
, bundleManifest = (bundleManifest $ buildBundle [("main", Leaf)])
|
|
{ manifestRoots = [BundleRoot 1 "default"]
|
|
, manifestExports = [BundleExport "main" 1 "term" "arboricx.abi.tree.v1"]
|
|
}
|
|
, bundleManifestBytes = BS.empty
|
|
}
|
|
case verifyBundle bundle of
|
|
Left err -> assertBool ("Expected acyclicity error, got: " ++ err) ("references child 1" `isInfixOf` err)
|
|
Right () -> assertFailure "Expected forward reference to be rejected"
|
|
|
|
, testCase "Indexed bundle: verify rejects duplicate nodes" $ do
|
|
let bundle = Bundle
|
|
{ bundleVersion = 1000
|
|
, bundleRoots = [0]
|
|
, bundleNodes = Seq.fromList [BNLeaf, BNLeaf]
|
|
, bundleManifest = (bundleManifest $ buildBundle [("main", Leaf)])
|
|
{ manifestRoots = [BundleRoot 0 "default"]
|
|
, manifestExports = [BundleExport "main" 0 "term" "arboricx.abi.tree.v1"]
|
|
}
|
|
, bundleManifestBytes = BS.empty
|
|
}
|
|
case verifyBundle bundle of
|
|
Left err -> assertBool ("Expected duplicate error, got: " ++ err) ("duplicate" `isInfixOf` err)
|
|
Right () -> assertFailure "Expected duplicate nodes to be rejected"
|
|
|
|
, testCase "Indexed bundle: import into content store" $ do
|
|
let term = result $ evalTricu Map.empty $ parseTricu "validateEmail = a : a\nmain = validateEmail t"
|
|
bundle = buildBundle [("validateEmail", term)]
|
|
wireData = encodeBundle bundle
|
|
dstConn <- newContentStore
|
|
roots <- importBundle dstConn wireData
|
|
roots @?= ["validateEmail"]
|
|
loaded <- loadTerm dstConn "validateEmail"
|
|
loaded @?= Just term
|
|
close dstConn
|
|
|
|
, testCase "Indexed bundle: round-trip decode and verify" $ do
|
|
let term = result $ evalTricu Map.empty $ parseTricu "x = t\ny = t x\nz = t y\nmain = z"
|
|
bundle = buildBundle [("main", term)]
|
|
wireData = encodeBundle bundle
|
|
case decodeBundle wireData of
|
|
Left err -> assertFailure $ "decodeBundle failed: " ++ err
|
|
Right decoded -> case verifyBundle decoded of
|
|
Left err -> assertFailure $ "verifyBundle failed: " ++ err
|
|
Right () -> do
|
|
bundleRoots decoded @?= bundleRoots bundle
|
|
Seq.length (bundleNodes decoded) @?= Seq.length (bundleNodes bundle)
|
|
|
|
, testCase "Indexed bundle: unsupported manifest semantics rejected" $ do
|
|
let term = Leaf
|
|
bundle = buildBundle [("main", term)]
|
|
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"
|
|
]
|
|
|
|
-- --------------------------------------------------------------------------
|
|
-- Tricu reader tests
|
|
-- Smoke-test the tricu-native Arboricx reader against indexed bundles.
|
|
-- --------------------------------------------------------------------------
|
|
|
|
tricuReaderTests :: TestTree
|
|
tricuReaderTests = testGroup "Tricu Reader Tests"
|
|
[ testCase "Tricu reader parses indexed bundle (id fixture)" $ do
|
|
bundleBytes <- BS.readFile "./test/fixtures/id.arboricx"
|
|
let bundleT = ofBytes bundleBytes
|
|
readerEnv <- evaluateFile "./lib/arboricx.tri"
|
|
let env = Map.insert "testBundle" bundleT readerEnv
|
|
tagExpr = parseTricu "pairFirst (runArboricx testBundle t)"
|
|
tag = result (evalTricu env tagExpr)
|
|
codeExpr = parseTricu "pairFirst (pairSecond (runArboricx testBundle t))"
|
|
code = result (evalTricu env codeExpr)
|
|
tag @?= trueT
|
|
|
|
, testCase "Tricu reader parses indexed bundle (append fixture)" $ do
|
|
bundleBytes <- BS.readFile "./test/fixtures/append.arboricx"
|
|
let bundleT = ofBytes bundleBytes
|
|
readerEnv <- evaluateFile "./lib/arboricx.tri"
|
|
let env = Map.insert "testBundle" bundleT readerEnv
|
|
tagExpr = parseTricu "pairFirst (runArboricx testBundle t)"
|
|
tag = result (evalTricu env tagExpr)
|
|
tag @?= trueT
|
|
|
|
, testCase "Tricu reader parses indexed bundle (bool fixtures)" $ do
|
|
forM_ ["true", "false"] $ \name -> do
|
|
bundleBytes <- BS.readFile ("./test/fixtures/" ++ name ++ ".arboricx")
|
|
let bundleT = ofBytes bundleBytes
|
|
readerEnv <- evaluateFile "./lib/arboricx.tri"
|
|
let env = Map.insert "testBundle" bundleT readerEnv
|
|
tagExpr = parseTricu "pairFirst (runArboricx testBundle t)"
|
|
tag = result (evalTricu env tagExpr)
|
|
tag @?= trueT
|
|
]
|
|
|
|
-- --------------------------------------------------------------------------
|
|
-- 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
|
|
]
|
|
|
|
-- --------------------------------------------------------------------------
|
|
-- IO driver tests
|
|
-- --------------------------------------------------------------------------
|
|
|
|
ioDriverTests :: TestTree
|
|
ioDriverTests = testGroup "IO driver tests"
|
|
[ testCase "readFile through onReadFile returns file contents" $
|
|
withSystemTempDirectory "tricu-io-read" $ \dir -> do
|
|
let sourcePath = dir ++ "/input.txt"
|
|
writeFile sourcePath "abc123"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onReadFile \"" ++ sourcePath ++ "\""
|
|
, " (err rest : pure \"read failed\")"
|
|
, " (contents rest : pure contents))"
|
|
]
|
|
final @?= ofString "abc123"
|
|
|
|
, testCase "readFile error path returns explicit error branch" $
|
|
withSystemTempDirectory "tricu-io-read-missing" $ \dir -> do
|
|
let sourcePath = dir ++ "/missing.txt"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onReadFile \"" ++ sourcePath ++ "\""
|
|
, " (err rest : pure \"read failed\")"
|
|
, " (contents rest : pure contents))"
|
|
]
|
|
final @?= ofString "read failed"
|
|
|
|
, testCase "chains multiple readFile actions through Result-aware helper" $
|
|
withSystemTempDirectory "tricu-io-chain" $ \dir -> do
|
|
let firstPath = dir ++ "/first.txt"
|
|
secondPath = dir ++ "/second.txt"
|
|
writeFile firstPath "abc"
|
|
writeFile secondPath "def"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onReadFile \"" ++ firstPath ++ "\""
|
|
, " (err rest : pure \"first read failed\")"
|
|
, " (first rest : onReadFile \"" ++ secondPath ++ "\""
|
|
, " (err rest : pure \"second read failed\")"
|
|
, " (second rest : pure (append first second))))"
|
|
]
|
|
final @?= ofString "abcdef"
|
|
]
|
|
|
|
runIOSource :: String -> IO T
|
|
runIOSource source = do
|
|
ioEnv <- evaluateFile "./lib/io.tri"
|
|
env <- evalTricuWithStore Nothing ioEnv (parseTricu source)
|
|
case checkIOSentinel (mainResult env) of
|
|
Right (1, action) -> runIO defaultPerms action
|
|
Right (v, _) -> assertFailure ("Unsupported IO ABI version: " ++ show v)
|
|
Left err -> assertFailure ("Expected IO sentinel: " ++ err)
|