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

make lots of fields optional & get rid of vector

Browse source
This commit is contained in:
Rhiannon Morris 2020-07-12 05:40:14 +02:00
parent cc485f798d
commit de160967e8
3 changed files with 62 additions and 43 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

36
make-pages/Info.hs
View file

@ -2,16 +2,14 @@
module Info module Info
(Info (..), Image (..), Link (..), (Info (..), Image (..), Link (..),
-- ** Reexports -- ** Reexports
Day (..), Text, Vector) Day (..), Text)
where where
import Data.YAML (FromYAML (..), (.:)) import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
import qualified Data.YAML as YAML import qualified Data.YAML as YAML
import Data.Time.Calendar (Day (..)) import Data.Time.Calendar (Day (..))
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Control.Applicative import Control.Applicative
import Text.Read (readMaybe) import Text.Read (readMaybe)
@ -20,12 +18,12 @@ import Text.Read (readMaybe)
data Info = data Info =
Info { Info {
date :: !Day, date :: !Day,
title :: !Text, title :: !(Maybe Text),
tags :: !(Vector Text), tags :: ![Text],
description :: !Text, description :: !(Maybe Text),
images :: !(Vector Image), images :: ![Image],
thumb :: !Text, thumb :: !Text,
links :: !(Vector Link) links :: ![Link]
} }
deriving (Eq, Show) deriving (Eq, Show)
@ -48,13 +46,13 @@ data Link =
instance FromYAML Info where instance FromYAML Info where
parseYAML = YAML.withMap "info" \m -> parseYAML = YAML.withMap "info" \m ->
Info <$> m .: "date" Info <$> m .: "date"
<*> m .: "title" <*> m .:? "title"
<*> m .: "tags" <*> m .:? "tags" .!= []
<*> m .: "description" <*> m .:? "description"
<*> m .: "images" <*> m .: "images"
<*> m .: "thumb" <*> m .: "thumb"
<*> m .: "links" <*> m .:? "links" .!= []
instance FromYAML Image where instance FromYAML Image where
parseYAML = labelledOptNsfw Image "path" "path" parseYAML = labelledOptNsfw Image "path" "path"
@ -95,7 +93,8 @@ parseOptNsfw :: FromYAML a
-> YAML.Node YAML.Pos -> YAML.Parser (OptNsfw a) -> YAML.Node YAML.Pos -> YAML.Parser (OptNsfw a)
parseOptNsfw name field y = yes y <|> no y where parseOptNsfw name field y = yes y <|> no y where
yes = YAML.withMap (name <> " & nsfw") \m -> yes = YAML.withMap (name <> " & nsfw") \m ->
WithNsfw <$> m .: field <*> m .: "nsfw" WithNsfw <$> m .: field
<*> m .:? "nsfw" .!= False
no = fmap NoNsfw . parseYAML no = fmap NoNsfw . parseYAML
@ -104,6 +103,3 @@ instance FromYAML Day where
case readMaybe $ Text.unpack str of case readMaybe $ Text.unpack str of
Just d -> pure d Just d -> pure d
Nothing -> fail $ "couldn't parse date " ++ show str Nothing -> fail $ "couldn't parse date " ++ show str
instance FromYAML a => FromYAML (Vector a) where
parseYAML = YAML.withSeq "seq" $ fmap Vector.fromList . traverse parseYAML

66
make-pages/SinglePage.hs
View file

@ -1,12 +1,24 @@
module SinglePage (make) where module SinglePage (make) where
import Info hiding (Text) import Info hiding (Text)
import Control.Exception
import qualified Data.Text as Strict import qualified Data.Text as Strict
import qualified Data.Text.Lazy as Lazy import qualified Data.Text.Lazy as Lazy
import Data.Text.Lazy.Builder import Data.Text.Lazy.Builder
import Data.Time (formatTime, defaultTimeLocale) import Data.Time (formatTime, defaultTimeLocale)
import Data.Maybe (fromMaybe)
import qualified Data.Char as Char import qualified Data.Char as Char
import qualified Data.Vector as Vector import qualified Data.List as List
-- | 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 :: Bool -> Info -> Lazy.Text
@ -18,25 +30,31 @@ make' includeNsfw (Info {date, title, tags, description, images, links}) =
"<html lang=en>\n" <> "<html lang=en>\n" <>
"<meta charset=utf-8>\n" <> "<meta charset=utf-8>\n" <>
"<link href=single.css rel=stylesheet>\n\n" <> "<link href=single.css rel=stylesheet>\n\n" <>
"<title>" <> esc title <> "</title>\n\n" <> ifJust title (\t -> "<title>" <> esc t <> "</title>\n\n") <>
"<header>\n" <> "<header>\n" <>
" <h1>" <> esc title <> "</h1>\n" <> ifJust title (\t -> " <h1>" <> esc t <> "</h1>\n") <>
" <h2 class=date>" <> formatDate date <> "</h2>\n" <> " <h2 class=date>" <> formatDate date <> "</h2>\n" <>
buttonBar includeNsfw images <> buttonBar title' includeNsfw images <>
"</header>\n\n" <> "</header>\n\n" <>
"<main>\n" <> "<main>\n" <>
" <img id=it src=\"" <> path0 <> "\">\n" <> " <img id=it src=\"" <> path0 <> "\">\n" <>
" <section id=description>\n" <> ifJust description (\d ->
indent 4 description <> " <div class=desc>\n" <>
" </section>\n\n" <> " <h2>description</h2>\n" <>
indent 4 d <>
" </div>\n") <>
extLinks includeNsfw links <> extLinks includeNsfw links <>
"</main>\n\n" <> "</main>\n\n" <>
"<nav class=back>\n" <> "<nav class=back>\n" <>
" <a href=../>back to gallery</a>\n" <> " <a href=../>back to gallery</a>\n" <>
"</nav>\n" "</nav>\n"
where where
path0 = let Image {path} = Vector.head images in fromText path path0' = let Image {path} = head images in path
path0 = fromText path0'
title' = fromMaybe path0' title
ifJust :: Monoid b => Maybe a -> (a -> b) -> b
ifJust x f = maybe mempty f x
esc :: Strict.Text -> Builder esc :: Strict.Text -> Builder
esc = foldMap esc1 . Strict.unpack where esc = foldMap esc1 . Strict.unpack where
@ -50,21 +68,23 @@ esc = foldMap esc1 . Strict.unpack where
formatDate :: Day -> Builder formatDate :: Day -> Builder
formatDate = fromString . formatTime defaultTimeLocale "%e %#B %Y" formatDate = fromString . formatTime defaultTimeLocale "%e %#B %Y"
buttonBar :: Bool -> Vector Image -> Builder buttonBar :: Strict.Text -> Bool -> [Image] -> Builder
buttonBar includeNsfw images = buttonBar title includeNsfw allImages =
let images' = if includeNsfw then images if null images then
else Vector.filter (\Image {nsfw} -> not nsfw) images in throw $ NoEligibleImages title
if null images' then else if length images == 1 then
error "not including nsfw but there are no sfw images!"
else if length images' == 1 then
mempty mempty
else else
" <nav id=variants class=buttonbar>\n" <> " <nav id=variants class=buttonbar>\n" <>
" <h2>alts</h2>\n" <> " <h2>alts</h2>\n" <>
" <ul id=variantlist>\n" <> " <ul id=variantlist>\n" <>
Vector.ifoldl' (\b i im -> b <> altButton i im) mempty images' <> List.foldl' (\b (i, im) -> b <> altButton i im) mempty iimages <>
" </ul>\n" <> " </ul>\n" <>
" </nav>\n" " </nav>\n"
where
images | includeNsfw = allImages
| otherwise = filter (\Image {nsfw} -> not nsfw) allImages
iimages = zip [0..] images
altButton :: Int -> Image -> Builder altButton :: Int -> Image -> Builder
altButton i (Image {label, path, nsfw}) = altButton i (Image {label, path, nsfw}) =
@ -93,16 +113,18 @@ indent n txt = spaces <> go (Strict.unpack txt) where
go (c:cs) = singleton c <> go cs go (c:cs) = singleton c <> go cs
spaces = fromString $ replicate n ' ' spaces = fromString $ replicate n ' '
extLinks :: Bool -> Vector Link -> Builder extLinks :: Bool -> [Link] -> Builder
extLinks includeNsfw links = extLinks includeNsfw links =
let links' = let links' =
if includeNsfw then links if includeNsfw then links
else Vector.filter (\Link {nsfw} -> not nsfw) links in else filter (\Link {nsfw} -> not nsfw) links in
if null links' then mempty else if null links' then mempty else
" <h2>links</h2>\n" <> " <div class=links>\n" <>
" <ul>\n" <> " <h2>links</h2>\n" <>
foldMap extLink links' <> " <ul>\n" <>
" </ul>\n" foldMap extLink links' <>
" </ul>\n" <>
" </div>\n"
extLink :: Link -> Builder extLink :: Link -> Builder
extLink (Link {title, url}) = extLink (Link {title, url}) =

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

@ -13,6 +13,8 @@ executable make-pages
default-language: Haskell2010 default-language: Haskell2010
default-extensions: default-extensions:
BlockArguments, BlockArguments,
DeriveAnyClass,
DerivingStrategies,
DuplicateRecordFields, DuplicateRecordFields,
LambdaCase, LambdaCase,
NamedFieldPuns, NamedFieldPuns,
@ -23,7 +25,6 @@ executable make-pages
time ^>= 1.8.0.2, time ^>= 1.8.0.2,
bytestring ^>= 0.10.8.2, bytestring ^>= 0.10.8.2,
text ^>= 1.2.3.1, text ^>= 1.2.3.1,
vector ^>= 0.12.1.2,
HsYAML ^>= 0.2.1.0, HsYAML ^>= 0.2.1.0,
optparse-applicative ^>= 0.15.1.0 optparse-applicative ^>= 0.15.1.0
ghc-options: ghc-options: