tricu

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

687cd83bc56d246e2126875cf894e08a82e8e59c470debb56f11263e7fd9ceeb.tri (6365B)

      1 !import prelude *
      2 !import patterns *
      3 !export *
      4 
      5 -- IO constructors for host-interpreted interaction trees.
      6 -- Free-monad style: Bind is the single sequencing mechanism.
      7 
      8 version = 1
      9 
     10 io        = action : pair "tricuIO" (pair version action)
     11 
     12 pure      = x          : pair 0 x
     13 bind      = action k   : pair 1 (pair action k)
     14 -- Terminal diagnostic control for the Haskell IO scheduler.
     15 abortIO   = diagnostic : pair 2 diagnostic
     16 
     17 putStr    = s          : pair 10 s
     18 getLine   = pair 11 t
     19 
     20 readFile  = p          : pair 20 p
     21 writeFile = p c        : pair 21 (pair p c)
     22 putBytes  = bs         : pair 12 bs
     23 writeBytes = p c       : pair 22 (pair p c)
     24 
     25 listDirectory   = p          : pair 23 p
     26 renameFile      = old new    : pair 24 (pair old new)
     27 createDirectory = p          : pair 25 p
     28 deleteFile      = p          : pair 26 p
     29 fileExists      = p          : pair 27 p
     30 
     31 sha256Hex       = bs         : pair 28 bs
     32 currentTime     = pair 29 t
     33 -- Filesystem-only atomic primitives. writeBytesIfAbsent returns ok true
     34 -- for a new object and ok false if the path already exists, without changing
     35 -- it. atomicWriteBytes returns ok true after atomic replacement of an alias.
     36 -- Hosts sync file contents before publication and the parent directory
     37 -- afterwards. Publish referenced objects before replacing a lock or alias;
     38 -- a post-publication sync failure can leave the new name visible.
     39 writeBytesIfAbsent = p bs : pair 32 (pair p bs)
     40 atomicWriteBytes = p bs : pair 33 (pair p bs)
     41 
     42 -- Read-permitted canonical tree-term transport. Verify the fixed
     43 -- arboricx.tree-term.v1 digest before decoding; returns Result tree.
     44 -- This loads an inert normal-form tree, never source or an applied program.
     45 readTreeTerm = p digest : pair 34 (pair p digest)
     46 
     47 -- Fixed canonical tree-term domain. No byte-list marshalling. Publication
     48 -- requires read and write permission, never replaces an existing path, and
     49 -- verifies its bytes even when another publisher wins. Directories are explicit.
     50 hashTreeTerm = tree : pair 35 tree
     51 writeTreeTermIfAbsent = p digest tree : pair 36 (pair p (pair digest tree))
     52 
     53 ask       = pair 30 t
     54 local     = f action   : pair 31 (pair f action)
     55 
     56 get       = pair 40 t
     57 put       = s          : pair 41 s
     58 
     59 fork      = action     : pair 60 action
     60 await     = handle     : pair 61 handle
     61 yield     = pair 62 t
     62 sleep     = ms         : pair 63 ms
     63 
     64 -- ---------------------------------------------------------------------------
     65 -- Generic sequencing combinators
     66 -- ---------------------------------------------------------------------------
     67 
     68 thenIO = a b : bind a (_ : b)
     69 mapIO  = action f : bind action (x : pure (f x))
     70 void   = action : bind action (_ : pure t)
     71 
     72 -- ---------------------------------------------------------------------------
     73 -- Conditional execution
     74 -- ---------------------------------------------------------------------------
     75 
     76 when   = cond action : matchBool action (pure t) cond
     77 unless = cond action : matchBool (pure t) action cond
     78 
     79 -- ---------------------------------------------------------------------------
     80 -- Infinite loop
     81 -- ---------------------------------------------------------------------------
     82 
     83 forever = y (self : action :
     84   bind action (_ :
     85     self action))
     86 
     87 -- ---------------------------------------------------------------------------
     88 -- Result-aware combinators
     89 -- ---------------------------------------------------------------------------
     90 
     91 -- Propagate driver Result on error; run okCase on success.
     92 onOk = action okCase :
     93   bind action (result :
     94     matchResult
     95       (err rest : pure result)
     96       okCase
     97       result)
     98 
     99 -- Same as onOk, but the okCase only receives the value (rest is dropped).
    100 onOk_ = action okCase :
    101   bind action (result :
    102     matchResult
    103       (err rest : pure result)
    104       (val _ : okCase val)
    105       result)
    106 
    107 -- Generalized Result handler with explicit branches.
    108 onResult = action errCase okCase :
    109   bind action (result :
    110     matchResult errCase okCase result)
    111 
    112 -- Same as onResult, but handlers only receive the value/msg (rest is dropped).
    113 onResult_ = action errCase okCase :
    114   bind action (result :
    115     matchResult
    116       (err _ : errCase err)
    117       (val _ : okCase val)
    118       result)
    119 
    120 mapErrIO prefix action =
    121   onResult_ action
    122     (e : pure (err (append prefix e) t))
    123     (v : pure (ok v t))
    124 
    125 -- ---------------------------------------------------------------------------
    126 -- Convenience helpers
    127 -- ---------------------------------------------------------------------------
    128 
    129 print    = s : void (putStr s)
    130 putStrLn = s : void (putStr (append s "\n"))
    131 
    132 -- ---------------------------------------------------------------------------
    133 -- Result-aware file helpers
    134 -- ---------------------------------------------------------------------------
    135 
    136 onReadFile = path : onResult (readFile path)
    137 
    138 onWriteFile = path contents : onResult (writeFile path contents)
    139 
    140 onListDirectory   = path : onResult (listDirectory path)
    141 onRenameFile      = old new : onResult (renameFile old new)
    142 onCreateDirectory = path : onResult (createDirectory path)
    143 onDeleteFile      = path : onResult (deleteFile path)
    144 onFileExists      = path : onResult (fileExists path)
    145 onSha256Hex       = bs : onResult (sha256Hex bs)
    146 onCurrentTime     = onResult currentTime
    147 
    148 -- ---------------------------------------------------------------------------
    149 -- Convenience helpers for the common cases
    150 -- ---------------------------------------------------------------------------
    151 
    152 readFileOrPrintError = (path okCase :
    153   onReadFile path
    154     (err rest : putStrLn (append "Read failed: " err))
    155     okCase)
    156 
    157 writeFileOrPrintError = (path contents okCase :
    158   onWriteFile path contents
    159     (err rest : putStrLn (append "Write failed: " err))
    160     okCase)
    161 
    162 copyFile = (src dst :
    163   onResult (readFile src)
    164     (err rest : putStrLn (append "Read failed: " err))
    165     (contents rest :
    166       onResult (writeFile dst contents)
    167         (err rest : putStrLn (append "Write failed: " err))
    168         (_ _ : pure t)))
    169 
    170 -- ---------------------------------------------------------------------------
    171 -- Resource-safe combinators
    172 -- ---------------------------------------------------------------------------
    173 
    174 finally = action cleanup :
    175   bind action (result :
    176     bind cleanup (_ :
    177       pure result))
    178 
    179 bracket = acquire release use :
    180   bind acquire (resource :
    181     bind (use resource) (result :
    182       bind (release resource) (_ :
    183         pure result)))
    184