+++ /dev/null
-module a7
-
-import StdEnv
-
-import qualified Data.List as List
-import Data.Func
-import Control.Applicative
-
-import iTasks
-
-:: Job =
- { id :: Int
- , jobName :: String
- , skills :: [Skill]
- , blocked :: Bool
- , children :: [Job]
- }
-:: Skill = Programming | Design | Testing
-:: Worker =
- { username :: String
- , password :: String
- , skills :: [Skill]
- , loggedIn :: Bool
- }
-instance == Worker where == w1 w2 = w1.Worker.username == w2.Worker.username
-instance == Skill where == s1 s2 = s1 === s2
-instance == Job where == s1 s2 = s1.jobName == s2.jobName
-derive class iTask Worker, Skill, Job
-derive JSONEncode Set
-derive JSONDecode Set
-derive gText Set
-derive gEditor Set
-derive gDefault Set
-
-usersStore :: Shared [Worker]
-usersStore = sharedStore "Users" [{Worker|username="mart",password="mart",loggedIn=False,skills=[Design,Testing]}]
-userStore :: String -> Shared Worker
-userStore u = mapReadWriteError
- (\wl->case filter (\w->w.Worker.username == u) wl of
- [u] = Ok u
- u = Error (exception ("worker not found: " +++ toSingleLineText u))
- ,\nw wl->Ok $ Just [nw:filter (\w->w.Worker.username <> u) wl]
- ) usersStore
-
-jobsStore :: Shared [Job]
-jobsStore = sharedStore "Jobs"
- [{id=1,jobName="Testing",skills=[Testing],children=[],blocked=False}
- ,{id=2,jobName="Bigjob",skills=[Testing],blocked=False,children=
- [{id=3,jobName="subjob1",skills=[Testing],children=[],blocked=False}
- ,{id=4,jobName="subjob1",skills=[Testing],children=[],blocked=False}
- ]}
- ]
-jobStore :: Int -> Shared Job
-jobStore i = mapReadWriteError
- (findJob i
- ,\nj jl->Ok $ Just $ map (updateJob nj) jl
- ) jobsStore
-where
- findJob i [] = Error (exception "Job not found")
- findJob i [j=:{Job|id}:_] | id == i = Ok j
- findJob i [j:js] = case findJob i j.Job.children of
- Error e = findJob i js
- Ok u = Ok u
-
- updateJob nj j=:{Job|id} | id == i = nj
- updateJob nj j = {Job|j & children=map (updateJob nj) j.Job.children}
-
-removeJob :: Int [Job] -> [Job]
-removeJob i [] = []
-removeJob i [j=:{Job|id}:js] | i == id = js
-removeJob i [j:js] = [{Job|j & children=removeJob i j.Job.children}:removeJob i js]
-
-jobID :: Shared Int
-jobID = sharedStore "JobIDS" 4
-
-Start w = doTasks ((login -||- register <<@ ArrangeWithTabs False) >>- work) w
-
-register :: Task Worker
-register = tune (Title "Register")
- $ enterInformation "Enter credentials" [EnterUsing id credentialEditor]
- -&&- enterInformation "Enter Skills" []
- >>= \((u, p),s)->get usersStore
- @ filter (\a->a.Worker.username==u)
- >>- \exists->case exists of
- [] = let user = {loggedIn=True,username=u,password=p,skills=removeDup s}
- in upd (\l->[user:l]) usersStore >>| treturn user
- _ = viewInformation "User already exists" [] () >>| register
-
-login :: Task Worker
-login = tune (Title "Login")
- $ enterInformation "Enter credentials" [EnterUsing id credentialEditor]
- >>= \(u,p)->get usersStore
- @ filter (\a->a.Worker.username==u && a.Worker.password==p)
- >>- \u->case u of
- [] = viewInformation "User not found or incorrect password" [] () >>| login
- [{loggedIn=True}] = viewInformation "User is already logged in" [] () >>| login
- [u] = upd (\w->{w & loggedIn=True}) (userStore u.Worker.username)
-
-credentialEditor = panel2
- (textField <<@ labelAttr "Username")
- (passwordField <<@ labelAttr "Password")
-
-work :: Worker -> Task [()]
-work {Worker|username} = allTasks
- [ viewJobs
- , createNewJobs
- , updateSkills
- ] <<@ Title ("Welcome " +++ username) <<@ ArrangeWithTabs False
-where
- viewJobs
- = tune (Title "View jobs")
- $ editSelectionWithShared "Select a job" False
- (SelectInTree toCN fromSel)
- (jobsStore >*< userStore username)
- (\_->[])
- >^*
- [OnAction (Action "Execute") $ ifValue (\j->j=:[_]) \[j]->
- upd (\j->{j & blocked=True}) (jobStore j.Job.id)
- >>| viewSharedInformation "Job" [] (jobStore j.Job.id)
- >>*
- [OnAction (Action "Finish") $ always $
- upd (removeJob j.Job.id) jobsStore
- ,OnAction (Action "Split") $ always $
- enterInformation "Enter sub jobs" [EnterUsing id (gEditor{|*->*|} jobEditor gText{|*|} JSONEncode{|*|} JSONDecode{|*|})]
- >>= \sjs->sequence (take (length sjs) (repeat (upd inc jobID)))
- >>= \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)
- @! []
- ,OnAction (Action "Cancel") $ always $
- upd (\j->{j & blocked=False}) (jobStore j.Job.id)
- @! []
- ]
- ]
- @! ()
-
- toCN ::([Job],Worker) -> [ChoiceNode]
- toCN (jobs, worker) =
- [
- {id=if (job.Job.blocked || not (job.Job.children =: []) || not (matchSkills job)) (~job.Job.id) job.Job.id
- ,label=job.Job.jobName +++ "(" +++ toSingleLineText job.Job.skills +++ ")"
- ,icon=if (job.Job.blocked || not (matchSkills job)) (Just "document-error") Nothing
- ,expanded=True
- ,children=toCN (job.Job.children, worker)
- }
- \\job<-jobs
- ]
- where
- matchSkills job = 'List'.difference job.Job.skills worker.Worker.skills == []
-
- fromSel :: ([Job],Worker) [Int] -> [Job]
- fromSel (jobs,w) ids
- = [j\\j<-jobs | isMember j.Job.id ids]
- ++ flatten [fromSel (j.Job.children, w) ids\\j<-jobs]
-
- createNewJobs
- = tune (Title "Create new jobs")
- $ forever
- $ enterInformation "Enter job" [EnterUsing id jobEditor]
- >>= \(name, skills)->upd inc jobID
- >>= \i->upd ((++) [{Job|id=i,skills=skills,jobName=name,blocked=False,children=[]}]) jobsStore
- @! ()
-
- jobEditor :: Editor (String, [Skill])
- jobEditor = panel2
- (gEditor{|*|} <<@ labelAttr "Name")
- (gEditor{|*|} <<@ labelAttr "Skills")
-
- updateSkills
- = tune (Title "Edit skills")
- $ updateSharedInformation "Skills" [UpdateAs (\w->w.Worker.skills) (\w s->{Worker|w & skills=s})] (userStore username)
- @! ()
repositories / clean-tests.git / blobdiff