summaryrefslogtreecommitdiff
path: root/assignment-7/appointments.icl
diff options
context:
space:
mode:
Diffstat (limited to 'assignment-7/appointments.icl')
-rw-r--r--assignment-7/appointments.icl113
1 files changed, 94 insertions, 19 deletions
diff --git a/assignment-7/appointments.icl b/assignment-7/appointments.icl
index 9de3c26..ae23a6d 100644
--- a/assignment-7/appointments.icl
+++ b/assignment-7/appointments.icl
@@ -1,8 +1,18 @@
module appointments
-from StdFunc import flip
+from StdFunc import flip, id, seq
+
from Data.Func import $
+import Data.Functor
+import qualified Graphics.Scalable as G
+from Graphics.Scalable import class margin, instance margin Span
+import System.Time
+
import iTasks
+import iTasks.Extensions.DateTime
+import iTasks.Extensions.SVG.SVGEditor
+
+import DateExtensions
:: Appointment =
{ title :: String
@@ -13,36 +23,101 @@ import iTasks
}
derive class iTask Appointment
+derive JSEncode Appointment, User, Time, DateTime, Maybe
appointments :: Shared [Appointment]
-appointments = sharedStore "appointments" []
+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=[]}
+ ]
-Start :: *World -> *World
-Start w = startEngine
- ( addWorkFlows
- >>| loginAndManageWorkList "Scheduler" worklist
- ) w
+belongsTo :: User Appointment -> Bool
+belongsTo u a = isMember u [a.owner:a.participants]
+
+inFuture :: DateTime Appointment -> Bool
+inFuture d a = d < timestampToGmDateTime tsend
where
- addWorkFlows :: Task [Workflow]
- addWorkFlows = upd (flip (++) newwfs) workflows
- where
- newwfs =
- [ transientWorkflow "Show appointments" "Show appointments" showAppointments
- , transientWorkflow "Make appointment" "Make appointment" makeAppointment
- ]
+ (Timestamp tsapp) = utcDateTimeToTimestamp a.when
+ tsend = Timestamp $ tsapp + a.duration.Time.sec + 60 * (a.duration.Time.min + 60 * a.duration.Time.hour)
+:: ProposedAppointment =
+ { appointment :: Appointment
+ , startOptions :: [DateTime]
+ }
+
+derive class iTask ProposedAppointment
+
+proposedAppointments :: Shared [ProposedAppointment]
+proposedAppointments = sharedStore "proposedAppointments" []
+
+Start :: *World -> *World
+Start w = startEngine (loginAndManageWorkList "Scheduler" worklist) w
+where
worklist :: [Workflow]
- worklist = [workflow "Manage users" "Manage users" manageUsers]
+ worklist =
+ [ workflow "Manage users" "Manage users" manageUsers
+ , transientWorkflow "Show appointments" "Show appointments" showAppointments
+ , transientWorkflow "Make appointment" "Make appointment" makeAppointment
+ , transientWorkflow "Propose appointment" "Propose appointment" proposeAppointment
+ ]
showAppointments :: Task [Appointment]
showAppointments =
get currentUser >>= \user ->
+ get currentDateTime >>= \now ->
viewSharedInformation
(Title "Future appointments")
- [ViewAs $ filter (\a -> a.owner == user)]
+ [ViewAs (filter (\a -> belongsTo user a && inFuture now a))]
appointments
-makeAppointment :: Task [Appointment]
+/*showAppointments :: Task [Appointment]
+showAppointments =
+ get currentUser >>= \user ->
+ get currentDate >>= \date ->
+ viewSharedInformation
+ (Title "Future appointments")
+ [ViewUsing (filter (belongsTo user)) (fromSVGEditor (editor (previous Sunday date)))]
+ appointments
+where
+ editor :: Date -> SVGEditor [Appointment] [Appointment]
+ editor day =
+ { initView = id
+ , renderImage = const (draw day)
+ , updView = flip const
+ , updModel = const
+ }
+
+ draw :: Date [Appointment] *'G'.TagSource -> 'G'.Image [Appointment]
+ draw date apps tags = 'G'.beside (repeat 'G'.AtMiddleY) []
+ ['G'.margin ('G'.px 10.0) $ 'G'.above (repeat 'G'.AtLeft) []
+ ['G'.text ('G'.normalFontDef "Arial" 20.0) "Appointments":
+ ['G'.text ('G'.normalFontDef "Arial" 14.0) app.Appointment.title
+ \\ app <- appsOn day apps
+ ]] 'G'.NoHost
+ \\ day <- days
+ ]
+ 'G'.NoHost
+ where
+ days = take 7 $ iterate nextDay date
+
+ appsOn :: Date -> [Appointment] -> [Appointment]
+ appsOn d = filter (\a -> toDate a.when == d)*/
+
+makeAppointment :: Task (Maybe Appointment)
makeAppointment =
- enterInformation (Title "Make appointment") [] >>= \app ->
- upd (flip (++) [app]) appointments
+ get currentUser >>= \user ->
+ get currentDateTime >>= \now ->
+ allTasks
+ [ enterInformation "Title" [] @ \t a -> {Appointment | a & title=t}
+ , updateInformation "When" [] (nextHour now) @ \w a -> {Appointment | a & when=w}
+ , updateInformation "Duration" [] onehour @ \d a -> {Appointment | a & duration=d}
+ , 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)
+ ]
+where onehour = {Time | hour=1,min=0,sec=0}
+
+proposeAppointment :: Task (Maybe ProposedAppointment)
+proposeAppointment = return Nothing