1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
|
module appointments
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
import DateExtensions
:: Appointment =
{ title :: String
, when :: DateTime
, duration :: Time
, owner :: User
, participants :: [User]
}
derive class iTask Appointment
derive JSEncode Appointment, User, Time, DateTime, Maybe
appointments :: Shared [Appointment]
appointments = sharedStore "appointments" []
belongsTo :: User Appointment -> Bool
belongsTo u a = isMember u [a.owner:a.participants]
inFuture :: DateTime Appointment -> Bool
inFuture d a = d < timestampToGmDateTime tsend
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]
}
derive class iTask ProposedAppointment
proposedAppointments :: Shared [ProposedAppointment]
proposedAppointments = sharedStore "proposedAppointments" []
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 "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 = 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 =
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 =
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 = return Nothing
|
