diff options
Diffstat (limited to 'assignment-7/appointments.icl')
| -rw-r--r-- | assignment-7/appointments.icl | 113 |
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 |