@@ -0,0 +1,280 @@
1+module Frontend where
2+
3+import Common.Route
4+import Control.Monad
5+import Control.Monad.Fix
6+import Control.Monad.State
7+import Control.Monad.Writer
8+import Data.Foldable
9+import Data.Functor
10+import qualified Data.Text as T
11+import Data.Traversable
12+import Obelisk.Frontend
13+import Obelisk.Generated.Static
14+import Obelisk.Route
15+import Reflex.Dom.Core
16+
17+-- * Типы данных, описывающие состояние виджета.
18+
19+type QuestionText = T.Text
20+
21+type AnswerText = T.Text
22+
23+data IsChosen = Chosen | NotChosen
24+ deriving (Show, Eq)
25+
26+data IsCorrect = Correct | Incorrect
27+ deriving (Show, Eq)
28+
29+data CanCheckAnswers = CanCheckAnswers | CantCheckAnswers
30+ deriving (Show, Eq)
31+
32+data AreAnswersShown = AnswersShown | AnswersHidden
33+ deriving (Show, Eq)
34+
35+data Answer = Answer
36+ { answerText :: AnswerText
37+ , isCorrect :: IsCorrect }
38+ deriving (Show, Eq)
39+
40+data Score
41+ = NoScore
42+ | Score
43+ { totalQuestions :: Int
44+ , correctAnswers :: Int }
45+ deriving (Eq, Show)
46+
47+-- ** Типы данных, описывающие payload различных событий.
48+
49+-- | Выбор варианта ответа.
50+data SelectAnswer
51+ = SelectAnswer
52+ { questionNumber :: Int
53+ , answerNumber :: Int }
54+
55+-- | Payload для события "показать ответы"
56+data CheckAnswers = CheckAnswers
57+
58+-- ** Типы данных, описывающие внутренние интерфейсы нашего виджета.
59+
60+-- | Тип, содержащий все события, с которыми мы будем работать.
61+data QuizEvents t = QuizEvents
62+ { selectAnswer :: Event t SelectAnswer
63+ , showAnswers :: Event t CheckAnswers }
64+
65+-- | Тип, содержащий все изменяющиеся (Dynamic) данные.
66+data QuizState t = QuizState
67+ { areAnswersShown :: Dynamic t AreAnswersShown
68+ , allQuestions :: [(QuestionText, [(Answer, Dynamic t IsChosen)])]
69+ , canCheckAnswers :: Dynamic t CanCheckAnswers
70+ , score :: Dynamic t Score }
71+
72+-- * Model
73+
74+-- | Функция, описывающая всю внутреннюю логику работы виджета. Она принимает
75+-- тип данных 'QuizEvents', хранящий все события и возвращает динамическое
76+-- состояние.
77+mkQuizModel :: ObeliskWidget js t route m
78+ => [(QuestionText, [Answer])]
79+ -- ^ Список вопросов с ответами
80+ -> QuizEvents t
81+ -> m (QuizState t)
82+mkQuizModel questions events = do
83+ areAnswersShown <- holdDyn AnswersHidden (showAnswers events $> AnswersShown)
84+ allQuestions <- mkAllQuestionsModel questions events
85+ canCheckAnswers <- mkCanCheckAnswersModel allQuestions
86+ score <- mkScoreModel areAnswersShown allQuestions
87+ return QuizState{..}
88+
89+mkAllQuestionsModel :: ObeliskWidget js t route m
90+ => [(QuestionText, [Answer])]
91+ -- ^ Список вопросов с ответами
92+ -> QuizEvents t
93+ -> m [(QuestionText, [(Answer, Dynamic t IsChosen)])]
94+mkAllQuestionsModel questions events = do
95+ for (enumerate questions)
96+ \(qNum, (questionText, answers)) -> do
97+ (questionText, ) <$> for (enumerate answers)
98+ \(aNum, Answer{..}) -> do
99+ let
100+ updChosenState SelectAnswer{questionNumber,answerNumber} isChosen = do
101+ guard (questionNumber == qNum)
102+ return
103+ if answerNumber == aNum
104+ then toggleChosen isChosen
105+ else NotChosen
106+ isChosenDyn <- foldDynMaybe updChosenState NotChosen
107+ (selectAnswer events)
108+ return (Answer{..}, isChosenDyn)
109+
110+mkCanCheckAnswersModel :: ObeliskWidget js t route m
111+ => [(QuestionText, [(Answer, Dynamic t IsChosen)])]
112+ -> m (Dynamic t CanCheckAnswers)
113+mkCanCheckAnswersModel allQuestions = holdUniqDyn do
114+ -- Для каждого вопроса хотя бы один ответ выбран
115+ allQuestionsAnswered <- all (Chosen `elem`) <$> do
116+ for allQuestions \(_, answers) -> do
117+ for answers \(_, dynIsChosen) -> dynIsChosen
118+ return if allQuestionsAnswered then CanCheckAnswers else CantCheckAnswers
119+
120+mkScoreModel :: ObeliskWidget js t route m
121+ => Dynamic t AreAnswersShown
122+ -> [(QuestionText, [(Answer, Dynamic t IsChosen)])]
123+ -> m (Dynamic t Score)
124+mkScoreModel areAnswersShown allQuestions = holdUniqDyn do
125+ areAnswersShown >>= \case
126+ AnswersHidden -> return NoScore
127+ AnswersShown -> do
128+ correctAnswers <- flip execStateT 0 do
129+ for_ allQuestions \(_, answers) -> do
130+ for_ answers \(answer, dynIsChosen) -> do
131+ isChosen <- lift dynIsChosen
132+ when (isChosen == Chosen && isCorrect answer == Correct) do
133+ modify (+ 1)
134+ return Score { correctAnswers, totalQuestions = length allQuestions }
135+
136+-- * Интерфейс пользователя
137+
138+quizUI :: ObeliskWidget js t route m => QuizState t -> m (QuizEvents t)
139+quizUI QuizState{..} = wrapUI do
140+ selectAnswer <- leftmost <$> for (enumerate allQuestions)
141+ \(qNum, (questionText, answers)) -> do
142+ divClass "question" do
143+ text questionText
144+ answersUI qNum areAnswersShown answers
145+ showAnswers <- footerUI canCheckAnswers score
146+ return QuizEvents{..}
147+
148+answersUI :: ObeliskWidget js t route m
149+ => Int
150+ -> Dynamic t AreAnswersShown
151+ -> [(Answer, Dynamic t IsChosen)]
152+ -> m (Event t SelectAnswer)
153+answersUI qNum areAnswersShown answers = elClass "div" "answers" do
154+ leftmost <$> for (enumerate answers)
155+ \(aNum, (Answer{answerText,isCorrect}, dynIsChosen)) -> do
156+ event <- answerUI areAnswersShown answerText isCorrect dynIsChosen
157+ return (event $> SelectAnswer { questionNumber = qNum, answerNumber = aNum })
158+
159+answerUI :: ObeliskWidget js t route m
160+ => Dynamic t AreAnswersShown
161+ -> AnswerText
162+ -> IsCorrect
163+ -> Dynamic t IsChosen
164+ -> m (Event t ())
165+answerUI areAnswersShown answerText isCorrect dynIsChosen =
166+ domEvent Click . fst <$> elDynAttr' "div" dynAttrs do
167+ text answerText
168+ where
169+ dynAttrs = do
170+ isChosen <- dynIsChosen
171+ areShown <- areAnswersShown
172+ let
173+ className = T.intercalate " " $ execWriter do
174+ tell ["answer"]
175+ when (isChosen == Chosen) $ tell ["answer-chosen"]
176+ tell [ if areShown == AnswersShown
177+ then "answer-shown"
178+ else "answer-hidden" ]
179+ tell [ if isCorrect == Correct
180+ then "answer-correct"
181+ else "answer-incorrect" ]
182+ return $ "class" =: className
183+
184+-- | Виджет, содержащий либо текст с предложением ответить на все вопросы, либо
185+-- кнопку проверки ответов, либо информацию о результатах.
186+footerUI :: ObeliskWidget js t route m
187+ => Dynamic t CanCheckAnswers -> Dynamic t Score -> m (Event t CheckAnswers)
188+footerUI canCheckAnswersDyn dynScore = wrapContainer do
189+ evt <- switchHold never <=< dyn $ do
190+ canCheckAnswers <- canCheckAnswersDyn
191+ score <- dynScore
192+ return if score /= NoScore
193+ then return never
194+ else
195+ case canCheckAnswers of
196+ CanCheckAnswers -> do
197+ domEvent Click . fst <$> do
198+ el' "button" do
199+ text "Check answers"
200+ CantCheckAnswers -> do
201+ divClass "unfinished-quiz-notice" do
202+ text "Select answers for all questions before you can get the results."
203+ return never
204+ dyn_ $ dynScore <&> \case
205+ NoScore -> blank
206+ Score{totalQuestions, correctAnswers} -> do
207+ text "Your score: "
208+ text . T.pack $ show correctAnswers
209+ text " of "
210+ text . T.pack $ show totalQuestions
211+ return (evt $> CheckAnswers)
212+ where wrapContainer = divClass "check-answers-button-container"
213+
214+-- | Функция, снабжающая наш виджет статическим контентом.
215+wrapUI :: ObeliskWidget js t route m => m a -> m a
216+wrapUI contents = do
217+ el "h1" do
218+ text "Quiz Demo using "
219+ mkLink "Reflex framework" "https://reflex-frp.org/"
220+ result <- elAttr "div" ("id" =: "container") contents
221+ el "h3" do
222+ text "Demo made by "
223+ mkLink "Typeable" "https://typeable.io/"
224+ return result
225+ where
226+ mkLink linkText url = do
227+ elAttr "a" ("href" =: url <> "target" =: "blank") do
228+ text linkText
229+
230+-- * Main widget
231+
232+questions :: [(QuestionText, [Answer])]
233+questions =
234+ [ ( "How many arguments does update function have?"
235+ , [ Answer "1" Incorrect
236+ , Answer "2" Correct
237+ , Answer "3" Incorrect
238+ , Answer "4" Incorrect
239+ ] )
240+ , ( "Which of the following does not contain a value at any point of time?"
241+ , [ Answer "Behaviour" Incorrect
242+ , Answer "Event" Correct
243+ , Answer "Dynamic" Incorrect
244+ ] )
245+ , ( "Which framework does not use Virtual DOM?"
246+ , [ Answer "Elm" Incorrect
247+ , Answer "Reflex" Correct
248+ ] )
249+ ]
250+
251+mkQuizWidget :: ObeliskWidget js t route m => [(QuestionText, [Answer])] -> m ()
252+mkQuizWidget qs =
253+ mkWidget (mkQuizModel qs) quizUI
254+
255+-- * Вспомогательные функции.
256+
257+mkWidget :: ObeliskWidget js t route m
258+ => (events -> m state) -> (state -> m events) -> m ()
259+mkWidget model ui = void (mfix (model >=> ui))
260+
261+enumerate :: [a] -> [(Int, a)]
262+enumerate = zip [0..]
263+
264+toggleChosen :: IsChosen -> IsChosen
265+toggleChosen Chosen = NotChosen
266+toggleChosen NotChosen = Chosen
267+
268+frontend :: Frontend (R FrontendRoute)
269+frontend = Frontend
270+ { _frontend_head = do
271+ el "title" $ text "Quiz Demo (Reflex)"
272+ elAttr "link"
273+ ( "href" =: static @"main.css" <>
274+ "type" =: "text/css" <>
275+ "rel" =: "stylesheet" ) blank
276+ , _frontend_body = do
277+ el "div" do
278+ mkQuizWidget questions
279+ return ()
280+ }