tricu

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

1d79ec9eec9e14abbf8a44c9bd577e4a2a3f371a4f05d93fc711024d45d46543.tri (7409B)

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