96 lines
2.7 KiB
Haskell
96 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 {..}) =
|
||
|
|
"<!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 {..} = Vector.head images in fromText path
|
||
|
|
|
||
|
|
|
||
|
|
esc :: Strict.Text -> Builder
|
||
|
|
esc = foldMap esc1 . Strict.unpack where
|
||
|
|
esc1 '<' = "<"
|
||
|
|
esc1 '>' = ">"
|
||
|
|
esc1 '&' = "&"
|
||
|
|
esc1 '"' = """
|
||
|
|
esc1 '\'' = "&squot;"
|
||
|
|
esc1 c = singleton c
|
||
|
|
|
||
|
|
formatDate :: Day -> Builder
|
||
|
|
formatDate = fromString . formatTime defaultTimeLocale "%e %#B %Y"
|
||
|
|
|
||
|
|
altButton :: Int -> Image -> Builder
|
||
|
|
altButton i (Image {..}) =
|
||
|
|
" <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 {..}) =
|
||
|
|
" <li>\n" <>
|
||
|
|
" <a href=\"" <> fromText url <> "\">\n" <>
|
||
|
|
" " <> fromText title <> "\n" <>
|
||
|
|
" </a>\n"
|