initial check in of what stuff I tried so far, not looking very good
[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
42 listAssignments :: Query State AssignmentsWithHandIns
43 listAssignments = do    s <- askState
44                         let perAss ass = AssignmentWithHandIns ass (filter ((== assName ass) . hiAssName) (handIns s))
45                         return . AssignmentsWithHandIns $ map perAss (assignments s)
46
47
48 listStudents :: Query State [Student]
49 listStudents = students `fmap` askState
50
51 listHandIns :: Query State (Table AssName StudentID HandIn)
52 listHandIns = do s <- askState
53                  let colHeads = sort $ map assName $ assignments s
54                      rowHeads = sort $ map studentID $ students s
55                      his  = handIns s
56                      rows = map mkRow rowHeads
57                      mkRow id = TableRow (TableHead id) (map (mkCell id) colHeads)
58                      mkCell id name = TableCell $ listToMaybe $ filter (selectHandIn name id) his
59                  return $ Table (map TableHead colHeads) rows
60
61
62 getAssignment :: AssName ->  Query State (Maybe Assignment)
63 getAssignment name = return . findAssignment name . assignments =<< askState
64
65 getStudent :: StudentID ->  Query State (Maybe Student)
66 getStudent id = return . findStudent id =<< listStudents
67
68 deleteAssignment :: Assignment ->  Update State ()
69 deleteAssignment ass = withAssignments $ modify (removeAssignment ass)  
70
71 deleteStudent :: StudentID ->  Update State ()
72 deleteStudent id = withStudents $ modify (removeStudent id)     
73
74 updateAssignment :: Assignment -> Assignment -> Update State ()
75 updateAssignment ass newAss = withAssignments $ modify (map replace)
76   where replace a = if assName a /= assName ass then a else newAss
77
78 updateStudent :: Student ->Student -> Update State ()
79 updateStudent stud newStud = withStudents $ modify (map replace)
80   where replace s = if studentID s /= studentID stud then s else newStud
81
82 addAssignment :: Assignment -> Update State ()
83 addAssignment ass = withAssignments $ modify (ass :)
84
85 addStudent :: Student -> Update State ()
86 addStudent stud = withStudents $ modify (stud :)
87
88 getHandIn :: Assignment -> StudentID -> Query State (Maybe HandIn)
89 getHandIn ass studentid = return . find check . handIns =<< askState
90   where check hi = hiStudentID hi == studentid && hiAssName hi == assName ass
91
92 updateHandIn :: HandIn -> HandIn -> Update State ()
93 updateHandIn hi newHi = withHandIns $ modify (map replace)
94   where replace h = if hiAssName h /= hiAssName hi then h else
95                         if hiStudentID h /= hiStudentID hi then h else newHi
96
97 addHandIn :: HandIn -> Update State ()
98 addHandIn hi = withHandIns $ modify (hi :)
99
100 deleteHandIn :: HandIn -> Update State ()
101 deleteHandIn hi = withHandIns $ modify (removeHandIn hi)
102
103 $(expose ['listAssignments, 'getAssignment, 'addAssignment, 'updateAssignment, 'deleteAssignment,
104           'listHandIns, 'getHandIn, 'addHandIn, 'updateHandIn, 'deleteHandIn,
105           'listStudents, 'getStudent, 'addStudent, 'updateStudent, 'deleteStudent
106           ])
107