From 5c3ca348c2b23d77a3e7467731add4227d717292 Mon Sep 17 00:00:00 2001
From: Rhiannon Morris <rhi@rhiannon.website>
Date: Sun, 7 Mar 2021 22:08:44 +0100
Subject: [PATCH] add support for structured descriptions

---
 make-pages/Info.hs       | 56 +++++++++++++++++++++++++++++++++-------
 make-pages/RSS.hs        | 12 +++++++--
 make-pages/SinglePage.hs | 21 +++++++++++++--
 3 files changed, 76 insertions(+), 13 deletions(-)

diff --git a/make-pages/Info.hs b/make-pages/Info.hs
index 269237b..cd42281 100644
--- a/make-pages/Info.hs
+++ b/make-pages/Info.hs
@@ -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
diff --git a/make-pages/RSS.hs b/make-pages/RSS.hs
index d09d971..a1ccad0 100644
--- a/make-pages/RSS.hs
+++ b/make-pages/RSS.hs
@@ -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|]
diff --git a/make-pages/SinglePage.hs b/make-pages/SinglePage.hs
index e1a9509..39a5b27 100644
--- a/make-pages/SinglePage.hs
+++ b/make-pages/SinglePage.hs
@@ -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 =