make lots of fields optional & get rid of vector
This commit is contained in:
parent
cc485f798d
commit
de160967e8
3 changed files with 62 additions and 43 deletions
|
|
@ -2,16 +2,14 @@
|
|||
module Info
|
||||
(Info (..), Image (..), Link (..),
|
||||
-- ** Reexports
|
||||
Day (..), Text, Vector)
|
||||
Day (..), Text)
|
||||
where
|
||||
|
||||
import Data.YAML (FromYAML (..), (.:))
|
||||
import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
|
||||
import qualified Data.YAML as YAML
|
||||
import Data.Time.Calendar (Day (..))
|
||||
import Data.Text (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 Control.Applicative
|
||||
import Text.Read (readMaybe)
|
||||
|
|
@ -20,12 +18,12 @@ import Text.Read (readMaybe)
|
|||
data Info =
|
||||
Info {
|
||||
date :: !Day,
|
||||
title :: !Text,
|
||||
tags :: !(Vector Text),
|
||||
description :: !Text,
|
||||
images :: !(Vector Image),
|
||||
title :: !(Maybe Text),
|
||||
tags :: ![Text],
|
||||
description :: !(Maybe Text),
|
||||
images :: ![Image],
|
||||
thumb :: !Text,
|
||||
links :: !(Vector Link)
|
||||
links :: ![Link]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
|
@ -49,12 +47,12 @@ data Link =
|
|||
instance FromYAML Info where
|
||||
parseYAML = YAML.withMap "info" \m ->
|
||||
Info <$> m .: "date"
|
||||
<*> m .: "title"
|
||||
<*> m .: "tags"
|
||||
<*> m .: "description"
|
||||
<*> m .:? "title"
|
||||
<*> m .:? "tags" .!= []
|
||||
<*> m .:? "description"
|
||||
<*> m .: "images"
|
||||
<*> m .: "thumb"
|
||||
<*> m .: "links"
|
||||
<*> m .:? "links" .!= []
|
||||
|
||||
instance FromYAML Image where
|
||||
parseYAML = labelledOptNsfw Image "path" "path"
|
||||
|
|
@ -95,7 +93,8 @@ parseOptNsfw :: FromYAML a
|
|||
-> YAML.Node YAML.Pos -> YAML.Parser (OptNsfw a)
|
||||
parseOptNsfw name field y = yes y <|> no y where
|
||||
yes = YAML.withMap (name <> " & nsfw") \m ->
|
||||
WithNsfw <$> m .: field <*> m .: "nsfw"
|
||||
WithNsfw <$> m .: field
|
||||
<*> m .:? "nsfw" .!= False
|
||||
no = fmap NoNsfw . parseYAML
|
||||
|
||||
|
||||
|
|
@ -104,6 +103,3 @@ instance FromYAML Day where
|
|||
case readMaybe $ Text.unpack str of
|
||||
Just d -> pure d
|
||||
Nothing -> fail $ "couldn't parse date " ++ show str
|
||||
|
||||
instance FromYAML a => FromYAML (Vector a) where
|
||||
parseYAML = YAML.withSeq "seq" $ fmap Vector.fromList . traverse parseYAML
|
||||
|
|
|
|||
|
|
@ -1,12 +1,24 @@
|
|||
module SinglePage (make) where
|
||||
|
||||
import Info hiding (Text)
|
||||
import Control.Exception
|
||||
import qualified Data.Text as Strict
|
||||
import qualified Data.Text.Lazy as Lazy
|
||||
import Data.Text.Lazy.Builder
|
||||
import Data.Time (formatTime, defaultTimeLocale)
|
||||
import Data.Maybe (fromMaybe)
|
||||
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
|
||||
|
|
@ -18,25 +30,31 @@ make' includeNsfw (Info {date, title, tags, description, images, links}) =
|
|||
"<html lang=en>\n" <>
|
||||
"<meta charset=utf-8>\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" <>
|
||||
" <h1>" <> esc title <> "</h1>\n" <>
|
||||
ifJust title (\t -> " <h1>" <> esc t <> "</h1>\n") <>
|
||||
" <h2 class=date>" <> formatDate date <> "</h2>\n" <>
|
||||
buttonBar includeNsfw images <>
|
||||
buttonBar title' includeNsfw images <>
|
||||
"</header>\n\n" <>
|
||||
"<main>\n" <>
|
||||
" <img id=it src=\"" <> path0 <> "\">\n" <>
|
||||
" <section id=description>\n" <>
|
||||
indent 4 description <>
|
||||
" </section>\n\n" <>
|
||||
ifJust description (\d ->
|
||||
" <div class=desc>\n" <>
|
||||
" <h2>description</h2>\n" <>
|
||||
indent 4 d <>
|
||||
" </div>\n") <>
|
||||
extLinks includeNsfw links <>
|
||||
"</main>\n\n" <>
|
||||
"<nav class=back>\n" <>
|
||||
" <a href=../>back to gallery</a>\n" <>
|
||||
"</nav>\n"
|
||||
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 = foldMap esc1 . Strict.unpack where
|
||||
|
|
@ -50,21 +68,23 @@ esc = foldMap esc1 . Strict.unpack where
|
|||
formatDate :: Day -> Builder
|
||||
formatDate = fromString . formatTime defaultTimeLocale "%e %#B %Y"
|
||||
|
||||
buttonBar :: Bool -> Vector Image -> Builder
|
||||
buttonBar includeNsfw images =
|
||||
let images' = if includeNsfw then images
|
||||
else Vector.filter (\Image {nsfw} -> not nsfw) images in
|
||||
if null images' then
|
||||
error "not including nsfw but there are no sfw images!"
|
||||
else if length images' == 1 then
|
||||
buttonBar :: Strict.Text -> Bool -> [Image] -> Builder
|
||||
buttonBar title includeNsfw allImages =
|
||||
if null images then
|
||||
throw $ NoEligibleImages title
|
||||
else if length images == 1 then
|
||||
mempty
|
||||
else
|
||||
" <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' <>
|
||||
List.foldl' (\b (i, im) -> b <> altButton i im) mempty iimages <>
|
||||
" </ul>\n" <>
|
||||
" </nav>\n"
|
||||
where
|
||||
images | includeNsfw = allImages
|
||||
| otherwise = filter (\Image {nsfw} -> not nsfw) allImages
|
||||
iimages = zip [0..] images
|
||||
|
||||
altButton :: Int -> Image -> Builder
|
||||
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
|
||||
spaces = fromString $ replicate n ' '
|
||||
|
||||
extLinks :: Bool -> Vector Link -> Builder
|
||||
extLinks :: Bool -> [Link] -> Builder
|
||||
extLinks includeNsfw links =
|
||||
let 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
|
||||
" <div class=links>\n" <>
|
||||
" <h2>links</h2>\n" <>
|
||||
" <ul>\n" <>
|
||||
foldMap extLink links' <>
|
||||
" </ul>\n"
|
||||
" </ul>\n" <>
|
||||
" </div>\n"
|
||||
|
||||
extLink :: Link -> Builder
|
||||
extLink (Link {title, url}) =
|
||||
|
|
|
|||
|
|
@ -13,6 +13,8 @@ executable make-pages
|
|||
default-language: Haskell2010
|
||||
default-extensions:
|
||||
BlockArguments,
|
||||
DeriveAnyClass,
|
||||
DerivingStrategies,
|
||||
DuplicateRecordFields,
|
||||
LambdaCase,
|
||||
NamedFieldPuns,
|
||||
|
|
@ -23,7 +25,6 @@ executable make-pages
|
|||
time ^>= 1.8.0.2,
|
||||
bytestring ^>= 0.10.8.2,
|
||||
text ^>= 1.2.3.1,
|
||||
vector ^>= 0.12.1.2,
|
||||
HsYAML ^>= 0.2.1.0,
|
||||
optparse-applicative ^>= 0.15.1.0
|
||||
ghc-options:
|
||||
|
|
|
|||
Loading…
Reference in a new issue