James Eversole
2e2db07bd6
+ let bindings + where bindings + do notation I explored enough of the alternative language design space and decided that we should commit fully to Lambda style. That means no more highly tacit/concatenative point-free/partial programs as default. We'll keep taking advantage of those capabilities when it makes sense, but the library will continue to see massive overhauls.
3641 lines
139 KiB
Haskell
3641 lines
139 KiB
Haskell
module Main where
|
|
|
|
import Eval
|
|
import FileEval
|
|
import Lexer
|
|
import Parser
|
|
import REPL
|
|
import Research
|
|
import Wire
|
|
import ContentStore
|
|
import IODriver (IOPermissions(..), checkIOSentinel, runIO, runIOWithEnv, runIOWith, unsafePerms, defaultPerms)
|
|
|
|
import Control.Exception (bracket, evaluate, try, SomeException)
|
|
import qualified Network.Socket as NS
|
|
import Control.Monad (forM_)
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import System.IO.Temp (withSystemTempDirectory)
|
|
import System.Directory (createDirectory, doesFileExist, doesDirectoryExist)
|
|
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
|
|
, maybeTests
|
|
, fileEval
|
|
, modules
|
|
, demos
|
|
, decoding
|
|
-- , elimLambdaSingle
|
|
-- , stressElimLambda
|
|
-- , byteMarshallingTests
|
|
-- , wireTests
|
|
-- , tricuReaderTests
|
|
-- , byteListUtilities
|
|
-- , binaryParserTests
|
|
, httpParsingTests
|
|
-- , 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"
|
|
|
|
, testCase "Lex <| as arrow-left token" $ do
|
|
let input = "f <| g"
|
|
expect = Right [LIdentifier "f", LArrowLeft, LIdentifier "g"]
|
|
runParser tricuLexer "" input @?= expect
|
|
|
|
, testCase "Lex <| without surrounding spaces" $ do
|
|
let input = "a<|b"
|
|
expect = Right [LIdentifier "a", LArrowLeft, LIdentifier "b"]
|
|
runParser tricuLexer "" input @?= expect
|
|
|
|
, testCase "Lex |> as arrow-right token" $ do
|
|
let input = "f |> g"
|
|
expect = Right [LIdentifier "f", LArrowRight, LIdentifier "g"]
|
|
runParser tricuLexer "" input @?= expect
|
|
|
|
, testCase "Lex |> without surrounding spaces" $ do
|
|
let input = "a|>b"
|
|
expect = Right [LIdentifier "a", LArrowRight, LIdentifier "b"]
|
|
runParser tricuLexer "" input @?= expect
|
|
|
|
, testCase "Lex <- as bind arrow token" $ do
|
|
let input = "x <- action"
|
|
expect = Right [LIdentifier "x", LBindArrow, LIdentifier "action"]
|
|
runParser tricuLexer "" input @?= expect
|
|
|
|
, testCase "Lex $ remains legal identifier char" $ do
|
|
let input = "foo$bar = 1"
|
|
expect = Right [LIdentifier "foo$bar", LAssign, LIntegerLiteral 1]
|
|
runParser tricuLexer "" input @?= expect
|
|
]
|
|
|
|
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 "Parse top-level definition arguments" $ do
|
|
let input = "const a b = a"
|
|
expect = SDef "const" ["a", "b"] (SVar "a" Nothing)
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Evaluate top-level definition arguments" $ do
|
|
tricuTestString "const a b = a\nconst 1 2" @?= "Fork (Stem Leaf) Leaf"
|
|
|
|
, testCase "Parse let expression" $ do
|
|
let input = "let x = t t in x"
|
|
expect = SApp (SLambda ["x"] (SVar "x" Nothing)) (SApp TLeaf TLeaf)
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Evaluate let expression" $ do
|
|
tricuTestString "let x = 1 in x" @?= "Fork (Stem Leaf) Leaf"
|
|
|
|
, testCase "Parse let function binding" $ do
|
|
let input = "let f x = x in f t"
|
|
expect = SApp (SLambda ["f"] (SApp (SVar "f" Nothing) TLeaf))
|
|
(SLambda ["x"] (SVar "x" Nothing))
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse where expression" $ do
|
|
let input = "x where x = t t"
|
|
expect = SApp (SLambda ["x"] (SVar "x" Nothing)) (SApp TLeaf TLeaf)
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Evaluate where expression" $ do
|
|
tricuTestString "x where x = 1" @?= "Fork (Stem Leaf) Leaf"
|
|
|
|
, testCase "Parse indented multiline definition body" $ do
|
|
let input = "x =\n t\n t"
|
|
expect = SDef "x" [] (SApp TLeaf TLeaf)
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Evaluate indented multiline let" $ do
|
|
tricuTestString "let\n x =\n 1\nin\n x" @?= "Fork (Stem Leaf) Leaf"
|
|
|
|
, testCase "Evaluate indented multiline where" $ do
|
|
tricuTestString "x\n where x =\n 1" @?= "Fork (Stem Leaf) Leaf"
|
|
|
|
, testCase "Parse explicit custom-bind do" $ do
|
|
let input = "do bind\n x <- pure t\n pure x"
|
|
expect = SApp
|
|
(SApp (SVar "bind" Nothing) (SApp (SVar "pure" Nothing) TLeaf))
|
|
(SLambda ["x"] (SApp (SVar "pure" Nothing) (SVar "x" Nothing)))
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse do statement without binder" $ do
|
|
let input = "do bind\n pure t\n pure t"
|
|
expect = SApp
|
|
(SApp (SVar "bind" Nothing) (SApp (SVar "pure" Nothing) TLeaf))
|
|
(SLambda ["_"] (SApp (SVar "pure" Nothing) TLeaf))
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Reject bare do without explicit bind operator" $ do
|
|
parsed <- try (evaluate (parseSingle "do\n x <- pure t\n pure x")) :: IO (Either SomeException TricuAST)
|
|
case parsed of
|
|
Left _ -> pure ()
|
|
Right _ -> assertFailure "Expected bare do to fail"
|
|
|
|
, 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
|
|
|
|
, testCase "Parse <| as low-precedence application" $ do
|
|
let input = "f x <| g y"
|
|
expect = SApp (SApp (SVar "f" Nothing) (SVar "x" Nothing))
|
|
(SApp (SVar "g" Nothing) (SVar "y" Nothing))
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse chained <| as left-associative" $ do
|
|
let input = "f <| g <| h"
|
|
expect = SApp (SApp (SVar "f" Nothing) (SVar "g" Nothing))
|
|
(SVar "h" Nothing)
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse <| after newline inside parens" $ do
|
|
let input = "(f x <|\n g y)"
|
|
expect = SApp (SApp (SVar "f" Nothing) (SVar "x" Nothing))
|
|
(SApp (SVar "g" Nothing) (SVar "y" Nothing))
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse <| in lambda body" $ do
|
|
let input = "(x : f x <| g)"
|
|
expect = SLambda ["x"] (SApp (SApp (SVar "f" Nothing) (SVar "x" Nothing))
|
|
(SVar "g" Nothing))
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse |> as low-precedence application" $ do
|
|
let input = "f x |> g y"
|
|
expect = SApp (SApp (SVar "g" Nothing) (SVar "y" Nothing))
|
|
(SApp (SVar "f" Nothing) (SVar "x" Nothing))
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse chained |> as left-associative" $ do
|
|
let input = "f |> g |> h"
|
|
expect = SApp (SVar "h" Nothing)
|
|
(SApp (SVar "g" Nothing) (SVar "f" Nothing))
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse |> after newline inside parens" $ do
|
|
let input = "(f x |>\n g y)"
|
|
expect = SApp (SApp (SVar "g" Nothing) (SVar "y" Nothing))
|
|
(SApp (SVar "f" Nothing) (SVar "x" Nothing))
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse |> in lambda body" $ do
|
|
let input = "(x : f x |> g)"
|
|
expect = SLambda ["x"] (SApp (SVar "g" Nothing)
|
|
(SApp (SVar "f" Nothing) (SVar "x" Nothing)))
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse mixed <| and |>" $ do
|
|
let input = "f |> g <| h"
|
|
expect = SApp (SApp (SVar "g" Nothing) (SVar "f" Nothing))
|
|
(SVar "h" Nothing)
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse forward pipe chain" $ do
|
|
let input = "x |> f |> g"
|
|
expect = SApp (SVar "g" Nothing)
|
|
(SApp (SVar "f" Nothing) (SVar "x" Nothing))
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse backward pipe" $ do
|
|
let input = "f <| x"
|
|
expect = SApp (SVar "f" Nothing) (SVar "x" Nothing)
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse backward pipe chain left associative" $ do
|
|
let input = "f <| x <| y"
|
|
expect = SApp (SApp (SVar "f" Nothing) (SVar "x" Nothing))
|
|
(SVar "y" Nothing)
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse newline after forward pipe" $ do
|
|
let input = "x |>\nf"
|
|
expect = SApp (SVar "f" Nothing) (SVar "x" Nothing)
|
|
parseSingle input @?= expect
|
|
|
|
, testCase "Parse newline after backward pipe" $ do
|
|
let input = "f <|\nx"
|
|
expect = SApp (SVar "f" Nothing) (SVar "x" Nothing)
|
|
parseSingle 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"
|
|
]
|
|
|
|
maybeTests :: TestTree
|
|
maybeTests = testGroup "Maybe Tests"
|
|
[ testCase "nothing is Leaf" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "nothing"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= Leaf
|
|
|
|
, testCase "just wraps value in Stem" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "just (t t)"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= Stem (Stem Leaf)
|
|
|
|
, testCase "matchMaybe on nothing returns default" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "matchMaybe \"empty\" (x : x) nothing"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofString "empty"
|
|
|
|
, testCase "matchMaybe on just extracts value" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "matchMaybe \"empty\" (x : x) (just (t t))"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= Stem Leaf
|
|
|
|
, testCase "maybe applies f inside just" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "maybe 0 (x : succ x) (just 5)"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 6
|
|
|
|
, testCase "maybe returns default on nothing" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "maybe 0 (x : succ x) nothing"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 0
|
|
|
|
, testCase "maybeMap transforms just value" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "maybeMap (x : succ x) (just 3)"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= justT (ofNumber 4)
|
|
|
|
, testCase "maybeMap returns nothing on nothing" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "maybeMap (x : succ x) nothing"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= nothingT
|
|
|
|
, testCase "maybeBind flattens just" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "maybeBind (just 3) (x : just (succ x))"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= justT (ofNumber 4)
|
|
|
|
, testCase "maybeBind returns nothing on nothing" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "maybeBind nothing (x : just (succ x))"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= Leaf
|
|
|
|
, testCase "maybeOr returns just value" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "maybeOr 99 (just 5)"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 5
|
|
|
|
, testCase "maybeOr returns default on nothing" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "maybeOr 99 nothing"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 99
|
|
|
|
, testCase "maybe? on just is true" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "maybe? (just t)"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "maybe? on nothing is false" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "maybe? nothing"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= falseT
|
|
]
|
|
|
|
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
|
|
|
|
, testCase "headMaybe on empty list" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "headMaybe []"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= nothingT
|
|
|
|
, testCase "headMaybe on non-empty list" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "headMaybe [(t) (t t)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= justT Leaf
|
|
|
|
, testCase "lastMaybe on empty list" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "lastMaybe []"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= nothingT
|
|
|
|
, testCase "lastMaybe on single element" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "lastMaybe [(t t)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= justT (Stem Leaf)
|
|
|
|
, testCase "lastMaybe on multi-element list" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "lastMaybe [(t) (t t) (t t t)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= justT (Fork Leaf Leaf)
|
|
|
|
, testCase "nthMaybe first element" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "nthMaybe 0 [(t) (t t)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= justT Leaf
|
|
|
|
, testCase "nthMaybe middle element" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "nthMaybe 1 [(t) (t t) (t t t)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= justT (Stem Leaf)
|
|
|
|
, testCase "nthMaybe out of bounds" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "nthMaybe 5 [(t) (t t)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= nothingT
|
|
|
|
, testCase "reverse empty list" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "reverse []"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofList []
|
|
|
|
, testCase "reverse non-empty list" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "reverse [(1) (2) (3)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofList [ofNumber 3, ofNumber 2, ofNumber 1]
|
|
|
|
, testCase "take 0 any list = empty" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "take 0 [(1) (2) (3)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofList []
|
|
|
|
, testCase "take 2 [1,2,3] = [1,2]" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "take 2 [(1) (2) (3)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofList [ofNumber 1, ofNumber 2]
|
|
|
|
, testCase "take overlong returns whole list" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "take 5 [(1) (2)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofList [ofNumber 1, ofNumber 2]
|
|
|
|
, testCase "drop 0 any list = list" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "drop 0 [(1) (2) (3)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofList [ofNumber 1, ofNumber 2, ofNumber 3]
|
|
|
|
, testCase "drop 2 [1,2,3] = [3]" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "drop 2 [(1) (2) (3)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofList [ofNumber 3]
|
|
|
|
, testCase "drop overlong returns empty" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "drop 5 [(1) (2)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofList []
|
|
|
|
, testCase "splitAt 0 [1,2] = pair [] [1,2]" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "splitAt 0 [(1) (2)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= pairT (ofList []) (ofList [ofNumber 1, ofNumber 2])
|
|
|
|
, testCase "splitAt 2 [1,2,3] = pair [1,2] [3]" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "splitAt 2 [(1) (2) (3)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= pairT (ofList [ofNumber 1, ofNumber 2]) (ofList [ofNumber 3])
|
|
|
|
, testCase "splitAt overlong = pair [1,2] []" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "splitAt 5 [(1) (2)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= pairT (ofList [ofNumber 1, ofNumber 2]) (ofList [])
|
|
|
|
, testCase "concatMap on empty list" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "concatMap (x : [(x) (x)]) []"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofList []
|
|
|
|
, testCase "concatMap doubles elements" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "concatMap (x : [(x) (x)]) [(1) (2)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofList [ofNumber 1, ofNumber 1, ofNumber 2, ofNumber 2]
|
|
|
|
, testCase "find on empty list" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "find (x : equal? x 2) []"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= nothingT
|
|
|
|
, testCase "find finds element" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "find (x : equal? x 2) [(1) (2) (3)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= justT (ofNumber 2)
|
|
|
|
, testCase "find missing element" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "find (x : equal? x 9) [(1) (2) (3)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= nothingT
|
|
|
|
, testCase "partition empty list" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "partition (x : equal? x 2) []"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= pairT (ofList []) (ofList [])
|
|
|
|
, testCase "partition splits list" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "partition (x : lt? 2 x) [(1) (2) (3) (4)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= pairT (ofList [ofNumber 3, ofNumber 4]) (ofList [ofNumber 1, ofNumber 2])
|
|
|
|
, testCase "zipWith on empty lists" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "zipWith add [] []"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofList []
|
|
|
|
, testCase "zipWith adds pairwise" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "zipWith add [(1) (2)] [(10) (20)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofList [ofNumber 11, ofNumber 22]
|
|
|
|
, testCase "zipWith truncates to shorter list" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "zipWith add [(1) (2)] [(10)]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofList [ofNumber 11]
|
|
|
|
, testCase "strLength" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "strLength \"hello\""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofNumber 5
|
|
|
|
, testCase "strAppend" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "strAppend \"hello\" \" world\""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofString "hello world"
|
|
|
|
, testCase "equal? equal strings" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "equal? \"abc\" \"abc\""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "equal? different strings" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "equal? \"abc\" \"def\""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= falseT
|
|
|
|
, testCase "strEmpty? on empty" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "strEmpty? \"\""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "strEmpty? on non-empty" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "strEmpty? \"a\""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= falseT
|
|
|
|
, testCase "startsWith? prefix matches" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "startsWith? \"he\" \"hello\""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "startsWith? prefix too long" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "startsWith? \"hello\" \"he\""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= falseT
|
|
|
|
, testCase "startsWith? empty prefix" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "startsWith? \"\" \"hello\""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "endsWith? suffix matches" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "endsWith? \"lo\" \"hello\""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "endsWith? suffix too long" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "endsWith? \"hello\" \"lo\""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= falseT
|
|
|
|
, testCase "endsWith? empty suffix" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "endsWith? \"\" \"hello\""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "contains? substring found" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "contains? \"ell\" \"hello\""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "contains? substring missing" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "contains? \"xyz\" \"hello\""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= falseT
|
|
|
|
, testCase "contains? empty needle" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "contains? \"\" \"hello\""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "lines splits on newline" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "lines \"a\\nb\\nc\""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofList [ofString "a", ofString "b", ofString "c"]
|
|
|
|
, testCase "lines single line" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "lines \"hello\""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofList [ofString "hello"]
|
|
|
|
, testCase "lines empty string" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "lines \"\""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofList [ofString ""]
|
|
|
|
, testCase "lines trailing newline" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "lines \"a\\n\""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofList [ofString "a", ofString ""]
|
|
|
|
, testCase "unlines joins with newline" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "unlines [(\"a\") (\"b\")]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofString "a\nb\n"
|
|
|
|
, testCase "unlines empty list" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "unlines []"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofString ""
|
|
|
|
, testCase "words splits on space" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "words \"hello world\""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofList [ofString "hello", ofString "world"]
|
|
|
|
, testCase "words empty string" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "words \"\""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofList []
|
|
|
|
, testCase "words multiple spaces" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "words \" hello world \""
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofList [ofString "hello", ofString "world"]
|
|
|
|
, testCase "unwords joins with space" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "unwords [(\"hello\") (\"world\")]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofString "hello world"
|
|
|
|
, testCase "unwords single word" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "unwords [(\"hello\")]"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofString "hello"
|
|
|
|
, testCase "unwords empty list" $ do
|
|
library <- evaluateFile "./lib/list.tri"
|
|
let input = "unwords []"
|
|
env = evalTricu library (parseTricu input)
|
|
result env @?= ofString ""
|
|
]
|
|
|
|
arithmeticTests :: TestTree
|
|
arithmeticTests = testGroup "Arithmetic Tests"
|
|
[ testCase "isZero? on 0" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "isZero? 0"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "isZero? on 5" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "isZero? 5"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= falseT
|
|
|
|
, testCase "add 0 3 = 3" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "add 0 3"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 3
|
|
|
|
, testCase "add 3 0 = 3" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "add 3 0"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 3
|
|
|
|
, testCase "add 2 3 = 5" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "add 2 3"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 5
|
|
|
|
, testCase "sub 5 2 = 3" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "sub 5 2"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 3
|
|
|
|
, testCase "sub 2 5 = 0 (saturated)" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "sub 2 5"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 0
|
|
|
|
, testCase "sub 5 5 = 0" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "sub 5 5"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 0
|
|
|
|
, testCase "lt? 2 3 = true" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "lt? 2 3"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "lt? 3 2 = false" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "lt? 3 2"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= falseT
|
|
|
|
, testCase "lt? 2 2 = false" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "lt? 2 2"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= falseT
|
|
|
|
, testCase "lte? 2 3 = true" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "lte? 2 3"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "lte? 3 2 = false" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "lte? 3 2"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= falseT
|
|
|
|
, testCase "lte? 2 2 = true" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "lte? 2 2"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "mul 0 5 = 0" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "mul 0 5"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 0
|
|
|
|
, testCase "mul 5 0 = 0" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "mul 5 0"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 0
|
|
|
|
, testCase "mul 2 3 = 6" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "mul 2 3"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 6
|
|
|
|
, testCase "mul 3 3 = 9" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "mul 3 3"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 9
|
|
|
|
, testCase "pred 0 = 0" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "pred 0"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 0
|
|
|
|
, testCase "pred 1 = 0" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "pred 1"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 0
|
|
|
|
, testCase "pred 5 = 4" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "pred 5"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 4
|
|
|
|
, testCase "add is commutative" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "equal? (add 4 7) (add 7 4)"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "add is associative" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "equal? (add (add 2 3) 4) (add 2 (add 3 4))"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "sub x 0 = x" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "sub 7 0"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 7
|
|
|
|
, testCase "sub chained" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "sub (sub 10 3) 2"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 5
|
|
|
|
, testCase "mul identity 1" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "mul 1 5"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 5
|
|
|
|
, testCase "mul identity 2" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "mul 5 1"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 5
|
|
|
|
, testCase "mul is commutative" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "equal? (mul 3 4) (mul 4 3)"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "mul is associative" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "equal? (mul (mul 2 3) 4) (mul 2 (mul 3 4))"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "mul distributes over add" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "equal? (mul 2 (add 3 4)) (add (mul 2 3) (mul 2 4))"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "lt? reflexive is false" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "lt? 5 5"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= falseT
|
|
|
|
, testCase "lte? reflexive is true" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "lte? 5 5"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "lt? transitivity" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "and? (lt? 2 5) (lt? 5 7)"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= trueT
|
|
|
|
, testCase "add larger numbers" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "add 12 15"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 27
|
|
|
|
, testCase "mul larger numbers" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "mul 5 6"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= ofNumber 30
|
|
|
|
, testCase "isZero? on add 0 0" $ do
|
|
base <- evaluateFile "./lib/base.tri"
|
|
let input = "isZero? (add 0 0)"
|
|
env = evalTricu base (parseTricu input)
|
|
result env @?= trueT
|
|
]
|
|
|
|
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/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/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/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 = "equal? 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 = "equal? 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 parser combinator tests
|
|
-- --------------------------------------------------------------------------
|
|
|
|
parserOk :: T -> T -> T
|
|
parserOk val rest = Fork trueT (Fork val rest)
|
|
|
|
parserErr :: T -> T -> T
|
|
parserErr code rest = Fork falseT (Fork code rest)
|
|
|
|
binaryParserTests :: TestTree
|
|
binaryParserTests = testGroup "Binary Parser Tests"
|
|
[ testCase "pureParser succeeds" $ do
|
|
lib <- evaluateFile "./lib/binary.tri"
|
|
let input = "pureParser 42 [(1) (2)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserOk (ofNumber 42) (bytesT [1, 2])
|
|
|
|
, testCase "failParser fails" $ do
|
|
lib <- evaluateFile "./lib/binary.tri"
|
|
let input = "failParser 99 [(1) (2)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserErr (ofNumber 99) (bytesT [1, 2])
|
|
|
|
, testCase "mapParser transforms value" $ do
|
|
lib <- evaluateFile "./lib/binary.tri"
|
|
let input = "mapParser succ readU8 [(1) (2)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserOk (ofNumber 2) (bytesT [2])
|
|
|
|
, testCase "bindParser chains parsers" $ do
|
|
lib <- evaluateFile "./lib/binary.tri"
|
|
let input = "bindParser readU8 (x : readU8) [(1) (2)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserOk (ofNumber 2) (bytesT [])
|
|
|
|
, testCase "thenParser discards first result" $ do
|
|
lib <- evaluateFile "./lib/binary.tri"
|
|
let input = "thenParser readU8 readU8 [(1) (2)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserOk (ofNumber 2) (bytesT [])
|
|
|
|
, testCase "orParser tries second on first failure" $ do
|
|
lib <- evaluateFile "./lib/binary.tri"
|
|
let input = "orParser (failParser 1) readU8 [(5)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserOk (ofNumber 5) (bytesT [])
|
|
|
|
, testCase "orParser returns first on success" $ do
|
|
lib <- evaluateFile "./lib/binary.tri"
|
|
let input = "orParser readU8 (failParser 1) [(5)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserOk (ofNumber 5) (bytesT [])
|
|
|
|
, testCase "readWhile consumes matching bytes" $ do
|
|
lib <- evaluateFile "./lib/binary.tri"
|
|
let input = "readWhile (x : lt? x 3) [(1) (2) (3) (4)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserOk (bytesT [1, 2]) (bytesT [3, 4])
|
|
|
|
, testCase "readWhile leaves non-matching byte" $ do
|
|
lib <- evaluateFile "./lib/binary.tri"
|
|
let input = "bindParser (readWhile (x : lt? x 3)) (x : readU8) [(1) (2) (3)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserOk (ofNumber 3) (bytesT [])
|
|
|
|
, testCase "readUntil stops at matching byte" $ do
|
|
lib <- evaluateFile "./lib/binary.tri"
|
|
let input = "readUntil (x : equal? x 3) [(1) (2) (3) (4)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserOk (bytesT [1, 2]) (bytesT [3, 4])
|
|
|
|
, testCase "readRemaining returns all bytes" $ do
|
|
lib <- evaluateFile "./lib/binary.tri"
|
|
let input = "readRemaining [(1) (2) (3)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserOk (bytesT [1, 2, 3]) (bytesT [])
|
|
|
|
, testCase "peekU8 does not consume" $ do
|
|
lib <- evaluateFile "./lib/binary.tri"
|
|
let input = "bindParser peekU8 (x : readU8) [(7) (8)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserOk (ofNumber 7) (bytesT [8])
|
|
|
|
, testCase "peekU8 second read gets same byte" $ do
|
|
lib <- evaluateFile "./lib/binary.tri"
|
|
let input = "bindParser peekU8 (x : bindParser peekU8 (y : pureParser (pair x y))) [(7)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserOk (pairT (ofNumber 7) (ofNumber 7)) (bytesT [7])
|
|
|
|
, testCase "eof? succeeds at empty input" $ do
|
|
lib <- evaluateFile "./lib/binary.tri"
|
|
let input = "eof? []"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserOk Leaf (bytesT [])
|
|
|
|
, testCase "eof? fails on non-empty input" $ do
|
|
lib <- evaluateFile "./lib/binary.tri"
|
|
let input = "eof? [(1)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserErr (ofNumber 1) (bytesT [1])
|
|
|
|
, testCase "expectAscii matches string" $ do
|
|
lib <- evaluateFile "./lib/binary.tri"
|
|
let input = "expectAscii \"hi\" [(104) (105) (106)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserOk Leaf (bytesT [106])
|
|
|
|
, testCase "expectAscii fails on mismatch" $ do
|
|
lib <- evaluateFile "./lib/binary.tri"
|
|
let input = "expectAscii \"hi\" [(104) (99)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserErr (ofNumber 2) (bytesT [104, 99])
|
|
]
|
|
|
|
-- --------------------------------------------------------------------------
|
|
-- IO driver tests
|
|
-- --------------------------------------------------------------------------
|
|
|
|
ioDriverTests :: TestTree
|
|
ioDriverTests = testGroup "IO driver tests"
|
|
[ -- Existing behaviour 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"
|
|
|
|
-- Monad law tests
|
|
, testCase "left identity: bind (pure x) f == f x" $ do
|
|
left <- runIOSource $
|
|
unlines
|
|
[ "f = x : pure (append x \"!\")"
|
|
, "main = io (bind (pure \"abc\") f)"
|
|
]
|
|
right <- runIOSource $
|
|
unlines
|
|
[ "f = x : pure (append x \"!\")"
|
|
, "main = io (f \"abc\")"
|
|
]
|
|
left @?= right
|
|
left @?= ofString "abc!"
|
|
|
|
, testCase "right identity: bind m pure == m" $
|
|
withSystemTempDirectory "tricu-io-right-id" $ \dir -> do
|
|
let path = dir ++ "/input.txt"
|
|
writeFile path "abc"
|
|
left <- runIOSource $
|
|
unlines
|
|
[ "main = io (bind (readFile \"" ++ path ++ "\")"
|
|
, " (result : pure result))"
|
|
]
|
|
right <- runIOSource $
|
|
unlines
|
|
[ "main = io (readFile \"" ++ path ++ "\")"
|
|
]
|
|
left @?= right
|
|
left @?= ioOkResult (ofString "abc")
|
|
|
|
, testCase "associativity: bind (bind m f) g == bind m (x : bind (f x) g)" $
|
|
withSystemTempDirectory "tricu-io-assoc" $ \dir -> do
|
|
let path = dir ++ "/input.txt"
|
|
writeFile path "abc"
|
|
left <- runIOSource $
|
|
unlines
|
|
[ "m = readFile \"" ++ path ++ "\""
|
|
, "f = result : matchResult (err rest : pure \"read failed\") (contents rest : pure (append contents \"-f\")) result"
|
|
, "g = value : pure (append value \"-g\")"
|
|
, "main = io (bind (bind m f) g)"
|
|
]
|
|
right <- runIOSource $
|
|
unlines
|
|
[ "m = readFile \"" ++ path ++ "\""
|
|
, "f = result : matchResult (err rest : pure \"read failed\") (contents rest : pure (append contents \"-f\")) result"
|
|
, "g = value : pure (append value \"-g\")"
|
|
, "main = io (bind m (x : bind (f x) g))"
|
|
]
|
|
left @?= right
|
|
left @?= ofString "abc-f-g"
|
|
|
|
, testCase "associativity preserves error flow" $
|
|
withSystemTempDirectory "tricu-io-assoc-err" $ \dir -> do
|
|
let missingPath = dir ++ "/missing.txt"
|
|
left <- runIOSource $
|
|
unlines
|
|
[ "m = readFile \"" ++ missingPath ++ "\""
|
|
, "f = result : matchResult (err rest : pure \"handled\") (contents rest : pure (append contents \"-ok\")) result"
|
|
, "g = value : pure (append value \"-g\")"
|
|
, "main = io (bind (bind m f) g)"
|
|
]
|
|
right <- runIOSource $
|
|
unlines
|
|
[ "m = readFile \"" ++ missingPath ++ "\""
|
|
, "f = result : matchResult (err rest : pure \"handled\") (contents rest : pure (append contents \"-ok\")) result"
|
|
, "g = value : pure (append value \"-g\")"
|
|
, "main = io (bind m (x : bind (f x) g))"
|
|
]
|
|
left @?= right
|
|
left @?= ofString "handled-g"
|
|
|
|
, testCase "bind defers continuation until left action completes" $
|
|
withSystemTempDirectory "tricu-io-lazy-k" $ \dir -> do
|
|
let path = dir ++ "/created.txt"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (bind (writeFile \"" ++ path ++ "\" \"created\")"
|
|
, " (_ : readFile \"" ++ path ++ "\"))"
|
|
]
|
|
final @?= ioOkResult (ofString "created")
|
|
|
|
-- Primitive effect shape tests
|
|
, testCase "readFile without continuation returns Result" $
|
|
withSystemTempDirectory "tricu-io-raw-read" $ \dir -> do
|
|
let path = dir ++ "/input.txt"
|
|
writeFile path "abc"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (readFile \"" ++ path ++ "\")"
|
|
]
|
|
final @?= ioOkResult (ofString "abc")
|
|
|
|
, testCase "writeFile then readFile executes exactly once" $
|
|
withSystemTempDirectory "tricu-io-once" $ \dir -> do
|
|
let path = dir ++ "/test.txt"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (bind (writeFile \"" ++ path ++ "\" \"abc\")"
|
|
, " (_ : readFile \"" ++ path ++ "\"))"
|
|
]
|
|
final @?= ioOkResult (ofString "abc")
|
|
|
|
, testCase "sequencing order is left-to-right" $
|
|
withSystemTempDirectory "tricu-io-order" $ \dir -> do
|
|
let path = dir ++ "/test.txt"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (bind (writeFile \"" ++ path ++ "\" \"a\")"
|
|
, " (_ : bind (writeFile \"" ++ path ++ "\" \"ab\")"
|
|
, " (_ : readFile \"" ++ path ++ "\")))"
|
|
]
|
|
final @?= ioOkResult (ofString "ab")
|
|
|
|
, testCase "thenIO sequences two actions and discards first result" $
|
|
withSystemTempDirectory "tricu-io-then" $ \dir -> do
|
|
let path = dir ++ "/test.txt"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (thenIO (writeFile \"" ++ path ++ "\" \"x\")"
|
|
, " (readFile \"" ++ path ++ "\"))"
|
|
]
|
|
final @?= ioOkResult (ofString "x")
|
|
|
|
, testCase "bind does not short-circuit on readFile error" $
|
|
withSystemTempDirectory "tricu-io-no-short" $ \dir -> do
|
|
let path = dir ++ "/missing.txt"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (bind (readFile \"" ++ path ++ "\")"
|
|
, " (result : pure \"continued\"))"
|
|
]
|
|
final @?= ofString "continued"
|
|
|
|
, testCase "mapIO transforms pure value" $ do
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (mapIO (pure \"abc\") (x : append x \"!\"))"
|
|
]
|
|
final @?= ofString "abc!"
|
|
|
|
-- Malformed action tests
|
|
, testCase "unknown IO action tag returns err result" $ do
|
|
final <- runIOSource "main = io (pair 99 t)"
|
|
final @?= ioErrResult "invalid action"
|
|
|
|
, testCase "malformed Bind returns err result" $ do
|
|
final <- runIOSource "main = io (pair 1 t)"
|
|
final @?= ioErrResult "invalid action"
|
|
|
|
, testCase "malformed ReadFile payload returns err result" $ do
|
|
final <- runIOSource "main = io (readFile (t t))"
|
|
final @?= ioErrResult "invalid string"
|
|
|
|
-- Permission tests
|
|
, testCase "allowed read path succeeds" $
|
|
withSystemTempDirectory "tricu-io-allowed" $ \dir -> do
|
|
let path = dir ++ "/allowed.txt"
|
|
writeFile path "allowed"
|
|
let perms = defaultPerms { allowRead = [path] }
|
|
result <- runIOSourceWithPerms perms $
|
|
unlines
|
|
[ "main = io (readFile \"" ++ path ++ "\")"
|
|
]
|
|
result @?= ioOkResult (ofString "allowed")
|
|
|
|
, testCase "readFile denied path returns err result" $
|
|
withSystemTempDirectory "tricu-io-read-denied" $ \dir -> do
|
|
let allowedPath = dir ++ "/allowed.txt"
|
|
deniedPath = dir ++ "/denied.txt"
|
|
writeFile allowedPath "allowed"
|
|
writeFile deniedPath "denied"
|
|
let perms = defaultPerms { allowRead = [allowedPath] }
|
|
result <- runIOSourceWithPerms perms $
|
|
unlines
|
|
[ "main = io (readFile \"" ++ deniedPath ++ "\")"
|
|
]
|
|
result @?= ioErrResult "permission denied"
|
|
|
|
, testCase "writeFile denied path returns err result" $
|
|
withSystemTempDirectory "tricu-io-write-denied" $ \dir -> do
|
|
let allowedPath = dir ++ "/allowed.txt"
|
|
deniedPath = dir ++ "/denied.txt"
|
|
let perms = defaultPerms { allowWrite = [allowedPath] }
|
|
result <- runIOSourceWithPerms perms $
|
|
unlines
|
|
[ "main = io (writeFile \"" ++ deniedPath ++ "\" \"x\")"
|
|
]
|
|
result @?= ioErrResult "permission denied"
|
|
|
|
, testCase "path prefix does not allow prefix bypass" $
|
|
withSystemTempDirectory "tricu-io-prefix" $ \dir -> do
|
|
let allowedDir = dir ++ "/foo"
|
|
bypassPath = dir ++ "/foobar/secret.txt"
|
|
createDirectory allowedDir
|
|
createDirectory (dir ++ "/foobar")
|
|
writeFile bypassPath "secret"
|
|
let perms = defaultPerms { allowRead = [allowedDir] }
|
|
result <- runIOSourceWithPerms perms $
|
|
unlines
|
|
[ "main = io (readFile \"" ++ bypassPath ++ "\")"
|
|
]
|
|
result @?= ioErrResult "permission denied"
|
|
|
|
-- Pure test
|
|
, testCase "pure performs no effects" $ do
|
|
final <- runIOSource "main = io (pure \"abc\")"
|
|
final @?= ofString "abc"
|
|
|
|
-- Reader tests
|
|
, testCase "ask returns initial environment" $ do
|
|
final <- runIOSourceWithEnv unsafePerms (ofString "dev") $
|
|
unlines
|
|
[ "main = io (bind ask (env : pure env))"
|
|
]
|
|
final @?= ofString "dev"
|
|
|
|
, testCase "local transforms environment" $ do
|
|
final <- runIOSourceWithEnv unsafePerms (ofString "root") $
|
|
unlines
|
|
[ "main = io (local (env : append env \"-local\") (bind ask (env : pure env)))"
|
|
]
|
|
final @?= ofString "root-local"
|
|
|
|
, testCase "local restores environment afterward" $ do
|
|
final <- runIOSourceWithEnv unsafePerms (ofString "root") $
|
|
unlines
|
|
[ "main = io (bind ask (before :"
|
|
, " bind (local (env : append env \"-local\") (bind ask (env : pure env))) (inside :"
|
|
, " bind ask (after :"
|
|
, " pure (pair before (pair inside after))))))"
|
|
]
|
|
final @?= Fork (ofString "root") (Fork (ofString "root-local") (ofString "root"))
|
|
|
|
, testCase "nested local composes correctly" $ do
|
|
final <- runIOSourceWithEnv unsafePerms (ofString "root") $
|
|
unlines
|
|
[ "f = x : append x \"-f\""
|
|
, "g = x : append x \"-g\""
|
|
, "main = io (bind"
|
|
, " (local f (local g (bind ask (env : pure env))))"
|
|
, " (inner :"
|
|
, " bind ask (after :"
|
|
, " pure (pair inner after))))"
|
|
]
|
|
final @?= Fork (ofString "root-f-g") (ofString "root")
|
|
|
|
, testCase "local result passes through bind correctly" $ do
|
|
final <- runIOSourceWithEnv unsafePerms (ofString "root") $
|
|
unlines
|
|
[ "main = io (bind"
|
|
, " (local (env : append env \"-local\") (pure \"value\"))"
|
|
, " (x : pure x))"
|
|
]
|
|
final @?= ofString "value"
|
|
|
|
, testCase "IO inside local uses transformed environment and restores after" $ do
|
|
final <- runIOSourceWithEnv unsafePerms (ofString "root") $
|
|
unlines
|
|
[ "main = io (bind"
|
|
, " (local (env : append env \"-local\")"
|
|
, " (bind ask (env : pure env)))"
|
|
, " (result :"
|
|
, " bind ask (after :"
|
|
, " pure (pair result after))))"
|
|
]
|
|
final @?= Fork (ofString "root-local") (ofString "root")
|
|
|
|
, testCase "local does not affect outer bind continuation" $ do
|
|
final <- runIOSourceWithEnv unsafePerms (ofString "root") $
|
|
unlines
|
|
[ "main = io (bind"
|
|
, " (local (env : append env \"-local\") (pure \"x\"))"
|
|
, " (_ : bind ask (env : pure env)))"
|
|
]
|
|
final @?= ofString "root"
|
|
|
|
, testCase "local environment persists across inner binds" $ do
|
|
final <- runIOSourceWithEnv unsafePerms (ofString "root") $
|
|
unlines
|
|
[ "main = io (local (env : append env \"-local\")"
|
|
, " (bind (pure t) (_ :"
|
|
, " bind ask (env : pure env))))"
|
|
]
|
|
final @?= ofString "root-local"
|
|
|
|
, testCase "local restores environment when scoped action returns error value" $ do
|
|
final <- runIOSourceWithEnv defaultPerms (ofString "root") $
|
|
unlines
|
|
[ "main = io (bind"
|
|
, " (local (env : append env \"-local\") (readFile \"definitely-missing.txt\"))"
|
|
, " (_ : bind ask (env : pure env)))"
|
|
]
|
|
final @?= ofString "root"
|
|
|
|
-- State tests
|
|
, testCase "get returns initial state" $ do
|
|
(final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 42) $
|
|
unlines
|
|
[ "main = io (bind get (s : pure s))"
|
|
]
|
|
final @?= ofNumber 42
|
|
st @?= ofNumber 42
|
|
|
|
, testCase "put updates state" $ do
|
|
(final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 0) $
|
|
unlines
|
|
[ "main = io (bind (put 100) (_ : bind get (s : pure s)))"
|
|
]
|
|
final @?= ofNumber 100
|
|
st @?= ofNumber 100
|
|
|
|
, testCase "state persists through bind" $ do
|
|
(final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 5) $
|
|
unlines
|
|
[ "main = io (bind get (s1 :"
|
|
, " bind (put (succ s1)) (_ :"
|
|
, " bind get (s2 :"
|
|
, " pure (pair s1 s2)))))"
|
|
]
|
|
final @?= Fork (ofNumber 5) (ofNumber 6)
|
|
st @?= ofNumber 6
|
|
|
|
, testCase "local does not restore state" $ do
|
|
(final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 0) $
|
|
unlines
|
|
[ "main = io (bind (put 10) (_ :"
|
|
, " bind (local (env : env) (put 20)) (_ :"
|
|
, " bind get (s :"
|
|
, " pure s))))"
|
|
]
|
|
final @?= ofNumber 20
|
|
st @?= ofNumber 20
|
|
|
|
, testCase "state and reader are independent" $ do
|
|
(final, st) <- runIOSourceWith unsafePerms (ofString "hello") (ofNumber 42) $
|
|
unlines
|
|
[ "main = io (bind ask (env :"
|
|
, " bind get (s :"
|
|
, " pure (pair env s))))"
|
|
]
|
|
final @?= Fork (ofString "hello") (ofNumber 42)
|
|
st @?= ofNumber 42
|
|
|
|
-- Async tests
|
|
, testCase "fork returns handle and await returns child value" $ do
|
|
(final, st) <- runIOSourceWith unsafePerms Leaf Leaf $
|
|
unlines
|
|
[ "main = io (bind (fork (pure \"child\")) (h :"
|
|
, " await h))"
|
|
]
|
|
final @?= ofString "child"
|
|
st @?= Leaf
|
|
|
|
, testCase "main completion abandons unawaited child" $ do
|
|
(final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
|
|
unlines
|
|
[ "main = io (bind (fork (pure \"child\")) (_ :"
|
|
, " pure \"main\"))"
|
|
]
|
|
final @?= ofString "main"
|
|
|
|
, testCase "fork captures reader environment at fork point" $ do
|
|
(final, _) <- runIOSourceWith unsafePerms (ofString "root") Leaf $
|
|
unlines
|
|
[ "main = io (local (env : append env \"-local\")"
|
|
, " (bind (fork (bind ask (env : pure env))) (h :"
|
|
, " await h)))"
|
|
]
|
|
final @?= ofString "root-local"
|
|
|
|
, testCase "fork inside local captures child env and parent restores env" $ do
|
|
(final, _) <- runIOSourceWith unsafePerms (ofString "root") Leaf $
|
|
unlines
|
|
[ "main = io (bind"
|
|
, " (local (env : append env \"-local\")"
|
|
, " (fork (bind ask (env : pure env))))"
|
|
, " (h : bind ask (after :"
|
|
, " bind (await h) (child :"
|
|
, " pure (pair after child)))))"
|
|
]
|
|
final @?= Fork (ofString "root") (ofString "root-local")
|
|
|
|
, testCase "fork copies state and child state does not merge" $ do
|
|
(final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 0) $
|
|
unlines
|
|
[ "main = io (bind (put 1) (_ :"
|
|
, " bind (fork (bind (put 99) (_ : bind get (s : pure s)))) (h :"
|
|
, " bind (put 2) (_ :"
|
|
, " bind (await h) (childState :"
|
|
, " bind get (parentState :"
|
|
, " pure (pair childState parentState)))))))"
|
|
]
|
|
final @?= Fork (ofNumber 99) (ofNumber 2)
|
|
st @?= ofNumber 2
|
|
|
|
, testCase "multiple awaiters receive same completed value" $ do
|
|
(final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
|
|
unlines
|
|
[ "main = io (bind (fork (pure \"done\")) (h :"
|
|
, " bind (await h) (a :"
|
|
, " bind (await h) (b :"
|
|
, " pure (pair a b)))))"
|
|
]
|
|
final @?= Fork (ofString "done") (ofString "done")
|
|
|
|
, testCase "self await returns async error" $ do
|
|
(final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
|
|
unlines
|
|
[ "main = io (await (pair \"task\" 0))"
|
|
]
|
|
final @?= ioErrResult "self await"
|
|
|
|
, testCase "await invalid handle returns async error" $ do
|
|
(final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
|
|
unlines
|
|
[ "main = io (await 123)"
|
|
]
|
|
final @?= ioErrResult "invalid task handle"
|
|
|
|
, testCase "yield returns unit and resumes continuation" $ do
|
|
(final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
|
|
unlines
|
|
[ "main = io (bind yield (_ : pure \"after\"))"
|
|
]
|
|
final @?= ofString "after"
|
|
|
|
, testCase "sleep resumes continuation" $ do
|
|
(final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
|
|
unlines
|
|
[ "main = io (bind (sleep 1) (_ : pure \"awake\"))"
|
|
]
|
|
final @?= ofString "awake"
|
|
|
|
, testCase "await waits for sleeping child" $ do
|
|
(final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
|
|
unlines
|
|
[ "main = io (bind (fork (bind (sleep 1) (_ : pure \"awake\"))) (h :"
|
|
, " await h))"
|
|
]
|
|
final @?= ofString "awake"
|
|
|
|
, testCase "await waits for sleeping child and returns child value" $ do
|
|
(final, st) <- runIOSourceWith unsafePerms Leaf Leaf $
|
|
unlines
|
|
[ "main = io (bind (fork (bind (sleep 1) (_ : pure \"child done\"))) (h :"
|
|
, " await h))"
|
|
]
|
|
final @?= ofString "child done"
|
|
st @?= Leaf
|
|
|
|
, testCase "sleep inside bind resumes as unit" $ do
|
|
(final, st) <- runIOSourceWith unsafePerms Leaf Leaf $
|
|
unlines
|
|
[ "main = io (bind (sleep 1) (_ : pure \"awake\"))"
|
|
]
|
|
final @?= ofString "awake"
|
|
st @?= Leaf
|
|
|
|
, testCase "fork await returns child value" $ do
|
|
(final, st) <- runIOSourceWith unsafePerms Leaf Leaf $
|
|
unlines
|
|
[ "main = io (bind (fork (pure \"child done\")) (h :"
|
|
, " await h))"
|
|
]
|
|
final @?= ofString "child done"
|
|
st @?= Leaf
|
|
|
|
-- Scheduler hardening tests
|
|
, testCase "runIO rejects non-IO tree with sentinel error" $ do
|
|
result <- runIO unsafePerms (ofString "not an io program")
|
|
case result of
|
|
Left _ -> return ()
|
|
Right _ -> assertFailure "Expected Left for invalid sentinel"
|
|
|
|
, testCase "cyclic await returns error instead of hanging" $ do
|
|
(final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
|
|
unlines
|
|
[ "main = io (bind (fork (await (pair \"task\" 0))) (h :"
|
|
, " await h))"
|
|
]
|
|
final @?= ioErrResult "cyclic await"
|
|
|
|
, testCase "writeBytes and readFile roundtrip binary data" $
|
|
withSystemTempDirectory "tricu-io-bytes" $ \dir -> do
|
|
let path = dir ++ "/binary.bin"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (bind (writeBytes \"" ++ path ++ "\" [(0) (255) (128) (1)])"
|
|
, " (_ : readFile \"" ++ path ++ "\"))"
|
|
]
|
|
final @?= ioOkResult (ofBytes (BS.pack [0, 255, 128, 1]))
|
|
|
|
, testCase "stress test: many concurrent sleepers complete promptly" $ do
|
|
let n = 5000
|
|
(final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
|
|
unlines
|
|
[ "spawner = y (self n acc : if (equal? n 0) (pure acc) (bind (fork (sleep 1)) (h : self (pred n) (pair h acc))))"
|
|
, "awaitAll = y (self hs : matchList (pure \"done\") (h r : bind (await h) (_ : self r)) hs)"
|
|
, "main = io (bind (spawner " ++ show n ++ " t) (hs : awaitAll hs))"
|
|
]
|
|
final @?= ofString "done"
|
|
|
|
, testCase "long fork await loop does not leak" $ do
|
|
let n = 200
|
|
build 0 = "pure \"done\""
|
|
build k = "bind (fork (pure \"x\")) (h : bind (await h) (_ : " ++ build (k - 1) ++ "))"
|
|
(final, _) <- runIOSourceWith unsafePerms Leaf Leaf ("main = io (" ++ build n ++ ")")
|
|
final @?= ofString "done"
|
|
|
|
, testGroup "Socket primitives"
|
|
[ testCase "socket returns ok result with valid handle" $ do
|
|
final <- runIOSource "main = io socket"
|
|
final @?= ioOkResult (Fork (ofString "sock") (ofNumber 0))
|
|
|
|
, testCase "closeSocket on invalid handle returns error" $ do
|
|
final <- runIOSource "main = io (closeSocket (pair \"sock\" 99999))"
|
|
final @?= ioErrResult "invalid socket handle"
|
|
|
|
, testCase "bindSocket and listen succeed on loopback port 0" $ do
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io ("
|
|
, " onOk socket (server rest :"
|
|
, " onOk (bindSocket server \"127.0.0.1\" 0) (_ rest :"
|
|
, " bind (listen server 1) (listenResult :"
|
|
, " pure listenResult))))"
|
|
]
|
|
final @?= ioOkResult Leaf
|
|
|
|
, testCase "connect to non-listening port returns error" $ do
|
|
final <- runIOSource "main = io (onOk socket (sock rest : connect sock \"127.0.0.1\" 1))"
|
|
case final of
|
|
Fork Leaf (Fork _ Leaf) -> return ()
|
|
other -> assertFailure $ "Expected error result, got: " ++ show other
|
|
|
|
, testCase "accept and recv receive bytes from forked client" $
|
|
withFreePort $ \port -> do
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "client = port :"
|
|
, " onOk socket (sock rest :"
|
|
, " onOk (connect sock \"127.0.0.1\" port) (_ rest :"
|
|
, " send sock [104 105]))"
|
|
, ""
|
|
, "main = io ("
|
|
, " onOk socket (server rest :"
|
|
, " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :"
|
|
, " onOk (listen server 1) (_ rest :"
|
|
, " bind (fork (client " ++ show port ++ ")) (_ :"
|
|
, " onOk (accept server) (accepted rest :"
|
|
, " recv (fst accepted) 2))))))"
|
|
]
|
|
final @?= ioOkResult (ofBytes (BS.pack [104, 105]))
|
|
|
|
, testCase "client recv receives server response via accepted socket" $
|
|
withFreePort $ \port -> do
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "serverTask = (server :"
|
|
, " onOk (accept server) (accepted rest :"
|
|
, " onOk (recv (fst accepted) 4) (msg rest :"
|
|
, " send (fst accepted) [112 111 110 103])))"
|
|
, ""
|
|
, "clientTask = (port :"
|
|
, " onOk socket (sock rest :"
|
|
, " onOk (connect sock \"127.0.0.1\" port) (_ rest :"
|
|
, " bind (send sock [112 105 110 103]) (_ :"
|
|
, " recv sock 4))))"
|
|
, ""
|
|
, "main = io ("
|
|
, " onOk socket (server rest :"
|
|
, " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :"
|
|
, " onOk (listen server 1) (_ rest :"
|
|
, " bind (fork (serverTask server)) (_ :"
|
|
, " clientTask " ++ show port ++ ")))))"
|
|
]
|
|
final @?= ioOkResult (ofBytes (BS.pack [112, 111, 110, 103]))
|
|
|
|
, testCase "recv on closed peer returns connection closed" $
|
|
withFreePort $ \port -> do
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "clientTask = port :"
|
|
, " onOk socket (sock rest :"
|
|
, " onOk (connect sock \"127.0.0.1\" port) (_ rest :"
|
|
, " closeSocket sock))"
|
|
, ""
|
|
, "main = io ("
|
|
, " onOk socket (server rest :"
|
|
, " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :"
|
|
, " onOk (listen server 1) (_ rest :"
|
|
, " bind (fork (clientTask " ++ show port ++ ")) (_ :"
|
|
, " onOk (accept server) (accepted rest :"
|
|
, " bind (yield) (_ :"
|
|
, " recv (fst accepted) 1)))))))"
|
|
]
|
|
final @?= ioErrResult "connection closed"
|
|
|
|
, testCase "accept invalid socket handle returns error" $ do
|
|
final <- runIOSource "main = io (accept (pair \"sock\" 99999))"
|
|
final @?= ioErrResult "invalid socket handle"
|
|
|
|
, testCase "recv invalid socket handle returns error" $ do
|
|
final <- runIOSource "main = io (recv (pair \"sock\" 99999) 1)"
|
|
final @?= ioErrResult "invalid socket handle"
|
|
|
|
, testCase "send invalid socket handle returns error" $ do
|
|
final <- runIOSource "main = io (send (pair \"sock\" 99999) [(1)])"
|
|
final @?= ioErrResult "invalid socket handle"
|
|
|
|
, testCase "getSocketName returns positive port after bind 0" $ do
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io ("
|
|
, " onOk socket (server rest :"
|
|
, " onOk (bindSocket server \"127.0.0.1\" 0) (_ rest :"
|
|
, " bind (getSocketName server) (nameResult :"
|
|
, " pure nameResult))))"
|
|
]
|
|
case final of
|
|
Fork (Stem Leaf) (Fork val Leaf) ->
|
|
case toNumber val of
|
|
Right port | port > 0 -> return ()
|
|
Right 0 -> assertFailure "Expected positive port, got 0"
|
|
Left _ -> assertFailure $ "Expected numeric port, got: " ++ show val
|
|
other -> assertFailure $ "Expected ok result, got: " ++ show other
|
|
|
|
, testCase "connectTo creates connected socket" $
|
|
withFreePort $ \port -> do
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "clientTask = port :"
|
|
, " onOk (connectTo \"127.0.0.1\" port) (client rest :"
|
|
, " onOk (send client [104 105]) (_ rest :"
|
|
, " pure t))"
|
|
, ""
|
|
, "main = io ("
|
|
, " onOk socket (server rest :"
|
|
, " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :"
|
|
, " onOk (listen server 1) (_ rest :"
|
|
, " bind (fork (clientTask " ++ show port ++ ")) (_ :"
|
|
, " onOk (accept server) (accepted rest :"
|
|
, " onOk (recv (fst accepted) 2) (msg rest :"
|
|
, " pure msg)))))))"
|
|
]
|
|
final @?= ofBytes (BS.pack [104, 105])
|
|
|
|
, testCase "serveOnce handles a single client connection" $
|
|
withFreePort $ \port -> do
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "echoHandler = (client peer :"
|
|
, " onOk (recv client 2) (msg rest :"
|
|
, " onOk (send client msg) (_ rest :"
|
|
, " pure t)))"
|
|
, ""
|
|
, "clientTask = (port :"
|
|
, " onOk socket (sock rest :"
|
|
, " onOk (connect sock \"127.0.0.1\" port) (_ rest :"
|
|
, " onOk (send sock [104 105]) (_ rest :"
|
|
, " onOk (recv sock 2) (msg rest :"
|
|
, " pure msg)))))"
|
|
, ""
|
|
, "main = io ("
|
|
, " onOk socket (server rest :"
|
|
, " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :"
|
|
, " onOk (listen server 1) (_ rest :"
|
|
, " bind (fork (serveOnce server echoHandler)) (_ :"
|
|
, " clientTask " ++ show port ++ ")))))"
|
|
]
|
|
final @?= ofBytes (BS.pack [104, 105])
|
|
|
|
, testCase "finally preserves successful action result" $ do
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (finally (pure 42) (pure 99))"
|
|
]
|
|
final @?= ofNumber 42
|
|
|
|
, testCase "finally runs cleanup after successful action" $
|
|
withSystemTempDirectory "tricu-finally" $ \dir -> do
|
|
let cleanupPath = dir ++ "/cleanup.txt"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (finally"
|
|
, " (pure 42)"
|
|
, " (writeFile \"" ++ cleanupPath ++ "\" \"cleaned\"))"
|
|
]
|
|
final @?= ofNumber 42
|
|
contents <- readFile cleanupPath
|
|
contents @?= "cleaned"
|
|
|
|
, testCase "bracket passes acquired resource to use" $ do
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (bracket (pure 41) (_ : pure t) (r : pure (succ r)))"
|
|
]
|
|
final @?= ofNumber 42
|
|
|
|
, testCase "bracket preserves successful use result over release result" $ do
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (bracket (pure \"res\") (_ : pure 123) (_ : pure 99))"
|
|
]
|
|
final @?= ofNumber 99
|
|
|
|
, testCase "bracket runs release on successful use" $
|
|
withSystemTempDirectory "tricu-bracket" $ \dir -> do
|
|
let releasePath = dir ++ "/release.txt"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (bracket"
|
|
, " (pure \"" ++ releasePath ++ "\")"
|
|
, " (path : writeFile path \"released\")"
|
|
, " (path : pure 99))"
|
|
]
|
|
final @?= ofNumber 99
|
|
contents <- readFile releasePath
|
|
contents @?= "released"
|
|
|
|
, testCase "bracket passes acquired resource to release" $
|
|
withSystemTempDirectory "tricu-bracket-release-resource" $ \dir -> do
|
|
let releasePath = dir ++ "/release.txt"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (bracket"
|
|
, " (pure \"" ++ releasePath ++ "\")"
|
|
, " (path : writeFile path \"released\")"
|
|
, " (_ : pure 99))"
|
|
]
|
|
final @?= ofNumber 99
|
|
contents <- readFile releasePath
|
|
contents @?= "released"
|
|
|
|
-- Directory and file management primitives
|
|
, testGroup "listDirectory"
|
|
[ testCase "listDirectory returns entry names" $
|
|
withSystemTempDirectory "tricu-listdir" $ \dir -> do
|
|
writeFile (dir ++ "/a.txt") "a"
|
|
writeFile (dir ++ "/b.txt") "b"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onListDirectory \"" ++ dir ++ "\""
|
|
, " (err rest : pure false)"
|
|
, " (entries rest :"
|
|
, " pure (pair (lExist? \"a.txt\" entries) (lExist? \"b.txt\" entries))))"
|
|
]
|
|
final @?= Fork (Stem Leaf) (Stem Leaf)
|
|
|
|
, testCase "listDirectory missing path returns does not exist" $ do
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onListDirectory \"/nonexistent/path/12345\""
|
|
, " (err rest : pure err)"
|
|
, " (_ rest : pure \"ok\"))"
|
|
]
|
|
final @?= ofString "does not exist"
|
|
|
|
, testCase "listDirectory on file returns not a directory" $
|
|
withSystemTempDirectory "tricu-listdir-file" $ \dir -> do
|
|
let path = dir ++ "/file.txt"
|
|
writeFile path "x"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onListDirectory \"" ++ path ++ "\""
|
|
, " (err rest : pure err)"
|
|
, " (_ rest : pure \"ok\"))"
|
|
]
|
|
final @?= ofString "not a directory"
|
|
|
|
, testCase "listDirectory denied path returns permission denied" $
|
|
withSystemTempDirectory "tricu-listdir-denied" $ \dir -> do
|
|
let allowedDir = dir ++ "/allowed"
|
|
deniedDir = dir ++ "/denied"
|
|
createDirectory allowedDir
|
|
createDirectory deniedDir
|
|
let perms = defaultPerms { allowRead = [allowedDir] }
|
|
final <- runIOSourceWithPerms perms $
|
|
unlines
|
|
[ "main = io (listDirectory \"" ++ deniedDir ++ "\")"
|
|
]
|
|
final @?= ioErrResult "permission denied"
|
|
]
|
|
|
|
, testCase "listDirectory excludes dot entries" $
|
|
withSystemTempDirectory "tricu-listdir-dot" $ \dir -> do
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onListDirectory \"" ++ dir ++ "\""
|
|
, " (err rest : pure false)"
|
|
, " (entries rest :"
|
|
, " pure (pair (lExist? \".\" entries) (lExist? \"..\" entries))))"
|
|
]
|
|
final @?= Fork Leaf Leaf
|
|
|
|
, testGroup "renameFile"
|
|
[ testCase "renameFile moves file atomically" $
|
|
withSystemTempDirectory "tricu-rename" $ \dir -> do
|
|
let oldPath = dir ++ "/old.txt"
|
|
newPath = dir ++ "/new.txt"
|
|
writeFile oldPath "contents"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onRenameFile \"" ++ oldPath ++ "\" \"" ++ newPath ++ "\""
|
|
, " (err rest : pure err)"
|
|
, " (_ rest : pure \"ok\"))"
|
|
]
|
|
final @?= ofString "ok"
|
|
newExists <- doesFileExist newPath
|
|
oldExists <- doesFileExist oldPath
|
|
newExists @?= True
|
|
oldExists @?= False
|
|
|
|
, testCase "renameFile missing source returns does not exist" $ do
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onRenameFile \"/nonexistent/old.txt\" \"/nonexistent/new.txt\""
|
|
, " (err rest : pure err)"
|
|
, " (_ rest : pure \"ok\"))"
|
|
]
|
|
final @?= ofString "does not exist"
|
|
|
|
, testCase "renameFile denied destination returns permission denied" $
|
|
withSystemTempDirectory "tricu-rename-denied" $ \dir -> do
|
|
let allowedDir = dir ++ "/allowed"
|
|
deniedDir = dir ++ "/denied"
|
|
createDirectory allowedDir
|
|
createDirectory deniedDir
|
|
let oldPath = allowedDir ++ "/old.txt"
|
|
newPath = deniedDir ++ "/new.txt"
|
|
writeFile oldPath "contents"
|
|
let perms = defaultPerms { allowWrite = [allowedDir] }
|
|
final <- runIOSourceWithPerms perms $
|
|
unlines
|
|
[ "main = io (renameFile \"" ++ oldPath ++ "\" \"" ++ newPath ++ "\")"
|
|
]
|
|
final @?= ioErrResult "permission denied"
|
|
|
|
, testCase "renameFile replaces existing destination atomically" $
|
|
withSystemTempDirectory "tricu-rename-replace" $ \dir -> do
|
|
let oldPath = dir ++ "/old.txt"
|
|
newPath = dir ++ "/new.txt"
|
|
writeFile oldPath "new"
|
|
writeFile newPath "old"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onRenameFile \"" ++ oldPath ++ "\" \"" ++ newPath ++ "\""
|
|
, " (err rest : pure err)"
|
|
, " (_ rest : pure \"ok\"))"
|
|
]
|
|
final @?= ofString "ok"
|
|
readFile newPath >>= (@?= "new")
|
|
oldExists <- doesFileExist oldPath
|
|
oldExists @?= False
|
|
]
|
|
|
|
, testGroup "createDirectory"
|
|
[ testCase "createDirectory creates new directory" $
|
|
withSystemTempDirectory "tricu-mkdir" $ \dir -> do
|
|
let newDir = dir ++ "/subdir"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onCreateDirectory \"" ++ newDir ++ "\""
|
|
, " (err rest : pure err)"
|
|
, " (_ rest : pure \"ok\"))"
|
|
]
|
|
final @?= ofString "ok"
|
|
exists <- doesDirectoryExist newDir
|
|
exists @?= True
|
|
|
|
, testCase "createDirectory is idempotent for existing directory" $
|
|
withSystemTempDirectory "tricu-mkdir-idempotent" $ \dir -> do
|
|
let existingDir = dir ++ "/exists"
|
|
createDirectory existingDir
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onCreateDirectory \"" ++ existingDir ++ "\""
|
|
, " (err rest : pure err)"
|
|
, " (_ rest : pure \"ok\"))"
|
|
]
|
|
final @?= ofString "ok"
|
|
|
|
, testCase "createDirectory on existing file returns already exists" $
|
|
withSystemTempDirectory "tricu-mkdir-file" $ \dir -> do
|
|
let path = dir ++ "/file.txt"
|
|
writeFile path "x"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onCreateDirectory \"" ++ path ++ "\""
|
|
, " (err rest : pure err)"
|
|
, " (_ rest : pure \"ok\"))"
|
|
]
|
|
final @?= ofString "already exists"
|
|
|
|
, testCase "createDirectory missing parent returns does not exist" $ do
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onCreateDirectory \"/nonexistent/path/12345/sub\""
|
|
, " (err rest : pure err)"
|
|
, " (_ rest : pure \"ok\"))"
|
|
]
|
|
final @?= ofString "does not exist"
|
|
|
|
, testCase "createDirectory denied path returns permission denied" $
|
|
withSystemTempDirectory "tricu-mkdir-denied" $ \dir -> do
|
|
let allowedDir = dir ++ "/allowed"
|
|
deniedDir = dir ++ "/denied"
|
|
createDirectory allowedDir
|
|
createDirectory deniedDir
|
|
let perms = defaultPerms { allowWrite = [allowedDir] }
|
|
final <- runIOSourceWithPerms perms $
|
|
unlines
|
|
[ "main = io (createDirectory \"" ++ deniedDir ++ "/new\")"
|
|
]
|
|
final @?= ioErrResult "permission denied"
|
|
, testCase "createDirectory with file parent returns not a directory or does not exist" $
|
|
withSystemTempDirectory "tricu-mkdir-file-parent" $ \dir -> do
|
|
let parentFile = dir ++ "/file"
|
|
child = parentFile ++ "/sub"
|
|
writeFile parentFile "x"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onCreateDirectory \"" ++ child ++ "\""
|
|
, " (err rest : pure err)"
|
|
, " (_ rest : pure \"ok\"))"
|
|
]
|
|
final @?= ofString "not a directory"
|
|
]
|
|
|
|
, testGroup "deleteFile"
|
|
[ testCase "deleteFile removes file" $
|
|
withSystemTempDirectory "tricu-delete" $ \dir -> do
|
|
let path = dir ++ "/del.txt"
|
|
writeFile path "x"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onDeleteFile \"" ++ path ++ "\""
|
|
, " (err rest : pure err)"
|
|
, " (_ rest : pure \"ok\"))"
|
|
]
|
|
final @?= ofString "ok"
|
|
exists <- doesFileExist path
|
|
exists @?= False
|
|
|
|
, testCase "deleteFile is idempotent for missing file" $ do
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onDeleteFile \"/nonexistent/path/12345.txt\""
|
|
, " (err rest : pure err)"
|
|
, " (_ rest : pure \"ok\"))"
|
|
]
|
|
final @?= ofString "ok"
|
|
|
|
, testCase "deleteFile on directory returns is a directory" $
|
|
withSystemTempDirectory "tricu-delete-dir" $ \dir -> do
|
|
let subDir = dir ++ "/subdir"
|
|
createDirectory subDir
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onDeleteFile \"" ++ subDir ++ "\""
|
|
, " (err rest : pure err)"
|
|
, " (_ rest : pure \"ok\"))"
|
|
]
|
|
final @?= ofString "is a directory"
|
|
|
|
, testCase "deleteFile denied path returns permission denied" $
|
|
withSystemTempDirectory "tricu-delete-denied" $ \dir -> do
|
|
let allowedDir = dir ++ "/allowed"
|
|
deniedDir = dir ++ "/denied"
|
|
createDirectory allowedDir
|
|
createDirectory deniedDir
|
|
let path = deniedDir ++ "/file.txt"
|
|
writeFile path "x"
|
|
let perms = defaultPerms { allowWrite = [allowedDir] }
|
|
final <- runIOSourceWithPerms perms $
|
|
unlines
|
|
[ "main = io (deleteFile \"" ++ path ++ "\")"
|
|
]
|
|
final @?= ioErrResult "permission denied"
|
|
]
|
|
|
|
, testGroup "fileExists"
|
|
[ testCase "fileExists true for existing file" $
|
|
withSystemTempDirectory "tricu-exists" $ \dir -> do
|
|
let path = dir ++ "/file.txt"
|
|
writeFile path "x"
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onFileExists \"" ++ path ++ "\""
|
|
, " (err rest : pure err)"
|
|
, " (exists rest : pure exists))"
|
|
]
|
|
final @?= Stem Leaf
|
|
|
|
, testCase "fileExists false for missing path" $ do
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onFileExists \"/nonexistent/path/12345.txt\""
|
|
, " (err rest : pure err)"
|
|
, " (exists rest : pure exists))"
|
|
]
|
|
final @?= Leaf
|
|
|
|
, testCase "fileExists denied path returns permission denied" $
|
|
withSystemTempDirectory "tricu-exists-denied" $ \dir -> do
|
|
let allowedDir = dir ++ "/allowed"
|
|
deniedDir = dir ++ "/denied"
|
|
createDirectory allowedDir
|
|
createDirectory deniedDir
|
|
let path = deniedDir ++ "/file.txt"
|
|
writeFile path "x"
|
|
let perms = defaultPerms { allowRead = [allowedDir] }
|
|
final <- runIOSourceWithPerms perms $
|
|
unlines
|
|
[ "main = io (fileExists \"" ++ path ++ "\")"
|
|
]
|
|
final @?= ioErrResult "permission denied"
|
|
]
|
|
|
|
, testGroup "sha256Hex"
|
|
[ testCase "sha256Hex returns lowercase hex digest" $ do
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onSha256Hex [(104) (105)]"
|
|
, " (err rest : pure err)"
|
|
, " (hex rest : pure hex))"
|
|
]
|
|
final @?= ofString "8f434346648f6b96df89dda901c5176b10a6d83961dd3c1ac88b59b2dc327aa4"
|
|
|
|
, testCase "sha256Hex empty bytes returns empty digest" $ do
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onSha256Hex []"
|
|
, " (err rest : pure err)"
|
|
, " (hex rest : pure hex))"
|
|
]
|
|
final @?= ofString "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"
|
|
|
|
, testCase "sha256Hex hashes raw bytes" $ do
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onSha256Hex [(0) (255) (1)]"
|
|
, " (err rest : pure err)"
|
|
, " (hex rest : pure hex))"
|
|
]
|
|
final @?= ofString "47ffa3ea45a70b8a41c2c0825df323c00a8b7a01c1ea06083cc41dddcc001123"
|
|
]
|
|
|
|
, testGroup "currentTime"
|
|
[ testCase "currentTime returns a positive integer" $ do
|
|
final <- runIOSource $
|
|
unlines
|
|
[ "main = io (onCurrentTime"
|
|
, " (err rest : pure 0)"
|
|
, " (v rest : pure v))"
|
|
]
|
|
case toNumber final of
|
|
Right n | n > 1600000000 -> return () -- after ~Sep 2020
|
|
Right n -> assertFailure $ "Expected recent timestamp, got: " ++ show n
|
|
Left err -> assertFailure $ "Expected number, got error: " ++ err
|
|
]
|
|
]
|
|
]
|
|
|
|
httpParsingTests :: TestTree
|
|
httpParsingTests = testGroup "HTTP Parsing Tests"
|
|
[
|
|
-- chomp / request-line reader
|
|
testCase "chomp strips trailing CR" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "chomp [(104) (105) (13)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= bytesT [104, 105]
|
|
|
|
, testCase "chomp leaves line without CR" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "chomp [(104) (105)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= bytesT [104, 105]
|
|
|
|
, testCase "chomp empty list" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "chomp []"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= bytesT []
|
|
|
|
, testCase "readLineBytes with CRLF" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "readLineBytes [(104) (105) (13) (10) (120)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= pairT (bytesT [104, 105]) (bytesT [120])
|
|
|
|
, testCase "readLineBytes with bare LF" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "readLineBytes [(104) (105) (10) (120)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= pairT (bytesT [104, 105]) (bytesT [120])
|
|
|
|
, testCase "readLineBytes empty line" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "readLineBytes [(13) (10) (120)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= pairT (bytesT []) (bytesT [120])
|
|
|
|
, testCase "readLineBytes EOF mid-line returns line" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "readLineBytes [(104) (105)]"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= pairT (bytesT [104, 105]) (bytesT [])
|
|
|
|
-- parseRequestLine
|
|
, testCase "parseRequestLine GET slash" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "parseRequestLine (append \"GET / HTTP/1.1\\r\\n\" \"x\")"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserOk
|
|
(pairT (ofString "GET") (pairT (ofString "/") (ofString "HTTP/1.1")))
|
|
(ofString "x")
|
|
|
|
, testCase "parseRequestLine POST path" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "parseRequestLine \"POST /foo/bar HTTP/1.1\\r\\n\""
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserOk
|
|
(pairT (ofString "POST") (pairT (ofString "/foo/bar") (ofString "HTTP/1.1")))
|
|
(ofString "")
|
|
|
|
, testCase "parseRequestLine too short" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "parseRequestLine \"GET\\r\\n\""
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
|
|
|
|
, testCase "parseRequestLine no version" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "parseRequestLine \"GET /foo\\r\\n\""
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
|
|
|
|
, testCase "parseRequestLine empty line" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "parseRequestLine \"\\r\\n\""
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
|
|
|
|
, testCase "parseRequestLine rejects extra fields" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "parseRequestLine \"GET / HTTP/1.1 wat\\r\\n\""
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
|
|
|
|
-- parseHeaders
|
|
, testCase "parseHeaders two headers lowercases names" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "parseHeaders (append \"Host: localhost\\r\\nContent-Length: 42\\r\\n\\r\\n\" \"x\")"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserOk
|
|
(ofList
|
|
[ pairT (ofString "host") (ofString "localhost")
|
|
, pairT (ofString "content-length") (ofString "42")
|
|
])
|
|
(ofString "x")
|
|
|
|
, testCase "parseHeaders preserves colon in value" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "parseHeaders (append \"X-Custom: a: b\\r\\n\\r\\n\" \"x\")"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserOk
|
|
(ofList [pairT (ofString "x-custom") (ofString "a: b")])
|
|
(ofString "x")
|
|
|
|
, testCase "parseHeaders accepts empty value" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "parseHeaders (append \"X-Empty:\\r\\n\\r\\n\" \"x\")"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserOk
|
|
(ofList [pairT (ofString "x-empty") (ofString "")])
|
|
(ofString "x")
|
|
|
|
, testCase "parseHeaders immediate blank" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "parseHeaders \"\\r\\nx\""
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserOk (ofList []) (ofString "x")
|
|
|
|
, testCase "parseHeaders rejects missing colon" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "parseHeaders \"Host\\r\\n\\r\\n\""
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
|
|
|
|
, testCase "parseContentLengthValue accepts max body bytes" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "matchResult \"err\" (maybeLen rest : \"ok\") (parseContentLengthValue \"1048576\")"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "ok"
|
|
|
|
, testCase "parseContentLengthValue accepts shorter decimal below max" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "matchResult \"err\" (maybeLen rest : \"ok\") (parseContentLengthValue \"999999\")"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "ok"
|
|
|
|
, testCase "parseContentLengthValue strips leading zeros before limit check" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "parseContentLengthValue \"0000000000001\""
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserOk (justT (ofNumber 1)) Leaf
|
|
|
|
, testCase "parseContentLengthValue rejects body above max" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "parseContentLengthValue \"1048577\""
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserErr (ofNumber 413) (ofString "Request body too large\n")
|
|
|
|
, testCase "parseContentLengthValue rejects longer body above max" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "parseContentLengthValue \"2000000\""
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= parserErr (ofNumber 413) (ofString "Request body too large\n")
|
|
|
|
-- statusLine / headerLine
|
|
, testCase "statusLine 200 OK" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "statusLine 200 \"OK\""
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "HTTP/1.1 200 OK\r\n"
|
|
|
|
, testCase "headerLine Content-Length" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "headerLine \"Content-Length\" \"42\""
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "Content-Length: 42\r\n"
|
|
|
|
-- statusPhrase
|
|
, testCase "statusPhrase 200" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "statusPhrase 200"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "OK"
|
|
|
|
, testCase "statusPhrase 201" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "statusPhrase 201"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "Created"
|
|
|
|
, testCase "statusPhrase 204" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "statusPhrase 204"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "No Content"
|
|
|
|
, testCase "statusPhrase 400" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "statusPhrase 400"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "Bad Request"
|
|
|
|
, testCase "statusPhrase 404" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "statusPhrase 404"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "Not Found"
|
|
|
|
, testCase "statusPhrase 405" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "statusPhrase 405"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "Method Not Allowed"
|
|
|
|
, testCase "statusPhrase 431" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "statusPhrase 431"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "Request Header Fields Too Large"
|
|
|
|
, testCase "statusPhrase 501" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "statusPhrase 501"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "Not Implemented"
|
|
|
|
, testCase "statusPhrase 505" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "statusPhrase 505"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "HTTP Version Not Supported"
|
|
|
|
, testCase "statusPhrase 500" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "statusPhrase 500"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "Internal Server Error"
|
|
|
|
, testCase "statusPhrase unknown" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "statusPhrase 999"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "Internal Server Error"
|
|
|
|
-- buildResponse
|
|
, testCase "buildResponse 200 no headers" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "buildResponse 200 [] \"hi\""
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "HTTP/1.1 200 OK\r\n\r\nhi"
|
|
|
|
, testCase "buildResponse 404 with header" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "buildResponse 404 [(pair \"Content-Length\" \"9\")] \"Not found\""
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "HTTP/1.1 404 Not Found\r\nContent-Length: 9\r\n\r\nNot found"
|
|
|
|
-- convenience responses
|
|
, testCase "okResponse" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "okResponse \"hi\""
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "HTTP/1.1 200 OK\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 2\r\nConnection: close\r\n\r\nhi"
|
|
|
|
, testCase "notFoundResponse" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "notFoundResponse"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "HTTP/1.1 404 Not Found\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 10\r\nConnection: close\r\n\r\nNot found\n"
|
|
|
|
, testCase "textResponse" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "textResponse \"hi\""
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "HTTP/1.1 200 OK\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 2\r\nConnection: close\r\n\r\nhi"
|
|
|
|
, testCase "jsonResponse" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "jsonResponse \"{}\""
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "HTTP/1.1 200 OK\r\nContent-Type: application/json\r\nContent-Length: 2\r\nConnection: close\r\n\r\n{}"
|
|
|
|
, testCase "createdResponse" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "createdResponse \"created\\n\""
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "HTTP/1.1 201 Created\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 8\r\nConnection: close\r\n\r\ncreated\n"
|
|
|
|
, testCase "emptyResponse 204" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "emptyResponse 204"
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "HTTP/1.1 204 No Content\r\nContent-Length: 0\r\nConnection: close\r\n\r\n"
|
|
|
|
, testCase "badRequestResponse" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "badRequestResponse \"Bad Request\\n\""
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "HTTP/1.1 400 Bad Request\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 12\r\nConnection: close\r\n\r\nBad Request\n"
|
|
|
|
, testCase "errorResponse 405" $ do
|
|
lib <- evaluateFile "./lib/http.tri"
|
|
let input = "errorResponse 405 \"Method Not Allowed\\n\""
|
|
env = evalTricu lib (parseTricu input)
|
|
result env @?= ofString "HTTP/1.1 405 Method Not Allowed\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 19\r\nConnection: close\r\n\r\nMethod Not Allowed\n"
|
|
]
|
|
|
|
withFreePort :: (Int -> IO a) -> IO a
|
|
withFreePort action =
|
|
bracket
|
|
(NS.socket NS.AF_INET NS.Stream NS.defaultProtocol)
|
|
NS.close
|
|
(\s -> do
|
|
NS.setSocketOption s NS.ReuseAddr 1
|
|
NS.bind s (NS.SockAddrInet 0 (NS.tupleToHostAddress (127, 0, 0, 1)))
|
|
port <- NS.socketPort s
|
|
action (fromIntegral port))
|
|
|
|
runIOSourceWith :: IOPermissions -> T -> T -> String -> IO (T, T)
|
|
runIOSourceWith perms readerEnv initialState source = do
|
|
ioEnv <- evaluateFile "./lib/io.tri"
|
|
sockEnv <- evaluateFile "./lib/socket.tri"
|
|
let combinedEnv = Map.union sockEnv ioEnv
|
|
evalEnv <- evalTricuWithStore Nothing combinedEnv (parseTricu source)
|
|
let fullTree = mainResult evalEnv
|
|
result <- runIOWith perms readerEnv initialState fullTree
|
|
case result of
|
|
Left err -> assertFailure ("IO runtime error: " ++ err)
|
|
Right pair -> pure pair
|
|
|
|
runIOSource :: String -> IO T
|
|
runIOSource source = fmap fst $ runIOSourceWith unsafePerms Leaf Leaf source
|
|
|
|
runIOSourceWithPerms :: IOPermissions -> String -> IO T
|
|
runIOSourceWithPerms perms source = fmap fst $ runIOSourceWith perms Leaf Leaf source
|
|
|
|
runIOSourceWithEnv :: IOPermissions -> T -> String -> IO T
|
|
runIOSourceWithEnv perms readerEnv source = fmap fst $ runIOSourceWith perms readerEnv Leaf source
|
|
|
|
ioOkResult :: T -> T
|
|
ioOkResult val = Fork (Stem Leaf) (Fork val Leaf)
|
|
|
|
ioErrResult :: String -> T
|
|
ioErrResult msg = Fork Leaf (Fork (ofString msg) Leaf)
|