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
|
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) (\_ -> 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 (AuthenticatedUser s _ _) = isMember s ["Rinus", "Pieter"]
isTeacher _ = False
isAdmin u = u =: (AuthenticatedUser "admin" _ _)
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 a) -> Task (Maybe a) | iTask a
cancelable t = t >>*
[ OnAction (Action "Cancel") $ always $ return Nothing
, OnAction (Action "Save") $ hasValue $ return o Just
]
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..]
|
