
  0 | module Web.MVC
  1 | 
  2 | import Data.IORef
  3 | import Data.Queue
  4 | 
  5 | import public JS
  6 | import public Web.MVC.Cmd
  7 | import public Web.MVC.View
  8 | import public Text.HTML
  9 | 
 10 | ||| Run (a part of) an interactive web page firing events of type
 11 | ||| `e` and holding state of type `s`.
 12 | export covering
 13 | runController :
 14 |      {0 e,s  : Type}
 15 |   -> (ctrl   : e -> s -> (s, Cmd e))
 16 |   -> (onErr  : JSErr -> IO ())
 17 |   -> (initEv : e)
 18 |   -> (initST : s)
 19 |   -> IO ()
 20 | runController ctrl onErr initEv initST = Prelude.do
 21 |   state <- newIORef initST
 22 |   flag  <- newIORef False
 23 |   queue <- newIORef $ Queue.empty {a = e}
 24 | 
 25 |   let covering handle : e -> IO ()
 26 |       handle ev = Prelude.do
 27 | 
 28 |         -- Enqueue synchronously fired events if we are already handling
 29 |         -- an event
 30 |         False <- readIORef flag | True => modifyIORef queue (`enqueue` ev)
 31 | 
 32 |         -- Start handing the event and prevent others from currently
 33 |         -- being handled
 34 |         writeIORef flag True
 35 | 
 36 |         -- read current application state
 37 |         stOld <- readIORef state
 38 | 
 39 |         -- compute new application state and the command to run
 40 |         let (stNew, cmd) := ctrl ev stOld
 41 | 
 42 |         -- update application state
 43 |         writeIORef state stNew
 44 | 
 45 |         -- run the command by invoking it with this very event handler
 46 |         -- the command might fire one or more events synchronously. these
 47 |         -- will be enqueued and processed in a moment.
 48 |         ei <- runEitherT (run cmd (liftIO . handle))
 49 | 
 50 |         case ei of
 51 |           Left err => onErr err
 52 |           Right () => pure ()
 53 | 
 54 |         -- we are do with handling the current event so we set the flag
 55 |         -- back to false.
 56 |         writeIORef flag False
 57 | 
 58 |         -- we are now going to process the next enqueued command (if any)
 59 |         Just (ev2,q) <- dequeue <$> readIORef queue | Nothing => pure ()
 60 |         writeIORef queue q
 61 |         handle ev2
 62 | 
 63 |   handle initEv
 64 | 
 65 | export covering
 66 | runMVC :
 67 |      {0 e,s   : Type}
 68 |   -> (update  : e -> s -> s)
 69 |   -> (display : e -> s -> Cmd e)
 70 |   -> (onErr   : JSErr -> IO ())
 71 |   -> (initEv  : e)
 72 |   -> (initST  : s)
 73 |   -> IO ()
 74 | runMVC upd disp onErr =
 75 |   runController (\ev,st => let st2 := upd ev st in (st2, disp ev st2)) onErr
 76 |