tricu

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

core-controls.tri (2384B)

      1 !import base as B
      2 !import io_v2 as IO
      3 !export cancelChild
      4 !export currentScopes
      5 !export badFlags
      6 !export badTransfer
      7 !export discardedTicket
      8 !export selfCycle
      9 !export selfCycleWrong
     10 !export pureDomainError
     11 !export rootFailure
     12 !export rootCancelled
     13 !export malformedBind
     14 !export unknownWithPoison
     15 !export legacyEnvelope
     16 
     17 spin seed = IO.bind (IO.pure seed) (_ : spin seed)
     18 diverge seed = diverge seed
     19 joinSpawn reply = case reply of
     20   ((t t), ([task ticket], t)) = IO.require (IO.join ticket) IO.pure
     21   _ = IO.fail "invalid spawn reply"
     22 cancelChild = IO.io <| IO.require (IO.spawn 1 1 [] (_ : spin t)) (spawned : case spawned of
     23   [task ticket] = do IO.bind
     24     _ <- IO.require (IO.cancel task "stop") IO.pure
     25     IO.require (IO.join ticket) IO.pure
     26   _ = IO.fail "invalid spawn reply")
     27 currentScopes = IO.io <| do IO.bind
     28   before <- IO.currentScope
     29   inside <- IO.scope (_ : IO.currentScope)
     30   after <- IO.currentScope
     31   case after of
     32     ^before = case inside of
     33       ^before = IO.pure 0
     34       _ = IO.pure 1
     35     _ = IO.pure 0
     36 badFlags seed = IO.io (IO.spawn 2 1 [] (diverge seed))
     37 badTransfer seed = IO.io (IO.spawn 1 1 [t] (diverge seed))
     38 discardedTicket = IO.io <| IO.require (IO.spawn 1 1 [] (_ : IO.pure 5)) (spawned : case spawned of
     39   [task ticket] = IO.bind (IO.discard ticket) (_ : IO.join ticket)
     40   _ = IO.fail "invalid spawn reply")
     41 selfCheck expected = IO.bind IO.currentScope (scope : case scope of
     42   [_ identity key] = IO.scope (_ : IO.bind (IO.join ["io.v2.join" identity key]) (reply : case reply of
     43     (t, ([category _ _ _], t)) = case category of
     44       ^expected = IO.pure t
     45       _ = IO.fail "wrong cycle category"
     46     _ = IO.fail "self join succeeded"))
     47   _ = IO.fail "invalid scope")
     48 -- Parent never claims this ticket. Normal-exit joining must wait for the child's
     49 -- assertion; the wrong-expectation control must fail, not merely lose its result.
     50 selfRun expected = IO.io <| IO.bind (IO.spawn 0 1 [] (_ : selfCheck expected)) (_ : IO.pure 42)
     51 selfCycle = selfRun "join-cycle"
     52 selfCycleWrong = selfRun "not-the-category"
     53 pureDomainError = IO.io (IO.pure (B.err "ordinary" t))
     54 rootFailure seed = IO.io (IO.fail (diverge seed))
     55 rootCancelled seed = IO.io (IO.cancelled (diverge seed))
     56 malformedBind = IO.io (B.pair 1 t)
     57 unknownWithPoison seed = IO.io (IO.request "future" 3 "call" (diverge seed))
     58 legacyEnvelope seed = B.pair "tricuIO" (B.pair 1 (diverge seed))