@@ -0,0 +1,251 @@
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 Events t = Events
62+ { selectAnswer :: Event t SelectAnswer
63+ , showAnswers :: Event t CheckAnswers }
64+
65+-- | Тип, содержащий все изменяющиеся (Dynamic) данные.
66+data Model t
67+ = Model
68+ { areAnswersShown :: Dynamic t AreAnswersShown
69+ , allQuestions :: [(QuestionText, [(Answer, Dynamic t IsChosen)])]
70+ , canCheckAnswers :: Dynamic t CanCheckAnswers
71+ , score :: Dynamic t Score }
72+
73+-- * Model
74+
75+-- | Функция, описывающая всю внутреннюю логику работы виджета. Она принимает
76+-- тип данных 'Events', хранящий все события и возвращает динамическую модель.
77+mkModel :: ObeliskWidget js t route m
78+ => [(QuestionText, [Answer])]
79+ -- ^ Список вопросов с ответами
80+ -> Events t
81+ -> m (Model t)
82+mkModel questions evs = do
83+ areAnswersShown <- holdDyn AnswersHidden $ showAnswers evs $> AnswersShown
84+ allQuestions <- do
85+ for (enumerate questions) \(qNum, (questionText, answers)) -> do
86+ (questionText, ) <$> for (enumerate answers) \(aNum, Answer{..}) -> do
87+ let
88+ updChosenState SelectAnswer{questionNumber,answerNumber} isChosen = do
89+ guard (questionNumber == qNum)
90+ return
91+ if answerNumber == aNum
92+ then toggleChosen isChosen
93+ else NotChosen
94+ isChosenDyn <- foldDynMaybe updChosenState NotChosen (selectAnswer evs)
95+ return (Answer{..}, isChosenDyn)
96+ let
97+ canCheckAnswers = do
98+ -- Для каждого вопроса хотя бы один ответ выбран
99+ status <- all (Chosen `elem`) <$> do
100+ for allQuestions \(_, answers) -> do
101+ for answers \(_, dynIsChosen) -> dynIsChosen
102+ return if status then CanCheckAnswers else CantCheckAnswers
103+ score = do
104+ areAnswersShown >>= \case
105+ AnswersHidden -> return NoScore
106+ AnswersShown -> do
107+ correctAnswers <- flip execStateT 0 do
108+ for_ allQuestions \(_, answers) -> do
109+ for_ answers \(answer, dynIsChosen) -> do
110+ isChosen <- lift dynIsChosen
111+ when (isChosen == Chosen && isCorrect answer == Correct) do
112+ modify (+ 1)
113+ return Score {correctAnswers, totalQuestions = length allQuestions}
114+ return Model{..}
115+
116+-- * Интерфейс пользователя
117+
118+quizUI :: ObeliskWidget js t route m => Model t -> m (Events t)
119+quizUI Model{..} = wrapUI do
120+ selectAnswer <- leftmost <$> for (enumerate allQuestions)
121+ \(qNum, (questionText, answers)) -> do
122+ divClass "question" do
123+ text questionText
124+ answersUI qNum areAnswersShown answers
125+ showAnswers <- footerUI canCheckAnswers score
126+ return Events{..}
127+
128+answersUI :: ObeliskWidget js t route m
129+ => Int
130+ -> Dynamic t AreAnswersShown
131+ -> [(Answer, Dynamic t IsChosen)]
132+ -> m (Event t SelectAnswer)
133+answersUI qNum areAnswersShown answers = do
134+ leftmost <$> elClass "div" "answers" do
135+ for (enumerate answers)
136+ \(aNum, (Answer{answerText,isCorrect}, dynIsChosen)) -> do
137+ let
138+ dynAttrs = do
139+ isChosen <- dynIsChosen
140+ areShown <- areAnswersShown
141+ let
142+ className = T.intercalate " " $ execWriter do
143+ tell ["answer"]
144+ when (isChosen == Chosen) $ tell ["answer-chosen"]
145+ tell [ if areShown == AnswersShown
146+ then "answer-shown"
147+ else "answer-hidden" ]
148+ tell [ if isCorrect == Correct
149+ then "answer-correct"
150+ else "answer-incorrect" ]
151+ return $ "class" =: className
152+ event <- domEvent Click . fst <$> elDynAttr' "div" dynAttrs do
153+ text answerText
154+ return $ event $>
155+ SelectAnswer { questionNumber = qNum, answerNumber = aNum }
156+
157+-- | Виджет, содержащий либо текст с предложением ответить на все вопросы, либо
158+-- кнопку проверки ответов, либо информацию о результатах.
159+footerUI :: ObeliskWidget js t route m
160+ => Dynamic t CanCheckAnswers -> Dynamic t Score -> m (Event t CheckAnswers)
161+footerUI canCheckAnswersDyn dynScore = wrapContainer do
162+ evt <- switchHold never <=< dyn $ do
163+ canCheckAnswers <- canCheckAnswersDyn
164+ score <- dynScore
165+ return if score /= NoScore
166+ then return never
167+ else canCheckAnswers & \case
168+ CanCheckAnswers -> do
169+ domEvent Click . fst <$> do
170+ el' "button" do
171+ text "Check answers"
172+ CantCheckAnswers -> do
173+ divClass "unfinished-quiz-notice" do
174+ text "Select answers for all questions before you can get the results."
175+ return never
176+ dyn_ $ dynScore <&> \case
177+ NoScore -> blank
178+ Score{totalQuestions, correctAnswers} -> do
179+ text "Your score: "
180+ text . T.pack $ show correctAnswers
181+ text " of "
182+ text . T.pack $ show totalQuestions
183+ return $ evt $> CheckAnswers
184+ where wrapContainer = divClass "check-answers-button-container"
185+
186+wrapUI :: ObeliskWidget js t route m => m a -> m a
187+wrapUI contents = do
188+ el "h1" do
189+ text "Quiz Demo using "
190+ mkLink "Reflex framework" "https://reflex-frp.org/"
191+ result <- elAttr "div" ("id" =: "container") contents
192+ el "h3" do
193+ text "Demo made by "
194+ mkLink "Typeable" "https://typeable.io/"
195+ return result
196+ where
197+ mkLink linkText url = do
198+ elAttr "a" ("href" =: url <> "target" =: "blank") do
199+ text linkText
200+
201+-- * Main widget
202+
203+questions :: [(QuestionText, [Answer])]
204+questions =
205+ [ ( "How many arguments does update function have?"
206+ , [ Answer "1" Incorrect
207+ , Answer "2" Correct
208+ , Answer "3" Incorrect
209+ , Answer "4" Incorrect
210+ ] )
211+ , ( "Which of the following does not contain a value at any point of time?"
212+ , [ Answer "Behaviour" Incorrect
213+ , Answer "Event" Correct
214+ , Answer "Dynamic" Incorrect
215+ ] )
216+ , ( "Which framework does not use Virtual DOM?"
217+ , [ Answer "Elm" Incorrect
218+ , Answer "Reflex" Correct
219+ ] )
220+ ]
221+
222+mkQuizWidget :: ObeliskWidget js t route m => [(QuestionText, [Answer])] -> m ()
223+mkQuizWidget qs =
224+ mkWidget (mkModel qs) quizUI
225+
226+-- * Вспомогательные функции.
227+
228+mkWidget :: ObeliskWidget js t route m
229+ => (events -> m model) -> (model -> m events) -> m ()
230+mkWidget model ui = void $ mfix (model >=> ui)
231+
232+enumerate :: [a] -> [(Int, a)]
233+enumerate = zip [0..]
234+
235+toggleChosen :: IsChosen -> IsChosen
236+toggleChosen Chosen = NotChosen
237+toggleChosen NotChosen = Chosen
238+
239+frontend :: Frontend (R FrontendRoute)
240+frontend = Frontend
241+ { _frontend_head = do
242+ el "title" $ text "Quiz Demo (Reflex)"
243+ elAttr "link"
244+ ( "href" =: static @"main.css" <>
245+ "type" =: "text/css" <>
246+ "rel" =: "stylesheet" ) blank
247+ , _frontend_body = do
248+ el "div" do
249+ mkQuizWidget questions
250+ return ()
251+ }