tricu

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

369b3d37d4704c1c28f038df3392572ab906c11bbdde16710f97b33fdc3e54fd.tri (8715B)

      1 !import base as B
      2 !import io as IO
      3 !import io_v2 as V2
      4 !export pure
      5 !export bind
      6 !export request
      7 !export checkedRequest
      8 !export handle
      9 !export forward
     10 !export label
     11 !export fail
     12 !export liftIO
     13 !export runPure
     14 !export runIO
     15 !export collect
     16 !export view
     17 !export diagnostic
     18 !export scopeV2
     19 !export spawnV2
     20 !export runIOV2
     21 
     22 -- Request/response effects, separate from both host IO and base.exceptE.
     23 -- Handler callbacks return computations yielding one reply, not resumptions.
     24 pure value = B.pair 100 value
     25 bind action next = B.pair 101 (B.pair action next)
     26 request service operation argument = B.pair 102 (B.pair [service operation argument] pure)
     27 handle service handler action = B.pair 104 (B.pair [service handler] action)
     28 label name action = B.pair 105 (B.pair [name] action)
     29 fail kind service operation detail = B.pair 103 [kind service operation detail]
     30 
     31 -- Handlers execute outside their own installation scope, so forwarding is an
     32 -- ordinary request there. At other call sites this is just request, not a way
     33 -- to bypass the current environment. Names are routing values, not authority.
     34 forward = request
     35 liftIO action = request "host.io" "run" action
     36 
     37 -- Boundary constructors, not host.io requests: normalization must snapshot the
     38 -- actual lexical environment, including when invoked inside a handler callback.
     39 -- Child frames start empty; immutable routing and label values are inherited.
     40 scopeV2 body = B.pair 107 body
     41 spawnV2 supervised keep handles body = B.pair 108 [supervised keep handles body]
     42 
     43 -- Diagnostics are data: kind, service, operation, detail, outer-to-inner labels.
     44 diagnostic kind service operation detail labels = [kind service operation detail labels]
     45 
     46 checkedRequest service operation inputC outputC argument =
     47   case B.checkContract inputC argument of
     48     ((t t), (checked, t)) = do bind
     49       reply <- request service operation checked
     50       case B.checkContract outputC reply of
     51         ((t t), (value, t)) = pure value
     52         (t, (message, _)) = fail "invalid-response" service operation message
     53         _ = fail "invalid-response-contract" service operation reply
     54     (t, (message, _)) = fail "invalid-request" service operation message
     55     _ = fail "invalid-request-contract" service operation argument
     56 
     57 findHandler wanted [[service handler] | outer] = B.lazyBool
     58   (_ : B.pair handler outer)
     59   (_ : findHandler wanted outer)
     60   (B.equal? wanted service)
     61 findHandler _ _ = t
     62 
     63 -- Normalized views: 100 value; 103 complete diagnostic; 106 ([service op arg],
     64 -- outer-to-inner labels, reply continuation). View stops at the first request.
     65 -- Frames retain caller environments and labels; handlers use the environment
     66 -- suffix outside their installation, but keep the requesting execution's labels.
     67 normalize action environment frames labels = let
     68   broken = B.pair 103 (diagnostic "invalid-computation" t t t labels)
     69   resume value [] = pure value
     70   -- Force the popped stack tail's outer constructor before reusing it. A lazy
     71   -- projection here can keep consumed frames (and their old chunks) reachable.
     72   resume value [[saved savedLabels next] | rest] = case rest of
     73     [] = normalize (next value) saved [] savedLabels
     74     more{[_ | _]} = normalize (next value) saved more savedLabels
     75     _ = broken
     76   resume _ _ = broken
     77   dispatch event{[service operation argument]} next = case findHandler service environment of
     78     (handler, outer) = normalize (handler operation argument) outer
     79       (B.pair [environment labels next] frames) labels
     80     _ = B.pair 106 [event labels (reply : normalize (next reply) environment frames labels)]
     81   dispatch _ _ = broken
     82   in case action of
     83     (100, value) = resume value frames
     84     (101, (first, next)) = normalize first environment (B.pair [environment labels next] frames) labels
     85     (102, (event, next)) = dispatch event next
     86     (103, [kind service operation detail]) = B.pair 103 (diagnostic kind service operation detail labels)
     87     (104, (entry{[service handler]}, body)) = normalize body (B.pair entry environment)
     88       (B.pair [environment labels pure] frames) labels
     89     (105, (extraLabels, body)) = normalize body environment
     90       (B.pair [environment labels pure] frames) (B.append labels extraLabels)
     91     (107, body) = B.pair 107 [labels
     92       (owner : normalize (body owner) environment [] labels)
     93       (reply : resume reply frames)]
     94     (108, [supervised keep handles body]) = B.pair 108 [supervised keep handles labels
     95       (fresh : normalize (body fresh) environment [] labels)
     96       (reply : resume reply frames)]
     97     _ = broken
     98 
     99 view action = normalize action [] [] []
    100 
    101 -- Execution Result is distinct from an operation's ordinary Result value.
    102 -- Pure interpretation rejects every unhandled request, including host IO.
    103 runPure action = case view action of
    104   (100, value) = B.ok value t
    105   (103, problem) = B.err problem t
    106   (106, [[service operation argument] labels next]) = B.err
    107     (diagnostic "unhandled-request" service operation argument labels) t
    108   _ = B.err (diagnostic "invalid-view" t t t []) t
    109 
    110 -- Diagnostic labels are normally unused on successful IO. Settle their list
    111 -- spine at each IO boundary so frame projections do not retain request history.
    112 -- Label payloads and continuations remain lazy; do not normalize them as data.
    113 runHost current = case current of
    114   (100, value) = IO.pure (B.ok value t)
    115   (103, problem) = IO.pure (B.err problem t)
    116   (106, [["host.io" "run" action] labels next]) = case B.checkContract (B.listOf B.anyC) labels of
    117     ((t t), _) = IO.bind action (reply : runHost (next reply))
    118     _ = IO.pure (B.err (diagnostic "invalid-view" t t t []) t)
    119   (106, [[service operation argument] labels next]) = IO.pure <| B.err
    120     (diagnostic "unhandled-request" service operation argument labels) t
    121   _ = IO.pure (B.err (diagnostic "invalid-view" t t t []) t)
    122 runIO action = runHost (view action)
    123 
    124 -- Unlike the v1 execution-Result runner, this runner maps handler failures to
    125 -- terminal v2 outcomes. Ordinary service Results remain ordinary values. A
    126 -- supervisor observes terminal child outcomes through the host join operation.
    127 runHostV2 current = case current of
    128   (100, value) = V2.pure value
    129   (103, problem) = V2.fail problem
    130   (106, [["host.io" "run" action] labels next]) = case B.checkContract (B.listOf B.anyC) labels of
    131     ((t t), _) = V2.bind action (reply : runHostV2 (next reply))
    132     _ = V2.fail (diagnostic "invalid-view" t t t [])
    133   (106, [[service operation argument] labels next]) = V2.fail
    134     (diagnostic "unhandled-request" service operation argument labels)
    135   (107, [labels body next]) = case B.checkContract (B.listOf B.anyC) labels of
    136     ((t t), _) = V2.bind (V2.scope (owner : runHostV2 (body owner)))
    137       (reply : runHostV2 (next reply))
    138     _ = V2.fail (diagnostic "invalid-view" t t t [])
    139   (108, [supervised keep handles labels body next]) = case B.checkContract (B.listOf B.anyC) labels of
    140     ((t t), _) = V2.bind (V2.spawn supervised keep handles (fresh : runHostV2 (body fresh)))
    141       (reply : runHostV2 (next reply))
    142     _ = V2.fail (diagnostic "invalid-view" t t t [])
    143   _ = V2.fail (diagnostic "invalid-view" t t t [])
    144 runIOV2 action = runHostV2 (view action)
    145 
    146 -- Stateful collection as a boundary transformer, not mutable handler state.
    147 -- Inner handlers run first. Other residual requests are relayed to outer
    148 -- handlers, with their labels scoped ONLY around the forwarded request.
    149 -- It returns [value chronological-events]. Failures retain their labels.
    150 collect service operation argumentC reply action = let rec
    151   walk current reversed = case current of
    152     (100, value) = pure [value (B.reverse reversed)]
    153     (103, [kind failedService failedOperation detail labels]) = B.pair 105
    154       (B.pair labels (fail kind failedService failedOperation detail))
    155     (106, [event{[wanted op argument]} labels next]) = B.lazyBool
    156       (_ : case B.checkContract argumentC argument of
    157         ((t t), (checked, t)) = walk (next reply) (B.pair checked reversed)
    158         (t, (message, _)) = B.pair 105 (B.pair labels (fail "invalid-request" service operation message))
    159         _ = B.pair 105 (B.pair labels (fail "invalid-request-contract" service operation argument)))
    160       (_ : bind (B.pair 105 (B.pair labels (request wanted op argument)))
    161         (answer : walk (next answer) reversed))
    162       (B.and? (B.equal? wanted service) (B.equal? op operation))
    163     (107, [labels body next]) = B.pair 105 (B.pair labels
    164       (fail "state-boundary" service operation "Install collection inside the scoped body"))
    165     (108, [supervised keep handles labels body next]) = B.pair 105 (B.pair labels
    166       (fail "state-boundary" service operation "Install child-local collection explicitly"))
    167     _ = fail "invalid-view" t t t
    168   in walk (view action) []