From e2a17445082bea95e46eb098c6fe33dd1e9b03f8 Mon Sep 17 00:00:00 2001 From: James Eversole Date: Tue, 19 May 2026 17:30:43 -0500 Subject: [PATCH] Helpful library updates --- demos/interactionTrees/echo-server.tri | 60 +- lib/base.tri | 100 +++ lib/binary.tri | 70 +- lib/bytes.tri | 3 - lib/conversions.tri | 17 - lib/io.tri | 72 +- lib/list.tri | 173 +++- lib/socket.tri | 92 ++- notes/iodriver-updates.md | 749 ----------------- notes/stdlib-todo.md | 262 ++++++ test/Spec.hs | 1052 +++++++++++++++++++++--- 11 files changed, 1684 insertions(+), 966 deletions(-) delete mode 100644 notes/iodriver-updates.md create mode 100644 notes/stdlib-todo.md diff --git a/demos/interactionTrees/echo-server.tri b/demos/interactionTrees/echo-server.tri index 67f3050..21f3b46 100644 --- a/demos/interactionTrees/echo-server.tri +++ b/demos/interactionTrees/echo-server.tri @@ -2,45 +2,27 @@ !import "../../lib/io.tri" !Local !import "../../lib/socket.tri" !Local --- Preserve the host-driver Result shape on error, run okCase on success. -onOk = action okCase : - bind action (result : - matchResult - (err rest : pure result) - okCase - result) - --- Convenience: print a string and continue. -printLn = s : bind (putStr (append s "\n")) (_ : pure t) - --- Main accept+echo loop. Recursion via y. -echoLoop = y (self server : - bind (accept server) (acceptResult : - matchResult - (err rest : - bind (printLn (append "accept error: " err)) (_ : - self server)) - (accepted rest : - matchPair - (clientSock addr : - bind (printLn (append "client from " addr)) (_ : - bind (recv clientSock 4096) (msgResult : - matchResult - (err rest : - bind (closeSocket clientSock) (_ : - self server)) - (msg rest : - bind (send clientSock msg) (_ : - bind (closeSocket clientSock) (_ : - self server))) - msgResult))) - accepted) - acceptResult)) +-- Main accept+echo loop. Recursion via y. +echoLoop = y (self : server : + withAccepted_ server + (err : + bind (putStrLn (append "accept error: " err)) (_ : + self server)) + (clientSock addr : + bind (putStrLn (append "client from " addr)) (_ : + onResult_ (recv clientSock 4096) + (err : + bind (closeSocket clientSock) (_ : + self server)) + (msg : + bind (send clientSock msg) (_ : + bind (closeSocket clientSock) (_ : + self server)))))) main = io ( - onOk socket (server rest : - onOk (bindSocket server "127.0.0.1" 0) (_ rest : - onOk (listen server 5) (_ rest : - onOk (getSocketName server) (port rest : - bind (printLn (append "Echo server listening on port " (showNumber port))) (_ : + onOk_ socket (server : + onOk_ (bindSocket server "127.0.0.1" 0) (_ : + onOk_ (listen server 5) (_ : + onOk_ (getSocketName server) (port : + bind (putStrLn (append "Echo server listening on port " (showNumber port))) (_ : echoLoop server)))))) diff --git a/lib/base.tri b/lib/base.tri index a018a4d..767c0a7 100644 --- a/lib/base.tri +++ b/lib/base.tri @@ -33,6 +33,15 @@ lOr = (triage matchPair = a : triage _ _ a +fst = p : matchPair (a b : a) p +snd = p : matchPair (a b : b) p + +resultIsOk = result : + matchResult (err rest : false) (val rest : true) result + +resultIsErr = result : + matchResult (err rest : true) (val rest : false) result + not? = matchBool false true and? = matchBool id (_ : false) @@ -87,3 +96,94 @@ matchResult = (errCase okCase result : tag) payload) result) + +-- --------------------------------------------------------------------------- +-- Maybe / Option type +-- --------------------------------------------------------------------------- + +nothing = t +just = x : t x + +matchMaybe = (nothingCase justCase maybe : + triage + nothingCase + justCase + (_ _ : nothingCase) + maybe) + +maybe = default f m : matchMaybe default f m +maybeMap = f m : matchMaybe nothing (x : just (f x)) m +maybeBind = m f : matchMaybe nothing f m +maybeOr = default m : matchMaybe default id m +maybe? = matchMaybe false (_ : true) + +-- --------------------------------------------------------------------------- +-- Basic arithmetic +-- --------------------------------------------------------------------------- + +pred = y (self : triage + 0 + (_ : 0) + (bit rest : + matchBool + (matchBool + 0 + (pair 0 rest) + (equal? rest 0)) + (matchBool + 0 + (pair 1 (self rest)) + (equal? rest 0)) + bit)) + +isZero? = triage true (_ : false) (_ _ : false) + +add = y (self x y : + triage + y + (_ : succ y) + (_ _ : succ (self (pred x) y)) + x) + +sub = y (self a b : + matchBool + a + (self (pred a) (pred b)) + (isZero? b)) + +lt? = a b : not? (isZero? (sub b a)) +lte? = a b : isZero? (sub a b) + +mul = y (self a b : + matchBool + 0 + (add a (self a (pred b))) + (isZero? b)) + +-- --------------------------------------------------------------------------- +-- Result combinators +-- --------------------------------------------------------------------------- + +mapResult = (f result : + matchResult + (code rest : err code rest) + (value rest : ok (f value) rest) + result) + +bindResult = (result f : + matchResult + (code rest : err code rest) + (value rest : f value rest) + result) + +resultOr = (default result : + matchResult + (_ _ : default) + (value _ : value) + result) + +resultMapErr = (f result : + matchResult + (code rest : err (f code) rest) + (value rest : ok value rest) + result) diff --git a/lib/binary.tri b/lib/binary.tri index 5c84117..6ca4982 100644 --- a/lib/binary.tri +++ b/lib/binary.tri @@ -54,19 +54,65 @@ expectU8 = (expected bs : (byteEq? actual expected)) (readU8 bs)) -mapResult = (f result : - matchResult - (code rest : err code rest) - (value rest : ok (f value) rest) - result) - -bindResult = (result f : - matchResult - (code rest : err code rest) - (value rest : f value rest) - result) - read2 = (bs : readBytes 2 bs) read4 = (bs : readBytes 4 bs) readU16BEBytes = (bs : read2 bs) readU32BEBytes = (bs : read4 bs) + +-- --------------------------------------------------------------------------- +-- Parser combinators +-- --------------------------------------------------------------------------- + +pureParser = value bs : ok value bs +failParser = code bs : err code bs + +mapParser = f p bs : mapResult f (p bs) +bindParser = p f bs : bindResult (p bs) f +thenParser = p q bs : bindResult (p bs) (_ : q) + +orParser = (p q bs : + matchResult + (_ _ : q bs) + (value rest : ok value rest) + (p bs)) + +readWhile_ = y (self pred bs acc : + matchResult + (code rest : ok (reverse acc) bs) + (value rest : + matchBool + (self pred rest (pair value acc)) + (ok (reverse acc) (pair value rest)) + (pred value)) + (readU8 bs)) + +readWhile = pred bs : readWhile_ pred bs t + +readUntil = pred : readWhile (x : not? (pred x)) + +readRemaining = bs : ok bs t + +peekU8 = (bs : + matchResult + (code rest : err code bs) + (value rest : ok value bs) + (readU8 bs)) + +eof? = (bs : + matchBool + (ok t bs) + (err errUnexpectedEof bs) + (emptyList? bs)) + +expectAscii = expectBytes + +-- --------------------------------------------------------------------------- +-- Endian / int conversion helpers +-- --------------------------------------------------------------------------- + +u16BE = bytes : add (mul 256 (head bytes)) (head (tail bytes)) + +u16LE = bytes : add (mul 256 (head (tail bytes))) (head bytes) + +readU16BE = bs : bindParser read2 (bytes rest : ok (u16BE bytes) rest) bs +readU16LE = bs : bindParser read2 (bytes rest : ok (u16LE bytes) rest) bs diff --git a/lib/bytes.tri b/lib/bytes.tri index 7ef77cf..46a89e6 100644 --- a/lib/bytes.tri +++ b/lib/bytes.tri @@ -1,9 +1,6 @@ !import "base.tri" !Local !import "list.tri" !Local -nothing = t -just = x : t x - bytesNil? = emptyList? bytesHead = matchList nothing (h _ : just h) diff --git a/lib/conversions.tri b/lib/conversions.tri index f9de661..97621fd 100644 --- a/lib/conversions.tri +++ b/lib/conversions.tri @@ -1,23 +1,6 @@ !import "base.tri" !Local !import "list.tri" !Local -pred = y (self : triage - 0 - (_ : 0) - (bit rest : - matchBool - -- odd: 2n + 1 -> 2n - (matchBool - 0 - (pair 0 rest) - (equal? rest 0)) - -- even: 2n -> 2n - 1 - (matchBool - 0 - (pair 1 (self rest)) - (equal? rest 0)) - bit)) - incDecRev = y (self : matchList "1" (digit rest : diff --git a/lib/io.tri b/lib/io.tri index 165dfe3..b2e8603 100644 --- a/lib/io.tri +++ b/lib/io.tri @@ -37,6 +37,55 @@ sleep = ms : pair 63 ms thenIO = a b : bind a (_ : b) mapIO = action f : bind action (x : pure (f x)) +void = action : bind action (_ : pure t) + +-- --------------------------------------------------------------------------- +-- Conditional execution +-- --------------------------------------------------------------------------- + +when = cond action : matchBool action (pure t) cond +unless = cond action : matchBool (pure t) action cond + +-- --------------------------------------------------------------------------- +-- Infinite loop +-- --------------------------------------------------------------------------- + +forever = y (self : action : + bind action (_ : + self action)) + +-- --------------------------------------------------------------------------- +-- Result-aware combinators +-- --------------------------------------------------------------------------- + +-- Propagate driver Result on error; run okCase on success. +onOk = action okCase : + bind action (result : + matchResult + (err rest : pure result) + okCase + result) + +-- Same as onOk, but the okCase only receives the value (rest is dropped). +onOk_ = action okCase : + bind action (result : + matchResult + (err rest : pure result) + (val _ : okCase val) + result) + +-- Generalized Result handler with explicit branches. +onResult = action errCase okCase : + bind action (result : + matchResult errCase okCase result) + +-- Same as onResult, but handlers only receive the value/msg (rest is dropped). +onResult_ = action errCase okCase : + bind action (result : + matchResult + (err _ : errCase err) + (val _ : okCase val) + result) -- --------------------------------------------------------------------------- -- Convenience helpers @@ -49,13 +98,9 @@ putStrLn = s : bind (putStr (append s "\n")) (_ : pure t) -- Result-aware file helpers -- --------------------------------------------------------------------------- -onReadFile = (path errCase okCase : - bind (readFile path) (result : - matchResult errCase okCase result)) +onReadFile = path : onResult (readFile path) -onWriteFile = (path contents errCase okCase : - bind (writeFile path contents) (result : - matchResult errCase okCase result)) +onWriteFile = path contents : onResult (writeFile path contents) -- --------------------------------------------------------------------------- -- Convenience helpers for the common cases @@ -84,3 +129,18 @@ copyFile = (src dst : (ok rest : pure t) wr)) result)) + +-- --------------------------------------------------------------------------- +-- Resource-safe combinators +-- --------------------------------------------------------------------------- + +finally = action cleanup : + bind action (result : + bind cleanup (_ : + pure result)) + +bracket = acquire release use : + bind acquire (resource : + bind (use resource) (result : + bind (release resource) (_ : + pure result))) diff --git a/lib/list.tri b/lib/list.tri index 04a5976..046831d 100644 --- a/lib/list.tri +++ b/lib/list.tri @@ -37,9 +37,13 @@ length = y (self : matchList 0 (_ tail : succ (self tail))) -reverse = y (self : matchList - t - (head tail : append (self tail) (pair head t))) +reverse_ = y (self xs acc : + matchList + acc + (h r : self r (pair h acc)) + xs) + +reverse = xs : reverse_ xs t snoc = y (self x : matchList (pair x t) @@ -80,3 +84,166 @@ nth_ = y (self n xs i : xs) nth = n xs : nth_ n xs 0 + +headMaybe = matchList nothing (h _ : just h) + +lastMaybe = y (self : matchList + nothing + (hd tl : matchBool + (just hd) + (self tl) + (emptyList? tl))) + +nthMaybe_ = y (self n xs i : + matchList + nothing + (h r : + matchBool + (just h) + (self n r (succ i)) + (equal? i n)) + xs) + +nthMaybe = n xs : nthMaybe_ n xs 0 + +take_ = y (self n xs i : + matchList + t + (h r : + matchBool + t + (pair h (self n r (succ i))) + (equal? i n)) + xs) + +take = n xs : take_ n xs 0 + +drop_ = y (self n xs i : + matchBool + xs + (matchList + t + (_ r : self n r (succ i)) + xs) + (equal? i n)) + +drop = n xs : drop_ n xs 0 + +splitAt = n xs : pair (take n xs) (drop n xs) + +concatMap_ = y (self f xs : + matchList + t + (h r : append (f h) (self f r)) + xs) + +concatMap = f xs : concatMap_ f xs + +find = y (self pred xs : + matchList + nothing + (h r : matchBool (just h) (self pred r) (pred h)) + xs) + +partition_ = y (self pred xs trues falses : + matchList + (pair (reverse trues) (reverse falses)) + (h r : + matchBool + (self pred r (pair h trues) falses) + (self pred r trues (pair h falses)) + (pred h)) + xs) + +partition = pred xs : partition_ pred xs t t + +partition = pred xs : partition_ pred xs t t + +strLength = length +strAppend = append +strEq? = equal? +strEmpty? = emptyList? + +startsWith? = y (self prefix str : + matchList + true + (ph pr : + matchList + false + (sh sr : + matchBool + (self pr sr) + false + (equal? ph sh)) + str) + prefix) + +endsWith? = prefix str : startsWith? (reverse prefix) (reverse str) + +contains? = y (self needle haystack : + matchBool + true + (matchList + false + (_ r : self needle r) + haystack) + (startsWith? needle haystack)) + +lines_ = y (self str : + matchList + (acc current : append acc [(reverse current)]) + (h r : + acc current : + matchBool + (self r (append acc [(reverse current)]) t) + (self r acc (pair h current)) + (equal? h 10)) + str) + +lines = str : lines_ str t t + +unlines = y (self lines : + matchList + "" + (h r : append h (append "\n" (self r))) + lines) + +words_ = y (self str : + matchList + (acc current : + matchBool + acc + (append acc [(reverse current)]) + (emptyList? current)) + (h r : + acc current : + matchBool + (matchBool + (self r acc current) + (self r (append acc [(reverse current)]) t) + (emptyList? current)) + (self r acc (pair h current)) + (equal? h 32)) + str) + +words = str : words_ str t t + +unwords = y (self words : + matchList + "" + (h r : + matchBool + h + (append h (append " " (self r))) + (emptyList? r)) + words) + +zipWith = y (self f xs ys : + matchList + t + (xh xt : + matchList + t + (yh yt : pair (f xh yh) (self f xt yt)) + ys) + xs) diff --git a/lib/socket.tri b/lib/socket.tri index defe11f..2ec7094 100644 --- a/lib/socket.tri +++ b/lib/socket.tri @@ -16,48 +16,68 @@ recv = sock maxBytes : pair 76 (pair sock maxBytes) send = sock bytes : pair 77 (pair sock bytes) getSocketName = sock : pair 78 sock --- --------------------------------------------------------------------------- --- Convenience helpers --- --------------------------------------------------------------------------- +-- Result-aware wrappers over raw socket actions. +onSocket = onResult socket +onBindSocket = sock addr port : onResult (bindSocket sock addr port) +onListen = sock backlog : onResult (listen sock backlog) +onAccept = sock : onResult (accept sock) +onConnect = sock addr port : onResult (connect sock addr port) +onRecv = sock maxBytes : onResult (recv sock maxBytes) +onSend = sock bytes : onResult (send sock bytes) +onGetSocketName = sock : onResult (getSocketName sock) -onSocket = (action errCase okCase : - bind action (result : - matchResult errCase okCase result)) +-- Result-aware wrappers that drop the useless 'rest' parameter. +onSocket_ = onResult_ socket +onBindSocket_ = sock addr port : onResult_ (bindSocket sock addr port) +onListen_ = sock backlog : onResult_ (listen sock backlog) +onAccept_ = sock : onResult_ (accept sock) +onConnect_ = sock addr port : onResult_ (connect sock addr port) +onRecv_ = sock maxBytes : onResult_ (recv sock maxBytes) +onSend_ = sock bytes : onResult_ (send sock bytes) +onGetSocketName_ = sock : onResult_ (getSocketName sock) + +-- Close a socket, ignoring errors. +closeSocket_ = sock : void (closeSocket sock) -- Create a listening socket bound to an address and port. -- Returns ok listenSocket or err message. listenSocket = addr port backlog : - bind (socket) (result : - matchResult - (err rest : pure (err "socket creation failed")) - (sock rest : - bind (bindSocket sock addr port) (bindResult : - matchResult - (err rest : pure (err "bind failed")) - (_ rest : - bind (listen sock backlog) (listenResult : - matchResult - (err rest : pure (err "listen failed")) - (_ rest : pure (ok sock)) - listenResult)) - bindResult)) - result) + onOk_ socket (server : + onOk_ (bindSocket server addr port) (_ : + onOk_ (listen server backlog) (_ : + pure (ok server)))) --- Accept a connection and return (clientSocket, peerAddr). --- The returned peerAddr is a string like "127.0.0.1:8080". -onAccept = (sock errCase okCase : - bind (accept sock) (result : - matchResult errCase okCase result)) +-- Accept a connection with explicit error and ok branches. +-- okHandler receives (clientSocket, peerAddr). +withAccepted = (server errHandler okHandler : + onResult (accept server) + errHandler + (accepted rest : + okHandler (fst accepted) (snd accepted))) --- Receive all available bytes up to maxBytes. -onRecv = (sock maxBytes errCase okCase : - bind (recv sock maxBytes) (result : - matchResult errCase okCase result)) +-- Same as withAccepted, but handlers drop the useless 'rest' parameter. +withAccepted_ = (server errHandler okHandler : + onResult_ (accept server) + errHandler + (accepted : + okHandler (fst accepted) (snd accepted))) --- Send bytes and return number of bytes sent. -onSend = (sock bytes errCase okCase : - bind (send sock bytes) (result : - matchResult errCase okCase result)) +serveOnce = (server handler : + withAccepted_ server + (err : pure t) + (client peer : + handler client peer)) --- Close a socket, ignoring errors. -closeSocket_ = sock : bind (closeSocket sock) (_ : pure t) +serveForkingOnce = (server handler : + withAccepted_ server + (err : pure t) + (client peer : + fork (handler client peer))) + +serveForever = (server handler : + forever (serveForkingOnce server handler)) + +connectTo = (addr port : + onOk socket (client rest : + onOk (connect client addr port) (_ rest : + pure (ok client rest)))) diff --git a/notes/iodriver-updates.md b/notes/iodriver-updates.md deleted file mode 100644 index 025ce5c..0000000 --- a/notes/iodriver-updates.md +++ /dev/null @@ -1,749 +0,0 @@ -Below is the implementation handoff for replacing the current recursive/rebuilding IO small-step interpreter with an explicit machine stack, primarily to support `Reader` via `ask` and `local`, while setting up the right shape for eventual async. - -## Goal - -Refactor `IODriver` from this model: - -```haskell -stepIO :: IOPermissions -> T -> IO Step - -data Step - = Done T - | Continue T -``` - -to an explicit abstract machine: - -```haskell -Machine = Runtime + current action + continuation frames -``` - -This is required because `local` is dynamically scoped. It needs to modify the Reader environment for a sub-computation, then restore the previous environment exactly when that sub-computation completes. The current “rebuild `Bind left' k`” approach has nowhere to store that restoration behavior. - -This change should support: - -```tricu -ask -local -``` - -now, and keep the structure compatible with future async suspension/resumption. - -Do not implement async in this pass. - ---- - -## New action tags - -Extend the tricu IO action language with Reader tags: - -```tricu -ask = _ : pair 6 t -local = f action : pair 7 (pair f action) -``` - -Host-side: - -```haskell -data Action - = APure T - | ABind T T - | APutStr T - | AGetLine - | AReadFile T - | AWriteFile T T - | AAsk - | ALocal T T - deriving (Show) -``` - -Recommended tag allocation: - -```text -0 = pure -1 = bind -2 = putStr -3 = getLine -4 = readFile -5 = writeFile -6 = ask -7 = local -``` - -State tags can come later: - -```text -8 = get -9 = put -``` - -Do not add `bindR`, `bindS`, or `bindRS` yet. Reader is being added as an effect inside the existing IO action language, so the existing IO `bind` remains the only sequencing operator. - ---- - -## New runtime model - -Add a runtime context: - -```haskell -data Runtime = Runtime - { rtPerms :: IOPermissions - , rtEnv :: T - } - deriving (Show) -``` - -Later this can become: - -```haskell -data Runtime = Runtime - { rtPerms :: IOPermissions - , rtEnv :: T - , rtState :: T - } -``` - -but for this pass, keep it minimal unless State is implemented at the same time. - -Add continuation frames: - -```haskell -data Frame - = BindFrame T - | LocalFrame T - deriving (Show) -``` - -Frame meanings: - -```text -BindFrame k: - When the current action produces value x, continue with apply k x. - -LocalFrame oldEnv: - When the current action produces value x, restore oldEnv, then continue with x. -``` - -Add the machine state: - -```haskell -data Machine = Machine - { machineRuntime :: Runtime - , machineCurrent :: T - , machineFrames :: [Frame] - } - deriving (Show) -``` - -Frames should be treated as a stack, with the head as the top: - -```haskell -push frame machine = machine { machineFrames = frame : machineFrames machine } -``` - ---- - -## New step result - -Replace the current `Step` with machine-oriented stepping: - -```haskell -data Step - = Halt Runtime T - | Continue Machine - deriving (Show) -``` - -`Halt runtime value` means the entire IO program is done. - -`Continue machine` means the machine can take another step. - ---- - -## Core stepping semantics - -The central function should become: - -```haskell -stepMachine :: Machine -> IO Step -``` - -It should decode `machineCurrent`. - -### `pure` - -When the current action is `APure value`, do not immediately halt. First inspect the frame stack. - -Pseudo-code: - -```haskell -finishValue :: Machine -> T -> IO Step -finishValue machine value = - case machineFrames machine of - [] -> - pure (Halt (machineRuntime machine) value) - - BindFrame k : rest -> - pure (Continue machine - { machineCurrent = apply k value - , machineFrames = rest - }) - - LocalFrame oldEnv : rest -> - let runtime' = (machineRuntime machine) { rtEnv = oldEnv } - in pure (Continue machine - { machineRuntime = runtime' - , machineCurrent = pureAction value - , machineFrames = rest - }) -``` - -You will need a helper: - -```haskell -pureAction :: T -> T -pureAction x = Fork (ofNumber 0) x -``` - -This is important: restoring a `LocalFrame` should not discard the value. It restores the environment and re-enters the machine as `pure value`, allowing the next frame to receive the value. - -### `bind` - -For: - -```haskell -ABind left k -``` - -do not recursively step `left`, and do not rebuild `Bind left' k`. - -Instead: - -```haskell -Continue machine - { machineCurrent = left - , machineFrames = BindFrame k : machineFrames machine - } -``` - -This is the major refactor. Continuations move out of the tree and into the frame stack. - -### `ask` - -For: - -```haskell -AAsk -``` - -produce the current Reader environment: - -```haskell -finishValue machine (rtEnv (machineRuntime machine)) -``` - -or equivalently: - -```haskell -Continue machine { machineCurrent = pureAction currentEnv } -``` - -Prefer `finishValue` because it avoids an extra step. - -### `local` - -For: - -```haskell -ALocal f action -``` - -do: - -```haskell -let runtime = machineRuntime machine - oldEnv = rtEnv runtime - newEnv = apply f oldEnv - runtime' = runtime { rtEnv = newEnv } - -Continue machine - { machineRuntime = runtime' - , machineCurrent = action - , machineFrames = LocalFrame oldEnv : machineFrames machine - } -``` - -This is the central correctness point. - -`local` enters a scoped environment by pushing a restoration frame. When the scoped action finishes, `LocalFrame oldEnv` restores the previous environment and passes the produced value onward. - -Nested `local` works naturally because frames stack: - -```tricu -local f ( - local g ask -) -``` - -becomes: - -```text -push LocalFrame env0 -set env = f env0 - -push LocalFrame env1 -set env = g env1 - -ask returns env2 - -pop LocalFrame env1 -restore env1 - -pop LocalFrame env0 -restore env0 -``` - -### Normal IO actions - -For host IO actions, perform the side effect and then call `finishValue`. - -Examples: - -```haskell -APutStr str -> - case decodeString str "PutStr" of - Right s -> do - putStr s - finishValue machine Leaf - Left _ -> - finishValue machine (errResult 6) -``` - -```haskell -AReadFile path -> - case decodeString path "ReadFile" of - Right p -> do - result <- ... - finishValue machine result - Left _ -> - finishValue machine (errResult 6) -``` - -Important: IO actions should no longer return `Done value` directly. They should return a value to the frame stack via `finishValue`. - ---- - -## Decode changes - -Extend `decodeAction`: - -```haskell -decodeAction :: T -> Either String Action -decodeAction tree = - case tree of - Fork tag payload -> - case toNumber tag of - Right 0 -> Right (APure payload) - - Right 1 -> case payload of - Fork left k -> Right (ABind left k) - _ -> Left "Invalid Bind: expected pair action continuation" - - Right 2 -> Right (APutStr payload) - - Right 3 -> Right AGetLine - - Right 4 -> Right (AReadFile payload) - - Right 5 -> case payload of - Fork path contents -> Right (AWriteFile path contents) - _ -> Left "Invalid WriteFile: expected pair path contents" - - Right 6 -> Right AAsk - - Right 7 -> case payload of - Fork f action -> Right (ALocal f action) - _ -> Left "Invalid Local: expected pair function action" - - Right n -> Left $ "Unknown IO action tag: " ++ show n - - Left err -> Left $ "Invalid action tag: " ++ err - - _ -> - Left $ "Invalid action tree: expected pair tag payload, got " ++ show tree -``` - ---- - -## Runner API - -Add a new Reader-aware runner: - -```haskell -runIOWithEnv :: IOPermissions -> T -> T -> IO T -runIOWithEnv perms env action = loop initialMachine - where - initialMachine = Machine - { machineRuntime = Runtime - { rtPerms = perms - , rtEnv = env - } - , machineCurrent = action - , machineFrames = [] - } - - loop machine = do - step <- stepMachine machine - case step of - Halt _ value -> pure value - Continue machine' -> loop machine' -``` - -Keep the existing API as a compatibility wrapper: - -```haskell -runIO :: IOPermissions -> T -> IO T -runIO perms action = - runIOWithEnv perms Leaf action -``` - -If State is added in the same branch, prefer: - -```haskell -runIOWith :: IOPermissions -> T -> T -> T -> IO (T, T) -``` - -where: - -```text -permissions -initial reader env -initial state -action -``` - -returns: - -```text -final result -final state -``` - -But if this handoff is only for Reader, use `runIOWithEnv`. - ---- - -## Permission helpers - -The current permission helper functions can mostly stay as-is, but they should read permissions from runtime: - -```haskell -let perms = rtPerms (machineRuntime machine) -``` - -The current helpers are nested inside `stepIO`. After the refactor, either: - -1. keep them in a `where` block under `stepMachine`, or -2. lift them to top-level helper functions. - -Prefer lifting pure/reusable helpers to top-level if this file is getting large: - -```haskell -decodeString :: T -> String -> Either String String -canonicalizeSafe :: FilePath -> IO (Either String FilePath) -pathAllowed :: FilePath -> [FilePath] -> IO Bool -tryReadFile :: FilePath -> IO T -tryWriteFile :: FilePath -> String -> IO T -okResult :: T -> T -errResult :: Integer -> T -ioErrorCode :: IOException -> Integer -``` - -This will make `stepMachine` much easier to read. - ---- - -## `io.tri` changes - -Add the Reader constructors: - -```tricu -ask = _ : pair 6 t -local = f action : pair 7 (pair f action) -``` - -No new bind is required. - -Example usage: - -```tricu -program = - bind ask (env : - putStrLn env) -``` - -Example `local` usage: - -```tricu -program = - bind ask (outer : - bind (local (env : append env "-inner") - (bind ask (inner : - pure inner))) - (result : - bind ask (after : - pure result))) -``` - -Expected behavior: - -```text -outer ask sees original env -inner ask sees transformed env -after ask sees original env again -``` - ---- - -## Tests to add - -Add tests around behavior, not implementation details. - -### 1. `ask` returns initial environment - -Program: - -```tricu -io (bind ask (env : pure env)) -``` - -Run with env: - -```text -"dev" -``` - -Expected result: - -```text -"dev" -``` - -### 2. `local` transforms environment - -Program: - -```tricu -io ( - local (env : append env "-local") - (bind ask (env : pure env)) -) -``` - -Initial env: - -```text -"root" -``` - -Expected result: - -```text -"root-local" -``` - -### 3. `local` restores environment afterward - -Program structure: - -```tricu -bind ask (before : -bind (local transform scopedAsk) (inside : -bind ask (after : -pure (pair before (pair inside after))))) -``` - -Initial env: - -```text -"root" -``` - -Expected: - -```text -pair "root" (pair "root-local" "root") -``` - -### 4. nested `local` composes correctly - -Program: - -```tricu -local f ( - local g ask -) -``` - -Initial env: - -```text -"root" -``` - -Example: - -```tricu -f = x : append x "-f" -g = x : append x "-g" -``` - -Expected inner ask: - -```text -"root-f-g" -``` - -Also verify after both locals, environment is restored by doing a final `ask`. - -### 5. `local` result passes through bind correctly - -Program: - -```tricu -bind - (local transform (pure "value")) - (x : pure x) -``` - -Expected: - -```text -"value" -``` - -This catches a common bug where `LocalFrame` restores env but loses the value. - -### 6. IO still works through bind - -Existing IO tests should continue passing unchanged through `runIO`. - -### 7. IO inside local - -Program: - -```tricu -local transform ( - bind ask (env : - bind (putStrLn env) (_ : - pure env)) -) -``` - -Expected: - -```text -prints transformed env -returns transformed env -``` - -Then optionally ask after local to verify restoration. - ---- - -## Invariants to preserve - -The implementation should maintain these invariants: - -```text -1. The current action is always the next instruction to evaluate. - -2. The frame stack contains all pending continuations and cleanup scopes. - -3. Bind does not recursively step its left side. - It pushes BindFrame and switches current to the left action. - -4. local does not run its action to completion. - It pushes LocalFrame and switches current to the scoped action. - -5. Only LocalFrame restores Reader environment. - -6. State, when added later, should not be restored by LocalFrame. - -7. Existing runIO behavior remains source-compatible. -``` - ---- - -## Common failure modes - -The likely bugs are: - -```text -Bug: local leaks environment. -Cause: setting rtEnv but never restoring it. -Fix: push LocalFrame oldEnv and restore in finishValue. - -Bug: local restores environment but loses result. -Cause: popping LocalFrame and halting directly. -Fix: after restoration, continue with pureAction value. - -Bug: bind continuations run under the wrong env. -Cause: LocalFrame and BindFrame pop order is wrong. -Fix: use stack head as top. Push LocalFrame when entering local; push BindFrame when entering bind. Pop exactly one frame when a value is produced. - -Bug: existing IO bind tests fail. -Cause: IO actions halt instead of passing result to finishValue. -Fix: every completed primitive action should call finishValue. - -Bug: nested binds still rebuild trees. -Cause: old ABind logic left in place. -Fix: ABind should only push BindFrame and switch current to left. -``` - ---- - -## Async relevance, but not implementation - -This machine representation is intentionally compatible with async. - -A future scheduler can store: - -```haskell -Machine runtime current frames -``` - -when a task blocks, then resume it later by restoring the same `Machine`. - -Do not implement any of these now: - -```haskell -AFork -AAwait -ASleep -TaskId -Scheduler -Runnable queue -Blocked table -``` - -But avoid designs that would make future suspension impossible, especially recursive “run sub-computation to completion” implementations of `local`. The point of the frame machine is that every effect remains small-step and resumable. - ---- - -## Recommended implementation order - -1. Add `Runtime`, `Frame`, and `Machine`. -2. Add `pureAction`. -3. Replace `Step` with `Halt Runtime T | Continue Machine`. -4. Implement `finishValue`. -5. Rewrite `ABind` to push `BindFrame`. -6. Rewrite existing primitive IO actions to call `finishValue`. -7. Add `AAsk` and `ALocal`. -8. Add `runIOWithEnv`. -9. Rewrite `runIO` as a wrapper. -10. Add `ask` and `local` to `io.tri`. -11. Add Reader behavior tests. -12. Run all existing IO tests and confirm no regressions. - -The key handoff instruction is: implement `local` as a continuation frame, not as a recursive nested run. This keeps the interpreter genuinely small-step and gives the eventual async runtime the exact representation it will need for suspension and resumption. diff --git a/notes/stdlib-todo.md b/notes/stdlib-todo.md new file mode 100644 index 0000000..77190ab --- /dev/null +++ b/notes/stdlib-todo.md @@ -0,0 +1,262 @@ +# Standard Library TODO / Expansion Plan + +> Foundational expansions that improve safety, composability, and ergonomics across the entire tricu ecosystem. + +--- + +## 1. Extract a `maybe.tri` / Option layer + +**Motivation:** `head`, `tail`, `last`, `nth`, `bytesHead`, and `bytesTail` currently return `t` on failure, which is ambiguous because `t` is also a valid tree value. A proper option layer makes all of these APIs safer and self-describing. + +**Additions:** + +```tricu +nothing = t +just = x : t x + +matchMaybe = nothingCase justCase maybe : + triage + nothingCase + justCase + (_ _ : nothingCase) + maybe + +maybe = default f m : matchMaybe default f m +maybeMap = f m : matchMaybe nothing (x : just (f x)) m +maybeBind = m f : matchMaybe nothing f m +maybeOr = default m : matchMaybe default id m +maybe? = matchMaybe false (_ : true) +``` + +**Then update existing list/bytes primitives:** + +```tricu +headMaybe +lastMaybe +nthMaybe +bytesHead +bytesTail +``` + +--- + +## 2. Move `Result` combinators from `binary.tri` into `base.tri` + +**Motivation:** `Result` is defined in `base.tri`, but `mapResult` and `bindResult` currently live in `binary.tri`. This makes them unavailable to IO, socket, and file helpers unless every consumer imports binary parsing. + +**Move / add to `base.tri`:** + +```tricu +mapResult = f result : + matchResult + (code rest : err code rest) + (value rest : ok (f value) rest) + result + +bindResult = result f : + matchResult + (code rest : err code rest) + (value rest : f value rest) + result + +resultOr = default result : + matchResult + (_ _ : default) + (value _ : value) + result + +resultMapErr = f result : + matchResult + (code rest : err (f code) rest) + (value rest : ok value rest) + result +``` + +--- + +## 3. Add basic numeric comparison and arithmetic + +**Motivation:** Without comparison and arithmetic, list slicing, parser limits, counters, socket loops, and CLI utilities are awkward or impossible. + +**Priority order:** + +1. `isZero?` +2. `add` +3. `sub` +4. `lt?` +5. `lte?` +6. `mul` + +Even simple Peano / binary-tree versions unlock a huge amount of functionality. + +--- + +## 4. Expand `list.tri` with safer and more complete primitives + +**Motivation:** `reverse` currently uses `append` recursively, which is quadratic. Many common operations (`take`, `drop`, `concatMap`) are missing entirely. + +**High-impact additions:** + +```tricu +take +drop +splitAt +concatMap +find +partition +zipWith +``` + +**Performance fix:** + +```tricu +reverse_ = y (self xs acc : + matchList + acc + (h r : self r (pair h acc)) + xs) + +reverse = xs : reverse_ xs t +``` + +This is low-effort, high-impact because `reverse` is already used by `binary.tri` and `conversions.tri`. + +--- + +## 5. Add string aliases / helpers + +**Motivation:** IO and CLI programs almost always need line/string manipulation. Socket protocols are also easier with canonical string utilities. + +**Highest value:** + +```tricu +startsWith? +contains? +lines +unlines +``` + +Also consider: + +```tricu +strLength +strAppend +strEq? +strEmpty? +words +unwords +endsWith? +``` + +--- + +## 6. Expand `binary.tri` into a small parser-combinator layer + +**Motivation:** `binary.tri` already has `readU8`, `readBytes`, `expectBytes`, etc. A thin combinator layer makes binary parsing much more ergonomic and reusable for protocols/file formats. + +**Suggested additions:** + +```tricu +pureParser = value bs : ok value bs +failParser = code bs : err code bs + +mapParser = mapResult +bindParser = bindResult +thenParser = p q : bindResult p (_ : q) +orParser = p q bs : + matchResult + (_ _ : q bs) + (value rest : ok value rest) + (p bs) +``` + +Then common parsers: + +```tricu +readWhile +readUntil +readRemaining +peekU8 +eof? +expectAscii +``` + +--- + +## 7. Add endian / int conversion helpers + +**Motivation:** `readU16BEBytes` and `readU32BEBytes` return raw byte lists. Either rename them or add actual numeric decoding. + +**Suggested additions:** + +```tricu +u16BE +u16LE +u32BE +u32LE + +readU16BE +readU16LE +readU32BE +readU32LE +``` + +--- + +## 8. Add resource-safe IO helpers + +**Motivation:** Sockets, files, and process-like resources need predictable cleanup. + +```tricu +finally = action cleanup : + bind action (result : + bind cleanup (_ : + pure result)) + +bracket = acquire release use : + bind acquire (resource : + bind (use resource) (result : + bind (release resource) (_ : + pure result))) +``` + +--- + +## 9. Add socket server loops + +**Motivation:** Almost every socket example repeats the same `forever` + `withAccepted_` scaffolding. + +```tricu +serveForever = server handler : + forever + (withAccepted_ server + (err : pure t) + (client peer : + fork (handler client peer))) +``` + +Also consider: + +```tricu +connectTo = addr port : + onOk_ socket (client : + onOk_ (connect client addr port) (_ : + pure (ok client))) +``` + +--- + +## 10. Add a curated `prelude.tri` + +**Motivation:** As libraries grow, users need a stable starting point. + +```tricu +!import "base.tri" !Local +!import "maybe.tri" !Local +!import "list.tri" !Local +!import "bytes.tri" !Local +!import "conversions.tri" !Local +``` + +This gives a standard baseline without importing IO / socket / binary by default. + diff --git a/test/Spec.hs b/test/Spec.hs index feab34e..74b9df8 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -45,6 +45,7 @@ tests = testGroup "Tricu Tests" , simpleEvaluation , lambdas , providedLibraries + , maybeTests , fileEval , modules , demos @@ -55,6 +56,7 @@ tests = testGroup "Tricu Tests" , wireTests , tricuReaderTests , byteListUtilities + , binaryParserTests , ioDriverTests ] @@ -490,6 +492,93 @@ lambdas = testGroup "Lambda Evaluation Tests" 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 @@ -588,6 +677,561 @@ providedLibraries = testGroup "Library Tests" 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 "strEq? equal strings" $ do + library <- evaluateFile "./lib/list.tri" + let input = "strEq? \"abc\" \"abc\"" + env = evalTricu library (parseTricu input) + result env @?= trueT + + , testCase "strEq? different strings" $ do + library <- evaluateFile "./lib/list.tri" + let input = "strEq? \"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 @@ -1364,6 +2008,157 @@ byteListUtilities = testGroup "Byte List Utility Tests" 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]) + + , testCase "u16BE decodes big-endian" $ do + lib <- evaluateFile "./lib/binary.tri" + let input = "u16BE [(1) (0)]" + env = evalTricu lib (parseTricu input) + result env @?= ofNumber 256 + + , testCase "u16BE zero" $ do + lib <- evaluateFile "./lib/binary.tri" + let input = "u16BE [(0) (1)]" + env = evalTricu lib (parseTricu input) + result env @?= ofNumber 1 + + , testCase "u16LE decodes little-endian" $ do + lib <- evaluateFile "./lib/binary.tri" + let input = "u16LE [(1) (0)]" + env = evalTricu lib (parseTricu input) + result env @?= ofNumber 1 + + , testCase "u16LE zero" $ do + lib <- evaluateFile "./lib/binary.tri" + let input = "u16LE [(0) (1)]" + env = evalTricu lib (parseTricu input) + result env @?= ofNumber 256 + + , testCase "readU16BE parses and decodes" $ do + lib <- evaluateFile "./lib/binary.tri" + let input = "readU16BE [(0) (1) (2)]" + env = evalTricu lib (parseTricu input) + result env @?= parserOk (ofNumber 1) (bytesT [2]) + + , testCase "readU16LE parses and decodes" $ do + lib <- evaluateFile "./lib/binary.tri" + let input = "readU16LE [(1) (0) (2)]" + env = evalTricu lib (parseTricu input) + result env @?= parserOk (ofNumber 1) (bytesT [2]) + ] + -- -------------------------------------------------------------------------- -- IO driver tests -- -------------------------------------------------------------------------- @@ -1930,18 +2725,18 @@ ioDriverTests = testGroup "IO driver tests" final @?= ioErrResult "invalid socket handle" , testCase "bindSocket and listen succeed on loopback port 0" $ do - final <- runIOSource "main = io (bind socket (result : matchResult (err rest : pure result) (sock rest : bind (bindSocket sock \"127.0.0.1\" 0) (bindResult : matchResult (err rest : pure bindResult) (_ rest : bind (listen sock 1) (listenResult : pure listenResult)) bindResult)) result))" + 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 $ - unlines - [ "main = io (bind socket (result :" - , " matchResult" - , " (err rest : pure \"socket-err\")" - , " (sock rest : connect sock \"127.0.0.1\" 1)" - , " result))" - ] + 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 @@ -1950,32 +2745,18 @@ ioDriverTests = testGroup "IO driver tests" withFreePort $ \port -> do final <- runIOSource $ unlines - [ "preserveResult = (result okCase :" - , " matchResult" - , " (err rest : pure result)" - , " okCase" - , " result)" - , "" - , "client = port :" - , " bind socket (result :" - , " preserveResult result (sock rest :" - , " bind (connect sock \"127.0.0.1\" port) (connectResult :" - , " preserveResult connectResult (_ rest :" - , " send sock [104 105]))))" + [ "client = port :" + , " onOk socket (sock rest :" + , " onOk (connect sock \"127.0.0.1\" port) (_ rest :" + , " send sock [104 105]))" , "" , "main = io (" - , " bind socket (result :" - , " preserveResult result (server rest :" - , " bind (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (bindResult :" - , " preserveResult bindResult (_ rest :" - , " bind (listen server 1) (listenResult :" - , " preserveResult listenResult (_ rest :" - , " bind (fork (client " ++ show port ++ ")) (_ :" - , " bind (accept server) (acceptResult :" - , " preserveResult acceptResult (accepted rest :" - , " matchPair" - , " (clientSock addr : recv clientSock 2)" - , " accepted))))))))))" + , " 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])) @@ -1983,39 +2764,23 @@ ioDriverTests = testGroup "IO driver tests" withFreePort $ \port -> do final <- runIOSource $ unlines - [ "preserveResult = (result okCase :" - , " matchResult" - , " (err rest : pure result)" - , " okCase" - , " result)" + [ "serverTask = (server :" + , " onOk (accept server) (accepted rest :" + , " onOk (recv (fst accepted) 4) (msg rest :" + , " send (fst accepted) [112 111 110 103])))" , "" - , "serverTask = server :" - , " bind (accept server) (acceptResult :" - , " preserveResult acceptResult (accepted rest :" - , " matchPair" - , " (clientSock addr :" - , " bind (recv clientSock 4) (msgResult :" - , " preserveResult msgResult (_ rest :" - , " send clientSock [112 111 110 103])))" - , " accepted))" - , "" - , "clientTask = port :" - , " bind socket (result :" - , " preserveResult result (sock rest :" - , " bind (connect sock \"127.0.0.1\" port) (connectResult :" - , " preserveResult connectResult (_ rest :" - , " bind (send sock [112 105 110 103]) (_ :" - , " recv sock 4)))))" + , "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 (" - , " bind socket (result :" - , " preserveResult result (server rest :" - , " bind (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (bindResult :" - , " preserveResult bindResult (_ rest :" - , " bind (listen server 1) (listenResult :" - , " preserveResult listenResult (_ rest :" - , " bind (fork (serverTask server)) (_ :" - , " clientTask " ++ show port ++ "))))))))" + , " 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])) @@ -2023,34 +2788,19 @@ ioDriverTests = testGroup "IO driver tests" withFreePort $ \port -> do final <- runIOSource $ unlines - [ "preserveResult = (result okCase :" - , " matchResult" - , " (err rest : pure result)" - , " okCase" - , " result)" - , "" - , "clientTask = port :" - , " bind socket (result :" - , " preserveResult result (sock rest :" - , " bind (connect sock \"127.0.0.1\" port) (connectResult :" - , " preserveResult connectResult (_ rest :" - , " closeSocket sock))))" + [ "clientTask = port :" + , " onOk socket (sock rest :" + , " onOk (connect sock \"127.0.0.1\" port) (_ rest :" + , " closeSocket sock))" , "" , "main = io (" - , " bind socket (result :" - , " preserveResult result (server rest :" - , " bind (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (bindResult :" - , " preserveResult bindResult (_ rest :" - , " bind (listen server 1) (listenResult :" - , " preserveResult listenResult (_ rest :" - , " bind (fork (clientTask " ++ show port ++ ")) (_ :" - , " bind (accept server) (acceptResult :" - , " preserveResult acceptResult (accepted rest :" - , " matchPair" - , " (clientSock addr :" - , " bind (yield) (_ :" - , " recv clientSock 1))" - , " accepted))))))))))" + , " 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" @@ -2069,18 +2819,11 @@ ioDriverTests = testGroup "IO driver tests" , testCase "getSocketName returns positive port after bind 0" $ do final <- runIOSource $ unlines - [ "preserveResult = (result okCase :" - , " matchResult" - , " (err rest : pure result)" - , " okCase" - , " result)" - , "" - , "main = io (" - , " bind socket (result :" - , " preserveResult result (server rest :" - , " bind (bindSocket server \"127.0.0.1\" 0) (bindResult :" - , " preserveResult bindResult (_ rest :" - , " getSocketName server)))))" + [ "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) -> @@ -2089,6 +2832,113 @@ ioDriverTests = testGroup "IO driver tests" 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" ] ]