tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

c4ec206590d25d581b9a96f242c22936d8d0b2e9903331ce50b30ad7de254bd6.tri (7237B)

      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 ask       = pair 30 t
     66 local     = f action   : pair 31 (pair f action)
     67 
     68 get       = pair 40 t
     69 put       = s          : pair 41 s
     70 
     71 fork      = action     : pair 60 action
     72 await     = handle     : pair 61 handle
     73 yield     = pair 62 t
     74 sleep     = ms         : pair 63 ms
     75 
     76 -- ---------------------------------------------------------------------------
     77 -- Generic sequencing combinators
     78 -- ---------------------------------------------------------------------------
     79 
     80 thenIO = a b : bind a (_ : b)
     81 mapIO  = action f : bind action (x : pure (f x))
     82 void   = action : bind action (_ : pure t)
     83 
     84 -- ---------------------------------------------------------------------------
     85 -- Conditional execution
     86 -- ---------------------------------------------------------------------------
     87 
     88 when   = cond action : matchBool action (pure t) cond
     89 unless = cond action : matchBool (pure t) action cond
     90 
     91 -- ---------------------------------------------------------------------------
     92 -- Infinite loop
     93 -- ---------------------------------------------------------------------------
     94 
     95 forever action = bind action (_ : forever action)
     96 
     97 -- ---------------------------------------------------------------------------
     98 -- Result-aware combinators
     99 -- ---------------------------------------------------------------------------
    100 
    101 -- Propagate driver Result on error; run okCase on success.
    102 onOk action okCase = (do bind
    103   reply <- action
    104   matchResult (_ _ : pure reply) okCase reply)
    105 
    106 -- Value-only adapter: success remainder is explicitly discarded.
    107 onOk_ action okCase = onOk action (value _ : okCase value)
    108 
    109 onResult action errCase okCase = (do bind
    110   reply <- action
    111   matchResult errCase okCase reply)
    112 
    113 -- Value-only handlers explicitly discard both Result remainders.
    114 onResult_ action errCase okCase = (onResult action
    115   (message _ : errCase message)
    116   (value _ : okCase value))
    117 
    118 mapErrIO prefix action =
    119   onResult_ action
    120     (e : pure (err (append prefix e) t))
    121     (v : pure (ok v t))
    122 
    123 -- ---------------------------------------------------------------------------
    124 -- Convenience helpers
    125 -- ---------------------------------------------------------------------------
    126 
    127 print    = s : void (putStr s)
    128 putStrLn = s : void (putStr (append s "\n"))
    129 
    130 -- ---------------------------------------------------------------------------
    131 -- Result-aware file helpers
    132 -- ---------------------------------------------------------------------------
    133 
    134 onReadFile = path : onResult (readFile path)
    135 
    136 onWriteFile = path contents : onResult (writeFile path contents)
    137 
    138 onListDirectory   = path : onResult (listDirectory path)
    139 onRenameFile      = old new : onResult (renameFile old new)
    140 onCreateDirectory = path : onResult (createDirectory path)
    141 onDeleteFile      = path : onResult (deleteFile path)
    142 onFileExists      = path : onResult (fileExists path)
    143 onSha256Hex       = bs : onResult (sha256Hex bs)
    144 onCurrentTime     = onResult currentTime
    145 
    146 -- ---------------------------------------------------------------------------
    147 -- Convenience helpers for the common cases
    148 -- ---------------------------------------------------------------------------
    149 
    150 readFileOrPrintError = (path okCase :
    151   onReadFile path
    152     (err rest : putStrLn (append "Read failed: " err))
    153     okCase)
    154 
    155 writeFileOrPrintError = (path contents okCase :
    156   onWriteFile path contents
    157     (err rest : putStrLn (append "Write failed: " err))
    158     okCase)
    159 
    160 copyFile = (src dst :
    161   onResult (readFile src)
    162     (err rest : putStrLn (append "Read failed: " err))
    163     (contents rest :
    164       onResult (writeFile dst contents)
    165         (err rest : putStrLn (append "Write failed: " err))
    166         (_ _ : pure t)))
    167 
    168 -- ---------------------------------------------------------------------------
    169 -- Ordinary-completion cleanup (not exception masking or abort recovery)
    170 -- ---------------------------------------------------------------------------
    171 
    172 -- Run cleanup once after action returns any ordinary value/Result, including
    173 -- failure; ignore cleanup's ordinary result and preserve the action's result.
    174 -- Terminal abortIO, divergence and host exceptions can prevent cleanup.
    175 finally action cleanup = (do bind
    176   result <- action
    177   cleanup
    178   pure result)
    179 
    180 -- Acquisition returns a Result. Failure propagates unchanged without use or
    181 -- release; success supplies the resource value (not the Result envelope).
    182 -- Use the same ordinary-completion/cleanup-result policy as finally.
    183 bracket acquire release use = (onOk_ acquire
    184   (resource : finally (use resource) (release resource)))