implementation module Section8 // Examples showing the usage of editors with multiple buttons import iTasks from Section4 import onlyIf from Section6 import selectUser from Section7 import normalTask, const2 derive bimap (,), Maybe Start :: *World -> *World Start world = startEngine (manageWorkflows flows8) world flows8 :: [Workflow] flows8 = [ workflow "CEFP/Section 8 - Parallel Tasks II/1. Chat with several users" "Chat with several users" chat3 , workflow "CEFP/Section 8 - Parallel Tasks II/2. Editing a text file" "Editing a text file" editorApplication // , workflow "CEFP/Section 8 - Parallel Tasks II/3. Arrange a meeting date between several users" "Arrange meeting" mkAppointment ] // chat with several users derive class iTask ChatState, Message :: ChatState = { chatters :: [User] , chats :: [Message] } :: Message = { chatting :: User , message :: String } emptyChatState = {chatters = [], chats = []} addMessage user message cs = {cs & chats = cs.chats ++ [{chatting = user, message = message}]} addUser user cs = {cs & chatters = [user:cs.chatters]} removeUser user cs = {cs & chatters = removeMember user cs.chatters} chat3 = get currentUser >>= \me -> parallel "Chat application" emptyChatState (const2 Void) [(BodyTask, chatTask me)] chatTask user cs = update (addUser user) (taskListState cs) >>| showSharedInformation ("Chat list view") [] (taskListState cs) Void ||- chatMore user "" cs chatMore user s cs = updateInformation ("Chat with iTask users") [UpdateView (GetLocal toView,PutbackLocal fromView)] s >?* [(ActionAdd, IfValid (\r -> appendTask newChatter cs >>| chatMore user r cs)) ,(ActionOk, IfValid (\r -> update (addMessage user r) (taskListState cs) >>| chatMore user "" cs)) ,(ActionQuit, Always ( update (removeUser user o addMessage user "bye") (taskListState cs) >>| return Stop )) ] where toView c = Note c fromView (Note c) _ _ = c newChatter = (WindowTask "Append Chatter", handleNewChatter) handleNewChatter cs = selectUser >>= \someone -> appendTask (newChatTask someone) cs >>| return Continue where newChatTask someone = (DetachedTask (normalTask someone), chatTask someone) ActionAdd :== Action "Add Chatter" // pocket calculator, see Steffens example... import Text derive class iTask Replace, TextStatistics, EditorState :: Replace = { search :: String , replaceBy :: String } :: TextStatistics = { lines :: Int , words :: Int , characters :: Int } :: EditorState = { mytext :: String , replace :: Bool , statistics :: Bool } :: FileName :== String initEditorState text = {mytext = text, replace = False, statistics = False} updateReplace b = update (\s ->{s & replace = b}) updateStat b = update (\s -> {s & statistics = b}) updateText f = update (\s -> {s & mytext = f s.mytext}) voidResult _ _ = Void normalTask user = { worker = user, priority = NormalPriority, deadline = Nothing, status = Active} ActionReplace :== Action "File/Replace" ActionStatistics :== Action "File/Statistics" editorApplication :: Task Void editorApplication = enterInformation "Give name of text file you want to edit..." [] >>= \fileName -> readTextFile fileName >>= \(_,text) -> parallel "Editor" (initEditorState text) voidResult [(BodyTask, editor fileName)] editor :: String (TaskList EditorState) -> Task ParallelControl editor fileName ls = updateSharedInformation (fileName,"Edit text file \"" +++ fileName +++ "\"") views (taskListState ls) Void >?* [ (ActionSave, IfValid save) , (ActionReplace, Sometimes (onlyIf (\(s,_) -> not s.replace) replace)) , (ActionStatistics,Sometimes (onlyIf (\(s,_) -> not s.statistics) statistics)) , (ActionQuit, Always quit) ] where views = [UpdateView ( GetShared (\s -> Note s.mytext) , PutbackShared (\(Note text) _ s -> {s & mytext = text}) ) ] save (val,_) = saveTextFile fileName val.mytext >>| editor fileName ls replace _ = updateReplace True (taskListState ls) >>| appendTask (DialogTask "Find and Replace", replaceTask {search = "", replaceBy = ""}) ls >>| editor fileName ls statistics _ = updateStat True (taskListState ls) >>| appendTask (DialogTask "Statistics", statisticsTask) ls >>| editor fileName ls quit = return Stop replaceTask :: Replace (TaskList EditorState) -> Task ParallelControl replaceTask replacement ls = updateInformation ("Replace","Define replacement...") [] replacement >?* [(ActionOk, IfValid replace) ,(Action "Close", Always close) ] where replace repl = updateText (replaceSubString repl.search repl.replaceBy) (taskListState ls) >>| replaceTask repl ls close = updateReplace False (taskListState ls) >>| return Continue statisticsTask :: (TaskList EditorState) -> Task ParallelControl statisticsTask ls = showSharedInformation ("Statistics","Statistics of your document") views (taskListState ls) Void >?* [(Action "Close", Always close)] where views = [ShowView (GetShared showStatistics)] showStatistics state = { lines = length (split "\n" state.mytext) , words = length (split " " (replaceSubString "\n" " " state.mytext)) , characters = textSize state.mytext } close = updateStat False (taskListState ls) >>| return Continue // --- file access utility import StdFile saveTextFile :: FileName String -> Task Bool saveTextFile fileName text = accWorld (safeFileMonad fileName text) where safeFileMonad :: String String *World -> (Bool,*World) safeFileMonad fileName text world # (ok,file,world) = fopen fileName FWriteText world | not ok = (False,world) # file = fwrites text file = fclose file world readTextFile :: FileName -> Task (Bool,String) readTextFile fileName = accWorld (readFileMonad fileName) where readFileMonad :: String *World -> ((Bool,String),*World) readFileMonad fileName world # (ok,file,world) = fopen fileName FReadText world | not ok = ((False,""),world) # (text,file) = freads file 1000000 | text == "" = ((False,""),world) # (ok,world) = fclose file world | not ok = ((False,""),world) = ((True,text),world) /* // making an appointment :: MeetingProposal = { date :: Date , time :: Time , canMeet :: [Participant] } :: Participant = { name :: User , canAttend :: Bool , comment :: Maybe Note } :: MeetingProposalView = { date :: Display Date , time :: Display Time , canMeet :: [VisualizationHint ParticipantView] } :: ParticipantView = { name :: Display User , canAttend :: Bool , comment :: Maybe Note } derive class iTask MeetingProposal, Participant, MeetingProposalView, ParticipantView mkAppointment :: Task [MeetingProposal] mkAppointment = get users >>= \all -> enterMultipleChoice "Who should attend the meeting ?" [] all >>= \users -> enterInformation "Propose meeting dates" [] >>= \dates -> let initMeetingState = [ { MeetingProposal | date = date , time = time , canMeet = [ { Participant | name = user , canAttend = False , comment = Nothing } \\ user <- users ] } \\ (date,time) <- dates ] in parallel "Meeting Date Flow" initMeetingState finishPar [manage : map initMeeting users] where finishPar _ s = s initMeeting user = ShowAs (DetachedTask managerProperties) meetingTask where // meetingTask :: (SymmetricShared [MeetingProposal]) (ParallelInfo [MeetingProposal]) -> Task [MeetingProposal] meetingTask meetingState _ = updateSharedInformation "When can we meet ?" [View (viewForUser user,modelFromView)] meetingState managerProperties = { worker = user, priority = NormalPriority, deadline = Nothing, status = Active } viewForUser :: User [MeetingProposal] -> [MeetingProposalView] viewForUser user props = [ {MeetingProposalView | date=toDisplay date, time=toDisplay time, canMeet=map (viewParticipant user) canMeet} \\ {MeetingProposal | date,time,canMeet} <- props ] modelFromView :: [MeetingProposalView] .a -> [MeetingProposal] modelFromView props _ = [ {MeetingProposal | date=fromDisplay date, time=fromDisplay time, canMeet=map modelParticipant canMeet} \\ {MeetingProposalView | date,time,canMeet} <- props ] viewParticipant :: User Participant -> VisualizationHint ParticipantView viewParticipant user participant=:{Participant | name, canAttend, comment} = if (user == name) VHEditable VHDisplay view where view = {ParticipantView | name = Display name , canAttend = canAttend , comment = comment } modelParticipant :: (VisualizationHint ParticipantView) -> Participant modelParticipant view = { Participant | name=name, canAttend=canAttend, comment=comment } where {ParticipantView | name=Display name,canAttend,comment} = fromVisualizationHint view manage = ShowAs BodyTask check where check meetingState controlState = updateSharedInformation "Monitor answers" [View (viewForManager,\_ ps -> ps)] meetingState >?* [(ActionOk,IfValid return)] >>= \props -> enterChoice "Choose meeting" [] props where viewForManager :: [MeetingProposal] -> [MeetingProposal] viewForManager props = [ p \\ p=:{MeetingProposal | canMeet=can} <- props | and [canAttend \\ {Participant | canAttend} <- can] ] */