tricu

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

d771d199b8001c403f3191cfd463f26b572f3c38d827f940abcd142c91509422.tri (6715B)

      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 readFile  = p          : pair 20 p
     24 writeFile = p c        : pair 21 (pair p c)
     25 putBytes  = bs         : pair 12 bs
     26 writeBytes = p c       : pair 22 (pair p c)
     27 
     28 listDirectory   = p          : pair 23 p
     29 renameFile      = old new    : pair 24 (pair old new)
     30 createDirectory = p          : pair 25 p
     31 deleteFile      = p          : pair 26 p
     32 fileExists      = p          : pair 27 p
     33 
     34 sha256Hex       = bs         : pair 28 bs
     35 currentTime     = pair 29 t
     36 -- Filesystem-only atomic primitives. writeBytesIfAbsent returns ok true
     37 -- for a new object and ok false if the path already exists, without changing
     38 -- it. atomicWriteBytes returns ok true after atomic replacement of an alias.
     39 -- Hosts sync file contents before publication and the parent directory
     40 -- afterwards. Publish referenced objects before replacing a lock or alias;
     41 -- a post-publication sync failure can leave the new name visible.
     42 writeBytesIfAbsent = p bs : pair 32 (pair p bs)
     43 atomicWriteBytes = p bs : pair 33 (pair p bs)
     44 
     45 -- Read-permitted canonical tree-term transport. Verify the fixed
     46 -- arboricx.tree-term.v1 digest before decoding; returns Result tree.
     47 -- This loads an inert normal-form tree, never source or an applied program.
     48 readTreeTerm = p digest : pair 34 (pair p digest)
     49 
     50 -- Fixed canonical tree-term domain. No byte-list marshalling. Publication
     51 -- requires read and write permission, never replaces an existing path, and
     52 -- verifies its bytes even when another publisher wins. Directories are explicit.
     53 hashTreeTerm = tree : pair 35 tree
     54 writeTreeTermIfAbsent = p digest tree : pair 36 (pair p (pair digest tree))
     55 
     56 ask       = pair 30 t
     57 local     = f action   : pair 31 (pair f action)
     58 
     59 get       = pair 40 t
     60 put       = s          : pair 41 s
     61 
     62 fork      = action     : pair 60 action
     63 await     = handle     : pair 61 handle
     64 yield     = pair 62 t
     65 sleep     = ms         : pair 63 ms
     66 
     67 -- ---------------------------------------------------------------------------
     68 -- Generic sequencing combinators
     69 -- ---------------------------------------------------------------------------
     70 
     71 thenIO = a b : bind a (_ : b)
     72 mapIO  = action f : bind action (x : pure (f x))
     73 void   = action : bind action (_ : pure t)
     74 
     75 -- ---------------------------------------------------------------------------
     76 -- Conditional execution
     77 -- ---------------------------------------------------------------------------
     78 
     79 when   = cond action : matchBool action (pure t) cond
     80 unless = cond action : matchBool (pure t) action cond
     81 
     82 -- ---------------------------------------------------------------------------
     83 -- Infinite loop
     84 -- ---------------------------------------------------------------------------
     85 
     86 forever action = bind action (_ : forever action)
     87 
     88 -- ---------------------------------------------------------------------------
     89 -- Result-aware combinators
     90 -- ---------------------------------------------------------------------------
     91 
     92 -- Propagate driver Result on error; run okCase on success.
     93 onOk action okCase = (do bind
     94   reply <- action
     95   matchResult (_ _ : pure reply) okCase reply)
     96 
     97 -- Value-only adapter: success remainder is explicitly discarded.
     98 onOk_ action okCase = onOk action (value _ : okCase value)
     99 
    100 onResult action errCase okCase = (do bind
    101   reply <- action
    102   matchResult errCase okCase reply)
    103 
    104 -- Value-only handlers explicitly discard both Result remainders.
    105 onResult_ action errCase okCase = (onResult action
    106   (message _ : errCase message)
    107   (value _ : okCase value))
    108 
    109 mapErrIO prefix action =
    110   onResult_ action
    111     (e : pure (err (append prefix e) t))
    112     (v : pure (ok v t))
    113 
    114 -- ---------------------------------------------------------------------------
    115 -- Convenience helpers
    116 -- ---------------------------------------------------------------------------
    117 
    118 print    = s : void (putStr s)
    119 putStrLn = s : void (putStr (append s "\n"))
    120 
    121 -- ---------------------------------------------------------------------------
    122 -- Result-aware file helpers
    123 -- ---------------------------------------------------------------------------
    124 
    125 onReadFile = path : onResult (readFile path)
    126 
    127 onWriteFile = path contents : onResult (writeFile path contents)
    128 
    129 onListDirectory   = path : onResult (listDirectory path)
    130 onRenameFile      = old new : onResult (renameFile old new)
    131 onCreateDirectory = path : onResult (createDirectory path)
    132 onDeleteFile      = path : onResult (deleteFile path)
    133 onFileExists      = path : onResult (fileExists path)
    134 onSha256Hex       = bs : onResult (sha256Hex bs)
    135 onCurrentTime     = onResult currentTime
    136 
    137 -- ---------------------------------------------------------------------------
    138 -- Convenience helpers for the common cases
    139 -- ---------------------------------------------------------------------------
    140 
    141 readFileOrPrintError = (path okCase :
    142   onReadFile path
    143     (err rest : putStrLn (append "Read failed: " err))
    144     okCase)
    145 
    146 writeFileOrPrintError = (path contents okCase :
    147   onWriteFile path contents
    148     (err rest : putStrLn (append "Write failed: " err))
    149     okCase)
    150 
    151 copyFile = (src dst :
    152   onResult (readFile src)
    153     (err rest : putStrLn (append "Read failed: " err))
    154     (contents rest :
    155       onResult (writeFile dst contents)
    156         (err rest : putStrLn (append "Write failed: " err))
    157         (_ _ : pure t)))
    158 
    159 -- ---------------------------------------------------------------------------
    160 -- Ordinary-completion cleanup (not exception masking or abort recovery)
    161 -- ---------------------------------------------------------------------------
    162 
    163 -- Run cleanup once after action returns any ordinary value/Result, including
    164 -- failure; ignore cleanup's ordinary result and preserve the action's result.
    165 -- Terminal abortIO, divergence and host exceptions can prevent cleanup.
    166 finally action cleanup = (do bind
    167   result <- action
    168   cleanup
    169   pure result)
    170 
    171 -- Acquisition returns a Result. Failure propagates unchanged without use or
    172 -- release; success supplies the resource value (not the Result envelope).
    173 -- Use the same ordinary-completion/cleanup-result policy as finally.
    174 bracket acquire release use = (onOk_ acquire
    175   (resource : finally (use resource) (release resource)))