tricu

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

BrowserTrees.hs (3262B)

      1 -- Private, run-local handles for the JS interaction interpreter inside the worker.
      2 -- No handles cross RuntimeSession. Registration never forces a tree; observation
      3 -- forces only its outer constructor. Sweep occurs between interpreter turns.
      4 module BrowserTrees (begin, command, clear, active) where
      5 
      6 import qualified BrowserRuntime as R
      7 import Runtime.Tree
      8 import Control.Exception (evaluate)
      9 import Control.Monad (unless)
     10 import Data.IORef
     11 import qualified Data.IntMap.Lazy as IM
     12 import System.IO.Unsafe (unsafePerformIO)
     13 import Text.Read (readMaybe)
     14 
     15 {-# NOINLINE trees #-}
     16 trees :: IORef (Maybe (IM.IntMap T))
     17 trees = unsafePerformIO (newIORef Nothing)
     18 {-# NOINLINE next #-}
     19 next :: IORef Integer
     20 next = unsafePerformIO (newIORef 1)
     21 
     22 active :: IO Bool
     23 active = maybe False (const True) <$> readIORef trees
     24 clear :: IO ()
     25 clear = writeIORef trees Nothing
     26 store :: IO (IM.IntMap T)
     27 store = readIORef trees >>= maybe (fail "no private tree run") pure
     28 put :: T -> IO Int
     29 put value = do
     30   table <- store
     31   key <- readIORef next
     32   -- wasm32 Int is narrower than a JS safe integer; never wrap either domain.
     33   unless (key <= min 9007199254740991 (toInteger (maxBound :: Int))) (fail "private tree identity exhausted")
     34   let ident = fromInteger key
     35   writeIORef trees (Just (IM.insert ident value table))
     36   writeIORef next (key+1)
     37   pure ident
     38 ident :: String -> IO Int
     39 ident text = case readMaybe text :: Maybe Integer of
     40   Just value | value > 0 && value <= toInteger (maxBound :: Int) && show value == text -> pure (fromInteger value)
     41   _ -> fail "invalid private tree handle"
     42 get :: String -> IO T
     43 get text = do
     44   key <- ident text
     45   table <- store
     46   maybe (fail "stale private tree handle") pure (IM.lookup key table)
     47 number :: Int -> R.J
     48 number = R.N . toInteger
     49 begin :: T -> IO R.J
     50 begin action = do
     51   busy <- active
     52   unless (not busy) (fail "private tree run already active")
     53   writeIORef trees (Just IM.empty)
     54   leaf <- put Leaf
     55   root <- put action
     56   pure (R.O [("leaf",number leaf),("action",number root)])
     57 command :: [String] -> IO R.J
     58 command fields = case fields of
     59   ["observe",handle] -> do
     60     tree <- get handle >>= evaluate
     61     node <- case tree of
     62       Leaf -> pure (R.O [("kind",R.S "leaf")])
     63       Stem child -> do
     64         key <- put child
     65         pure (R.O [("kind",R.S "stem"),("child",number key)])
     66       Fork left right -> do
     67         a <- put left; b <- put right
     68         pure (R.O [("kind",R.S "fork"),("left",number a),("right",number b)])
     69     pure (R.O [("node",node)])
     70   ["stem",a] -> get a >>= put . Stem >>= pure . number
     71   ["fork",a,b] -> do
     72     left <- get a; right <- get b
     73     put (Fork left right) >>= pure . number
     74   ["app",a,b] -> do
     75     left <- get a; right <- get b
     76     put (apply left right) >>= pure . number
     77   "retain":handles -> do
     78     unless (length handles <= 100000) (fail "private root limit")
     79     keys <- mapM ident handles
     80     table <- store
     81     unless (all (`IM.member` table) keys) (fail "stale private tree handle")
     82     writeIORef trees (Just (IM.fromList [(key,table IM.! key) | key <- keys]))
     83     pure (number (length keys))
     84   ["view",handle,codec] -> get handle >>= R.view codec
     85   ["count"] -> number . IM.size <$> store
     86   ["clear"] -> clear >> pure (R.O [])
     87   _ -> fail "invalid private tree operation"