gallery/make-pages/ImagePage.hs

95 lines
2.7 KiB
Haskell

{-# OPTIONS_GHC -fdefer-typed-holes #-}
module ImagePage
(make)
where
import Info hiding (Text)
import qualified Data.Text as Strict
import qualified Data.Text.Lazy as Lazy
import Data.Text.Lazy.Builder
import Data.Time (formatTime, defaultTimeLocale)
import qualified Data.Char as Char
import qualified Data.Vector as Vector
make :: Info -> Lazy.Text
make = toLazyText . make'
make' :: Info -> Builder
make' (Info {date, title, tags, description, images, links}) =
"<!DOCTYPE html>\n" <>
"<html lang=en>\n" <>
"<meta charset=utf-8>\n" <>
"<link href=single.css rel=stylesheet>\n\n" <>
"<title>" <> esc title <> "</title>\n\n" <>
"<header>\n" <>
" <h1>" <> esc title <> "</h1>\n" <>
" <h2 class=date>" <> formatDate date <> "</h2>\n" <>
" <nav id=variants class=buttonbar>\n" <>
" <h2>alts</h2>\n" <>
" <ul id=variantlist>\n" <>
Vector.ifoldl (\b i im -> b <> altButton i im) mempty images <>
" </ul>\n" <>
" </nav>\n" <>
"</header>\n\n" <>
"<main>\n" <>
" <img id=it src=\"" <> path0 <> "\">\n" <>
" <section id=description>\n" <>
indent 4 description <>
" </section>\n\n" <>
" <h2>links</h2>\n" <>
" <ul>\n" <>
foldMap extLink links <>
" </ul>\n" <>
"</main>\n\n" <>
"<nav class=back>\n" <>
" <a href=../>back to gallery</a>\n" <>
"</nav>\n"
where
path0 = let Image {path} = Vector.head images in fromText path
esc :: Strict.Text -> Builder
esc = foldMap esc1 . Strict.unpack where
esc1 '<' = "&lt;"
esc1 '>' = "&gt;"
esc1 '&' = "&amp;"
esc1 '"' = "&quot;"
esc1 '\'' = "&squot;"
esc1 c = singleton c
formatDate :: Day -> Builder
formatDate = fromString . formatTime defaultTimeLocale "%e %#B %Y"
altButton :: Int -> Image -> Builder
altButton i (Image {label, path, nsfw}) =
" <li>\n" <>
" <input type=radio " <> checked <> "id=\"" <> idLabel <> "\" " <>
"name=variant autocomplete=off\n" <>
" value=\"" <> fromText path <> "\">\n" <>
" <label for=\"" <> idLabel <> "\">" <> fromText label <> "</label>\n"
where
checked = if i == 0 then "checked " else ""
idLabel = escId label
escId :: Strict.Text -> Builder
escId = foldMap esc1 . Strict.unpack where
esc1 c
| Char.isSpace c = ""
| c < 'ÿ' && not (Char.isAlphaNum c || c == '-') = "_"
| otherwise = singleton c
indent :: Int -> Strict.Text -> Builder
indent n txt = spaces <> go (Strict.unpack txt) where
go "" = mempty
go "\n" = "\n"
go ('\n':cs) = singleton '\n' <> spaces <> go cs
go (c:cs) = singleton c <> go cs
spaces = fromString $ replicate n ' '
extLink :: Link -> Builder
extLink (Link {title, url}) =
" <li>\n" <>
" <a href=\"" <> fromText url <> "\">\n" <>
" " <> fromText title <> "\n" <>
" </a>\n"