tricu

A lazy functional language based on Tree Calculus
Log | Files | Refs | README | LICENSE

yield.tri (1611B)

      1 !import base as B
      2 !import io as IO
      3 !import io_text as Text
      4 !import handlers as H
      5 !import handler_log as Log
      6 !export main
      7 !export chatter
      8 
      9 -- Yield offers scheduling opportunities, never guaranteed alternation. Each
     10 -- child installs its own collection; the parent alone writes the observed events.
     11 -- No implicit shared state slot, inherited collector or concurrent stdout writes.
     12 chatter name result = H.runIO (Log.capture (do H.bind
     13   Log.info (B.append name " says 1")
     14   H.liftIO (IO.require IO.yield IO.pure)
     15   Log.info (B.append name " says 2")
     16   H.liftIO (IO.require IO.yield IO.pure)
     17   Log.info (B.append name " says 3")
     18   H.pure result))
     19 printEvents _ [] = IO.pure t
     20 printEvents writer [["info" _ message] | rest] = IO.require
     21   (Text.writeText writer (B.append message "\n")) (_ : printEvents writer rest)
     22 printEvents _ _ = IO.fail "Invalid child log event"
     23 consume writer [_ ticket] = IO.require (IO.join ticket) (outcome : case outcome of
     24   ["completed" [value events]] = IO.bind (printEvents writer events) (_ : IO.pure value)
     25   ["cancelled" reason _] = IO.cancelled reason
     26   ["failed" problem cleanup] = IO.fail [problem cleanup]
     27   _ = IO.fail "Invalid task outcome")
     28 consume _ _ = IO.fail "Invalid spawn reply"
     29 main = IO.io (IO.scope (_ : do IO.require
     30   first <- IO.spawn 0 1 [] (_ : chatter "A" "doneA")
     31   second <- IO.spawn 0 1 [] (_ : chatter "B" "doneB")
     32   IO.yield
     33   writer <- IO.stdout
     34   IO.bind (consume writer first) (a : IO.bind (consume writer second) (b :
     35     IO.require (Text.writeText writer (B.append "Finished: " (B.append a (B.append " " (B.append b "\n"))))) (_ : IO.pure t)))))