gallery/make-pages/Info.hs

549 lines
17 KiB
Haskell
Raw Normal View History

2023-03-07 10:14:42 -05:00
{-# OPTIONS_GHC -fdefer-typed-holes #-}
2020-07-07 20:52:01 -04:00
{-# OPTIONS_GHC -Wno-orphans #-}
module Info
2020-11-16 17:30:56 -05:00
(Info (..),
anySfw, anyNsfw, allSfw, allNsfw,
allImages, sfwImages, nsfwImages,
thumb, latestDateFor, latestYearFor,
sfwLinks, nsfwLinks, sfwUpdates, nsfwUpdates,
updatesFor, hasUpdatesFor, lastUpdateFor,
tagsFor, descFor, imagesFor, linksFor,
CompareKey (..), compareKeyFor, compareFor, sortFor,
2021-08-23 10:30:11 -04:00
Artist (..), Images' (..), Images, Image (..), Desc (..), DescField (..),
2023-03-07 10:14:42 -05:00
Link (..), Update (..), Bg (..),
2020-07-24 19:10:52 -04:00
GalleryInfo (..), GalleryFilters (..), ArtistFilter (..), NsfwFilter (..),
readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters,
IndexInfo (..),
2022-05-16 04:25:16 -04:00
NoThumb (..), getThumb, thumbFile, pageFile, bigFile,
2020-07-07 20:52:01 -04:00
-- ** Reexports
2024-07-07 20:47:18 -04:00
Date (..), Day (..), Text, NonEmpty (..))
2020-07-07 20:52:01 -04:00
where
2020-09-25 17:08:44 -04:00
import Date
import GHC.Records
2020-07-13 02:33:27 -04:00
2020-07-15 14:07:51 -04:00
import Control.Applicative
2021-04-16 12:02:17 -04:00
import Control.Monad
2020-08-11 14:29:54 -04:00
import Control.Exception
2021-03-07 19:26:29 -05:00
import Data.Foldable (find)
2020-08-03 20:27:19 -04:00
import Data.Hashable (Hashable)
import Data.HashSet (HashSet)
2020-07-24 19:10:52 -04:00
import qualified Data.HashSet as HashSet
2020-07-15 14:07:51 -04:00
import qualified Data.Map.Strict as Map
2021-12-03 05:16:05 -05:00
import Data.Set (Set, (\\))
import qualified Data.Set as Set
2024-07-07 20:47:18 -04:00
import Data.Maybe (isJust, isNothing, fromMaybe, mapMaybe, catMaybes)
2020-11-16 17:30:56 -05:00
import Data.List (nub, sortBy)
2024-07-07 20:47:18 -04:00
import Data.List.NonEmpty (NonEmpty (..), toList, nonEmpty)
2020-07-19 11:55:54 -04:00
import Data.Ord (comparing)
2020-07-16 05:48:09 -04:00
import Data.String (IsString)
2020-07-07 20:52:01 -04:00
import Data.Text (Text)
import qualified Data.Text as Text
2020-07-15 14:07:51 -04:00
import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
import qualified Data.YAML as YAML
2020-08-11 14:29:54 -04:00
import System.FilePath ((</>), takeBaseName, takeExtension, splitExtension)
2024-07-07 20:47:18 -04:00
import Data.Semigroup
2020-07-07 20:52:01 -04:00
data Info =
Info {
date :: !Date,
-- | extra sort key after date
-- e.g. multiple things on the same day might have a,b,c in @sortEx@ to
-- put them in the right order in the gallery
sortEx :: !Text,
updates :: ![(Date, NonEmpty Update)],
-- | if false, don't show updated emblem even if @updates@ is non-empty
showUpdated :: !Bool,
-- | hide from gallery view
unlisted :: !Bool,
title :: !Text,
galleryTitle :: !(Maybe Text),
artist :: !(Maybe Artist), -- nothing = me, obv
nsfwOnly :: !Bool,
tags :: ![Text],
nsfwTags :: ![Text],
desc :: !Desc,
nsfwDesc :: !Desc,
2023-03-07 10:14:42 -05:00
bg :: !Bg,
images :: !Images,
thumb' :: !(Maybe FilePath),
links :: ![Link],
extras :: ![FilePath]
2020-07-07 20:52:01 -04:00
}
deriving (Eq, Show)
2023-03-07 10:14:42 -05:00
data Bg = Default | NoBorder | Other !Text
deriving (Eq, Show)
data Desc =
NoDesc
| TextDesc !Text
| LongDesc ![DescField]
deriving (Eq, Show)
data DescField = DescField {name, text :: !Text}
deriving (Eq, Show)
2020-07-12 22:38:37 -04:00
data Artist =
Artist {
name :: !Text,
url :: !(Maybe Text)
}
deriving (Eq, Show)
2020-07-07 20:52:01 -04:00
data Image =
Image {
2020-07-21 19:48:29 -04:00
label :: !Text,
path :: !FilePath,
download :: !(Maybe FilePath),
nsfw :: !Bool,
warning :: !(Maybe Text)
2020-07-07 20:52:01 -04:00
}
deriving (Eq, Show)
2021-08-23 10:30:11 -04:00
data Images' a =
2024-07-07 20:47:18 -04:00
Uncat (NonEmpty a) -- ^ uncategorised
| Cat (NonEmpty (Text, NonEmpty a)) -- ^ categorised
2021-08-23 10:30:11 -04:00
deriving (Eq, Show, Functor, Foldable, Traversable)
type Images = Images' Image
2020-07-07 20:52:01 -04:00
data Link =
Link {
2020-07-07 23:27:38 -04:00
title :: !Text,
2020-07-09 15:45:57 -04:00
url :: !Text,
nsfw :: !Bool
2020-07-07 20:52:01 -04:00
}
deriving (Eq, Show)
2020-11-16 17:30:56 -05:00
data Update =
Update {
2021-04-16 12:02:17 -04:00
desc :: !Text,
nsfw :: !Bool,
ignoreSort :: !Bool
2020-11-16 17:30:56 -05:00
}
deriving (Eq, Ord, Show)
instance HasField "sfw" Image Bool where getField i = not i.nsfw
instance HasField "sfw" Link Bool where getField i = not i.nsfw
instance HasField "sfw" Update Bool where getField i = not i.nsfw
2020-07-13 02:33:27 -04:00
allImages :: Images' a -> NonEmpty a
allImages (Uncat is) = is
allImages (Cat cats) = sconcat $ fmap snd cats
2021-08-23 10:30:11 -04:00
2024-07-07 20:47:18 -04:00
filterNE :: (a -> Bool) -> NonEmpty a -> Maybe (NonEmpty a)
filterNE p = nonEmpty . filter p . toList
catMaybesNE :: NonEmpty (Maybe a) -> Maybe (NonEmpty a)
catMaybesNE = nonEmpty . catMaybes . toList
filterImages :: (a -> Bool) -> Images' a -> Maybe (Images' a)
filterImages p (Uncat is) = Uncat <$> filterNE p is
2021-08-23 10:30:11 -04:00
filterImages p (Cat cats) =
2024-07-07 20:47:18 -04:00
fmap Cat $ catMaybesNE $ fmap (traverse $ filterNE p) cats
2021-08-23 10:30:11 -04:00
sfwImages, nsfwImages :: Info -> Maybe Images
sfwImages i = filterImages (.sfw) i.images
nsfwImages i = filterImages (.nsfw) i.images
anySfw, anyNsfw, allSfw, allNsfw :: Info -> Bool
anySfw = isJust . sfwImages
anyNsfw = isJust . nsfwImages
allSfw = not . anyNsfw
allNsfw = not . anySfw
sfwLinks, nsfwLinks :: Info -> [Link]
sfwLinks i = filter (.sfw) i.links
nsfwLinks i = filter (.nsfw) i.links
2020-09-19 01:51:52 -04:00
updatesWith :: (Update -> Bool) -> Info -> [(Date, NonEmpty Update)]
updatesWith p i = mapMaybe (traverse $ filterNE p) i.updates
updatesFor :: Bool -> Info -> [(Date, NonEmpty Update)]
updatesFor nsfw = updatesWith \u -> nsfw || u.sfw
sfwUpdates, nsfwUpdates :: Info -> [(Date, NonEmpty Update)]
sfwUpdates = updatesWith (.sfw)
nsfwUpdates = updatesWith (.nsfw)
lastUpdateFor :: Bool -> Info -> Maybe Date
lastUpdateFor nsfw info = case updatesFor nsfw info of
[] -> Nothing
us -> Just $ fst $ last us
thumb :: Info -> Maybe FilePath
thumb (Info {thumb', images}) =
thumb' <|> (.path) <$> find (.sfw) (allImages images)
latestDateFor :: Bool -> Info -> Date
latestDateFor nsfw i = maximum $ i.date : mapMaybe relDate (updatesFor nsfw i)
where
relDate (date, us) = date <$ guard (not $ null us || any (.ignoreSort) us)
latestYearFor :: Bool -> Info -> Int
latestYearFor nsfw info = (latestDateFor nsfw info).year
hasUpdatesFor :: Bool -> Info -> Bool
hasUpdatesFor i nsfw = not $ null $ updatesFor i nsfw
2020-09-19 01:51:52 -04:00
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
2021-03-07 19:26:29 -05:00
(LongDesc m1) <> (LongDesc m2) = LongDesc $ merge m1 m2
merge :: [DescField] -> [DescField] -> [DescField]
merge fs1 fs2 = go fs1 [] fs2 where
go first unused [] = first <> reverse unused
go first unused (x:xs) =
case insert first x of
Just first' -> go first' unused xs
Nothing -> go first (x:unused) xs
insert [] _ = Nothing
insert (x:xs) y =
if x.name == y.name then
Just $ x {text = x.text <> y.text} : xs
else
2021-03-07 19:26:29 -05:00
(x :) <$> insert xs y
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
2020-08-03 13:36:48 -04:00
tagsFor :: Bool -> Info -> [Text]
tagsFor nsfw i = if nsfw then nub $ i.tags <> i.nsfwTags else i.tags
2020-08-03 13:36:48 -04:00
2024-07-07 20:47:18 -04:00
imagesFor :: Bool -> Info -> Maybe Images
imagesFor nsfw i = if nsfw then Just i.images else sfwImages i
2020-08-03 13:36:48 -04:00
linksFor :: Bool -> Info -> [Link]
linksFor nsfw i = if nsfw then i.links else sfwLinks i
2023-06-21 13:58:01 -04:00
data CompareKey = MkCompareKey !Date !Text !Text
deriving (Eq, Ord)
compareKeyFor :: Bool -> Info -> CompareKey
compareKeyFor nsfw i = MkCompareKey (latestDateFor nsfw i) i.sortEx i.title
2020-11-16 17:30:56 -05:00
compareFor :: Bool -> Info -> Info -> Ordering
compareFor nsfw = comparing $ compareKeyFor nsfw
2020-11-16 17:30:56 -05:00
sortFor :: Bool -> [Info] -> [Info]
sortFor = sortBy . compareFor
2020-07-19 11:55:54 -04:00
2020-07-07 20:52:01 -04:00
2020-08-11 14:29:54 -04:00
newtype NoThumb = NoThumb FilePath
deriving stock Eq deriving anyclass Exception
instance Show NoThumb where show (NoThumb dir) = "no thumbnail for " ++ dir
getThumb :: FilePath -> Info -> FilePath
getThumb dir =
maybe (throw $ NoThumb dir) (\t -> dir </> thumbFile t) . thumb
2020-08-11 14:29:54 -04:00
thumbFile :: FilePath -> FilePath
thumbFile = addSuffix "_small"
pageFile :: FilePath -> FilePath
pageFile f
| takeExtension f == ".gif" = f
| otherwise = addSuffix "_med" f
2022-05-16 04:25:16 -04:00
bigFile :: FilePath -> FilePath
bigFile f
| takeExtension f == ".gif" = f
| otherwise = addSuffix "_big" f
2020-08-11 14:29:54 -04:00
addSuffix :: String -> FilePath -> FilePath
addSuffix suf path =
let (pre, ext) = splitExtension path in
pre ++ suf ++ ext
2021-12-03 05:16:05 -05:00
getKeys :: YAML.Mapping YAML.Pos -> YAML.Parser (Set Text)
getKeys = fmap Set.fromList . traverse (YAML.withStr "key" pure) . Map.keys
checkKeys :: YAML.Mapping YAML.Pos -> Set Text -> YAML.Parser ()
checkKeys mapping wanted = do
keys <- getKeys mapping
let unused = Set.toList $ keys \\ wanted
unless (null unused) do
2021-12-11 16:18:59 -05:00
fail $ "unused keys: " <> show unused <> "\n" <>
"expected: " <> show wanted
2021-12-03 05:16:05 -05:00
2020-07-07 20:52:01 -04:00
instance FromYAML Info where
2021-12-03 05:16:05 -05:00
parseYAML = YAML.withMap "info" \m -> do
checkKeys m ["date", "sort", "updates", "show-updated", "unlisted",
"gallery-title", "title", "artist", "nsfw-only", "tags",
"nsfw-tags", "desc", "nsfw-desc", "bg", "images", "thumb",
"links", "extras"]
2020-08-04 18:52:39 -04:00
Info <$> m .: "date"
<*> m .:? "sort" .!= ""
2021-03-07 16:09:17 -05:00
<*> (m .:? "updates" >>= updateList)
<*> m .:? "show-updated" .!= True
<*> m .:? "unlisted" .!= False
2020-08-04 18:52:39 -04:00
<*> m .: "title"
<*> m .:? "gallery-title"
2020-08-04 18:52:39 -04:00
<*> m .:? "artist"
<*> m .:? "nsfw-only" .!= False
2020-08-04 18:52:39 -04:00
<*> m .:? "tags" .!= []
<*> m .:? "nsfw-tags" .!= []
<*> m .:? "desc" .!= NoDesc
<*> m .:? "nsfw-desc" .!= NoDesc
2023-03-07 10:14:42 -05:00
<*> m .:? "bg" .!= Default
2021-08-23 10:30:11 -04:00
<*> m .: "images"
2020-08-04 18:52:39 -04:00
<*> m .:? "thumb"
<*> m .:? "links" .!= []
<*> m .:? "extras" .!= []
2020-07-07 20:52:01 -04:00
2023-03-07 10:14:42 -05:00
instance FromYAML Bg where
parseYAML y =
YAML.withNull "default value" (pure Default) y
<|> YAML.withStr "css <image> or \"noborder\""
(\str -> pure if str == "noborder" then NoBorder else Other str) y
2020-07-12 22:38:37 -04:00
instance FromYAML Artist where
parseYAML y = justName y <|> withUrl y where
justName = YAML.withStr "name" \name -> pure $ Artist {name, url = Nothing}
2021-12-03 05:16:05 -05:00
withUrl = YAML.withMap "full info" \m -> do
checkKeys m ["name", "url"]
2020-07-12 22:38:37 -04:00
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
2024-07-07 20:47:18 -04:00
parseYAMLNE :: FromYAML a => YAML.Node YAML.Pos -> YAML.Parser (NonEmpty a)
parseYAMLNE = YAML.withSeq "non-empty sequence" \ys ->
case nonEmpty ys of
Just ys' -> traverse YAML.parseYAML ys'
Nothing -> fail "expected non-empty sequence"
imageList :: YAML.Node YAML.Pos -> YAML.Parser (NonEmpty Image)
imageList y = pure <$> unlabelledImage y <|> parseYAMLNE y
2020-07-07 20:52:01 -04:00
instance FromYAML Image where
parseYAML y = unlabelledImage y <|> labelled y where
2021-03-07 16:09:17 -05:00
labelled = withPairM \label -> unlabelledImage' (Just label)
unlabelledImage :: YAML.Node YAML.Pos -> YAML.Parser Image
2021-03-07 16:09:17 -05:00
unlabelledImage = unlabelledImage' Nothing
2021-08-23 10:30:11 -04:00
unlabelledImage' :: Maybe Text -> YAML.Node YAML.Pos -> YAML.Parser Image
2021-03-07 16:09:17 -05:00
unlabelledImage' label' y = asStr y <|> asObj y
where
asStr = YAML.withStr "path" \(Text.unpack -> path) ->
2021-03-07 16:09:17 -05:00
let label = fromMaybe (pathToLabel path) label' in
pure $ Image {label, path, download = Nothing,
2020-07-21 19:48:29 -04:00
nsfw = False, warning = Nothing}
asObj = YAML.withMap "image info" \m -> do
2021-12-03 05:16:05 -05:00
checkKeys m ["path", "download", "nsfw", "warning"]
2020-07-21 19:48:29 -04:00
path <- m .: "path"
download <- m .:? "download"
nsfw <- m .:? "nsfw" .!= False
warning <- m .:? "warning"
2021-03-07 16:09:17 -05:00
let label = fromMaybe (pathToLabel path) label'
pure $ Image {label, path, download, nsfw, warning}
2021-03-20 06:07:51 -04:00
pathToLabel = Text.pack . gapToSpace . takeBaseName
gapToSpace = map \case '-' -> ' '; '_' -> ' '; c -> c
2020-07-07 20:52:01 -04:00
2021-08-23 10:30:11 -04:00
instance FromYAML Images where
parseYAML y = Uncat <$> imageList y
<|> Cat <$> YAML.withSeq "list of categories" fromPairs y
2024-07-07 20:47:18 -04:00
where
fromPairs (nonEmpty -> Just xs) =
traverse (withPairM \label -> fmap (label,) . imageList) xs
fromPairs _ = YAML.typeMismatch "non-empty list" y
2021-08-23 10:30:11 -04:00
2020-07-07 20:52:01 -04:00
instance FromYAML Link where
2021-03-07 16:09:17 -05:00
parseYAML =
withPairM \title rest -> asStr title rest <|> asObj title rest
2020-07-17 06:29:13 -04:00
where
asStr title = YAML.withStr "url" \url ->
pure $ Link {title, url, nsfw = False}
asObj title = YAML.withMap "link info" \m -> do
2021-12-03 05:16:05 -05:00
checkKeys m ["url", "nsfw"]
2020-07-17 06:29:13 -04:00
url <- m .: "url"
nsfw <- m .:? "nsfw" .!= False
pure $ Link {title, url, nsfw}
2020-07-07 20:52:01 -04:00
2020-11-16 17:30:56 -05:00
updateList :: Maybe (YAML.Node YAML.Pos) ->
YAML.Parser [(Date, NonEmpty Update)]
2021-03-07 16:09:17 -05:00
updateList =
maybe (pure []) $ YAML.withMap "updates" $
nonEmptys <=< traverse bodies . Map.toList
2021-03-07 16:09:17 -05:00
where
bodies (date', rest) = (,) <$> parseYAML date' <*> body rest
body b =
return <$> body1 b
<|> YAML.withSeq "update list" (traverse body1) b
body1 b = asDesc b <|> asObj b
asDesc = YAML.withStr "desc" \desc ->
pure $ Update {desc, nsfw = False, ignoreSort = False}
asObj = YAML.withMap "update info" \m -> do
2021-12-03 05:16:05 -05:00
checkKeys m ["desc", "nsfw", "ignore-sort"]
2021-04-16 12:02:17 -04:00
desc <- m .: "desc"
nsfw <- m .:? "nsfw" .!= False
ignoreSort <- m .:? "ignore-sort" .!= False
pure $ Update {desc, nsfw, ignoreSort}
nonEmptys = traverse $ traverse $
maybe (fail "expected non-empty list") pure . nonEmpty
2020-11-16 17:30:56 -05:00
2020-07-07 20:52:01 -04:00
2020-07-16 05:48:09 -04:00
data GalleryInfo =
GalleryInfo {
2020-07-24 19:17:47 -04:00
title :: !Text,
desc :: !Text,
prefix :: !FilePath,
2020-08-03 20:27:19 -04:00
filters :: !GalleryFilters,
hidden :: !(HashSet Text) -- ^ tags to initially hide
2020-07-16 05:48:09 -04:00
}
deriving (Eq, Show)
2020-11-16 17:30:56 -05:00
instance HasField "nsfw" GalleryInfo Bool where
getField g = g.filters.nsfw /= NoNsfw
2020-11-16 17:30:56 -05:00
2020-07-16 05:48:09 -04:00
data GalleryFilters =
GalleryFilters {
2020-07-24 19:17:47 -04:00
nsfw :: !NsfwFilter,
2020-07-24 19:10:52 -04:00
artist :: !ArtistFilter,
2020-08-03 20:27:19 -04:00
require, exclude :: !(HashSet Text)
2020-07-16 05:48:09 -04:00
}
deriving (Eq, Show)
2020-07-24 19:10:52 -04:00
data NsfwFilter = NoNsfw | OnlyNsfw | AllN deriving (Eq, Show)
2020-07-16 05:48:09 -04:00
2020-07-24 19:10:52 -04:00
readNsfwFilter :: (IsString str, Eq str, Alternative f) => str -> f NsfwFilter
readNsfwFilter "no" = pure NoNsfw
readNsfwFilter "only" = pure OnlyNsfw
readNsfwFilter "all" = pure AllN
readNsfwFilter _ = empty
2020-07-16 05:48:09 -04:00
2020-07-24 19:10:52 -04:00
matchNsfw :: NsfwFilter -> Info -> Bool
matchNsfw NoNsfw i = anySfw i && not i.nsfwOnly
matchNsfw OnlyNsfw i = anyNsfw i
2020-07-24 19:10:52 -04:00
matchNsfw AllN _ = True
2020-07-16 05:48:09 -04:00
2020-07-24 19:10:52 -04:00
instance FromYAML NsfwFilter where
parseYAML = YAML.withStr "nsfw filter" readNsfwFilter
2020-07-16 05:48:09 -04:00
2020-07-24 19:10:52 -04:00
2020-07-31 21:02:26 -04:00
data ArtistFilter = Me | NotMe | AllA deriving (Eq, Show)
2020-07-24 19:10:52 -04:00
readArtistFilter :: (IsString str, Eq str, Alternative f)
=> str -> f ArtistFilter
readArtistFilter "me" = pure Me
readArtistFilter "not-me" = pure NotMe
2020-07-31 21:02:26 -04:00
readArtistFilter "all" = pure AllA
2020-07-24 19:10:52 -04:00
readArtistFilter _ = empty
matchArtist :: ArtistFilter -> Info -> Bool
matchArtist Me i = isNothing i.artist
matchArtist NotMe i = isJust i.artist
matchArtist AllA _ = True
2020-07-16 05:48:09 -04:00
noFilters :: GalleryFilters
2020-07-24 19:10:52 -04:00
noFilters =
2020-07-31 21:02:26 -04:00
GalleryFilters {nsfw = AllN, artist = AllA, require = [], exclude = []}
2020-07-16 05:48:09 -04:00
matchFilters :: GalleryFilters -> Info -> Bool
2020-07-24 19:10:52 -04:00
matchFilters (GalleryFilters {nsfw, artist, require, exclude}) i =
matchNsfw nsfw i && matchArtist artist i &&
2020-08-03 20:27:19 -04:00
all (\t -> HashSet.member t tags) require &&
all (\t -> not $ HashSet.member t tags) exclude
where tags = HashSet.fromList i.tags
2020-07-16 05:48:09 -04:00
instance FromYAML GalleryInfo where
2021-12-03 05:16:05 -05:00
parseYAML = YAML.withMap "gallery info" \m -> do
checkKeys m ["title", "desc", "prefix", "filters", "hidden"]
2020-07-16 10:07:28 -04:00
GalleryInfo <$> m .: "title"
2020-07-24 19:17:47 -04:00
<*> m .: "desc"
2020-07-16 10:07:28 -04:00
<*> m .: "prefix"
<*> m .:? "filters" .!= noFilters
2020-08-03 20:27:19 -04:00
<*> m .:? "hidden" .!= mempty
2020-07-16 05:48:09 -04:00
instance FromYAML GalleryFilters where
2021-12-03 05:16:05 -05:00
parseYAML = YAML.withMap "gallery filters" \m -> do
checkKeys m ["nsfw", "artist", "require", "exclude"]
2020-07-24 19:10:52 -04:00
GalleryFilters <$> m .:? "nsfw" .!= AllN
2020-07-31 21:02:26 -04:00
<*> m .:? "artist" .!= AllA
2020-07-24 19:10:52 -04:00
<*> m .:? "require" .!= []
<*> m .:? "exclude" .!= []
2020-07-16 05:48:09 -04:00
2020-07-24 19:10:52 -04:00
instance FromYAML ArtistFilter where
parseYAML = YAML.withStr "artist filter" readArtistFilter
2020-07-16 05:48:09 -04:00
2020-07-18 05:45:32 -04:00
data IndexInfo =
IndexInfo {
2020-07-19 06:10:27 -04:00
title :: !Text,
2020-08-11 14:29:54 -04:00
desc :: !Text,
2020-07-18 05:45:32 -04:00
galleries :: ![GalleryInfo],
2020-07-19 06:22:02 -04:00
links :: ![Link],
footer :: !(Maybe Text)
2020-07-18 05:45:32 -04:00
}
deriving Show
instance FromYAML IndexInfo where
2021-12-03 05:16:05 -05:00
parseYAML = YAML.withMap "index info" \m -> do
checkKeys m ["title", "desc", "galleries", "links", "footer"]
2020-07-19 06:10:27 -04:00
IndexInfo <$> m .: "title"
2020-08-11 14:29:54 -04:00
<*> m .: "desc"
2020-07-19 06:10:27 -04:00
<*> m .:? "galleries" .!= []
2020-07-19 06:22:02 -04:00
<*> m .:? "links" .!= []
<*> m .:? "footer"
2020-07-18 05:45:32 -04:00
2020-07-07 20:52:01 -04:00
data Pair a b = Pair !a !b
instance (FromYAML a, FromYAML b) => FromYAML (Pair a b) where
2020-07-31 21:02:26 -04:00
parseYAML = YAML.withMap "single-pair map" \m ->
case Map.toList m of
[(a, b)] -> Pair <$> parseYAML a <*> parseYAML b
_ -> fail "expected exactly one pair"
2020-07-07 20:52:01 -04:00
2021-03-07 16:09:17 -05:00
withPairM :: (FromYAML a, FromYAML b)
=> (a -> b -> YAML.Parser c)
-> (YAML.Node YAML.Pos -> YAML.Parser c)
withPairM k y = parseYAML y >>= \(Pair a b) -> k a b
withPair :: (FromYAML a, FromYAML b)
=> (a -> b -> c)
-> (YAML.Node YAML.Pos -> YAML.Parser c)
withPair f = withPairM \a b -> pure $ f a b
2020-07-09 15:45:57 -04:00
2020-07-15 05:35:32 -04:00
instance {-# OVERLAPPING #-} FromYAML String where
parseYAML y = Text.unpack <$> parseYAML y
2020-08-03 20:27:19 -04:00
instance (FromYAML a, Eq a, Hashable a) => FromYAML (HashSet a) where
parseYAML y = HashSet.fromList <$> parseYAML y