
   0 | module System.UV.Loop
   1 | 
   2 | import IO.Async.MVar
   3 | import IO.Async.Token
   4 | 
   5 | import Data.IORef
   6 | import System
   7 | import System.UV.Raw.Async
   8 | import System.UV.Raw.Handle
   9 | import System.UV.Raw.Loop
  10 | import System.UV.Raw.Pointer
  11 | 
  12 | import public IO.Async
  13 | import public System.UV.Data.Error
  14 | import public System.UV.Data.RunMode
  15 | 
  16 | %default total
  17 | 
  18 | public export
  19 | record UVLoop where
  20 |   [noHints]
  21 |   constructor MkLoop
  22 |   loop  : Ptr Loop
  23 |   async : Ptr Async
  24 |   tg    : TokenGen
  25 |   cc    : CloseCB
  26 |   ref   : IORef (SnocList $ IO ())
  27 |   limit : Nat
  28 | 
  29 | export %inline %hint
  30 | loopCtxt : UVLoop => ExecutionContext
  31 | loopCtxt @{l} =
  32 |   EC
  33 |     l.tg
  34 |     (\x => modifyIORef l.ref (:< x) >> ignore (uv_async_send l.async))
  35 |     l.limit
  36 | 
  37 | export %inline %hint
  38 | loopCloseCB : UVLoop => CloseCB
  39 | loopCloseCB @{l} = l.cc
  40 | 
  41 | ||| Returns the default loop, corresponding to `uv_default_loop`.
  42 | export
  43 | defaultLoop : IO UVLoop
  44 | defaultLoop = do
  45 |   l   <- uv_default_loop
  46 |   tg  <- newTokenGen
  47 |   ref <- newIORef {a = SnocList $ IO ()} [<]
  48 |   cc  <- defaultClose
  49 |   pa  <- mallocPtr Async
  50 | 
  51 |   let loop := MkLoop l pa tg cc ref 100
  52 | 
  53 |   r2  <- uv_async_init l pa $ \x => do
  54 |            ss <- readIORef ref
  55 |            writeIORef ref [<]
  56 |            sequence_ (ss <>> [])
  57 |   pure loop
  58 | 
  59 | parameters {auto has : Has UVError es}
  60 | 
  61 |   export
  62 |   uvCheck : a -> Int32 -> Result es a
  63 |   uvCheck v n = if n < 0 then Left (inject $ fromCode n) else Right v
  64 | 
  65 |   export %inline
  66 |   uvRes : Int32 -> Result es ()
  67 |   uvRes = uvCheck ()
  68 | 
  69 |   export
  70 |   uv : IO Int32 -> Async es ()
  71 |   uv = sync . map uvRes
  72 | 
  73 |   export
  74 |   uvAct : Resource a => (a -> IO Int32) -> a -> Async es a
  75 |   uvAct f v = onAbort (uv $ f v) (release v) $> v
  76 | 
  77 |   export
  78 |   uvCancelableAsync :
  79 |        (ptr : Async es r)
  80 |     -> (cancel : r -> Async [] ())
  81 |     -> (free   : r -> Async [] ())
  82 |     -> (r -> (a -> IO ()) -> IO Int32)
  83 |     -> Async es a
  84 |   uvCancelableAsync ptr cancel free reg =
  85 |     bracket
  86 |       ptr
  87 |       (\p => cancelableAsync $ \cb => do
  88 |          n <- reg p (cb . Succeeded)
  89 |          case uvRes n of
  90 |            Left err => cb (Error err) $> pure ()
  91 |            Right () => pure (cancel p)
  92 |            )
  93 |       free
  94 | 
  95 |   export
  96 |   uvAsync : ((Outcome es a -> IO ()) -> IO Int32) -> Async es a
  97 |   uvAsync f =
  98 |     async $ \cb => do
  99 |       n <- f cb
 100 |       case uvRes n of
 101 |         Left err => cb (Error err)
 102 |         Right () => pure ()
 103 | 
 104 | export %inline
 105 | Resource CloseCB where
 106 |   release = freeCloseCB
 107 | 
 108 | ||| Sets up the given application by registering it at the default loop
 109 | ||| and starting the loop afterwards.
 110 | covering export
 111 | runUV : (UVLoop => Async [] ()) -> IO ()
 112 | runUV act = do
 113 |   loop <- defaultLoop
 114 |   runAsync $ finally (act @{loop}) (liftIO $ uv_close loop.async loop.cc)
 115 |   res <- uv_run loop.loop (toCode Default)
 116 |   case uvRes {es = [UVError]} res of
 117 |     Left (Here err) => die "\{err}"
 118 |     Right _         => pure ()
 119 |