37cfec8f76370ad98a5d8a0b1a3d36f9af5b0597fedf996f6ed29e2c94c0358c.tri (7656B)
1 !import base * 2 !export * 3 4 -- IO constructors for host-interpreted interaction trees. 5 -- Free-monad style: Bind is the single sequencing mechanism. 6 7 version = 1 8 9 io = action : pair "tricuIO" (pair version action) 10 11 pure = x : pair 0 x 12 bind = action k : pair 1 (pair action k) 13 -- Terminal diagnostic control for the Haskell IO scheduler. 14 abortIO = diagnostic : pair 2 diagnostic 15 16 putStr = s : pair 10 s 17 getLine = pair 11 t 18 19 -- Source boundary only: Result (raw octets, Unicode scalar list), strict UTF-8. 20 -- Initial BOM is rejected; binary readFile remains unchanged. 21 readSourceFile = p : pair 37 p 22 encodeSourceText = chars : pair 38 chars 23 24 readFile = p : pair 20 p 25 writeFile = p c : pair 21 (pair p c) 26 putBytes = bs : pair 12 bs 27 writeBytes = p c : pair 22 (pair p c) 28 29 listDirectory = p : pair 23 p 30 renameFile = old new : pair 24 (pair old new) 31 createDirectory = p : pair 25 p 32 deleteFile = p : pair 26 p 33 fileExists = p : pair 27 p 34 35 sha256Hex = bs : pair 28 bs 36 currentTime = pair 29 t 37 -- Filesystem-only atomic primitives. writeBytesIfAbsent returns ok true 38 -- for a new object and ok false if the path already exists, without changing 39 -- it. atomicWriteBytes returns ok true after atomic replacement of an alias. 40 -- Hosts sync file contents before publication and the parent directory 41 -- afterwards. Publish referenced objects before replacing a lock or alias; 42 -- a post-publication sync failure can leave the new name visible. 43 writeBytesIfAbsent = p bs : pair 32 (pair p bs) 44 atomicWriteBytes = p bs : pair 33 (pair p bs) 45 46 -- Read-permitted canonical tree-term transport. Verify the fixed 47 -- arboricx.tree-term.v1 digest before decoding; returns Result tree. 48 -- This loads an inert normal-form tree, never source or an applied program. 49 readTreeTerm = p digest : pair 34 (pair p digest) 50 51 -- Fixed canonical tree-term domain. No byte-list marshalling. Publication 52 -- requires read and write permission, never replaces an existing path, and 53 -- verifies its bytes even when another publisher wins. Directories are explicit. 54 hashTreeTerm = tree : pair 35 tree 55 writeTreeTermIfAbsent = p digest tree : pair 36 (pair p (pair digest tree)) 56 57 -- Name-neutral indexed DAG transport under arboricx.indexed-tree.v1. 58 -- These primitive codecs preserve sharing; tricu chooses paths and publication 59 -- order. Read verifies before decode; write verifies an existing/racing winner. 60 -- Both read and write permission are required for no-replace publication. 61 readIndexedTree = p digest : pair 50 (pair p digest) 62 hashIndexedTree = tree : pair 51 tree 63 writeIndexedTreeIfAbsent = p digest tree : pair 52 (pair p (pair digest tree)) 64 65 -- Experimental Haskell-native bounded staging sessions. All return Results. 66 -- Run-local, task-owned identifiers are not independent filesystem authority. 67 uploadBegin directory expected = pair 90 (pair directory expected) 68 uploadAppend handle chunk = pair 91 (pair handle chunk) 69 uploadSeal handle = pair 92 handle 70 uploadCommit handle destination = pair 93 (pair handle destination) 71 uploadAbort handle = pair 94 handle 72 73 ask = pair 30 t 74 local = f action : pair 31 (pair f action) 75 76 get = pair 40 t 77 put = s : pair 41 s 78 79 fork = action : pair 60 action 80 await = handle : pair 61 handle 81 yield = pair 62 t 82 sleep = ms : pair 63 ms 83 84 -- --------------------------------------------------------------------------- 85 -- Generic sequencing combinators 86 -- --------------------------------------------------------------------------- 87 88 thenIO = a b : bind a (_ : b) 89 mapIO = action f : bind action (x : pure (f x)) 90 void = action : bind action (_ : pure t) 91 92 -- --------------------------------------------------------------------------- 93 -- Conditional execution 94 -- --------------------------------------------------------------------------- 95 96 when = cond action : matchBool action (pure t) cond 97 unless = cond action : matchBool (pure t) action cond 98 99 -- --------------------------------------------------------------------------- 100 -- Infinite loop 101 -- --------------------------------------------------------------------------- 102 103 forever action = bind action (_ : forever action) 104 105 -- --------------------------------------------------------------------------- 106 -- Result-aware combinators 107 -- --------------------------------------------------------------------------- 108 109 -- Propagate driver Result on error; run okCase on success. 110 onOk action okCase = (do bind 111 reply <- action 112 matchResult (_ _ : pure reply) okCase reply) 113 114 -- Value-only adapter: success remainder is explicitly discarded. 115 onOk_ action okCase = onOk action (value _ : okCase value) 116 117 onResult action errCase okCase = (do bind 118 reply <- action 119 matchResult errCase okCase reply) 120 121 -- Value-only handlers explicitly discard both Result remainders. 122 onResult_ action errCase okCase = (onResult action 123 (message _ : errCase message) 124 (value _ : okCase value)) 125 126 mapErrIO prefix action = 127 onResult_ action 128 (e : pure (err (append prefix e) t)) 129 (v : pure (ok v t)) 130 131 -- --------------------------------------------------------------------------- 132 -- Convenience helpers 133 -- --------------------------------------------------------------------------- 134 135 print = s : void (putStr s) 136 putStrLn = s : void (putStr (append s "\n")) 137 138 -- --------------------------------------------------------------------------- 139 -- Result-aware file helpers 140 -- --------------------------------------------------------------------------- 141 142 onReadFile = path : onResult (readFile path) 143 144 onWriteFile = path contents : onResult (writeFile path contents) 145 146 onListDirectory = path : onResult (listDirectory path) 147 onRenameFile = old new : onResult (renameFile old new) 148 onCreateDirectory = path : onResult (createDirectory path) 149 onDeleteFile = path : onResult (deleteFile path) 150 onFileExists = path : onResult (fileExists path) 151 onSha256Hex = bs : onResult (sha256Hex bs) 152 onCurrentTime = onResult currentTime 153 154 -- --------------------------------------------------------------------------- 155 -- Convenience helpers for the common cases 156 -- --------------------------------------------------------------------------- 157 158 readFileOrPrintError = (path okCase : 159 onReadFile path 160 (err rest : putStrLn (append "Read failed: " err)) 161 okCase) 162 163 writeFileOrPrintError = (path contents okCase : 164 onWriteFile path contents 165 (err rest : putStrLn (append "Write failed: " err)) 166 okCase) 167 168 copyFile = (src dst : 169 onResult (readFile src) 170 (err rest : putStrLn (append "Read failed: " err)) 171 (contents rest : 172 onResult (writeFile dst contents) 173 (err rest : putStrLn (append "Write failed: " err)) 174 (_ _ : pure t))) 175 176 -- --------------------------------------------------------------------------- 177 -- Ordinary-completion cleanup (not exception masking or abort recovery) 178 -- --------------------------------------------------------------------------- 179 180 -- Run cleanup once after action returns any ordinary value/Result, including 181 -- failure; ignore cleanup's ordinary result and preserve the action's result. 182 -- Terminal abortIO, divergence and host exceptions can prevent cleanup. 183 finally action cleanup = (do bind 184 result <- action 185 cleanup 186 pure result) 187 188 -- Acquisition returns a Result. Failure propagates unchanged without use or 189 -- release; success supplies the resource value (not the Result envelope). 190 -- Use the same ordinary-completion/cleanup-result policy as finally. 191 bracket acquire release use = (onOk_ acquire 192 (resource : finally (use resource) (release resource)))