tricu

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

consumer_effect_costs_pinned.tri (3130B)

      1 !import "prelude" !Local
      2 !import "io" !Local
      3 !import "consumers.structural" S
      4 !import "consumers.lexical-worker" L
      5 !import "consumers.unit-compile" U
      6 !import "consumers.effect-compose" E
      7 !import "consumers.effect" Registry
      8 
      9 source = __SCP_SOURCE__
     10 rowsResult = U.compileScpUnit source t
     11 receivers rows = map (row : pair (fst row) (S.makeConsumer t (L.lWorker t (fst (snd row))))) rows
     12 localNames = [(pair "shared" ["shared" "sharedRead" "held" "finish"])
     13   (pair "distinct" ["distinct" "loaded" "held" "finish"])
     14   (pair "chain" ["chain" "finish"]) (pair "leaf" ["leaf" "leafEnd"])]
     15 selected narrow rows entry = (lazyBool
     16   (_ : lazyMaybe (_ : t)
     17     (names : filter (row : lExist? (fst row) names) (receivers rows))
     18     (Registry.lookup localNames entry))
     19   (_ : receivers rows) narrow)
     20 package narrow rows entry helpers = (bindResult
     21   (L.lPrepareEffectReceivers (selected narrow rows entry)) (prepared _ :
     22     E.makePackage entry prepared helpers))
     23 checkpoint _ = thenIO yield (pure (ok t t))
     24 tick value = pure (ok value t)
     25 -- Hashing forces the runtime byte tree before it enters a retained frame.
     26 loadPayload path = (onOk_ (readFile path) (payload :
     27   onOk_ (sha256Hex payload) (_ : pure (ok payload t))))
     28 operations = [(pair "Tick" tick) (pair "ReadBytes" loadPayload) (pair "Checkpoint" checkpoint)]
     29 -- A second yield separates scheduler completion from full Result validation.
     30 finish expected result = thenIO yield (pure (ok (equal? result (ok expected t)) t))
     31 runRecursive step narrow entry input payload expected = (E.prepare rowsResult (rows :
     32   E.prepare (package narrow rows entry [(pair "again" E.selfReference)]) (scope :
     33     bind (E.run step operations scope input payload) (result : finish expected result))))
     34 shared step narrow input path = (io (onOk_ (loadPayload path) (payload :
     35   runRecursive step narrow "shared" input payload (map (_ : payload) input))))
     36 distinct step narrow input path = (io (onOk_ (loadPayload path) (payload :
     37   runRecursive step narrow "distinct" input path (map (_ : payload) input))))
     38 chain step narrow input path = (io (onOk_ (loadPayload path) (payload :
     39   E.prepare rowsResult (rows :
     40     E.prepare (package narrow rows "leaf" t) (leaf :
     41       E.prepare (package narrow rows "chain" [(pair "leaf" leaf)]) (scope :
     42         lazyMaybe (_ : abortIO "missing chain worker")
     43           (loop : bind (E.run step operations scope (pair input t)
     44             (pair (snd loop) payload)) (result : finish t result))
     45           (Registry.lookup (selected narrow rows "chain") "chain")))))))
     46 runShared = shared L.lEffectStep false
     47 runDistinct = distinct L.lEffectStep false
     48 runChain = chain L.lEffectStep false
     49 runNarrowShared = shared L.lEffectStep true
     50 runNarrowDistinct = distinct L.lEffectStep true
     51 runNarrowChain = chain L.lEffectStep true
     52 runPreparedShared = shared L.lPreparedEffectStep false
     53 runPreparedDistinct = distinct L.lPreparedEffectStep false
     54 runPreparedChain = chain L.lPreparedEffectStep false
     55 runNarrowPreparedShared = shared L.lPreparedEffectStep true
     56 runNarrowPreparedDistinct = distinct L.lPreparedEffectStep true
     57 runNarrowPreparedChain = chain L.lPreparedEffectStep true
     58 t