add image page

2020-07-08 05:28:09 +02:00 · 2020-07-08 05:28:09 +02:00 · 92ad510218
parent c1d14c539f
commit 92ad510218
2 changed files with 97 additions and 3 deletions
--- a/make-pages/ImagePage.hs
+++ b/make-pages/ImagePage.hs
@ -0,0 +1,95 @@
+{-# 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 '<'  = "&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 {..}) =
+ "      <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"
--- a/make-pages/make-pages.cabal
+++ b/make-pages/make-pages.cabal
@ -9,7 +9,7 @@ maintainer: Rhiannon Morris <rhi@rhiannon.website>
 executable make-pages
  hs-source-dirs: .
  main-is: Main.hs
-  other-modules: Info
+  other-modules: Info, ImagePage
  default-language: Haskell2010
  default-extensions:
    BlockArguments,
@ -23,7 +23,6 @@ executable make-pages
    time ^>= 1.8.0.2,
    text ^>= 1.2.3.1,
    vector ^>= 0.12.1.2,
-    HsYAML ^>= 0.2.1.0,
-    blaze-html ^>= 0.9.1.2
+    HsYAML ^>= 0.2.1.0
  ghc-options:
    -Wall -threaded -rtsopts -with-rtsopts=-N