0 | module IO.Async.JS
  1 |
  2 | import Data.Linear.Ref1
  3 | import public JS.Util
  4 | import public JS.Promise
  5 | import public IO.Async
  6 | import public IO.Async.Logging
  7 | import public IO.Async.Loop
  8 | import public IO.Async.Loop.TimerH
  9 |
 10 | %default total
 11 |
 12 | 0 Task : Type
 13 |
 14 | export
 15 | record JS where
 16 |   constructor J
 17 |   ||| Reference indicating whether the queue is currently
 18 |   ||| being processed
 19 |   running  : IORef Bool
 20 |
 21 |   ||| Work queue of this worker
 22 |   queue    : IORef (SnocList Task)
 23 |
 24 | Task = FbrState JS
 25 |
 26 | covering
 27 | spawnImpl : JS -> Task -> IO1 ()
 28 |
 29 | export %inline covering
 30 | EventLoop JS where
 31 |   spawn = spawnImpl
 32 |   limit = 1024
 33 |
 34 | export covering
 35 | app : Async JS [] () -> IO ()
 36 | app prog = do
 37 |   r <- newref False
 38 |   q <- newref [<]
 39 |   runAsyncWith (J r q) prog (\_ => putStrLn "Done. Shutting down")
 40 |
 41 | --------------------------------------------------------------------------------
 42 | -- Timers
 43 | --------------------------------------------------------------------------------
 44 |
 45 | %foreign "javascript:lambda:(m,f,w) => setTimeout(f, Number(m))"
 46 | prim__setTimeout : Integer -> PrimIO () -> PrimIO Bits32
 47 |
 48 | %foreign "javascript:lambda:(i,w) => clearTimeout(i)"
 49 | prim__clearTimeout : Bits32 -> PrimIO ()
 50 |
 51 | export
 52 | TimerH JS where
 53 |   primWait s cl act t =
 54 |    let ms    := toNano cl `div` 1_000_000
 55 |        x # t := ffi (prim__setTimeout ms (primRun act)) t
 56 |     in ffi (prim__clearTimeout x) # t
 57 |
 58 | --------------------------------------------------------------------------------
 59 | -- Promises
 60 | --------------------------------------------------------------------------------
 61 |
 62 | ||| Converts a JavaScript `Promise` to an `Async` by registering
 63 | ||| proper `resolve` and `reject` handlers.
 64 | export
 65 | promise : Has JSErr es => Promise a -> Async JS es a
 66 | promise p =
 67 |   primAsync_ $ \f => ioToF1 $ ignore $
 68 |     onPromise
 69 |       p
 70 |       (runIO . f . Right)
 71 |       (runIO . f . Left . inject . Caught)
 72 |
 73 | --------------------------------------------------------------------------------
 74 | -- Run Loop
 75 | --------------------------------------------------------------------------------
 76 |
 77 | covering
 78 | checkQueue : JS -> IO1 ()
 79 |
 80 | covering
 81 | run : JS -> List Task -> IO1 ()
 82 | run s []        t = checkQueue s t
 83 | run s (x :: xs) t =
 84 |   case runFbr s x t of
 85 |     Cont fst # t => let _ # t := mod1 s.queue (:< fst) t in run s xs t
 86 |     Done     # t => run s xs t
 87 |
 88 | -- Check if there is more work in the queue. If yes, run it, otherwise abort.
 89 | checkQueue s t =
 90 |   let sa # t := read1 s.queue t
 91 |       _  # t := write1 s.queue [<] t
 92 |    in case sa <>> [] of
 93 |         [] => write1 s.running False t
 94 |         as => run s as t
 95 |
 96 | spawnImpl s x t =
 97 |  let _     # t := mod1 s.queue (:<x) t
 98 |      False # t := read1 s.running t | True # t => () # t
 99 |      _     # t := write1 s.running True t
100 |   in run s [] t
101 |
102 | --------------------------------------------------------------------------------
103 | -- Loggable
104 | --------------------------------------------------------------------------------
105 |
106 | parameters {auto lgs : Loggable JS JSErr}
107 |
108 |   export %inline
109 |   jsunerr : (dflt : t) -> Async JS [JSErr] t -> Async JS [] t
110 |   jsunerr = unerr
111 |
112 |   export %inline
113 |   jsunerrMaybe : Async JS [JSErr] t -> Async JS [] (Maybe t)
114 |   jsunerrMaybe = unerrMaybe
115 |
116 |   export %inline
117 |   jslogErrs : Async JS [JSErr] () -> Async JS [] ()
118 |   jslogErrs = jsunerr ()
119 |