Commit 441bf44b authored by Christopher League's avatar Christopher League
Browse files

Group together activity id, points, deadline

parent ad08e8dd
......@@ -23,6 +23,7 @@ module App.Foundation
Route (..),
resourcesApp,
Handler,
AppHandler,
Widget,
runRo,
conRo,
......
......@@ -37,7 +37,6 @@ import System.Exit
import Text.Pandoc (Pandoc (..), runPure, writeHtml5String)
import qualified Text.Pandoc.Highlighting as PH
import UnliftIO.IORef (newIORef, readIORef, writeIORef)
import Yesod.Core.Types (FileInfo (..))
getFaviconR :: Handler TypedContent
getFaviconR =
......
......@@ -22,14 +22,8 @@ import App.Prelude
import App.Quiz1
import App.User
import qualified Data.Set as Set
import Data.Time.Format
import Data.Time.LocalTime
import Data.Tuple.Extra
formatDay :: FormatTime t => t -> String
formatDay =
formatTime defaultTimeLocale "%a %e %b"
cardList :: (ToWidget App h, ToWidget App b) => h -> b -> Widget
cardList header body =
[whamlet|
......@@ -104,15 +98,6 @@ unitTitle num title =
#{title}
|]
dueBadge :: ZonedTime -> Widget
dueBadge deadline = do
now <- getCurrentTime
let cls = if now > zonedTimeToUTC deadline then "danger" else "info" :: Text
[whamlet|
<span class="badge badge-#{cls}">
due #{formatDay deadline}
|]
unit1 :: Widget
unit1 = do
cardList (unitTitle 1 "Digital representations") $
......@@ -129,8 +114,8 @@ unit1 = do
Check-in:
<a href=@{U1ToBaseR}>
Convert to base
^{pointsBadgeU1ToBase}
^{dueBadge u1ToBaseDeadline}
^{pointsBadge u1ToBase}
^{dueBadge (actDeadline u1ToBase)}
<li .list-group-item>
Notes:
<a href=@{PageDocR "notes120-binary.org"}>
......
......@@ -10,17 +10,19 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module App.Quiz1
( handleU1FromBaseR,
( Activity (..),
handleU1FromBaseR,
handleU1ToBaseR,
u1ToBaseKey,
u1ToBaseDeadline,
u1ToBaseMaxPoints,
pointsBadgeU1ToBase,
u1ToBase,
pointsBadge,
dueBadge,
formatDay,
quiz1Tests,
)
where
......@@ -45,33 +47,59 @@ import Test.Tasty
import Test.Tasty.Hedgehog
import Text.Blaze.Html (ToMarkup (..))
u1ToBaseDeadline :: ZonedTime
u1ToBaseDeadline =
parseTimeOrError
True
defaultTimeLocale
"%F %H:%M %Z"
"2020-02-05 23:59 EST"
data Activity
= Activity
{ actId :: ActivityId,
actDeadline :: ZonedTime,
actMaxPoints :: Points
}
deriving (Show)
u1ToBaseKey :: ActivityId
u1ToBaseKey = "u1to"
makeActivity :: ActivityId -> Points -> String -> Activity
makeActivity actId actMaxPoints timeStr =
Activity {..}
where
actDeadline =
parseTimeOrError
False -- Allow leading spaces
defaultTimeLocale
"%F %H:%M %Z"
timeStr
u1ToBase :: Activity
u1ToBase =
makeActivity "u1to" 8 "2020-02-05 23:59 EST"
userPointsFor :: ActivityId -> UserEntity -> Points
userPointsFor aid =
view $ _2 . userScores . at aid . non 0
pointsBadge :: Activity -> Widget
pointsBadge Activity {..} = do
pts <- userPointsFor actId <$> requireAuth
let cls = if pts == actMaxPoints then "success" else "primary" :: Text
[whamlet|
<span class="badge badge-#{cls}">
#{tshow pts}/#{tshow actMaxPoints} points
|]
isPast :: MonadIO m => ZonedTime -> m Bool
isPast zt =
(> zonedTimeToUTC zt) <$> getCurrentTime
u1ToBaseMaxPoints :: Points
u1ToBaseMaxPoints = 8
formatDay :: FormatTime t => t -> String
formatDay =
formatTime defaultTimeLocale "%a %e %b"
pointsBadge :: ActivityId -> Points -> Widget
pointsBadge actId limit = do
pts <- (^. _2 . userScores . at actId . non 0) <$> requireAuth
let cls = if pts == limit then "success" else "primary" :: Text
dueBadge :: ZonedTime -> Widget
dueBadge deadline = do
isLate <- isPast deadline
let cls = if isLate then "danger" else "info" :: Text
[whamlet|
<span class="badge badge-#{cls}">
#{tshow pts}/#{tshow limit} points
due #{formatDay deadline}
|]
pointsBadgeU1ToBase :: Widget
pointsBadgeU1ToBase =
pointsBadge u1ToBaseKey u1ToBaseMaxPoints
type BaseWord = Word16
instance ToMarkup BaseWord where
......@@ -382,13 +410,14 @@ $else
handleU1ToBaseR :: Handler Html
handleU1ToBaseR = do
bc <- getBaseConvertSession u1ToBaseKey
bc <- getBaseConvertSession $ actId u1ToBase
((result, widget), enctype) <- runFormPost $ toBaseForm bc
onFormSuccess result \response -> do
let correct = matchDigits bc response
Activity {..} = u1ToBase
when correct $ do
origPts <- (^. _2 . userScores . at u1ToBaseKey . non 0) <$> requireAuth
isLate <- (> zonedTimeToUTC u1ToBaseDeadline) <$> getCurrentTime
origPts <- userPointsFor actId <$> requireAuth
isLate <- isPast actDeadline
let award =
if isLate
then 0
......@@ -396,24 +425,24 @@ handleU1ToBaseR = do
if bc ^. bcAttempts > 1
then 1
else 2
newPts = min u1ToBaseMaxPoints (origPts + award)
newPts = min actMaxPoints (origPts + award)
deltaPts = newPts - origPts
when (deltaPts > 0) $
updateAuth_
("u1ToBase points := " <> show newPts)
(userScores . at u1ToBaseKey ?~ newPts)
deleteSession u1ToBaseKey
(userScores . at actId ?~ newPts)
deleteSession actId
addMessage
"success"
[shamlet|
<b>
$if isLate && (newPts < u1ToBaseMaxPoints)
$if isLate && (newPts < actMaxPoints)
You got it! However, the deadline has passed, so no further points
can be awarded.
$elseif deltaPts == 0
Nice! You already have the maximum points for this activity,
but feel free to continue practicing.
$elseif newPts == u1ToBaseMaxPoints
$elseif newPts == actMaxPoints
Great job! You just earned #{plural deltaPts "point"}, and have reached
the maximum for this activity. 😎
$elseif deltaPts == 1
......@@ -451,7 +480,7 @@ $else
setTitle "Convert to a non-decimal base"
[whamlet|
<div .col-12>
^{pointsBadgeU1ToBase}
^{pointsBadge u1ToBase}
<p .mt-2>
This problem is about converting from base ten
<b>
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment