IPPrint 0.3 now provides pshow
[darcs-mirror-latutman.git] / haskell / State.hs
1 {-# OPTIONS -fglasgow-exts -fth -fallow-undecidable-instances #-}
2
3 module State where
4
5 import Types
6 import HAppS.Data
7 import HAppS.State
8 import HAppS.State.EventTH
9 import HAppS.Server
10 import Data.Maybe
11 import Data.List
12 import Control.Monad.State (modify)
13
14 import qualified State.State_000 as Old
15
16 $(deriveAll [''Read,''Show,''Default]
17   [d|
18       data State = State {assignments :: [Assignment],
19                           students    :: [Student],
20                           handIns     :: [HandIn] }
21    |]
22  )
23
24 instance Xml State where
25     version _ = Just "001"
26     otherVersion _ = Other (error "Other" :: Old.State)
27
28 instance Migrate Old.State State where
29     migrate os = State ass stud hi
30      where      ass = map migrate (Old.assignments os)
31                 stud = Old.students os
32                 hi = concatMap extr (Old.assignments os)
33                 extr oas = map (\(Old.HandIn s p) -> HandIn s (Old.assName oas) p) (Old.handIns oas)
34
35 instance Migrate Old.Assignment Assignment where
36     migrate (Old.Assignment n p _) = Assignment n p
37
38 $(inferStartState ''State) 
39 $(inferRecordUpdaters ''State) 
40
41 getCompleteState :: Query State State
42 getCompleteState = askState
43
44 putCompleteState :: State -> Update State ()
45 putCompleteState = putState
46
47 listAssignments :: Query State AssignmentsWithHandIns
48 listAssignments = do    s <- askState
49                         let perAss ass = AssignmentWithHandIns ass (filter ((== assName ass) . hiAssName) (handIns s))
50                         return . AssignmentsWithHandIns $ map perAss (assignments s)
51
52
53 listStudents :: Query State [Student]
54 listStudents = students `fmap` askState
55
56 listHandIns :: Query State (Table AssName StudentID HandIn)
57 listHandIns = do s <- askState
58                  let colHeads = sort $ map assName $ assignments s
59                      rowHeads = sort $ map studentID $ students s
60                      his  = handIns s
61                      rows = map mkRow rowHeads
62                      mkRow id = TableRow (TableHead id) (map (mkCell id) colHeads)
63                      mkCell id name = TableCell $ listToMaybe $ filter (selectHandIn name id) his
64                  return $ Table (map TableHead colHeads) rows
65
66 getAssignment :: AssName ->  Query State (Maybe Assignment)
67 getAssignment name = return . findAssignment name . assignments =<< askState
68
69 getStudent :: StudentID ->  Query State (Maybe Student)
70 getStudent id = return . findStudent id =<< listStudents
71
72 deleteAssignment :: Assignment ->  Update State ()
73 deleteAssignment ass = withAssignments $ modify (removeAssignment ass)  
74
75 deleteStudent :: StudentID ->  Update State ()
76 deleteStudent id = withStudents $ modify (removeStudent id)     
77
78 updateAssignment :: Assignment -> Assignment -> Update State ()
79 updateAssignment ass newAss = withAssignments $ modify (map replace)
80   where replace a = if assName a /= assName ass then a else newAss
81
82 updateStudent :: Student ->Student -> Update State ()
83 updateStudent stud newStud = withStudents $ modify (map replace)
84   where replace s = if studentID s /= studentID stud then s else newStud
85
86 addAssignment :: Assignment -> Update State ()
87 addAssignment ass = withAssignments $ modify (ass :)
88
89 addStudent :: Student -> Update State ()
90 addStudent stud = withStudents $ modify (stud :)
91
92 getHandIn :: Assignment -> StudentID -> Query State (Maybe HandIn)
93 getHandIn ass studentid = return . find check . handIns =<< askState
94   where check hi = hiStudentID hi == studentid && hiAssName hi == assName ass
95
96 updateHandIn :: HandIn -> HandIn -> Update State ()
97 updateHandIn hi newHi = withHandIns $ modify (map replace)
98   where replace h = if hiAssName h /= hiAssName hi then h else
99                         if hiStudentID h /= hiStudentID hi then h else newHi
100
101 addHandIn :: HandIn -> Update State ()
102 addHandIn hi = withHandIns $ modify (hi :)
103
104 deleteHandIn :: HandIn -> Update State ()
105 deleteHandIn hi = withHandIns $ modify (removeHandIn hi)
106
107 $(expose ['listAssignments, 'getAssignment, 'addAssignment, 'updateAssignment, 'deleteAssignment,
108           'listHandIns, 'getHandIn, 'addHandIn, 'updateHandIn, 'deleteHandIn,
109           'listStudents, 'getStudent, 'addStudent, 'updateStudent, 'deleteStudent,
110           'getCompleteState, 'putCompleteState
111           ])
112