gallery/make-pages/SinglePage.hs

module SinglePage (make) where

import Depend (pageFile)
import Info hiding (Text)
import BuilderQQ
import Records ()

import Control.Exception
import qualified Data.Text as Strict
import qualified Data.Text.Lazy as Lazy
import Data.Time (formatTime, defaultTimeLocale)
import Data.Maybe (fromMaybe)
import qualified Data.Char as Char
import qualified Data.List as List


-- | e.g. only nsfw images are present for a non-nsfw page
data NoEligibleImages = NoEligibleImages {title :: !Strict.Text}
  deriving stock Eq deriving anyclass Exception

instance Show NoEligibleImages where
  show (NoEligibleImages {title}) =
    Strict.unpack title <> ": no images selected\n" <>
    "  (probably a nsfw-only work without --nsfw set)"


make :: Bool -> Info -> Lazy.Text
make nsfw = toLazyText . make' nsfw

make' :: Bool -> Info -> Builder
make' nsfw (Info {date, title, artist, tags, nsfwTags,
                  description, images, background, links}) = [b|@0
    <!DOCTYPE html>
    <html lang=en>
    <meta charset=utf-8>
    <meta name=viewport content='width=1200,viewport-fit=cover'>
    <link rel=stylesheet href=/style/single.css>

    $titleTag

    <header>
      $titleHeader
      $artistTag
      <h2 class=date>$formattedDate</h2>
      $buttonBar
    </header>

    <script async src=/script/single.js></script>

    <main>
      <figure id=mainfig$dataBg>
        $warning'
        <a id=mainlink href="$@path0">
          <img id=mainimg src="$@path0'">
        </a>
      </figure>

      <section class=info>
        $descSection

        $tagsList

        $linksList
      </section>
    </main>

    <footer>
      <nav class=back>
        <a href=../>back to gallery</a>
      </nav>
    </footer>
  |]
  where
    titleTag    = ifJust title \t -> [b|<title>$*t</title>|]
    titleHeader = ifJust title \t -> [b|<h1>$*t</h1>|]

    artistTag = ifJust artist makeArtist

    formattedDate = formatDate date

    buttonBar = makeButtonBar (fromMaybe (Strict.pack path0) title) nsfw images
    image0    = head images
    path0     = #path image0
    path0'    = pageFile path0

    descSection = ifJust description makeDesc
    tagsList    = makeTags nsfw tags nsfwTags
    linksList   = extLinks nsfw links

    dataBg = ifJust background \bg -> [b| data-bg="$*bg"|]
    warning' = ifJust (#warning image0) \w -> [b|@4
      <figcaption id=cw>
        <span id=cw-text>cw: <b>$*w</b></span>
      </figcaption>
      |]

makeArtist :: Artist -> Builder
makeArtist (Artist {name, url}) =
  [b|<h2 class=artist>by $artistLink</h2>|]
 where
   artistLink = case url of
    Just u  -> [b|<a href="$*u">$*name</a>|]
    Nothing -> [b|$*name|]

makeDesc :: Strict.Text -> Builder
makeDesc desc = [b|@4
  <section class=desc>
    <h2>about</h2>
    <div>
      $8*desc
    </div>
  </section>
  |]

ifJust :: Monoid b => Maybe a -> (a -> b) -> b
ifJust x f = maybe mempty f x

formatDate :: Day -> Builder
formatDate d =
  let str = formatTime defaultTimeLocale "%e %#B %Y" d in [b|$@str|]

makeButtonBar :: Strict.Text -> Bool -> [Image] -> Builder
makeButtonBar title nsfw allImages =
  case length images of
    0 -> throw $ NoEligibleImages title
    1 -> ""
    _ -> [b|@2
      <nav class=alts>
        <ul id=altlist>
          $6.alts
        </ul>
      </nav>
      |]
 where
  images | nsfw      = allImages
         | otherwise = filter #sfw allImages
  alts = map (uncurry altButton) $ zip [0..] images

altButton :: Int -> Image -> Builder
altButton i (Image {label, path, nsfw, warning}) = [b|@6
  <li$nsfwClass>
    <input type=radio$checked id="$idLabel" name=variant
           autocomplete=off value="$@path'"
           data-link="$@path"$warning'>
    <label for="$idLabel">$*label</label>
  |]
 where
  nsfwClass = if nsfw then " class=nsfw" else ""
  checked   = if i == 0 then " checked" else ""
  idLabel   = escId label
  path'     = pageFile path
  warning'  = ifJust warning \w -> [b| data-warning="$*w"|]

escId :: Strict.Text -> Builder
escId = foldMap esc1 . Strict.unpack where
  esc1 c
    | Char.isSpace c = ""
    | c < 'ÿ' && not (Char.isAlphaNum c || c == '-') = "_"
    | otherwise = [b|$'c|]

makeTags :: Bool -> [Strict.Text] -> [Strict.Text] -> Builder
makeTags nsfw sfwTags nsfwTags =
  if null tags then "" else [b|@4
    <section class=tags>
      <h2>tags</h2>
      <ul>
        $8.tagList
      </ul>
    </section>
  |]
 where
  tagList = map makeTag tags
  makeTag t = [b|<li>$*t|]
  tags = List.nub $ if nsfw then sfwTags <> nsfwTags else sfwTags

extLinks :: Bool -> [Link] -> Builder
extLinks nsfw allLinks =
  if null links then "" else [b|@4
    <section class=links>
      <h2>links</h2>
      <ul>
        $8.linkList
      </ul>
    </section>
  |]
 where
  links    = if nsfw then allLinks else filter #sfw allLinks
  linkList = map extLink links

extLink :: Link -> Builder
extLink (Link {title, url}) = [b|@6
    <li>
      <a href="$*url">
        $*title
      </a>
  |]
move ImagePage → SinglePage 2020-07-09 00:20:09 -04:00			`module SinglePage (make) where`
add image page 2020-07-07 23:28:09 -04:00
a lot of stuff sorry 2020-07-16 10:07:28 -04:00			`import Depend (pageFile)`
add image page 2020-07-07 23:28:09 -04:00			`import Info hiding (Text)`
rename BuildVar module to BuilderQQ 2020-07-15 15:31:46 -04:00			`import BuilderQQ`
a lot of stuff sorry 2020-07-16 10:07:28 -04:00			`import Records ()`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00
make lots of fields optional & get rid of vector 2020-07-11 23:40:14 -04:00			`import Control.Exception`
add image page 2020-07-07 23:28:09 -04:00			`import qualified Data.Text as Strict`
			`import qualified Data.Text.Lazy as Lazy`
			`import Data.Time (formatTime, defaultTimeLocale)`
make lots of fields optional & get rid of vector 2020-07-11 23:40:14 -04:00			`import Data.Maybe (fromMaybe)`
add image page 2020-07-07 23:28:09 -04:00			`import qualified Data.Char as Char`
make lots of fields optional & get rid of vector 2020-07-11 23:40:14 -04:00			`import qualified Data.List as List`


change a comment 2020-07-12 23:02:16 -04:00			`-- \| e.g. only nsfw images are present for a non-nsfw page`
make lots of fields optional & get rid of vector 2020-07-11 23:40:14 -04:00			`data NoEligibleImages = NoEligibleImages {title :: !Strict.Text}`
			`deriving stock Eq deriving anyclass Exception`

			`instance Show NoEligibleImages where`
			`show (NoEligibleImages {title}) =`
			`Strict.unpack title <> ": no images selected\n" <>`
			`" (probably a nsfw-only work without --nsfw set)"`
add image page 2020-07-07 23:28:09 -04:00

skip nsfw stuff in non-nsfw singlepages 2020-07-09 15:48:29 -04:00			`make :: Bool -> Info -> Lazy.Text`
rename includeNsfw to just nsfw 2020-07-13 02:32:59 -04:00			`make nsfw = toLazyText . make' nsfw`
add image page 2020-07-07 23:28:09 -04:00
skip nsfw stuff in non-nsfw singlepages 2020-07-09 15:48:29 -04:00			`make' :: Bool -> Info -> Builder`
put artist on page 2020-07-14 00:51:46 -04:00			`make' nsfw (Info {date, title, artist, tags, nsfwTags,`
a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`description, images, background, links}) = [b\|@0`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`<!DOCTYPE html>`
			`<html lang=en>`
			`<meta charset=utf-8>`
some viewport thing that seems to work idk 2020-07-17 09:51:33 -04:00			`<meta name=viewport content='width=1200,viewport-fit=cover'>`
a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`<link rel=stylesheet href=/style/single.css>`

make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`$titleTag`

			`<header>`
			`$titleHeader`
put artist on page 2020-07-14 00:51:46 -04:00			`$artistTag`
a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`<h2 class=date>$formattedDate</h2>`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`$buttonBar`
			`</header>`

a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`<script async src=/script/single.js></script>`

make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`<main>`
a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`<figure id=mainfig$dataBg>`
			`$warning'`
			`<a id=mainlink href="$@path0">`
			`<img id=mainimg src="$@path0'">`
			`</a>`
			`</figure>`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00
a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`<section class=info>`
			`$descSection`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00
a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`$tagsList`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00
a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`$linksList`
			`</section>`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`</main>`

			`<footer>`
			`<nav class=back>`
			`<a href=../>back to gallery</a>`
			`</nav>`
			`</footer>`
			`\|]`
			`where`
use labels for fields 2020-07-13 02:33:27 -04:00			`titleTag = ifJust title \t -> [b\|<title>$*t</title>\|]`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`titleHeader = ifJust title \t -> [b\|<h1>$*t</h1>\|]`
use labels for fields 2020-07-13 02:33:27 -04:00
put artist on page 2020-07-14 00:51:46 -04:00			`artistTag = ifJust artist makeArtist`

make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`formattedDate = formatDate date`
use labels for fields 2020-07-13 02:33:27 -04:00
use FilePath for file paths 2020-07-15 05:35:32 -04:00			`buttonBar = makeButtonBar (fromMaybe (Strict.pack path0) title) nsfw images`
a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`image0 = head images`
			`path0 = #path image0`
a lot of stuff sorry 2020-07-16 10:07:28 -04:00			`path0' = pageFile path0`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00
			`descSection = ifJust description makeDesc`
rename includeNsfw to just nsfw 2020-07-13 02:32:59 -04:00			`tagsList = makeTags nsfw tags nsfwTags`
			`linksList = extLinks nsfw links`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00
a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`dataBg = ifJust background \bg -> [b\| data-bg="$*bg"\|]`
			`warning' = ifJust (#warning image0) \w -> [b\|@4`
			`<figcaption id=cw>`
add span #cw-text, grudgingly 2020-07-18 05:45:59 -04:00			`<span id=cw-text>cw: <b>$*w</b></span>`
a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`</figcaption>`
			`\|]`

put artist on page 2020-07-14 00:51:46 -04:00			`makeArtist :: Artist -> Builder`
			`makeArtist (Artist {name, url}) =`
			`[b\|<h2 class=artist>by $artistLink</h2>\|]`
			`where`
			`artistLink = case url of`
			`Just u -> [b\|<a href="$u">$name</a>\|]`
			`Nothing -> [b\|$*name\|]`

make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`makeDesc :: Strict.Text -> Builder`
a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`makeDesc desc = [b\|@4`
			`<section class=desc>`
			`<h2>about</h2>`
			`<div>`
			`$8*desc`
			`</div>`
			`</section>`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`\|]`
add image page 2020-07-07 23:28:09 -04:00
make lots of fields optional & get rid of vector 2020-07-11 23:40:14 -04:00			`ifJust :: Monoid b => Maybe a -> (a -> b) -> b`
			`ifJust x f = maybe mempty f x`
add image page 2020-07-07 23:28:09 -04:00
			`formatDate :: Day -> Builder`
a lot of stuff sorry 2020-07-16 10:07:28 -04:00			`formatDate d =`
			`let str = formatTime defaultTimeLocale "%e %#B %Y" d in [b\|$@str\|]`
add image page 2020-07-07 23:28:09 -04:00
make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`makeButtonBar :: Strict.Text -> Bool -> [Image] -> Builder`
rename includeNsfw to just nsfw 2020-07-13 02:32:59 -04:00			`makeButtonBar title nsfw allImages =`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`case length images of`
			`0 -> throw $ NoEligibleImages title`
			`1 -> ""`
			`_ -> [b\|@2`
a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`<nav class=alts>`
			`<ul id=altlist>`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`$6.alts`
			`</ul>`
			`</nav>`
			`\|]`
make lots of fields optional & get rid of vector 2020-07-11 23:40:14 -04:00			`where`
rename includeNsfw to just nsfw 2020-07-13 02:32:59 -04:00			`images \| nsfw = allImages`
use labels for fields 2020-07-13 02:33:27 -04:00			`\| otherwise = filter #sfw allImages`
			`alts = map (uncurry altButton) $ zip [0..] images`
skip nsfw stuff in non-nsfw singlepages 2020-07-09 15:48:29 -04:00
add image page 2020-07-07 23:28:09 -04:00			`altButton :: Int -> Image -> Builder`
a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`altButton i (Image {label, path, nsfw, warning}) = [b\|@6`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`<li$nsfwClass>`
			`<input type=radio$checked id="$idLabel" name=variant`
a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`autocomplete=off value="$@path'"`
			`data-link="$@path"$warning'>`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`<label for="$idLabel">$*label</label>`
			`\|]`
add image page 2020-07-07 23:28:09 -04:00			`where`
add nsfw class to alt buttons 2020-07-09 00:19:19 -04:00			`nsfwClass = if nsfw then " class=nsfw" else ""`
a lot of stuff sorry 2020-07-16 10:07:28 -04:00			`checked = if i == 0 then " checked" else ""`
			`idLabel = escId label`
			`path' = pageFile path`
a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`warning' = ifJust warning \w -> [b\| data-warning="$*w"\|]`
add image page 2020-07-07 23:28:09 -04:00
			`escId :: Strict.Text -> Builder`
			`escId = foldMap esc1 . Strict.unpack where`
			`esc1 c`
			`\| Char.isSpace c = ""`
			`\| c < 'ÿ' && not (Char.isAlphaNum c \|\| c == '-') = "_"`
a lot of stuff sorry 2020-07-16 10:07:28 -04:00			`\| otherwise = [b\|$'c\|]`
add image page 2020-07-07 23:28:09 -04:00
add nsfw tags & put tags on singlepage 2020-07-11 23:42:31 -04:00			`makeTags :: Bool -> [Strict.Text] -> [Strict.Text] -> Builder`
rename includeNsfw to just nsfw 2020-07-13 02:32:59 -04:00			`makeTags nsfw sfwTags nsfwTags =`
a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`if null tags then "" else [b\|@4`
			`<section class=tags>`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`<h2>tags</h2>`
			`<ul>`
a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`$8.tagList`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`</ul>`
a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`</section>`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`\|]`
add nsfw tags & put tags on singlepage 2020-07-11 23:42:31 -04:00			`where`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`tagList = map makeTag tags`
			`makeTag t = [b\|<li>$*t\|]`
got tags backwards 2020-07-17 10:00:55 -04:00			`tags = List.nub $ if nsfw then sfwTags <> nsfwTags else sfwTags`
add nsfw tags & put tags on singlepage 2020-07-11 23:42:31 -04:00
make lots of fields optional & get rid of vector 2020-07-11 23:40:14 -04:00			`extLinks :: Bool -> [Link] -> Builder`
rename includeNsfw to just nsfw 2020-07-13 02:32:59 -04:00			`extLinks nsfw allLinks =`
a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`if null links then "" else [b\|@4`
			`<section class=links>`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`<h2>links</h2>`
			`<ul>`
a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`$8.linkList`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`</ul>`
a lot of stylin and a little scriptin 2020-07-17 06:29:13 -04:00			`</section>`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`\|]`
			`where`
use labels for fields 2020-07-13 02:33:27 -04:00			`links = if nsfw then allLinks else filter #sfw allLinks`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`linkList = map extLink links`
skip nsfw stuff in non-nsfw singlepages 2020-07-09 15:48:29 -04:00
add image page 2020-07-07 23:28:09 -04:00			`extLink :: Link -> Builder`
make quasiquoter for text building 2020-07-12 22:01:31 -04:00			`extLink (Link {title, url}) = [b\|@6`
			`<li>`
			`<a href="$*url">`
			`$*title`
			`</a>`
			`\|]`