module appointments from StdFunc import flip, id, seq import StdInt import GenPrint import Data.Bifunctor from Data.Func import $ import Data.Functor import Data.List import qualified Data.Map as M import Data.Tuple import qualified Graphics.Scalable as G from Graphics.Scalable import class margin, instance margin Span, class *.(..), instance *. Span, :: FontDef{..}, :: FillAttr{..}, :: StrokeAttr{..}, :: StrokeWidthAttr{..}, <@<, class tuneImage, instance tuneImage FillAttr, instance tuneImage StrokeAttr, instance tuneImage StrokeWidthAttr, class toSVGColor(..), instance toSVGColor String import System.Time from Text import class Text(concat), instance Text String, <+ import Text.HTML import iTasks import iTasks.UI.Editor.Common import iTasks.Extensions.DateTime import iTasks.Extensions.SVG.SVGEditor import DateExtensions indexOf :: a [a] -> Int | == a indexOf e [x:xs] = if (x == e) 0 (1 + indexOf e xs) :: Appointment = { title :: String , when :: DateTime , duration :: Time , owner :: User , participants :: [User] } derive class iTask Appointment derive JSEncode Appointment, User, Time, DateTime, Maybe instance == Appointment where == a b = a === b // Some examples. Change the day fields (+7) if working later than 2017-11-18. // For these tasks, no user tasks are created (this is done in addAppointment). // They are just here to make it easier to develop the SVG calendar. appointments :: Shared [Appointment] appointments = sharedStore "appointments" [ {title="Advanced Programming", when={DateTime|year=2017,mon=11,day=13,hour=10,min=30,sec=0}, duration={Time|hour=2,min=0,sec=0}, owner=AuthenticatedUser "root" ["admin","manager"] (Just "Root user"), participants=[]} , {title="Information Retrieval", when={DateTime|year=2017,mon=11,day=13,hour=15,min=30,sec=0}, duration={Time|hour=2,min=0,sec=0}, owner=AuthenticatedUser "root" ["admin","manager"] (Just "Root user"), participants=[]} , {title="Cultural Contacts", when={DateTime|year=2017,mon=11,day=14,hour=13,min= 0,sec=0}, duration={Time|hour=2,min=0,sec=0}, owner=AuthenticatedUser "root" ["admin","manager"] (Just "Root user"), participants=[]} , {title="Historical Grammar", when={DateTime|year=2017,mon=11,day=14,hour=15,min= 0,sec=0}, duration={Time|hour=2,min=0,sec=0}, owner=AuthenticatedUser "root" ["admin","manager"] (Just "Root user"), participants=[]} , {title="Text Mining", when={DateTime|year=2017,mon=11,day=15,hour= 8,min=30,sec=0}, duration={Time|hour=2,min=0,sec=0}, owner=AuthenticatedUser "root" ["admin","manager"] (Just "Root user"), participants=[]} , {title="Testing Techniques", when={DateTime|year=2017,mon=11,day=15,hour= 8,min=30,sec=0}, duration={Time|hour=2,min=0,sec=0}, owner=AuthenticatedUser "root" ["admin","manager"] (Just "Root user"), participants=[]} , {title="Testing Techniques", when={DateTime|year=2017,mon=11,day=17,hour= 8,min=30,sec=0}, duration={Time|hour=2,min=0,sec=0}, owner=AuthenticatedUser "root" ["admin","manager"] (Just "Root user"), participants=[]} , {title="Advanced Programming", when={DateTime|year=2017,mon=11,day=17,hour=10,min=30,sec=0}, duration={Time|hour=2,min=0,sec=0}, owner=AuthenticatedUser "root" ["admin","manager"] (Just "Root user"), participants=[]} ] belongsTo :: User Appointment -> Bool belongsTo u a = isMember u [a.owner:a.participants] inFuture :: DateTime Appointment -> Bool inFuture d a = d < addTime a.duration a.when overlap :: Appointment Appointment -> Bool overlap a b = a.when.DateTime.year == b.when.DateTime.year && a.when.DateTime.mon == b.when.DateTime.mon && a.when.DateTime.day == b.when.DateTime.day && (starta <= startb && enda >= startb || startb <= starta && endb >= starta) where starta = 3600 * a.when.DateTime.hour + 60 * a.when.DateTime.min + a.when.DateTime.sec startb = 3600 * b.when.DateTime.hour + 60 * b.when.DateTime.min + b.when.DateTime.sec enda = starta + 3600 * a.duration.Time.hour + 60 * a.duration.Time.min + a.duration.Time.sec endb = startb + 3600 * b.duration.Time.hour + 60 * b.duration.Time.min + b.duration.Time.sec 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 >>= \_ -> viewSharedInformation (Title app.Appointment.title) [ViewAs (const "Click 'Done' to finish this task.")] currentDateTime >>* [ OnAction (Action "Done") (always $ return ()) , OnValue (ifValue (\now -> now >= addTime app.duration app.when) (const $ 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)) ] :: Availability = Maybe | Yes | No derive gPrint Availability instance toString Availability where toString a = printToString a showAvailability :: (Maybe Availability) -> String showAvailability Nothing = "Unknown" showAvailability (Just a) = toString a :: ProposedAppointment = { appointment :: Appointment , startOptions :: [(DateTime, 'M'.Map User Availability)] } derive class iTask Availability, ProposedAppointment proposedAppointments :: Shared (Int, 'M'.Map Int ProposedAppointment) proposedAppointments = sharedStore "proposedAppointments" (0, 'M'.newMap) addProposedAppointment :: ProposedAppointment -> Task Int addProposedAppointment papp=:{appointment={Appointment|title}} = get proposedAppointments >>= \(idx,_) -> upd (bifmap ((+) 1) ('M'.put idx papp)) proposedAppointments >>| allTasks [appendTopLevelTask (chooseAttrs u) False $ chooseTask idx u \\ u <- papp.appointment.participants] >>= appendTopLevelTask (manageAttrs papp.appointment.owner) False o manageTask idx >>| return idx where chooseTask :: Int User -> Task (Int, 'M'.Map Int ProposedAppointment) chooseTask idx user = viewSharedInformation (Title title) [ViewUsing (fromJust o 'M'.get idx o snd) proposalViewer] proposedAppointments ||- allTasks [updateInformation (toString w) [] Maybe \\ (w,_) <- papp.startOptions] >>= \avail -> upd (second $ 'M'.alter (fmap (setAvailability user avail)) idx) proposedAppointments where setAvailability :: User [Availability] ProposedAppointment -> ProposedAppointment setAvailability u as papp = {papp & startOptions=[(w, 'M'.put u a m) \\ (w,m) <- papp.startOptions & a <- as]} chooseAttrs :: User -> TaskAttributes chooseAttrs u = workerAttributes u [ ("title", "Indicate availability for " +++ title) , ("createdBy", toString papp.appointment.owner) , ("createdFor", toString u) ] manageTask :: Int [TaskId] -> Task () manageTask idx chooseTasks = (( viewSharedInformation (Title $ "Manage " +++ title) [ViewUsing (fromJust o 'M'.get idx o snd) proposalViewer] proposedAppointments ||- enterChoice "Pick start time" [] (map fst papp.startOptions) ) >>* [ OnAction (Action "Schedule appointment") $ hasValue schedule , OnAction (Action "Cancel appointment") $ always cancel ] ) $> () where schedule start = addAppointment {papp.appointment & when=start} >>| cancel cancel = allTasks (map (flip removeTask topLevelTasks) chooseTasks) >>| upd (second $ 'M'.del idx) proposedAppointments proposalViewer :: Editor ProposedAppointment proposalViewer = comapEditorValue toTuple $ container4 (withLabelAttr "Title" gEditor{|*|}) (withLabelAttr "Duration" gEditor{|*|}) (withLabelAttr "Participants" usersViewer) (withLabelAttr "Start options" grid) where toTuple :: ProposedAppointment -> (String, Time, [User], (ChoiceGrid, [Int])) toTuple papp = ( papp.appointment.Appointment.title , papp.appointment.duration , papp.appointment.participants , ( { header = ["User":[toString u \\ u <- papp.appointment.participants]] , rows = [ {id= i, cells=[Text $ toString d: [Text $ showAvailability $ 'M'.get u o \\ u <- papp.appointment.participants ]]} \\ i <- [0..] & (d,o) <- papp.startOptions] } , [] ) ) manageAttrs :: User -> TaskAttributes manageAttrs u = workerAttributes u [ ("title", "Manage " +++ title) , ("createdBy", toString papp.appointment.owner) , ("createdFor", toString papp.appointment.owner) ] Start :: *World -> *World Start w = startEngine (loginAndManageWorkList "Scheduler" worklist) w where worklist :: [Workflow] worklist = [ restrictedTransientWorkflow "Manage users" "Manage users" ["admin"] manageUsers , transientWorkflow "Show appointments" "Show appointments" showAppointments , transientWorkflow "Show calendar" "Show calendar" showCalendar , 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") [ViewUsing (filter (\a -> belongsTo user a && inFuture now a)) editor] appointments where editor = listEditor Nothing False False Nothing (bijectEditorValue toTuple fromTuple tupEdit) tupEdit = listitem5 gEditor{|*|} gEditor{|*|} gEditor{|*|} userViewer usersViewer <<@ directionAttr Horizontal userViewer = comapEditorValue 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} showCalendar :: Task [Appointment] showCalendar = get currentUser >>= \user -> get currentDate >>= \date -> viewSharedInformation (Title "Future appointments") [ViewUsing (filter (belongsTo user)) (fromSVGEditor (editor (take 7 $ iterate nextDay $ previous Sunday date)))] appointments where editor :: [Date] -> SVGEditor [Appointment] [Appointment] editor days = { initView = id , renderImage = const (draw days) , updView = \m _ -> m , updModel = \_ v -> v } draw :: [Date] [Appointment] *'G'.TagSource -> 'G'.Image [Appointment] draw dates apps tags = 'G'.margin ('G'.px 10.0) $ 'G'.grid ('G'.Columns 8) ('G'.ColumnMajor, 'G'.LeftToRight, 'G'.TopToBottom) (repeat ('G'.AtMiddleX, 'G'.AtTop)) [] ( [spacer,spacer,spacer,'G'.collage hourlocs ['G'.margin ('G'.px 9.0) $ 'G'.text {font & fontysize=12.0} $ timeString {Time|hour=h,min=0,sec=0} \\ h <- [0..23]] 'G'.NoHost] ++ flatten [['G'.empty daywidth ('G'.px 0.0) , 'G'.text {font & fontweight="bold"} (toString $ dayOfWeek day) , 'G'.text font (toString day) , 'G'.collage (hourlocs ++ [('G'.px $ toReal (overlapOffset app apps) * 40.0, timespan (toTime app.when)) \\ app <- apps | toDate app.when == day]) (hours ++ [appimage app \\ app <- apps | toDate app.when == day]) 'G'.NoHost ] \\ day <- dates ]) 'G'.NoHost where spacer = 'G'.empty ('G'.px 0.0) ('G'.px 0.0) font = 'G'.normalFontDef "Arial" 14.0 daywidth = 'G'.px 200.0 hourheight = 'G'.px 30.0 timespan t = hourheight *. (toReal t.Time.hour + toReal t.Time.min / 60.0) overlapOffset :: Appointment [Appointment] -> Int overlapOffset app apps = indexOf app (filter (overlap app) apps) hourlocs = [('G'.px 0.0, hourheight *. h) \\ h <- [0..23]] hours = ['G'.rect daywidth hourheight <@< {fill=toSVGColor "#eeeeee"} <@< {stroke=toSVGColor "#cccccc"} <@< {strokewidth='G'.px 1.0} \\ h <- [0..23]] appimage app = 'G'.overlay [('G'.AtLeft, 'G'.AtMiddleY)] [] ['G'.above [] (repeat ('G'.px 5.0, 'G'.px 0.0)) ['G'.text font app.Appointment.title ,'G'.text {font & fontysize=11.0} (timeString $ toTime app.Appointment.when) ] 'G'.NoHost] ('G'.Host ('G'.rect ('G'.px 200.0) (timespan app.duration) <@< {fill=toSVGColor "#92E1C0"} <@< {stroke=toSVGColor "#33B694"})) timeString :: Time -> String timeString {Time|hour,min,sec} = h +++ ":" +++ m +++ s +++ " " +++ ampm where h = if (hour == 12) "12" (toString (hour rem 12)) m = pad min s = if (sec == 0) "" (":" <+ pad sec) ampm = if (hour < 12) "am" "pm" pad v = if (v < 10) (0 <+ v) (toString v) makeAppointment :: Task (Maybe Appointment) makeAppointment = 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 $ fmap Just o addAppointment) , OnAction ActionCancel (always $ makeAppointment) ] where onehour = {Time | hour=1,min=0,sec=0} proposeAppointment :: Task (Maybe ProposedAppointment) proposeAppointment = get currentUser >>= \user -> get currentDateTime >>= \now -> allTasks [ enterInformation "Title" [] @ \t pa -> {pa & appointment.Appointment.title=t} , updateInformation "Duration" [] onehour @ \d pa -> {pa & appointment.duration=d} , enterInformation "Start options" [] @ \w pa -> {pa & startOptions=map (flip tuple 'M'.newMap) w} , enterMultipleChoiceWithShared "Participants" [ChooseFromCheckGroup id] users @ \ps pa -> {pa & appointment.participants=ps} ] @ flip seq {gDefault{|*|} & appointment.owner=user} >>* [ OnAction (Action "Propose") (ifValue (\papp -> not $ isEmpty papp.startOptions) addProposedAppointment`) , OnAction ActionCancel (always $ proposeAppointment) ] where addProposedAppointment` :: ProposedAppointment -> Task (Maybe ProposedAppointment) addProposedAppointment` papp = addProposedAppointment papp $> Just papp onehour = {Time | hour=1,min=0,sec=0} usersViewer :: Editor [User] usersViewer = comapEditorValue (concat o intersperse "; " o map toString) textView