add support for structured descriptions

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