path: root/assignment-7/appointments.icl

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
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 < addTime a.duration a.when

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))
		]

:: 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 =
		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)
		) >>= \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
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{|*|}
	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 =
	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