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
|
module appointments
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
, 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"
[ {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=[]}
]
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)
:: 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
, 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 -> belongsTo user a && inFuture now a))]
appointments
/*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 \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
|
