add support for structured descriptions

This commit is contained in:
Rhiannon Morris 2021-03-07 22:08:44 +01:00
parent 519a50489f
commit 5c3ca348c2
3 changed files with 76 additions and 13 deletions

View file

@ -2,7 +2,7 @@
module Info
(Info (..),
tagsFor, descFor, imagesFor, linksFor, updatesFor, compareFor, sortFor,
Artist (..), Image (..), Link (..), Update (..),
Artist (..), Image (..), Desc (..), DescField (..), Link (..), Update (..),
GalleryInfo (..), GalleryFilters (..), ArtistFilter (..), NsfwFilter (..),
IndexInfo (..),
readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters,
@ -15,14 +15,13 @@ import Date
import Records
import Control.Applicative
import Control.Monad
import Control.Exception
import Data.Foldable (find)
import Data.Hashable (Hashable)
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust, isNothing)
import Data.Maybe (isJust, isNothing, fromMaybe)
import Data.List (nub, sortBy)
import Data.Ord (comparing)
import Data.String (IsString)
@ -48,8 +47,8 @@ data Info =
nsfwOnly :: !Bool,
tags :: ![Text],
nsfwTags :: ![Text],
desc :: !(Maybe Text),
nsfwDesc :: !(Maybe Text),
desc :: !Desc,
nsfwDesc :: !Desc,
bg :: !(Maybe Text),
images :: ![Image],
thumb' :: !(Maybe FilePath),
@ -58,6 +57,15 @@ data Info =
}
deriving (Eq, Show)
data Desc =
NoDesc
| TextDesc !Text
| LongDesc ![DescField]
deriving (Eq, Show)
data DescField = DescField {name, text :: !Text}
deriving (Eq, Show)
data Artist =
Artist {
name :: !Text,
@ -132,8 +140,26 @@ instance HasField "updated" Info (Bool -> Bool) where
getField (Info {updates, showUpdated}) nsfw = showUpdated && updated
where updated = if nsfw then not $ null updates else any #sfw updates
descFor :: Bool -> Info -> Maybe Text
descFor nsfw (Info {desc, nsfwDesc}) = desc <> (guard nsfw *> nsfwDesc)
defDescKey :: Text
defDescKey = "about"
instance Semigroup Desc where
NoDesc <> d2 = d2
d1 <> NoDesc = d1
(TextDesc t1) <> (TextDesc t2) = TextDesc $ t1 <> t2
(LongDesc m1) <> (TextDesc t2) = LongDesc $ m1 <> [DescField defDescKey t2]
(TextDesc t1) <> (LongDesc m2) = LongDesc $ [DescField defDescKey t1] <> m2
(LongDesc m1) <> (LongDesc m2) = LongDesc $ m1 <> m2
instance Monoid Desc where
mempty = NoDesc
mappend = (<>)
instance HasField "exists" Desc Bool where
getField d = d /= NoDesc
descFor :: Bool -> Info -> Desc
descFor nsfw (Info {desc, nsfwDesc}) = if nsfw then desc <> nsfwDesc else desc
tagsFor :: Bool -> Info -> [Text]
tagsFor nsfw i = if nsfw then nub (#tags i <> #nsfwTags i) else #tags i
@ -187,8 +213,8 @@ instance FromYAML Info where
<*> m .:? "nsfw-only" .!= False
<*> m .:? "tags" .!= []
<*> m .:? "nsfw-tags" .!= []
<*> m .:? "desc"
<*> m .:? "nsfw-desc"
<*> m .:? "desc" .!= NoDesc
<*> m .:? "nsfw-desc" .!= NoDesc
<*> m .:? "bg"
<*> (m .: "images" >>= imageList)
<*> m .:? "thumb"
@ -201,6 +227,13 @@ instance FromYAML Artist where
withUrl = YAML.withMap "full info" \m ->
Artist <$> m .: "name" <*> m .:? "url"
instance FromYAML Desc where
parseYAML y = textDesc y <|> mapDesc y where
textDesc = YAML.withStr "text" $ pure . TextDesc
mapDesc = fmap LongDesc . parseYAML
instance FromYAML DescField where parseYAML = withPair DescField
imageList :: YAML.Node YAML.Pos -> YAML.Parser [Image]
imageList y = pure <$> unlabelledImage y <|> parseYAML y
@ -366,6 +399,11 @@ instance (FromYAML a, FromYAML b) => FromYAML (Pair a b) where
[(a, b)] -> Pair <$> parseYAML a <*> parseYAML b
_ -> fail "expected exactly one pair"
withPair :: (FromYAML a, FromYAML b)
=> (a -> b -> c)
-> (YAML.Node YAML.Pos -> YAML.Parser c)
withPair f = withPairM \a b -> pure $ f a b
instance {-# OVERLAPPING #-} FromYAML String where
parseYAML y = Text.unpack <$> parseYAML y

View file

@ -62,8 +62,8 @@ makeItem root prefix nsfw path i@(Info {title, date, artist}) = [b|@4
Artist {name, url = Nothing} -> [b|<p>by $name|]
Artist {name, url = Just url} -> [b|<p>by <a href=$url>$name</a>|]
desc = descFor nsfw i
desc' = ifJust desc \d -> [b|$10.d|]
descArtist' = if isJust desc || isJust artist then [b|@6
desc' = makeDesc desc
descArtist' = if #exists desc || isJust artist then [b|@6
<description>
<![CDATA[
$10.desc'
@ -73,3 +73,11 @@ makeItem root prefix nsfw path i@(Info {title, date, artist}) = [b|@4
|]
else ""
date' = formatRSS date
makeDesc :: Desc -> Builder
makeDesc NoDesc = ""
makeDesc (TextDesc txt) = [b|$txt|]
makeDesc (LongDesc fs) = [b|$fields|]
where
fields = map makeField fs
makeField (DescField {name, text}) = [b|<b>$name</b>: $text|]

View file

@ -166,8 +166,9 @@ makeArtist (Artist {name, url}) =
Just u -> [b|<a href="$u">$name</a>|]
Nothing -> [b|$name|]
makeDesc :: Maybe Strict.Text -> Builder
makeDesc mdesc = ifJust mdesc \desc -> [b|@0
makeDesc :: Desc -> Builder
makeDesc NoDesc = ""
makeDesc (TextDesc desc) = [b|@0
<section id=desc class=info-section>
<h2>about</h2>
<div>
@ -175,6 +176,22 @@ makeDesc mdesc = ifJust mdesc \desc -> [b|@0
</div>
</section>
|]
makeDesc (LongDesc fs) = [b|@0
<section id=desc class=info-section>
<h2>about</h2>
<div>
$4.fields
</div>
</section>
|]
where
fields = map makeField fs
makeField (DescField {name, text}) = [b|@0
<h2>$name</h2>
<div>
$4.text
</div>
|]
makeButtonBar :: Strict.Text -> [(Image, Size)] -> Builder
makeButtonBar title images =