Schedule proposed appointments

1 files changed, 110 insertions, 10 deletions

diff --git a/assignment-7/appointments.icl b/assignment-7/appointments.icl
index 773e7d3..66d8623 100644
--- a/assignment-7/appointments.icl
+++ b/assignment-7/appointments.icl
@@ -2,14 +2,19 @@ module appointments
 
 from StdFunc import flip, id, seq
 
+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
 import System.Time
 from Text import class Text(concat), instance Text String
+import Text.HTML
 
 import iTasks
 import iTasks.UI.Editor.Common
@@ -36,10 +41,7 @@ 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)
+inFuture d a = d < addTime a.duration a.when
 
 addAppointment :: Appointment -> Task Appointment
 addAppointment app =
@@ -62,15 +64,94 @@ where
 		, ("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]
+	, startOptions :: [(DateTime, 'M'.Map User Availability)]
 	}
 
-derive class iTask ProposedAppointment
+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 =
+		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)
+		]
 
-proposedAppointments :: Shared [ProposedAppointment]
-proposedAppointments = sharedStore "proposedAppointments" []
+	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)
+		) >>= \start ->
+		addAppointment {papp.appointment & when=start} >>= \_ ->
+		allTasks (map (flip removeTask topLevelTasks) chooseTasks) >>= \_ ->
+		upd (second $ 'M'.del idx) proposedAppointments $>
+		()
+	where
+		proposalViewer :: Editor ProposedAppointment
+		proposalViewer = comapEditorValue toTuple $ container4
+			(withLabelAttr "Title"         gEditor{|*|})
+			(withLabelAttr "Duration"      gEditor{|*|})
+			(withLabelAttr "Participants"  usersViewer)
+			(withLabelAttr "Start options" grid)
+
+		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
@@ -95,7 +176,6 @@ 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}
 
@@ -149,4 +229,24 @@ makeAppointment =
 where onehour = {Time | hour=1,min=0,sec=0}
 
 proposeAppointment :: Task (Maybe ProposedAppointment)
-proposeAppointment = return Nothing
+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