tricu

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

BrowserRuntime.hs (11081B)

      1 {-# LANGUAGE BangPatterns #-}
      2 -- Browser embedding primitives, not an alternate evaluator. All application is
      3 -- Runtime.Tree.apply; observation budgets bound transport, not reduction fuel.
      4 module BrowserRuntime where
      5 import Runtime.Tree
      6 import Runtime.Value
      7 import Control.Exception (evaluate)
      8 import Control.Monad (unless, forM_, foldM)
      9 import Data.Array (Array, listArray, (!), elems)
     10 import Data.Bits ((.|.), shiftL)
     11 import qualified Data.ByteString as BS
     12 import qualified Data.Text as Text
     13 import qualified Data.Text.Encoding as Text
     14 import qualified Data.IntMap.Strict as IM
     15 import qualified Data.IntSet as IS
     16 import Data.IORef
     17 import Data.Char (ord)
     18 import Data.List (intercalate)
     19 import System.Mem.StableName
     20 import Data.Word (Word32)
     21 import Numeric (showHex)
     22 import Text.Read (readMaybe)
     23 
     24 -- JSON output only. Inputs use length-prefixed byte fields, avoiding a second
     25 -- implementation of the site's JSON/literal validator inside the RTS.
     26 data J = S String | N Integer | B Bool | A [J] | O [(String,J)]
     27 json :: J -> String
     28 json (S s)='"':concatMap escape s++"\"" where
     29   escape '"'="\\\""; escape '\\'="\\\\"
     30   escape c | ord c<32 = let h=showHex (ord c) "" in "\\u"++replicate (4-length h) '0'++h
     31            | otherwise=[c]
     32 json (N n)=show n
     33 json (B b)=if b then "true" else "false"
     34 json (A xs)="["++intercalate "," (map json xs)++"]"
     35 json (O xs)="{"++intercalate "," [json(S k)++":"++json v | (k,v)<-xs]++"}"
     36 number :: Int -> J
     37 number=N . toInteger
     38 
     39 word :: BS.ByteString -> Int -> Int
     40 word b at=fromIntegral (foldr (.|.) 0 [fromIntegral(BS.index b (at+j)) `shiftL` (8*j) | j<-[0..3]] :: Word32)
     41 fields :: BS.ByteString -> IO [BS.ByteString]
     42 fields b=go 0 0 where
     43   go at count
     44     | at==BS.length b=pure []
     45     | count>=16384 || BS.length b-at<4=fail "invalid field framing"
     46     | otherwise=do
     47         let n=word b at
     48         unless(n>=0 && n<=BS.length b-at-4)(fail "truncated field")
     49         rest<-go (at+4+n) (count+1)
     50         pure(BS.take n (BS.drop (at+4) b):rest)
     51 utf8 :: BS.ByteString -> IO String
     52 utf8=either (fail.show) (pure.Text.unpack) . Text.decodeUtf8'
     53 index :: Int -> BS.ByteString -> IO Int
     54 index upper b=do
     55   s<-utf8 b
     56   case readMaybe s of Just n | n>=0 && n<upper -> pure n; _->fail "invalid index"
     57 
     58 loadDAG :: BS.ByteString -> IO (Array Int T,Int)
     59 loadDAG b=do
     60   unless(BS.length b>=8)(fail "truncated DAG")
     61   let n=word b 0;root=word b 4
     62   unless(n>0 && n<=1000000 && root>=0 && root<n && BS.length b==8+9*n)(fail "invalid DAG header")
     63   forM_ [0..n-1] $ \i->do
     64     let at=8+9*i;tag=BS.index b at;l=word b (at+1);r=word b(at+5);prior x=x>=0&&x<i
     65     unless(case tag of 0->l==0&&r==0;1->prior l&&r==0;2->prior l&&prior r;_->False)(fail "invalid DAG record")
     66   let trees=listArray (0,n-1) [case BS.index b(8+9*i) of
     67         0->Leaf;1->Stem(trees!word b(9+9*i));_->Fork(trees!word b(9+9*i))(trees!word b(13+9*i)) | i<-[0..n-1]]
     68   forM_ (elems trees) $ \t->evaluate(case t of Leaf->();Stem x->x `seq` ();Fork x y->x `seq` y `seq` ())
     69   pure(trees,n)
     70 
     71 boundedList :: Int -> T -> IO [T]
     72 boundedList limit=go limit where
     73   go n tree=case tree of
     74     Leaf->pure []
     75     Fork a rest | n>0 ->(a:) <$> go(n-1) rest
     76                 | otherwise->fail "List decode limit exceeded"
     77     _->fail "Invalid canonical list"
     78 natural :: T -> IO Integer
     79 natural=go 0 1 0 where
     80   go !bits !place !acc tree
     81     | bits>4096=fail "Natural number decode limit exceeded"
     82     | otherwise=case tree of
     83         Leaf->pure acc
     84         Fork bit rest->case bit of
     85           Leaf->go(bits+1)(2*place)acc rest
     86           Stem Leaf->go(bits+1)(2*place)(acc+place)rest
     87           _->fail "Invalid number bit"
     88         _->fail "Invalid canonical number"
     89 text :: Int -> T -> IO String
     90 text limit tree=boundedList limit tree >>= mapM (\t->natural t >>= either fail pure . toChar)
     91 boolean :: T -> IO Bool
     92 boolean Leaf=pure False
     93 boolean (Stem Leaf)=pure True
     94 boolean _=fail "Invalid canonical Boolean"
     95 pair :: T -> IO (T,T)
     96 pair (Fork a b)=pure(a,b)
     97 pair _=fail "Expected pair"
     98 
     99 -- Local IDs label a snapshot only. Register children WITHOUT evaluating them.
    100 -- Stable-name collisions are resolved by equality; aliases record thunk updates.
    101 -- Hitting the budget never forces the next pending child.
    102 preview :: Int -> T -> IO J
    103 preview limit root=do
    104   unless(limit>=1 && limit<=100000)(fail "Invalid snapshot budget")
    105   memo<-newIORef IM.empty
    106   next<-newIORef 0
    107   done<-newIORef IS.empty
    108   let register t=do
    109         sn<-makeStableName t
    110         seen<-readIORef memo
    111         case lookup sn (IM.findWithDefault [] (hashStableName sn) seen) of
    112           Just ident->pure ident
    113           Nothing->do
    114             ident<-readIORef next;modifyIORef' next (+1)
    115             modifyIORef' memo (IM.insertWith (++) (hashStableName sn) [(sn,ident)])
    116             pure ident
    117       go [] _ rows aliases=pure(rows,aliases,False)
    118       go _ 0 rows aliases=pure(rows,aliases,True)
    119       go ((ident,input):pending) budget rows aliases=do
    120         tree<-evaluate input
    121         sn<-makeStableName tree
    122         seen<-readIORef memo
    123         case lookup sn (IM.findWithDefault [] (hashStableName sn) seen) of
    124           Just other | other/=ident ->go pending budget rows ((ident,other):aliases)
    125           _->do
    126             modifyIORef' memo (IM.insertWith (++) (hashStableName sn) [(sn,ident)])
    127             visited<-readIORef done
    128             if IS.member ident visited then go pending budget rows aliases else do
    129               modifyIORef' done (IS.insert ident)
    130               let (kind,children)=case tree of Leaf->("leaf",[]);Stem a->("stem",[a]);Fork a b->("fork",[a,b])
    131               ids<-mapM register children
    132               go (reverse(zip ids children)++pending) (budget-1) ((ident,kind,ids):rows) aliases
    133   rid<-register root
    134   (rows,aliases,truncated)<-go [(rid,root)] limit [] []
    135   pure(O [("root",number rid),("nodes",A [O[("id",number i),("kind",S k),("children",A(map number cs))] | (i,k,cs)<-reverse rows]),
    136           ("aliases",A[O[("from",number a),("to",number b)] | (a,b)<-reverse aliases]),("truncated",B truncated)])
    137 
    138 view :: String -> T -> IO J
    139 view kind tree=do
    140   value<-case kind of
    141     "tricu"->preview 100000 tree
    142     "triangle"->preview 100000 tree
    143     "dag"->preview 100000 tree
    144     "ternary"->preview 100000 tree
    145     "tree"->preview 64 tree
    146     "string"->S <$> text 4096 tree
    147     "number"->S . show <$> natural tree
    148     "bool"->B <$> boolean tree
    149     "bytes"->do
    150       xs<-boundedList 4096 tree
    151       A <$> mapM (\x->do n<-natural x;unless(n<=255)(fail "Invalid byte");pure(N n)) xs
    152     "list"->boundedList 32 tree >>= fmap A . mapM (preview 8)
    153     "record"->do
    154       rows<-boundedList 32 tree
    155       (_,_,values)<-foldM record ([],0,[]) rows
    156       pure(O(reverse values))
    157     _->fail "Unsupported output codec"
    158   pure(O[("type",S kind),("value",value)])
    159   where
    160     record (names,size,values) row=do
    161       xs<-boundedList 3 row
    162       (key,tag,t)<-case xs of [a,b,c]->pure(a,b,c);_->fail "Record field must be [name tag value]"
    163       name<-text 128 key
    164       unless(not(null name)&&name `notElem` names)(fail "Record field names must be nonempty and unique")
    165       code<-natural tag
    166       (value,len)<-case code of
    167         0->do s<-text 4096 t;pure(S s,length s)
    168         1->do n<-natural t;unless(n<=9007199254740991)(fail "Record number exceeds safe integer range");pure(N n,length(show n))
    169         2->do b<-boolean t;pure(B b,if b then 4 else 5)
    170         _->fail "Unsupported record field tag"
    171       let total=size+length name+len
    172       unless(total<=16384)(fail "Record output limit exceeded")
    173       pure(name:names,total,(name,value):values)
    174 
    175 -- Explicit action machine. Events contain no tree handles; the RTS owns all
    176 -- continuations while the browser is waiting. Each resume consumes a fresh token.
    177 data Machine = Machine T [T] Int Int
    178 data Phase = Before Machine Integer T | ReadLine Machine | Wrote Machine | After Machine String | Done T
    179 
    180 beginIO :: T -> IO Phase
    181 beginIO root=do
    182   (sentinel,body)<-pair root
    183   s<-text 7 sentinel
    184   unless(s=="tricuIO")(fail "Missing tricuIO sentinel")
    185   (version,action)<-pair body
    186   v<-natural version
    187   unless(v==1)(fail "Unsupported tricuIO version")
    188   advance(Machine action [] 0 0)
    189 advance :: Machine -> IO Phase
    190 advance machine@(Machine action _ step _)=do
    191   unless(step<128)(fail "IO action limit exceeded")
    192   (tag,payload)<-pair action
    193   code<-natural tag
    194   unless(code `elem` [0,1,2,10,11])(fail ("Unsupported browser IO action "++show code))
    195   pure(Before machine code payload)
    196 finishValue :: String -> Machine -> T -> Phase
    197 finishValue _ (Machine _ [] _ _) value=Done value
    198 finishValue name (Machine _ (f:fs) step output) value=After (Machine (apply f value) fs step output) name
    199 
    200 -- An after event precedes completion too, so stepping never skips an action.
    201 data Pending = Pending Phase | Complete T Int String
    202 resumeIO :: Pending -> String -> IO Pending
    203 resumeIO (Complete value _ _) _=pure(Pending(Done value))
    204 resumeIO (Pending phase) value=case phase of
    205   Before (Machine action frames step output) code payload->do
    206     let m=Machine action frames (step+1) output
    207         result v=case frames of []->Complete v (step+1) (actionName code);_->Pending(finishValue (actionName code) m v)
    208     case code of
    209       0->pure(result payload)
    210       1->do (left,k)<-pair payload;pure(Pending(After (Machine left (k:frames) (step+1) output) "bind"))
    211       2->fail "Execution aborted (diagnostic payload not forced)."
    212       10->do
    213         s<-text 4096 payload
    214         unless(output+length s<=16384)(fail "Terminal output limit exceeded")
    215         pure(Pending(Wrote(Machine action frames (step+1) (output+length s))))
    216       11->pure(Pending(ReadLine m))
    217       _->fail "Unsupported IO action"
    218   ReadLine m@(Machine _ frames step _)->do
    219     unless(length value<=256 && all (`notElem` "\r\n") value)(fail "Input must be one bounded line")
    220     let t=ofString value
    221     pure(if null frames then Complete t step "getLine" else Pending(finishValue "getLine" m t))
    222   Wrote m@(Machine _ frames step _)->pure(if null frames then Complete Leaf step "putStr" else Pending(finishValue "putStr" m Leaf))
    223   After m _->Pending <$> advance m
    224   Done _->fail "IO already finished"
    225 actionName :: Integer -> String
    226 actionName code=case code of 0->"pure";1->"bind";2->"abortIO";10->"putStr";11->"getLine";_->"unknown"
    227 event :: Integer -> Pending -> IO J
    228 event token pending=do
    229   payload<-case pending of
    230     Complete _ step name->pure[("kind",S "after"),("step",number step),("name",S name),("value",S "retained value")]
    231     Pending phase->case phase of
    232       Before (Machine _ frames step _) code t->do
    233         detail<-if code==10 then text 4096 t else pure "retained value"
    234         pure[("kind",S "before"),("step",number(step+1)),("name",S(actionName code)),("detail",S detail),("depth",number(length frames))]
    235       ReadLine _->pure[("kind",S "read")]
    236       Wrote (Machine action _ _ _)->do (_,t)<-pair action;s<-text 4096 t;pure[("kind",S "write"),("text",S s)]
    237       After (Machine _ _ step _) name->pure[("kind",S "after"),("step",number step),("name",S name),("value",S "retained value")]
    238       Done _->pure[("kind",S "done")]
    239   pure(O(("token",N token):payload))