old/afp/a6/a7.icl

   1 module a7
   2
   3 import StdEnv
   4
   5 import qualified Data.List as List
   6 import Data.Func
   7 import Control.Applicative
   8
   9 import iTasks
  10
  11 :: Job =
  12         { id        :: Int
  13         , jobName   :: String
  14         , skills    :: [Skill]
  15         , blocked   :: Bool
  16         , children  :: [Job]
  17         }
  18 :: Skill = Programming | Design | Testing
  19 :: Worker =
  20         { username :: String
  21         , password :: String
  22         , skills   :: [Skill]
  23         , loggedIn :: Bool
  24         }
  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
  29 derive JSONEncode Set
  30 derive JSONDecode Set
  31 derive gText Set
  32 derive gEditor Set
  33 derive gDefault Set
  34
  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
  40                 [u] = Ok u
  41                 u = Error (exception ("worker not found: " +++ toSingleLineText u))
  42         ,\nw wl->Ok $ Just [nw:filter (\w->w.Worker.username <> u) wl]
  43         ) usersStore
  44
  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}
  51                 ]}
  52         ]
  53 jobStore :: Int -> Shared Job
  54 jobStore i = mapReadWriteError
  55         (findJob i
  56         ,\nj jl->Ok $ Just $ map (updateJob nj) jl
  57         ) jobsStore
  58 where
  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
  63                 Ok u = Ok u
  64
  65         updateJob nj j=:{Job|id} | id == i = nj
  66         updateJob nj j = {Job|j & children=map (updateJob nj) j.Job.children}
  67
  68 removeJob :: Int [Job] -> [Job]
  69 removeJob i [] = []
  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]
  72
  73 jobID :: Shared Int
  74 jobID = sharedStore "JobIDS" 4
  75
  76 Start w = doTasks ((login -||- register <<@ ArrangeWithTabs False) >>- work) w
  77
  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
  88
  89 login :: Task Worker
  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)
  94         >>- \u->case u of
  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)
  98
  99 credentialEditor = panel2
 100         (textField <<@ labelAttr "Username")
 101         (passwordField <<@ labelAttr "Password")
 102
 103 work :: Worker -> Task [()]
 104 work {Worker|username} = allTasks
 105         [ viewJobs
 106         , createNewJobs
 107         , updateSkills
 108         ] <<@ Title ("Welcome " +++ username) <<@ ArrangeWithTabs False
 109 where
 110         viewJobs
 111                 = tune (Title "View jobs")
 112                 $ editSelectionWithShared "Select a job" False
 113                         (SelectInTree toCN fromSel)
 114                         (jobsStore >*< userStore username)
 115                         (\_->[])
 116                 >^*
 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)
 120                                 >>*
 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)
 127                                                 @! []
 128                                         ,OnAction (Action "Cancel") $ always $
 129                                                 upd (\j->{j & blocked=False}) (jobStore j.Job.id)
 130                                                 @! []
 131                                         ]
 132                         ]
 133                 @! ()
 134
 135         toCN ::([Job],Worker) -> [ChoiceNode]
 136         toCN (jobs, worker) =
 137                 [
 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
 141                         ,expanded=True
 142                         ,children=toCN (job.Job.children, worker)
 143                         }
 144                 \\job<-jobs
 145                 ]
 146         where
 147                 matchSkills job = 'List'.difference job.Job.skills worker.Worker.skills == []
 148
 149         fromSel :: ([Job],Worker) [Int] -> [Job]
 150         fromSel (jobs,w) ids
 151                 =  [j\\j<-jobs | isMember j.Job.id ids]
 152                 ++ flatten [fromSel (j.Job.children, w) ids\\j<-jobs]
 153
 154         createNewJobs
 155                 = tune (Title "Create new jobs")
 156                 $ forever
 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
 160                 @! ()
 161
 162         jobEditor :: Editor (String, [Skill])
 163         jobEditor = panel2
 164                 (gEditor{|*|} <<@ labelAttr "Name")
 165                 (gEditor{|*|} <<@ labelAttr "Skills")
 166
 167         updateSkills
 168                 = tune (Title "Edit skills")
 169                 $ updateSharedInformation "Skills" [UpdateAs (\w->w.Worker.skills) (\w s->{Worker|w & skills=s})] (userStore username)
 170                 @! ()