diff options
| -rw-r--r-- | assignment-7/DateExtensions.dcl | 2 | ||||
| -rw-r--r-- | assignment-7/DateExtensions.icl | 6 | ||||
| -rw-r--r-- | assignment-7/appointments.icl | 45 |
3 files changed, 45 insertions, 8 deletions
diff --git a/assignment-7/DateExtensions.dcl b/assignment-7/DateExtensions.dcl index c7eacec..1cce935 100644 --- a/assignment-7/DateExtensions.dcl +++ b/assignment-7/DateExtensions.dcl @@ -7,6 +7,8 @@ import iTasks.Extensions.DateTime derive class iTask Day instance toString Day +addTime :: Time DateTime -> DateTime + nextHour :: DateTime -> DateTime nextDay :: (Date -> Date) diff --git a/assignment-7/DateExtensions.icl b/assignment-7/DateExtensions.icl index fa9ebb0..eded992 100644 --- a/assignment-7/DateExtensions.icl +++ b/assignment-7/DateExtensions.icl @@ -30,6 +30,12 @@ where timestampToGmDate :: (Timestamp -> Date) timestampToGmDate = toDate o timestampToGmDateTime +addTime :: Time DateTime -> DateTime +addTime t dt = timestampToGmDateTime (Timestamp dt`) +where + (Timestamp dtst) = utcDateTimeToTimestamp dt + dt` = dtst + 3600 * t.Time.hour + 60 * t.Time.min + t.Time.sec + nextHour :: DateTime -> DateTime nextHour t = timestampToGmDateTime (Timestamp ts`) where diff --git a/assignment-7/appointments.icl b/assignment-7/appointments.icl index ae23a6d..773e7d3 100644 --- a/assignment-7/appointments.icl +++ b/assignment-7/appointments.icl @@ -4,11 +4,15 @@ from StdFunc import flip, id, seq from Data.Func import $ import Data.Functor +import Data.List +import qualified Data.Map as M import qualified Graphics.Scalable as G from Graphics.Scalable import class margin, instance margin Span import System.Time +from Text import class Text(concat), instance Text String import iTasks +import iTasks.UI.Editor.Common import iTasks.Extensions.DateTime import iTasks.Extensions.SVG.SVGEditor @@ -26,10 +30,7 @@ derive class iTask Appointment derive JSEncode Appointment, User, Time, DateTime, Maybe appointments :: Shared [Appointment] -appointments = sharedStore "appointments" - [ {title="Sunday", when={DateTime | year=2017,mon=10,day=29,hour=10,min=0,sec=0}, duration={Time | hour=1,min=0,sec=0}, owner=SystemUser, participants=[]} - , {title="Monday", when={DateTime | year=2017,mon=10,day=30,hour=12,min=0,sec=0}, duration={Time | hour=1,min=0,sec=0}, owner=SystemUser, participants=[]} - ] +appointments = sharedStore "appointments" [] belongsTo :: User Appointment -> Bool belongsTo u a = isMember u [a.owner:a.participants] @@ -40,6 +41,27 @@ where (Timestamp tsapp) = utcDateTimeToTimestamp a.when tsend = Timestamp $ tsapp + a.duration.Time.sec + 60 * (a.duration.Time.min + 60 * a.duration.Time.hour) +addAppointment :: Appointment -> Task Appointment +addAppointment app = + upd (flip (++) [app]) appointments >>| + allTasks [assign (attrs u) finishTask \\ u <- app.participants] $> + app +where + finishTask :: Task () + finishTask = + wait (Title "Wait for the start of this appointment") (\now -> now >= app.when) currentDateTime >>= \_ -> + viewInformation (Title app.Appointment.title) [] "Click 'Done' to finish this task." >>* + [OnAction (Action "Done") (always $ return ())] + + attrs :: User -> TaskAttributes + attrs u = workerAttributes u + [ ("title", app.Appointment.title) + , ("createdAt", toString app.when) + , ("createdBy", toString app.owner) + , ("createdFor", toString u) + , ("completeBefore", toString (addTime app.duration app.when)) + ] + :: ProposedAppointment = { appointment :: Appointment , startOptions :: [DateTime] @@ -55,7 +77,7 @@ Start w = startEngine (loginAndManageWorkList "Scheduler" worklist) w where worklist :: [Workflow] worklist = - [ workflow "Manage users" "Manage users" manageUsers + [ restrictedTransientWorkflow "Manage users" "Manage users" ["admin"] manageUsers , transientWorkflow "Show appointments" "Show appointments" showAppointments , transientWorkflow "Make appointment" "Make appointment" makeAppointment , transientWorkflow "Propose appointment" "Propose appointment" proposeAppointment @@ -67,8 +89,15 @@ showAppointments = get currentDateTime >>= \now -> viewSharedInformation (Title "Future appointments") - [ViewAs (filter (\a -> belongsTo user a && inFuture now a))] + [ViewUsing (filter (\a -> belongsTo user a && inFuture now a)) editor] appointments +where + editor = listEditor Nothing False False Nothing (bijectEditorValue toTuple fromTuple tupEdit) + tupEdit = toolbar5 gEditor{|*|} gEditor{|*|} gEditor{|*|} userViewer usersViewer + userViewer = comapEditorValue toString gEditor{|*|} + usersViewer = comapEditorValue (concat o intersperse "; " o map toString) gEditor{|*|} + toTuple app = (app.Appointment.title, app.when, app.duration, app.owner, app.participants) + fromTuple (t,w,d,o,p) = {title=t, when=w, duration=d, owner=o, participants=p} /*showAppointments :: Task [Appointment] showAppointments = @@ -114,8 +143,8 @@ makeAppointment = , enterMultipleChoiceWithShared "Participants" [ChooseFromCheckGroup id] users @ \ps a -> {a & participants=ps} ] @ flip seq {gDefault{|*|} & owner=user} >>* - [ OnAction (Action "Make") (hasValue \app -> upd (flip (++) [app]) appointments $> Just app) - , OnAction ActionCancel (always $ return Nothing) + [ OnAction (Action "Make") (hasValue $ fmap Just o addAppointment) + , OnAction ActionCancel (always $ makeAppointment) ] where onehour = {Time | hour=1,min=0,sec=0} |