Commit dc30e897 authored by Bas Lijnse's avatar Bas Lijnse

Major simplification of user handling. Merged UserName and User into a more...

Major simplification of user handling. Merged UserName and User into a more simple User type that can be both. Since this is a big change it is likely that it may have broken some stuff.

git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/trunk@1033 63da3aa8-80fd-4f01-9db8-e6ea747a3da2
parent 5fd0692d
......@@ -38,6 +38,7 @@ import LaunchFlow
//Shared Value Examples
import SharedVariables
Start :: *World -> *World
Start world = startEngine workflows world
where
......@@ -64,4 +65,4 @@ where
, launchFlow
]
, sharedValueExamples
]
]
\ No newline at end of file
......@@ -21,7 +21,7 @@ derive bimap (,), Maybe
BookTrip :: Task FlightHotel
BookTrip
= enterInformation "Please fill in trip information to make booking"
>>= \info -> assign info.delegateTo NormalPriority Nothing (enterInformationAbout "Please book the following trip" info)
>>= \info -> assign info.delegateTo (enterInformationAbout "Please book the following trip" info)
>>= \booking -> showMessageAbout "The following trip has been booked" booking
>>| return booking
......@@ -30,7 +30,7 @@ BookTrip
= { destination :: String
, leaving :: Date
, returning :: Date
, delegateTo :: UserName
, delegateTo :: User
}
:: FlightHotel
= { carrier :: String
......
......@@ -44,10 +44,10 @@ duplicate me user topics =
where
change :: User User String TaskProperties (Task a) (Task a) -> (Maybe TaskProperties, Maybe (Task a), Maybe ChangeDyn) | iTask a
change me user topics props t t0
= ( Just {TaskProperties | props & managerProps = {ManagerProperties | props.managerProps & worker = toUserName me}}
, Just (assign (toUserName me) NormalPriority Nothing
(anyProc [ {AssignedTask| user = props.managerProps.ManagerProperties.worker , task = t <<@ topics}
, {AssignedTask| user = toUserName user, task = t <<@ topics}
= ( Just {TaskProperties | props & managerProps = {ManagerProperties | props.managerProps & worker = me}}
, Just (assign me
(anyProc [ props.managerProps.ManagerProperties.worker @>> topics @>> t
, user @>> topics @>> t
] Open
)
<<@ ("Duplicated " +++ topics))
......@@ -59,7 +59,7 @@ inform user procName =
dynamic change user :: A.a: Change a | iTask a
where
change :: User TaskProperties (Task a) (Task a) -> (Maybe TaskProperties, Maybe (Task a), Maybe ChangeDyn) | iTask a
change user props t t0 = (Nothing, Just (t >>= \res -> spawnProcess (toUserName user) True (showMessageAbout ("Process " +++ procName +++ " ended!") res) >>| return res), Nothing)
change user props t t0 = (Nothing, Just (t >>= \res -> spawnProcess user True (showMessageAbout ("Process " +++ procName +++ " ended!") res) >>| return res), Nothing)
//check will pass the result to the indicated user who can change the result in an editor before it passed.
check :: User String -> ChangeDyn
......@@ -67,7 +67,7 @@ check user procName =
dynamic change user :: A.a: Change a | iTask a
where
change :: User TaskProperties (Task a) (Task a) -> (Maybe TaskProperties, Maybe (Task a), Maybe ChangeDyn) | iTask a
change user props t t0 = (Nothing, Just (t >>= \res -> assign user HighPriority Nothing (updateInformation ("Please verify result of " +++ procName) res)), Nothing)
change user props t t0 = (Nothing, Just (t >>= \res -> assign user (HighPriority @>> (updateInformation ("Please verify result of " +++ procName) res))), Nothing)
//cancel stop the process, and give the indicated user the responsibility to fill in the result
cancel :: String ProcessId -> ChangeDyn
......@@ -87,8 +87,7 @@ reassign user procName pid =
where
change :: User TaskProperties (Task a) (Task a) -> (Maybe TaskProperties, Maybe (Task a), Maybe ChangeDyn) | iTask a
change user props t t0
# username = (toUserName user)
= (Just {TaskProperties | props & managerProps = {ManagerProperties | props.managerProps & worker = username}},Nothing, Nothing)
= (Just {TaskProperties | props & managerProps = {ManagerProperties | props.managerProps & worker = user}},Nothing, Nothing)
//restart starts the task from scratch and assigns it to the indicated user
restart :: User String -> Dynamic
......@@ -96,7 +95,7 @@ restart user procName =
dynamic change user procName :: A.a: Change a | iTask a
where
change :: User String TaskProperties (Task a) (Task a) -> (Maybe TaskProperties, Maybe (Task a), Maybe ChangeDyn) | iTask a
change user procName props t t0 = (Nothing, Just (assign (toUserName user) HighPriority Nothing (t0 <<@ procName)), Nothing)
change user procName props t t0 = (Nothing, Just (assign user (procName @>> HighPriority @>> t0 )), Nothing)
changePrio :: Task Void
changePrio
......
......@@ -41,25 +41,25 @@ where
::Provider =
{ name :: String
, id :: UserName
, id :: User
, location :: Location
, capacity :: Int
}
::Opinion = Opinion UserName Note
::Opinion = Opinion User Note
//Static population
allproviders = [{name="Ambulance Post 0",id=toUserName "ambupost0",location={street="Teststreet",place="Testville",coordinates=Just{lat=1.0,lon=2.0}},capacity=2}
,{name="Ambulance Post 1",id=toUserName "ambupost1",location={street="Teststreet",place="Testville",coordinates=Just{lat=2.0,lon=2.0}},capacity=2}
,{name="Ambulance Post 2",id=toUserName "ambupost2",location={street="Teststreet",place="Testville",coordinates=Just{lat=3.0,lon=2.0}},capacity=2}
,{name="Ambulance Post 3",id=toUserName "ambupost3",location={street="Teststreet",place="Testville",coordinates=Just{lat=4.0,lon=2.0}},capacity=2}
,{name="Ambulance Post 4",id=toUserName "ambupost4",location={street="Teststreet",place="Testville",coordinates=Just{lat=5.0,lon=2.0}},capacity=2}
,{name="Ambulance Post 5",id=toUserName "ambupost5",location={street="Teststreet",place="Testville",coordinates=Just{lat=6.0,lon=2.0}},capacity=2}
,{name="Ambulance Post 6",id=toUserName "ambupost6",location={street="Teststreet",place="Testville",coordinates=Just{lat=7.0,lon=2.0}},capacity=2}
,{name="Ambulance Post 7",id=toUserName "ambupost7",location={street="Teststreet",place="Testville",coordinates=Just{lat=8.0,lon=2.0}},capacity=2}
,{name="Ambulance Post 8",id=toUserName "ambupost8",location={street="Teststreet",place="Testville",coordinates=Just{lat=9.0,lon=2.0}},capacity=2}
,{name="Ambulance Post 9",id=toUserName "ambupost9",location={street="Teststreet",place="Testville",coordinates=Just{lat=9.0,lon=3.0}},capacity=2}
allproviders = [{name="Ambulance Post 0",id=NamedUser "ambupost0",location={street="Teststreet",place="Testville",coordinates=Just{lat=1.0,lon=2.0}},capacity=2}
,{name="Ambulance Post 1",id=NamedUser "ambupost1",location={street="Teststreet",place="Testville",coordinates=Just{lat=2.0,lon=2.0}},capacity=2}
,{name="Ambulance Post 2",id=NamedUser "ambupost2",location={street="Teststreet",place="Testville",coordinates=Just{lat=3.0,lon=2.0}},capacity=2}
,{name="Ambulance Post 3",id=NamedUser "ambupost3",location={street="Teststreet",place="Testville",coordinates=Just{lat=4.0,lon=2.0}},capacity=2}
,{name="Ambulance Post 4",id=NamedUser "ambupost4",location={street="Teststreet",place="Testville",coordinates=Just{lat=5.0,lon=2.0}},capacity=2}
,{name="Ambulance Post 5",id=NamedUser "ambupost5",location={street="Teststreet",place="Testville",coordinates=Just{lat=6.0,lon=2.0}},capacity=2}
,{name="Ambulance Post 6",id=NamedUser "ambupost6",location={street="Teststreet",place="Testville",coordinates=Just{lat=7.0,lon=2.0}},capacity=2}
,{name="Ambulance Post 7",id=NamedUser "ambupost7",location={street="Teststreet",place="Testville",coordinates=Just{lat=8.0,lon=2.0}},capacity=2}
,{name="Ambulance Post 8",id=NamedUser "ambupost8",location={street="Teststreet",place="Testville",coordinates=Just{lat=9.0,lon=2.0}},capacity=2}
,{name="Ambulance Post 9",id=NamedUser "ambupost9",location={street="Teststreet",place="Testville",coordinates=Just{lat=9.0,lon=3.0}},capacity=2}
]
derive gPrint Incident, IncidentType, Location, Address, MapCoordinates, Provider, Opinion
......@@ -171,16 +171,16 @@ where
preCombine as = (0,as)
allCombine as = (needed - sum (map numAmbulances as),as)
resourceRequestTimeOut :: [(b,UserName,a)] Time ([(b,Maybe a)] -> Bool) ([(b,Maybe a)] -> (a,[(b,Maybe a)])) ([(b,Maybe a)] -> (a,[(b,Maybe a)])) (a -> Task a) ->
resourceRequestTimeOut :: [(b,User,a)] Time ([(b,Maybe a)] -> Bool) ([(b,Maybe a)] -> (a,[(b,Maybe a)])) ([(b,Maybe a)] -> (a,[(b,Maybe a)])) (a -> Task a) ->
Task (a,[(b,Maybe a)]) | iTask a & iTask b
resourceRequestTimeOut resources time_out check predf allf task
= oldParallel "Resource_requests" check predf allf
[(delegateTaskTimeOut uid "Resource Request" amount task time_out >>= \mba -> return (resource, mba))
\\ (resource,uid,amount) <- resources]
delegateTaskTimeOut :: UserName String a (a -> Task a) Time -> Task (Maybe a) | iTask a
delegateTaskTimeOut :: User String a (a -> Task a) Time -> Task (Maybe a) | iTask a
delegateTaskTimeOut who description value task time_out
= timeOutTask (who @: (description, task value)) time_out
= timeOutTask (who @: (description @>> task value)) time_out
timeOutTask :: (Task a) Time -> Task (Maybe a) | iTask a
timeOutTask task time
......
......@@ -23,7 +23,7 @@ derive gHint Flow, FlowShape, AssignInfo, CleanExpr
| CleanExpr !CleanExpr
| First
| Second
:: AssignInfo = { nameOfUser:: !UserName
:: AssignInfo = { nameOfUser:: !User
, taskName :: !String
}
:: CleanExpr = CI Int
......
......@@ -30,7 +30,7 @@ derive bimap Maybe, (,)
| CleanExpr !CleanExpr
| First
| Second
:: AssignInfo = { nameOfUser:: !UserName
:: AssignInfo = { nameOfUser:: !User
, taskName :: !String
}
:: CleanExpr = CI Int
......@@ -91,7 +91,7 @@ where
assignTask :: !AssignInfo !Dynamic -> Task Dynamic
assignTask info (e :: DF0 a b | iTask a)
= return (dynamic (case e of
(DF0 e) -> DF0 (\v -> assign info.nameOfUser NormalPriority Nothing (e v <<@ info.taskName))) :: DF0 a b | iTask a)
(DF0 e) -> DF0 (\v -> assign info.nameOfUser (e v <<@ info.taskName))) :: DF0 a b | iTask a)
assignTask info d
= throw (typeErrorMess "Assign" d)
......
......@@ -48,7 +48,7 @@ where
= getCurrentUser
>>= \me -> requestConfirmation ("Workflow of type :: " +++ showDynType d +++ " can be started; Shall I ?")
>>= \ok -> if ok ( updateInformation "Name of this workflow: " "workflow"
>>= \name -> spawnProcess (toUserName me) True (t <<@ name)
>>= \name -> spawnProcess me True (t <<@ name)
>>| return Void)
(return Void)
......
......@@ -68,10 +68,9 @@ where
mergeTestList :: Task Void
mergeTestList =
getCurrentUser
>>= \user. return (toUserName user)
>>= \uname. createDB emptyL
>>= \sid. spawnProcess uname True ("1st View" @>> view sid)
>>| spawnProcess uname True ("2nd View" @>> view sid)
>>= \user. createDB emptyL
>>= \sid. spawnProcess user True ("1st View" @>> view sid)
>>| spawnProcess user True ("2nd View" @>> view sid)
>>| stop
where
view :: (DBid [String]) -> Task (Action,[String])
......@@ -83,11 +82,10 @@ where
mergeTestDocuments :: Task Void
mergeTestDocuments =
getCurrentUser
>>= \user. return (toUserName user)
>>= \uname. createDB emptyL
>>= \sid. spawnProcess uname True ("1st View" @>> view sid idEditor)
>>| spawnProcess uname True ("2nd View" @>> view sid idEditor)
>>| spawnProcess uname True ("3rd View" @>> view sid idListener)
>>= \user. createDB emptyL
>>= \sid. spawnProcess user True ("1st View" @>> view sid idEditor)
>>| spawnProcess user True ("2nd View" @>> view sid idEditor)
>>| spawnProcess user True ("3rd View" @>> view sid idListener)
>>| stop
where
view :: (DBid [Document]) (View [Document]) -> Task (Action,[Document])
......
......@@ -24,7 +24,7 @@ deadline :: (Task a) -> Task a | iTask a
deadline task
= chooseUser "Choose person you want to delegate work to:"
>>= \whom -> enterInformation "How long do you want to wait?"
>>= \time -> (delegateTask whom.User.userName time task)
>>= \time -> (delegateTask whom time task)
-||-
(showMessage "Cancel delegated work if you are getting impatient:" >>| return Nothing)
>>= checkDone
......@@ -35,7 +35,7 @@ where
= showMessage "Task expired or canceled, you have to do it yourself!" >>| task
delegateTask who time task
= who @: ("Timed Task",mytask)
= who @: ("Timed Task" @>> mytask)
where
mytask
= // wait for timeout and return nothing
......
......@@ -59,11 +59,7 @@ where
timerStop time = waitForTimerTask time #>> return True
*/
instance < UserName
where
(<) (UserName ida dispa) (UserName idb dispb) = ida < idb
determineSet :: [UserName] -> Task [UserName]
determineSet :: [User] -> Task [User]
determineSet people = determineSet`
where
determineSet`
......@@ -73,10 +69,10 @@ where
]
>>= \task -> task
>>= \result -> case result of
(Just new) -> determineSet (sort (removeDup [toUserName new:people]))
(Just new) -> determineSet (sort (removeDup [new:people]))
Nothing -> if (people == []) (determineSet people) (return people)
choosePerson = chooseUser "Select a user" >>= \user -> return (Just user.User.userName)
choosePerson = chooseUser "Select a user" >>= \user -> return (Just user)
cancelTask task = task -||- (showMessage "Cancel task?" >>| getDefaultValue )
\ No newline at end of file
......@@ -94,9 +94,8 @@ where
>>| return False
selectUser :: !String -> Task UserName
selectUser :: !String -> Task User
selectUser question
= getUsers
>>= \users -> enterChoice question users
>>= \user -> return (toUserName user)
......@@ -50,15 +50,15 @@ reviewTaskExample
= [workflow "Examples/Higher order/Review task" ("Review the results of a task" @>> reviewtask) ]
reviewtask :: Task (QForm,Review)
reviewtask = getDefaultValue >>= \def -> taskToReview "unknown" (def, mytask)
reviewtask = getDefaultValue >>= \def -> taskToReview AnyUser (def, mytask)
mytask :: a -> (Task a) | iTask a
mytask v = updateInformation "Fill in Form:" v
taskToReview :: String (a,a -> Task a) -> Task (a,Review) | iTask a
taskToReview :: User (a,a -> Task a) -> Task (a,Review) | iTask a
taskToReview reviewer (v`,task)
= task v`
>>= \v -> reviewer @: ("Review", review v)
>>= \v -> reviewer @: ("Review" @>> review v)
>>= \r -> showMessageAbout [Text ("Reviewer " <+++ reviewer <+++ " says ")] r
>>| case r of
(NeedsRework _) -> taskToReview reviewer (v,task)
......
......@@ -21,12 +21,12 @@ import CommonDomain
{ bugNr :: BugNr
, status :: BugStatus
, reportedAt :: (Date,Time)
, reportedBy :: UserName
, reportedBy :: User
, report :: BugReport
, analysis :: Maybe BugAnalysis
}
:: BugStatus = Reported | Assigned UserName | Repaired
:: BugStatus = Reported | Assigned User | Repaired
:: BugAnalysis =
{ cause :: Note
......@@ -63,7 +63,7 @@ reportBugVerySimple :: Task Note
reportBugVerySimple
= enterInformation "Please describe the bug you have found"
>>= \report ->
assign (toUserName "bas") NormalPriority Nothing
assign (NamedUser "bas")
("Bug Report" @>> showInstructionAbout "Fix bug" "The following bug has been reported, please fix it." report)
>>| return report
......@@ -71,7 +71,7 @@ reportBugSimple :: Task BugReport
reportBugSimple
= enterInformation "Please describe the bug you have found"
>>= \report ->
assign (toUserName "bas") NormalPriority Nothing
assign (NamedUser "bas")
("Bug Report" @>> showInstructionAbout "Fix bug" "The following bug has been reported, please fix it." report)
>>| return report
......@@ -83,7 +83,7 @@ where
reportBug = enterInformation "Please describe the bug you found"
fixBug :: BugReport -> Task Void
fixBug bug = "bas" @: ("Bug Report", showInstructionAbout "Fix bug" "The following bug has been reported, please fix it." bug)
fixBug bug = NamedUser "bas" @: ("Bug Report" @>> showInstructionAbout "Fix bug" "The following bug has been reported, please fix it." bug)
//Main workflow
reportBug :: Task Void
......@@ -106,8 +106,7 @@ assignBug bug critical
>>= \developer ->
updateBug (\b -> {Bug| b & status = Assigned developer}) bug
>>= \bug ->
assign developer priority Nothing
(subject @>> resolveBug bug critical)
assign developer (subject @>> priority @>> resolveBug bug critical)
where
priority = if critical HighPriority NormalPriority
subject = if critical "Critical bug!" "Bug"
......@@ -139,7 +138,7 @@ fileBug :: BugReport -> Task Bug
fileBug report
= getDefaultValue -&&- getCurrentUser
>>= \(bug,user) ->
dbCreateItem {bug & report = report, reportedBy = (toUserName user)}
dbCreateItem {bug & report = report, reportedBy = user}
updateBug :: (Bug -> Bug) Bug -> Task Bug
updateBug f bug = dbUpdateItem (f bug)
......@@ -148,30 +147,26 @@ confirmCritical :: BugReport -> Task Bool
confirmCritical report
= selectDeveloper report.BugReport.application
>>= \assessor ->
assign assessor HighPriority Nothing
assign assessor
( "Bug report assessment"
@>>
@>> HighPriority @>>
requestConfirmationAbout "Is this bug really critical?" report
)
instance < UserName
where
(<) (UserName ida dispa) (UserName idb dispb) = ida < idb
selectDeveloper :: String -> Task UserName
selectDeveloper :: String -> Task User
selectDeveloper application
= findAppDevelopers application
>>= \developers -> case developers of
[] = getCurrentUser >>= \user -> return (toUserName user)
[] = getCurrentUser
_ = selectLeastBusy developers
where
findAppDevelopers :: String -> Task [UserName]
findAppDevelopers "itasks" = return [toUserName "bas"]
findAppDevelopers :: String -> Task [User]
findAppDevelopers "itasks" = return [NamedUser "bas"]
findAppDevelopers _ = return []
selectLeastBusy :: [UserName] -> Task UserName
selectLeastBusy :: [User] -> Task User
selectLeastBusy []
= getCurrentUser >>= \user -> return (toUserName user)
= getCurrentUser
selectLeastBusy names
= allTasks [getNumTasksForUser name \\ name <- names]
>>= \activity ->
......@@ -179,7 +174,7 @@ where
where
minimum l = foldl min (hd l) (tl l)
getNumTasksForUser :: UserName -> Task Int
getNumTasksForUser :: User -> Task Int
getNumTasksForUser name = return 42 //TODO: Use API function
analyzeBug :: Bug -> Task Bug
......@@ -213,6 +208,6 @@ makePatches bug =
>>| return Void
notifyReporter :: Bug -> Task Void
notifyReporter bug = bug.reportedBy @: ("Bug Report Result", showMessageAbout "The bug you reported has been fixed" bug)
notifyReporter bug = bug.reportedBy @: ("Bug Report Result" @>> showMessageAbout "The bug you reported has been fixed" bug)
//notifyUser "The bug you reported has been fixed" bug.reportedBy
......@@ -14,7 +14,7 @@ coffeeTimeExample = [workflow "Examples/Miscellaneous/Coffee time" coffeeTime]
*/
coffeeTime :: Task Void
coffeeTime
= getUserNames
= getUsers
>>= \users ->
collectOrders users
>>= \orders ->
......@@ -26,8 +26,8 @@ where
/*
* Collect the drinks orders from all users
*/
collectOrders :: [UserName] -> Task [Maybe String]
collectOrders users = allTasks [u @: ("Coffee time!",getOrder) \\ u <- users]
collectOrders :: [User] -> Task [Maybe String]
collectOrders users = allTasks [u @: ("Coffee time!" @>> getOrder) \\ u <- users]
/*
* Ask someone if he/she wants something to drink
*/
......@@ -41,10 +41,10 @@ getOrder
* Determine who has to go get coffee
* A random choice is made between the people who want something
*/
determineWhoGoes :: [(UserName,String)] -> Task UserName
determineWhoGoes :: [(User,String)] -> Task User
determineWhoGoes orders = randomChoice [user \\ (user,_) <- orders]
/*
* Give someone directions to go get coffee for everyone
*/
goGetCoffee :: UserName [(UserName,String)] -> Task Void
goGetCoffee user orders = user @: ("Get coffee", showInstructionAbout "Coffee orders" "You have been chosen to get the following drinks" orders)
goGetCoffee :: User [(User,String)] -> Task Void
goGetCoffee user orders = user @: ("Get coffee" @>> showInstructionAbout "Coffee orders" "You have been chosen to get the following drinks" orders)
......@@ -38,7 +38,7 @@ derive gUpdate InstructionMsg
derive gError InstructionMsg
derive gHint InstructionMsg
:: InstructionMsg = { worker :: !UserName
:: InstructionMsg = { worker :: !User
, title :: !String
, instruction :: !Note
, attachments :: !(Maybe [Document])
......@@ -47,7 +47,7 @@ derive gHint InstructionMsg
mkInstruction :: Task Void
mkInstruction
= mkMsg
>>= \msg -> msg.InstructionMsg.worker @: ("Instructions regarding: "+++msg.InstructionMsg.title, showInstructionAbout msg.InstructionMsg.title msg.instruction msg.attachments)
>>= \msg -> msg.InstructionMsg.worker @: ("Instructions regarding: "+++msg.InstructionMsg.title @>> showInstructionAbout msg.InstructionMsg.title msg.instruction msg.attachments)
where
mkMsg :: Task InstructionMsg
......@@ -74,7 +74,7 @@ derive gMakeLocalCopy Meeting, Appointment, Attending
, till :: Time
}
:: Attending = No | Yes
:: MeetingDB :== (Appointment,[(Meeting,[(UserName, Maybe Attending)])])
:: MeetingDB :== (Appointment,[(Meeting,[(User, Maybe Attending)])])
mkAppointment
= meetingGoal
......@@ -110,7 +110,7 @@ where
meetingGoal :: Task Appointment
meetingGoal = enterInformation "Describe the topic of the meeting:"
defineParticipants :: Task [UserName]
defineParticipants :: Task [User]
defineParticipants = enterInformation "Select participants:"
defineOptions :: Task [Meeting]
......@@ -129,13 +129,13 @@ derive gHint Chat, ChatMessage, ChatView, ChatMessageView
//Shared State
:: Chat =
{ initUser :: UserName
, users :: [UserName]
{ initUser :: User
, users :: [User]
, messages :: [ChatMessage]
}
:: ChatMessage =
{ who :: UserName
{ who :: User
, when :: DateTime
, message :: Note
, replies :: [ChatMessage]
......@@ -143,7 +143,7 @@ derive gHint Chat, ChatMessage, ChatView, ChatMessageView
//Transformed View
:: ChatView =
{ users :: HtmlDisplay [UserName]
{ users :: HtmlDisplay [User]
, messages :: HtmlDisplay [ChatMessageView]
}
......@@ -159,19 +159,18 @@ ActionAddUser :== ActionLabel "Add User"
chat
= getCurrentUser
>>= \me -> selectFriends
>>= \friends -> createChatBox (toUserName me)
>>= \chatbox -> allTasks ([spawnProcess f True ("Chat Request" @>> (initiateChat chatbox f [un me:friends])) \\ f <- friends]
++ [spawnProcess (un me) True ("Chat Request" @>> (initSession >>| chatSession chatbox (un me)))])
>>= \friends -> createChatBox me
>>= \chatbox -> allTasks ([spawnProcess f True ("Chat Request" @>> (initiateChat chatbox f [me:friends])) \\ f <- friends]
++ [spawnProcess me True ("Chat Request" @>> (initSession >>| chatSession chatbox (me)))])
where
un me = toUserName me
createChatBox :: UserName -> (Task (DBid Chat))
createChatBox :: User -> (Task (DBid Chat))
createChatBox me = createDB {Chat | initUser = me, users = [], messages = []}
selectFriends :: Task [UserName]
selectFriends :: Task [User]
selectFriends = enterInformation "Whom do you want to chat with?"
initiateChat :: (DBid Chat) UserName [UserName] -> Task Void
initiateChat :: (DBid Chat) User [User] -> Task Void
initiateChat chatbox friend friends
= requestConfirmation ("Do you want to initiate a chat with "+++printFriends+++"?")
>>= \yes -> if yes
......@@ -188,31 +187,31 @@ where
]
]
chatSession :: (DBid Chat) UserName -> Task Void
chatSession :: (DBid Chat) User -> Task Void
chatSession chatbox user
= readDB chatbox
>>= \chat -> writeDB chatbox {Chat | chat & users = chat.Chat.users++[user]}
>>| dynamicGroupAOnly [chatEditor chatbox user <<@ GBAlwaysFixed] (chatActions chatbox user)
where
chatActions :: (DBid Chat) UserName -> [GroupAction GOnlyAction Void Chat]
chatActions :: (DBid Chat) User -> [GroupAction GOnlyAction Void Chat]
chatActions chatbox user = [ GroupAction ActionNew (GOExtend [ignoreResult (newTopic chatbox user)]) GroupAlways
, GroupAction ActionQuit GOStop GroupAlways
, GroupAction ActionAddUser (GOExtend [ignoreResult (addUsers chatbox)]) (SharedPredicate chatbox (\(SharedValue chat) -> chat.Chat.initUser == user))
]
chatEditor :: (DBid Chat) UserName -> Task Void
chatEditor :: (DBid Chat) User -> Task Void
chatEditor chatbox user = ignoreResult (getCurrentDateTime >>= \dt -> updateShared "Chat" [] chatbox [mainEditor user dt])
mainEditor :: UserName DateTime -> (View Chat)
mainEditor :: User DateTime -> (View Chat)
mainEditor user dt = editor {editorFrom = editorFrom user, editorTo = editorTo user dt}
where
editorFrom :: UserName Chat -> ChatView
editorFrom :: User Chat -> ChatView
editorFrom user chat = {ChatView
| users = HtmlDisplay chat.Chat.users
, messages = HtmlDisplay [(convertMessageToView user msg) \\ msg <- chat.Chat.messages]
}
where
convertMessageToView :: UserName ChatMessage -> ChatMessageView
convertMessageToView :: User ChatMessage -> ChatMessageView
convertMessageToView user msg =
{ ChatMessageView
| info = toString msg.ChatMessage.who+++" said at "+++toString msg.ChatMessage.when
......@@ -221,13 +220,13 @@ where
, addReply = Editable {FormButton | label = "Add reply", icon = "", state = NotPressed}
}
editorTo :: UserName DateTime ChatView Chat -> Chat
editorTo :: User DateTime ChatView Chat -> Chat
editorTo user dt view chat = {Chat
| chat
& messages = [convertViewToMessage user dt vmsg omsg \\ vmsg <- (fromHtmlDisplay view.ChatView.messages) & omsg <- chat.Chat.messages]
}
where
convertViewToMessage :: UserName DateTime ChatMessageView ChatMessage -> ChatMessage
convertViewToMessage :: User DateTime ChatMessageView ChatMessage -> ChatMessage
convertViewToMessage user dt vmsg omsg =
{ ChatMessage
| who = omsg.ChatMessage.who
......@@ -236,7 +235,7 @@ where
, replies = [convertViewToMessage user dt vreply oreply \\ vreply <- vmsg.ChatMessageView.replies & oreply <- omsg.ChatMessage.replies ] ++ addReply (fromEditable vmsg.addReply) user dt
}