rhi/gallery
1
0
Fork 0
Code Issues 5 Pull requests 1 Releases Wiki Activity

add image page

Browse source
This commit is contained in:
Rhiannon Morris 2020-07-08 05:28:09 +02:00
parent c1d14c539f
commit 92ad510218
2 changed files with 97 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

95
make-pages/ImagePage.hs Normal file
View file

@ -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"

5
make-pages/make-pages.cabal
View file

@ -9,7 +9,7 @@ maintainer: Rhiannon Morris <rhi@rhiannon.website>
executable make-pages executable make-pages
hs-source-dirs: . hs-source-dirs: .
main-is: Main.hs main-is: Main.hs
other-modules: Info other-modules: Info, ImagePage
default-language: Haskell2010 default-language: Haskell2010
default-extensions: default-extensions:
BlockArguments, BlockArguments,
@ -23,7 +23,6 @@ executable make-pages
time ^>= 1.8.0.2, time ^>= 1.8.0.2,
text ^>= 1.2.3.1, text ^>= 1.2.3.1,
vector ^>= 0.12.1.2, vector ^>= 0.12.1.2,
HsYAML ^>= 0.2.1.0, HsYAML ^>= 0.2.1.0
blaze-html ^>= 0.9.1.2
ghc-options: ghc-options:
-Wall -threaded -rtsopts -with-rtsopts=-N -Wall -threaded -rtsopts -with-rtsopts=-N