Add 'shf/' from commit 'b6c5a95b664aeb861d7b33ffc9eefe447ba99dd7'

git-subtree-dir: shf
git-subtree-mainline: 401408448f
git-subtree-split: b6c5a95b66

shf/shell/updater.sml

@@ -0,0 +1,47 @@
+structure Updater =
+struct
+  open MailboxType
+  open InputMsg
+
+  fun sendMsg msg =
+    case msg of DRAW msg => DrawMailbox.append msg
+
+  fun sendMsgs msgList =
+    case msgList of
+      hd :: tl => let val () = sendMsg hd in sendMsgs tl end
+    | [] => ()
+
+  fun updateOne (app: AppType.app_type, inputMsg) =
+    let
+      val time = Time.now ()
+
+      val () =
+        case inputMsg of
+          CHAR_EVENT #"~" =>
+            ExceptionLogger.log (Fail "intentionally caused exception")
+        | _ => ()
+
+      val () = ExceptionLogger.addCommand inputMsg
+
+      val app = AppUpdate.update (app, inputMsg, time)
+                handle e => ExceptionLogger.log e
+
+      val () = sendMsgs (#msgs app)
+    in
+      app
+    end
+
+  fun updateLoop (pos, msgVec, app) =
+    if pos = Vector.length msgVec then
+      app
+    else
+      let
+        val msg = Vector.sub (msgVec, pos)
+        val app = updateOne (app, msg)
+      in
+        updateLoop (pos + 1, msgVec, app)
+      end
+
+  fun update app =
+    updateLoop (0, InputMailbox.getMessagesAndClear (), app)
+end