1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
module multiplechoice
from StdEnv import flip
from Data.Func import $
import Data.Functor
import Data.Tuple
import iTasks
Start w = startEngine (allTasks createUsers >>| authedMain) w
where
createUsers :: [Task UserAccount]
createUsers = [catchAll (createUser u) (const $ return u) \\ u <- myUsers]
authedMain :: Task ()
authedMain = doAuthenticated (get currentUser >>- main) >>*
[OnAllExceptions (\_ ->
viewInformation (Title "Login failed") [] "Your username or password is incorrect"
>>| authedMain)]
:: Question =
{ question :: String
, answers :: [String]
, correct :: Int
}
:: Result
= Correct
| Incorrect
| Skipped
:: Results =
{ correct :: Int
, incorrect :: Int
, skipped :: Int
}
derive class iTask Question, Result, Results
clear :: (Question -> Question)
clear = const {question="", answers=[], correct=0}
questions :: Shared [Question]
questions = sharedStore "questions" []
main :: User -> Task ()
main u
| isTeacher u = teacherTask
| isAdmin u = adminTask
| otherwise = studentTask
where
isTeacher = hasRole TEACHER
isAdmin = hasRole ADMIN
hasRole r (AuthenticatedUser _ rs _) = isMember r rs
hasRole _ _ = False
teacherTask :: Task ()
teacherTask = enterChoiceWithShared
("Manage questions", "Select a question to modify:")
[ChooseFromGrid snd]
(mapRead withIndexes questions) >>*
[ OnAction (Action "Append") $ hasValue $ doAndContinue o append o ((+) 1) o fst
, OnAction (Action "Delete") $ hasValue $ doAndContinue o flip upd questions o removeAt o fst
, OnAction (Action "Edit") $ hasValue $ doAndContinue o edit
, OnAction (Action "First") $ always $ doAndContinue $ append 0
, OnAction (Action "Clear") $ hasValue $ doAndContinue o flip upd questions o flip updateWithAt clear o fst
, OnAction (Action "Quit") $ always $ return ()
]
where
doAndContinue :: (Task a) -> Task () | iTask a
doAndContinue t =
viewSharedInformation "Current items" [] questions ||- t
<<@ ApplyLayout (setUIAttributes (directionAttr Horizontal))
>>| teacherTask
cancelable :: (Task Question) -> Task (Maybe Question)
cancelable t = t >>*
[ OnAction (Action "Cancel") $ always $ return Nothing
, OnAction (Action "Save") $ ifValue isCorrect $ return o Just
]
where
isCorrect :: Question -> Bool
isCorrect q = q.Question.correct < length q.answers && q.Question.correct >= 0
append i = cancelable (enterInformation "New item" []) >>= ifJust (flip upd questions o insertAt i)
edit (i,q) = cancelable (updateInformation "Edit item" [] q) >>= ifJust (flip upd questions o updateAt i)
ifJust :: (a -> Task b) (Maybe a) -> Task () | iTask b
ifJust _ Nothing = return ()
ifJust t (Just v) = t v @ const ()
adminTask :: Task ()
adminTask = updateSharedInformation "Administrate questions" [] questions @ const ()
studentTask :: Task ()
studentTask = get questions >>= sequence "Answer questions" o map answer >>= showResults
where
answer :: Question -> Task Result
answer q =
enterChoice (q.question, "Answer:") [ChooseFromList snd] (withIndexes q.answers)
>>* [ OnAction (Action "Skip") $ always $ return Skipped
, OnAction (Action "Continue") $ hasValue \(a,_) -> return (if (a == q.Question.correct) Correct Incorrect)
]
showResults :: [Result] -> Task ()
showResults rs = viewInformation (Title "Results") [] {correct=c, incorrect=i, skipped=s} @ const ()
where
c = length [0 \\ Correct <- rs]
i = length [0 \\ Incorrect <- rs]
s = length [0 \\ Skipped <- rs]
TEACHER :== "teacher"
ADMIN :== "admin"
STUDENT :== "student"
myUsers :: [UserAccount]
myUsers =
[ user "Rinus" "1t4$ks" TEACHER
, user "Pieter" "naelc" TEACHER
, user "admin" "admin" ADMIN
, user "Camil" "root" STUDENT
, user "Laurens" "37+5" STUDENT
]
where
user u p r = {credentials={username=Username u,password=Password p},title=Nothing,roles=[r]}
updateWithAt :: Int (a -> a) [a] -> [a]
updateWithAt i f xs = updateAt i (f (xs!!i)) xs
withIndexes :: ([a] -> [(Int,a)])
withIndexes = zip2 [0..]
|
