Start of LinearStateMachine

examples/course.ur

@@ -3,6 +3,16 @@
 open Bootstrap3
 structure Theme = Ui.Make(Default)
 
+structure Sm = LinearStateMachine.Make(struct
+                                           val steps =
+                                               {BeforeSemester = {Label = "Before semester starts",
+                                                                  WhenEntered = fn _ => return ()},
+                                                FirstWeekOfClass = {Label = "First week of class",
+                                                                    WhenEntered = fn _ => return ()},
+                                                SemesterOver = {Label = "Semester ends",
+                                                                WhenEntered = fn _ => return ()}}
+                                       end)
+
 table section : { Section : string }
   PRIMARY KEY Section
 
@@ -526,7 +536,9 @@ val admin =
                (Some "Assign Pset Grading",
                 PsetGraders.MakeAssignments.ui),
                (Some "Assign Exam Grading",
-                ExamGraders.MakeAssignments.ui))
+                ExamGraders.MakeAssignments.ui),
+               (Some "Timeline",
+                Sm.ui))
 
 structure StaffMeetingTodo = Todo.Happenings(struct
                                                  con tag = #StaffMeeting

lib.urp

@@ -40,3 +40,4 @@ grades
 finalGrades
 discussion
 tableDiscussion
+linearStateMachine

linearStateMachine.ur

@@ -0,0 +1,100 @@
+(* Moving through steps in the life cycle of an application *)
+
+open Bootstrap3
+
+datatype activatedAs = NextStep | FastForward | Rewind
+
+type metadata = {Label : string,
+                 WhenEntered : activatedAs -> transaction unit}
+
+style downArrow
+style label
+
+functor Make(M : sig
+                 con steps :: {Unit}
+                 val fl : folder steps
+
+                 val steps : $(mapU metadata steps)
+             end) = struct
+
+    open M
+
+    type step = variant (mapU unit steps)
+
+    fun toInt (s : step) =
+        match s
+              (@fold [fn r => int * $(mapU (unit -> int) r)]
+                (fn [nm ::_] [u ::_] [r ::_] [[nm] ~ r] (n, r) =>
+                    (n-1,
+                     r ++ {nm = fn () => n}))
+                (0, {}) fl).2
+
+    val step_eq = mkEq (fn s1 s2 => toInt s1 = toInt s2)
+    val step_ord = mkOrd {Lt = fn s1 s2 => toInt s1 < toInt s2,
+                          Le = fn s1 s2 => toInt s1 <= toInt s2}
+
+    table step : { Step : serialized step }
+
+    val firstStep =
+        case @fold [fn r => option (variant (mapU unit r))]
+             (fn [nm ::_] [u ::_] [r ::_] [[nm] ~ r] _ =>
+                 Some (make [nm] ()))
+             None fl of
+            None => error <xml>Empty state machine passed to LinearStateMachine.Make</xml>
+          | Some x => x
+
+    task initialize = fn () =>
+         b <- oneRowE1 (SELECT COUNT( * ) > 0
+                        FROM step);
+         if b then
+             return ()
+         else
+             dml (INSERT INTO step(Step)
+                  VALUES ({[serialize firstStep]}))
+
+    val current =
+        s <- oneRowE1 (SELECT (step.Step)
+                       FROM step);
+        return (deserialize s)
+
+    type a = source step
+
+    val create =
+        st <- current;
+        source st
+
+    fun onload _ = return ()
+
+    fun render _ st = <xml>
+      <table>
+        {@Variant.withAllX fl
+          (fn st' => <xml>
+            <tr>
+              <td></td>
+              <td class={downArrow}><div class="glyphicon glyphicon-arrow-down"></div></td>
+            </tr>
+            <tr>
+              <td>
+                <div dynClass={cur <- signal st;
+                               return (if cur = st' then
+                                           CLASS "glyphicon glyphicon-arrow-right"
+                                       else
+                                           CLASS "")}></div>
+              </td>
+              <td class={label}>
+                <button dynClass={cur <- signal st;
+                                  return (if cur = st' then
+                                              CLASS ""
+                                          else
+                                              CLASS "btn")}>{[@Record.select [fn _ => metadata] [fn _ => unit] fl
+                                                               (fn [t] r () => r.Label)
+                                                               steps st']}</button></td>
+            </tr>
+          </xml>)}
+      </table>
+    </xml>
+
+    val ui = {Create = create,
+              Onload = onload,
+              Render = render}
+end

linearStateMachine.urs

@@ -0,0 +1,23 @@
+(* Moving through steps in the life cycle of an application *)
+
+datatype activatedAs = NextStep | FastForward | Rewind
+
+type metadata = {Label : string,
+                 WhenEntered : activatedAs -> transaction unit}
+
+style downArrow
+style label
+
+functor Make(M : sig
+                 con steps :: {Unit}
+                 val fl : folder steps
+
+                 val steps : $(mapU metadata steps)
+             end) : sig
+    type step = variant (mapU unit M.steps)
+    val step_eq : eq step
+    val step_ord : ord step
+    val current : transaction step
+
+    include Ui.S0
+end

style.css

@@ -104,3 +104,11 @@ div.Calendar_item {
     border-style: solid;
     padding: 5px;
 }
+
+.LinearStateMachine_downArrow {
+    text-align: center
+}
+
+.LinearStateMachine_label {
+    text-align: center
+}

variant.ur

@@ -29,6 +29,17 @@ fun withAll [K] [r ::: {K}] (fl : folder r) (f : variant (map (fn _ => unit) r)
     (fn [o :: {K}] [o ~ []] _ => return ())
     fl [[]] ! f
 
+fun withAllX [K] [r ::: {K}] [ctx] [inp] (fl : folder r) (f : variant (map (fn _ => unit) r) -> xml ctx inp []) =
+    @fold [fn r => o :: {K} -> [o ~ r] => (variant (map (fn _ => unit) (r ++ o)) -> xml ctx inp [])
+                                          -> xml ctx inp []]
+    (fn [nm ::_] [v ::_] [r ::_] [[nm] ~ r]
+                 (acc : o :: {K} -> [o ~ r] => (variant (map (fn _ => unit) (r ++ o)) -> xml ctx inp [])
+                                               -> xml ctx inp [])
+                 [o ::_] [o ~ [nm = v] ++ r] f =>
+        <xml>{f (make [nm] ())}{acc [[nm = v] ++ o] f}</xml>)
+    (fn [o :: {K}] [o ~ []] _ => <xml></xml>)
+    fl [[]] ! f
+
 fun erase [r ::: {Type}] (fl : folder r) (v : variant r) =
     match v
     (@fold [fn r => o :: {Type} -> [o ~ r] => $(map (fn t => t -> variant (map (fn _ => unit) (r ++ o))) r)]

variant.urs

@@ -5,6 +5,9 @@ val eq : ts ::: {Type} -> $(map eq ts) -> folder ts -> eq (variant ts)
 val withAll : K --> r ::: {K} -> folder r
               -> (variant (map (fn _ => unit) r) -> transaction unit) -> transaction unit
 
+val withAllX : K --> r ::: {K} -> ctx ::: {Unit} -> inp ::: {Type} -> folder r
+              -> (variant (map (fn _ => unit) r) -> xml ctx inp []) -> xml ctx inp []
+
 val erase : r ::: {Type} -> folder r
             -> variant r -> variant (map (fn _ => unit) r)