diff options
Diffstat (limited to 'src/Lib.hs')
| -rw-r--r-- | src/Lib.hs | 30 |
1 files changed, 19 insertions, 11 deletions
@@ -85,6 +85,9 @@ data PlayView = GameView [MediumTag] [T.Text] [Period] Level GameState (Work, Wo | FinalView [MediumTag] [T.Text] [Period] Level [Work] [Work] Integer newtype MediumTag = MediumTag T.Text deriving (Eq, Show, Ord, ToHttpApiData, FromHttpApiData, ToHtml) data Period = Ancient | Postclassical | EarlyModern | Modern deriving (Eq, Show, Read, Bounded, Enum) +renderPeriod :: Period -> T.Text +renderPeriod EarlyModern = "Early modern" +renderPeriod x = tshow x data Level = Short | Long deriving (Eq, Show, Read, Bounded, Enum) instance ToHttpApiData Period where toUrlPiece = tshow @@ -296,8 +299,9 @@ playURI mediumTags periods level gameState = "/" <> toUrlPiece (safeLink api (Pr gameCrumbs :: Monad m => [MediumTag] -> [T.Text] -> [Period] -> Level -> [HtmlT m ()] gameCrumbs _ labels periods level = [ - span_ $ toHtml $ T.intercalate ", " labels - , span_ $ toHtml $ T.intercalate ", " (fmap tshow periods) + span_ $ toHtmlRaw $ T.intercalate " · " labels + -- TODO + , span_ $ toHtmlRaw $ T.intercalate " · " (renderPeriod <$> periods) , span_ $ toHtml . tshow $ level ] instance ToHtml HomeView where @@ -367,7 +371,7 @@ feedbackPoor misses = "The Library regrets to inform you that due to the " <> (i feedback :: Level -> Integer -> T.Text feedback _ 0 = feedbackPerfect 0 feedback level misses = - if (level == Short && misses <= 4) || (level == Long && misses <= 8) + if (level == Short && misses <= 2) || (level == Long && misses <= 7) then feedbackMiddling misses else feedbackPoor misses @@ -378,7 +382,7 @@ showCard Work{name,year,wiki} = do renderWork :: Monad m => Work -> HtmlT m () -> HtmlT m () renderWork Work{figures} header = div_ [class_ "work"] $ do - div_ $ strong_ header + div_ header div_ [class_ "subwork"] $ mapM_ renderFigure figures renderFigure :: Monad m => Figure -> HtmlT m () renderFigure Figure{file,byline} = figure_ $ do @@ -392,8 +396,8 @@ instance ToHtml PlayView where body = do div_ [class_ "row"] $ div_ [class_ "narrow"] $ do p_ . toHtmlRaw $ feedback level misses - p_ $ do - a_ [href_ (playURI mediumTags periods level Nothing)] "Retry the current game" + p_ $ em_ $ do + a_ [href_ (playURI mediumTags periods level Nothing)] "Retry" span_ ", or " a_ [href_ homeURI] "choose different folios and periods" span_ "." @@ -403,7 +407,10 @@ instance ToHtml PlayView where td_ (showCard userWork) <> td_ (showCard sortedWork)) (zip userWorks sortedWorks) div_ [class_ "row"] $ div_ [class_ ""] $ mapM_ (\work -> do - renderWork work $ p_ $ showCard work <> p_ (toHtml $ location work) + renderWork work $ p_ $ do + strong_ $ showCard work + span_ $ toHtmlRaw $ T.pack " · " + span_ $ em_ (toHtml $ location work) br_ []) sortedWorks toHtml (GameView mediumTags labels periods level (GameState v s (Decisions comps)) (work1, work2)) = pageTemplate (gameCrumbs mediumTags labels periods level) body @@ -411,11 +418,12 @@ instance ToHtml PlayView where body = do div_ [class_ "row"] $ p_ $ do strong_ . toHtml $ "Question " <> tshow (length comps + 1) <> ". " - span_ "Select the work that was created first. Dates for ancient works are approximate and reflect when construction began." + span_ "Select the work that was created first." + small_ $ em_ " Dates for ancient works are approximate and reflect when construction began." div_ [class_ "row"] $ do - renderWork work1 (a_ [href_ (mkURI Less)] "Work A was created first.") + renderWork work1 (strong_ $ a_ [href_ (mkURI Less)] "Work A was created first.") hr_ [] - renderWork work2 (a_ [href_ (mkURI Greater)] "Work B was created first.") + renderWork work2 (strong_ $ a_ [href_ (mkURI Greater)] "Work B was created first.") mkURI nxt = playURI mediumTags periods level (Just (GameState v s (Decisions (comps ++ [nxt])))) toHtmlRaw = toHtml @@ -432,7 +440,7 @@ pageTemplate crumbs body = doctypehtml_ $ do div_ [class_ "row navbar"] $ sequence_ $ L.intersperse - (span_ [class_ "sep"] (toHtmlRaw (T.pack " · "))) + (span_ [] (toHtmlRaw (T.pack " / "))) (crumb : crumbs) body where |