tricu

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

ScriptedEffects.hs (1278B)

      1 module ScriptedEffects (runScriptedEffects) where
      2 
      3 import Runtime
      4 import Test.Tasty.HUnit
      5 
      6 -- Small independent host interpreter for authenticated HTTP/registry actions.
      7 -- Never opens a socket. Every primitive must match its complete expected action;
      8 -- no unused script entries, implicit cleanup or unbounded EOF loops are allowed.
      9 runScriptedEffects :: T -> [(T, T)] -> IO T
     10 runScriptedEffects initial expected = go (256 :: Int) initial [] expected
     11   where
     12     go 0 _ _ _ = assertFailure "scripted effect trace exceeded fuel"
     13     go fuel (Fork tag payload) stack script = case toNumber tag of
     14       Right 0 -> case stack of
     15         next : rest -> go (fuel - 1) (apply next payload) rest script
     16         [] -> do
     17           assertBool "effect script left unused entries" (null script)
     18           pure payload
     19       Right 1 -> case payload of
     20         Fork action continuation -> go (fuel - 1) action (continuation : stack) script
     21         _ -> assertFailure "malformed scripted Bind"
     22       _ -> case script of
     23         (wanted, reply) : rest -> do
     24           Fork tag payload @?= wanted
     25           go (fuel - 1) (Fork (ofNumber 0) reply) stack rest
     26         [] -> assertFailure ("unscripted effect: " ++ show (toNumber tag))
     27     go _ _ _ _ = assertFailure "malformed scripted action"
     28