5 import qualified Data.List as List
7 import Control.Applicative
18 :: Skill = Programming | Design | Testing
25 instance == Worker where == w1 w2 = w1.Worker.username == w2.Worker.username
26 instance == Skill where == s1 s2 = s1 === s2
27 instance == Job where == s1 s2 = s1.jobName == s2.jobName
28 derive class iTask Worker, Skill, Job
35 usersStore :: Shared [Worker]
36 usersStore = sharedStore "Users" [{Worker|username="mart",password="mart",loggedIn=False,skills=[Design,Testing]}]
37 userStore :: String -> Shared Worker
38 userStore u = mapReadWriteError
39 (\wl->case filter (\w->w.Worker.username == u) wl of
41 u = Error (exception ("worker not found: " +++ toSingleLineText u))
42 ,\nw wl->Ok $ Just [nw:filter (\w->w.Worker.username <> u) wl]
45 jobsStore :: Shared [Job]
46 jobsStore = sharedStore "Jobs"
47 [{id=1,jobName="Testing",skills=[Testing],children=[],blocked=False}
48 ,{id=2,jobName="Bigjob",skills=[Testing],blocked=False,children=
49 [{id=3,jobName="subjob1",skills=[Testing],children=[],blocked=False}
50 ,{id=4,jobName="subjob1",skills=[Testing],children=[],blocked=False}
53 jobStore :: Int -> Shared Job
54 jobStore i = mapReadWriteError
56 ,\nj jl->Ok $ Just $ map (updateJob nj) jl
59 findJob i [] = Error (exception "Job not found")
60 findJob i [j=:{Job|id}:_] | id == i = Ok j
61 findJob i [j:js] = case findJob i j.Job.children of
62 Error e = findJob i js
65 updateJob nj j=:{Job|id} | id == i = nj
66 updateJob nj j = {Job|j & children=map (updateJob nj) j.Job.children}
68 removeJob :: Int [Job] -> [Job]
70 removeJob i [j=:{Job|id}:js] | i == id = js
71 removeJob i [j:js] = [{Job|j & children=removeJob i j.Job.children}:removeJob i js]
74 jobID = sharedStore "JobIDS" 4
76 Start w = doTasks ((login -||- register <<@ ArrangeWithTabs False) >>- work) w
78 register :: Task Worker
79 register = tune (Title "Register")
80 $ enterInformation "Enter credentials" [EnterUsing id credentialEditor]
81 -&&- enterInformation "Enter Skills" []
82 >>= \((u, p),s)->get usersStore
83 @ filter (\a->a.Worker.username==u)
84 >>- \exists->case exists of
85 [] = let user = {loggedIn=True,username=u,password=p,skills=removeDup s}
86 in upd (\l->[user:l]) usersStore >>| treturn user
87 _ = viewInformation "User already exists" [] () >>| register
90 login = tune (Title "Login")
91 $ enterInformation "Enter credentials" [EnterUsing id credentialEditor]
92 >>= \(u,p)->get usersStore
93 @ filter (\a->a.Worker.username==u && a.Worker.password==p)
95 [] = viewInformation "User not found or incorrect password" [] () >>| login
96 [{loggedIn=True}] = viewInformation "User is already logged in" [] () >>| login
97 [u] = upd (\w->{w & loggedIn=True}) (userStore u.Worker.username)
99 credentialEditor = panel2
100 (textField <<@ labelAttr "Username")
101 (passwordField <<@ labelAttr "Password")
103 work :: Worker -> Task [()]
104 work {Worker|username} = allTasks
108 ] <<@ Title ("Welcome " +++ username) <<@ ArrangeWithTabs False
111 = tune (Title "View jobs")
112 $ editSelectionWithShared "Select a job" False
113 (SelectInTree toCN fromSel)
114 (jobsStore >*< userStore username)
117 [OnAction (Action "Execute") $ ifValue (\j->j=:[_]) \[j]->
118 upd (\j->{j & blocked=True}) (jobStore j.Job.id)
119 >>| viewSharedInformation "Job" [] (jobStore j.Job.id)
121 [OnAction (Action "Finish") $ always $
122 upd (removeJob j.Job.id) jobsStore
123 ,OnAction (Action "Split") $ always $
124 enterInformation "Enter sub jobs" [EnterUsing id (gEditor{|*->*|} jobEditor gText{|*|} JSONEncode{|*|} JSONDecode{|*|})]
125 >>= \sjs->sequence (take (length sjs) (repeat (upd inc jobID)))
126 >>= \ids->upd (\j->{Job|j & blocked=False,children=[{Job|id=i,jobName=n,skills=s,blocked=False,children=[]}\\(n,s)<-sjs & i<-ids]}) (jobStore j.Job.id)
128 ,OnAction (Action "Cancel") $ always $
129 upd (\j->{j & blocked=False}) (jobStore j.Job.id)
135 toCN ::([Job],Worker) -> [ChoiceNode]
136 toCN (jobs, worker) =
138 {id=if (job.Job.blocked || not (job.Job.children =: []) || not (matchSkills job)) (~job.Job.id) job.Job.id
139 ,label=job.Job.jobName +++ "(" +++ toSingleLineText job.Job.skills +++ ")"
140 ,icon=if (job.Job.blocked || not (matchSkills job)) (Just "document-error") Nothing
142 ,children=toCN (job.Job.children, worker)
147 matchSkills job = 'List'.difference job.Job.skills worker.Worker.skills == []
149 fromSel :: ([Job],Worker) [Int] -> [Job]
151 = [j\\j<-jobs | isMember j.Job.id ids]
152 ++ flatten [fromSel (j.Job.children, w) ids\\j<-jobs]
155 = tune (Title "Create new jobs")
157 $ enterInformation "Enter job" [EnterUsing id jobEditor]
158 >>= \(name, skills)->upd inc jobID
159 >>= \i->upd ((++) [{Job|id=i,skills=skills,jobName=name,blocked=False,children=[]}]) jobsStore
162 jobEditor :: Editor (String, [Skill])
164 (gEditor{|*|} <<@ labelAttr "Name")
165 (gEditor{|*|} <<@ labelAttr "Skills")
168 = tune (Title "Edit skills")
169 $ updateSharedInformation "Skills" [UpdateAs (\w->w.Worker.skills) (\w s->{Worker|w & skills=s})] (userStore username)