620 lines
20 KiB
Haskell
620 lines
20 KiB
Haskell
{-# OPTIONS_GHC -fdefer-typed-holes #-}
|
|
|
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
|
module Info
|
|
(Info (..),
|
|
anySfw, anyNsfw, allSfw, allNsfw,
|
|
allImages, sfwImages, nsfwImages,
|
|
thumb, latestDateFor, latestYearFor,
|
|
sfwLinks, nsfwLinks, sfwUpdates, nsfwUpdates,
|
|
updatesFor, bigUpdatesFor, hasUpdatesFor, lastUpdateFor,
|
|
tagsFor, descFor, imagesFor, linksFor,
|
|
|
|
CompareKey (..), compareKeyFor, compareFor, sortFor,
|
|
|
|
Artist (..), Images' (..), Images, Image (..), Desc (..), DescField (..),
|
|
PreviewImage (..), previewImage,
|
|
|
|
Link (..), Update (..), Bg (..),
|
|
|
|
GalleryInfo (..), GalleryFilters (..), ArtistFilter (..), NsfwFilter (..),
|
|
readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters,
|
|
|
|
IndexInfo (..),
|
|
|
|
NoThumb (..), getThumb, thumbFile, pageFile, bigFile,
|
|
-- ** Reexports
|
|
Date (..), Day (..), Text, NonEmpty (..))
|
|
where
|
|
|
|
import Date
|
|
import Control.Applicative
|
|
import Control.Exception
|
|
import Control.Monad
|
|
import Data.Bitraversable (bitraverse)
|
|
import Data.Foldable (find)
|
|
import Data.HashMap.Strict (HashMap)
|
|
import Data.HashMap.Strict qualified as HashMap
|
|
import Data.HashSet (HashSet)
|
|
import Data.HashSet qualified as HashSet
|
|
import Data.Hashable (Hashable (..))
|
|
import Data.List (sortBy)
|
|
import Data.List.NonEmpty (NonEmpty (..), toList, nonEmpty)
|
|
import Data.Map.Strict qualified as Map
|
|
import Data.Maybe (isJust, isNothing, fromMaybe, mapMaybe, catMaybes)
|
|
import Data.Ord (comparing)
|
|
import Data.Semigroup
|
|
import Data.Set (Set, (\\))
|
|
import Data.Set qualified as Set
|
|
import Data.String (IsString)
|
|
import Data.Text (Text)
|
|
import Data.Text qualified as Text
|
|
import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
|
|
import Data.YAML qualified as YAML
|
|
import GHC.Records
|
|
import System.FilePath ((</>), takeBaseName, takeExtension, splitExtension)
|
|
import Text.Regex.TDFA (Regex)
|
|
import Text.Regex.TDFA qualified as Regex
|
|
|
|
|
|
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 :: !(HashSet Text),
|
|
nsfwTags :: !(HashSet Text),
|
|
desc :: !Desc,
|
|
nsfwDesc :: !Desc,
|
|
bg :: !Bg,
|
|
images :: !Images,
|
|
thumb' :: !(Maybe FilePath),
|
|
links :: ![Link],
|
|
extras :: ![FilePath]
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
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)
|
|
|
|
data Artist =
|
|
Artist {
|
|
name :: !Text,
|
|
url :: !(Maybe Text)
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
data Image =
|
|
Image {
|
|
label :: !Text,
|
|
path :: !FilePath,
|
|
download :: !(Maybe FilePath),
|
|
desc :: !Text,
|
|
nsfw :: !Bool,
|
|
warning :: !(Maybe Text),
|
|
resize :: !Bool
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
data Images' a =
|
|
Uncat (NonEmpty a) -- ^ uncategorised
|
|
| Cat (NonEmpty (Text, NonEmpty a)) -- ^ categorised
|
|
deriving (Eq, Show, Functor, Foldable, Traversable)
|
|
|
|
type Images = Images' Image
|
|
|
|
data PreviewImage = PFull Image | PThumb FilePath
|
|
|
|
previewImage :: Info -> Maybe PreviewImage
|
|
previewImage info
|
|
| Just img <- find (.sfw) $ allImages info.images = Just $ PFull img
|
|
| otherwise = PThumb <$> info.thumb'
|
|
|
|
|
|
data Link =
|
|
Link {
|
|
title :: !Text,
|
|
url :: !Text,
|
|
nsfw :: !Bool
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
data Update =
|
|
Update {
|
|
desc :: !Text,
|
|
nsfw :: !Bool,
|
|
ignoreSort :: !Bool
|
|
}
|
|
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
|
|
|
|
allImages :: Images' a -> NonEmpty a
|
|
allImages (Uncat is) = is
|
|
allImages (Cat cats) = sconcat $ fmap snd cats
|
|
|
|
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
|
|
filterImages p (Cat cats) =
|
|
fmap Cat $ catMaybesNE $ fmap (traverse $ filterNE p) cats
|
|
|
|
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
|
|
|
|
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
|
|
|
|
bigUpdatesFor :: Bool -> Info -> [(Date, NonEmpty Update)]
|
|
bigUpdatesFor nsfw = updatesWith \u -> not u.ignoreSort && (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 || all (.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
|
|
|
|
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 $ 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
|
|
(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
|
|
|
|
tagsFor :: Bool -> Info -> HashSet Text
|
|
tagsFor nsfw i = if nsfw then i.tags <> i.nsfwTags else i.tags
|
|
|
|
imagesFor :: Bool -> Info -> Maybe Images
|
|
imagesFor nsfw i = if nsfw then Just i.images else sfwImages i
|
|
|
|
linksFor :: Bool -> Info -> [Link]
|
|
linksFor nsfw i = if nsfw then i.links else sfwLinks i
|
|
|
|
data CompareKey = MkCompareKey !Date !Text !Text
|
|
deriving (Eq, Ord)
|
|
|
|
compareKeyFor :: Bool -> Info -> CompareKey
|
|
compareKeyFor nsfw i = MkCompareKey (latestDateFor nsfw i) i.sortEx i.title
|
|
|
|
compareFor :: Bool -> Info -> Info -> Ordering
|
|
compareFor nsfw = comparing $ compareKeyFor nsfw
|
|
|
|
sortFor :: Bool -> [Info] -> [Info]
|
|
sortFor = sortBy . compareFor
|
|
|
|
|
|
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
|
|
|
|
thumbFile :: FilePath -> FilePath
|
|
thumbFile = addSuffix "_small"
|
|
|
|
canResize :: Image -> Bool
|
|
canResize i = i.resize && takeExtension i.path /= ".gif"
|
|
|
|
pageFile :: Image -> FilePath
|
|
pageFile img =
|
|
if canResize img then addSuffix "_med" img.path else img.path
|
|
|
|
bigFile :: Image -> FilePath
|
|
bigFile img =
|
|
if canResize img then addSuffix "_big" img.path else img.path
|
|
|
|
addSuffix :: String -> FilePath -> FilePath
|
|
addSuffix suf path =
|
|
let (pre, ext) = splitExtension path in
|
|
pre ++ suf ++ ext
|
|
|
|
|
|
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
|
|
fail $ "unused keys: " <> show unused <> "\n" <>
|
|
"expected: " <> show wanted
|
|
|
|
|
|
instance FromYAML Info where
|
|
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"]
|
|
Info <$> m .: "date"
|
|
<*> m .:? "sort" .!= ""
|
|
<*> (m .:? "updates" >>= updateList)
|
|
<*> m .:? "show-updated" .!= True
|
|
<*> m .:? "unlisted" .!= False
|
|
<*> m .: "title"
|
|
<*> m .:? "gallery-title"
|
|
<*> m .:? "artist"
|
|
<*> m .:? "nsfw-only" .!= False
|
|
<*> m .:? "tags" .!= []
|
|
<*> m .:? "nsfw-tags" .!= []
|
|
<*> m .:? "desc" .!= NoDesc
|
|
<*> m .:? "nsfw-desc" .!= NoDesc
|
|
<*> m .:? "bg" .!= Default
|
|
<*> m .: "images"
|
|
<*> m .:? "thumb"
|
|
<*> m .:? "links" .!= []
|
|
<*> m .:? "extras" .!= []
|
|
|
|
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
|
|
|
|
instance FromYAML Artist where
|
|
parseYAML y = justName y <|> withUrl y where
|
|
justName = YAML.withStr "name" \name -> pure $ Artist {name, url = Nothing}
|
|
withUrl = YAML.withMap "full info" \m -> do
|
|
checkKeys m ["name", "url"]
|
|
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
|
|
|
|
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
|
|
|
|
instance FromYAML Image where
|
|
parseYAML y = unlabelledImage y <|> labelled y where
|
|
labelled = withPairM \label -> unlabelledImage' (Just label)
|
|
|
|
unlabelledImage :: YAML.Node YAML.Pos -> YAML.Parser Image
|
|
unlabelledImage = unlabelledImage' Nothing
|
|
|
|
unlabelledImage' :: Maybe Text -> YAML.Node YAML.Pos -> YAML.Parser Image
|
|
unlabelledImage' label' y = asStr y <|> asObj y
|
|
where
|
|
asStr = YAML.withStr "path" \(Text.unpack -> path) ->
|
|
let label = fromMaybe (pathToLabel path) label' in
|
|
pure $ Image {label, path, download = Nothing, desc = "",
|
|
nsfw = False, warning = Nothing, resize = True}
|
|
asObj = YAML.withMap "image info" \m -> do
|
|
checkKeys m ["path", "download", "desc", "nsfw", "warning", "resize"]
|
|
path <- m .: "path"
|
|
download <- m .:? "download"
|
|
desc <- m .:? "desc" .!= ""
|
|
nsfw <- m .:? "nsfw" .!= False
|
|
warning <- m .:? "warning"
|
|
resize <- m .:? "resize" .!= True
|
|
let label = fromMaybe (pathToLabel path) label'
|
|
pure $ Image {label, path, download, nsfw, warning, desc, resize}
|
|
pathToLabel = Text.pack . gapToSpace . takeBaseName
|
|
gapToSpace = map \case '-' -> ' '; '_' -> ' '; c -> c
|
|
|
|
instance FromYAML Images where
|
|
parseYAML y = Uncat <$> imageList y
|
|
<|> Cat <$> YAML.withSeq "list of categories" fromPairs y
|
|
where
|
|
fromPairs (nonEmpty -> Just xs) =
|
|
traverse (withPairM \label -> fmap (label,) . imageList) xs
|
|
fromPairs _ = YAML.typeMismatch "non-empty list" y
|
|
|
|
instance FromYAML Link where
|
|
parseYAML =
|
|
withPairM \title rest -> asStr title rest <|> asObj title rest
|
|
where
|
|
asStr title = YAML.withStr "url" \url ->
|
|
pure $ Link {title, url, nsfw = False}
|
|
asObj title = YAML.withMap "link info" \m -> do
|
|
checkKeys m ["url", "nsfw"]
|
|
url <- m .: "url"
|
|
nsfw <- m .:? "nsfw" .!= False
|
|
pure $ Link {title, url, nsfw}
|
|
|
|
|
|
updateList :: Maybe (YAML.Node YAML.Pos) ->
|
|
YAML.Parser [(Date, NonEmpty Update)]
|
|
updateList =
|
|
maybe (pure []) $ YAML.withMap "updates" $ traverse bodies . Map.toList
|
|
where
|
|
bodies (date', rest) = (,) <$> parseYAML date' <*> body rest
|
|
body b = return <$> body1 b <|> YAML.withSeq "update list" (bodyN b) b
|
|
body1 b = asDesc b <|> asObj b
|
|
bodyN y =
|
|
maybe (YAML.typeMismatch "non-empty list" y) (traverse body1) . nonEmpty
|
|
asDesc = YAML.withStr "desc" \desc ->
|
|
pure $ Update {desc, nsfw = False, ignoreSort = False}
|
|
asObj = YAML.withMap "update info" \m -> do
|
|
checkKeys m ["desc", "nsfw", "ignore-sort"]
|
|
desc <- m .: "desc"
|
|
nsfw <- m .:? "nsfw" .!= False
|
|
ignoreSort <- m .:? "ignore-sort" .!= False
|
|
pure $ Update {desc, nsfw, ignoreSort}
|
|
|
|
|
|
data GalleryInfo =
|
|
GalleryInfo {
|
|
title :: !Text,
|
|
desc :: !Text,
|
|
prefix :: !FilePath,
|
|
filters :: !GalleryFilters,
|
|
hidden :: !(HashSet Text) -- ^ tags to initially hide
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
instance HasField "nsfw" GalleryInfo Bool where
|
|
getField g = g.filters.nsfw /= NoNsfw
|
|
|
|
data GalleryFilters =
|
|
GalleryFilters {
|
|
nsfw :: !NsfwFilter,
|
|
artist :: !ArtistFilter,
|
|
require, exclude :: !(HashSet Text)
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
data NsfwFilter = NoNsfw | OnlyNsfw | AllN deriving (Eq, Show)
|
|
|
|
readNsfwFilter :: (IsString str, Eq str, Alternative f) => str -> f NsfwFilter
|
|
readNsfwFilter "no" = pure NoNsfw
|
|
readNsfwFilter "only" = pure OnlyNsfw
|
|
readNsfwFilter "all" = pure AllN
|
|
readNsfwFilter _ = empty
|
|
|
|
matchNsfw :: NsfwFilter -> Info -> Bool
|
|
matchNsfw NoNsfw i = anySfw i && not i.nsfwOnly
|
|
matchNsfw OnlyNsfw i = anyNsfw i
|
|
matchNsfw AllN _ = True
|
|
|
|
instance FromYAML NsfwFilter where
|
|
parseYAML = YAML.withStr "nsfw filter" readNsfwFilter
|
|
|
|
|
|
data ArtistFilter = Me | NotMe | AllA deriving (Eq, Show)
|
|
|
|
readArtistFilter :: (IsString str, Eq str, Alternative f)
|
|
=> str -> f ArtistFilter
|
|
readArtistFilter "me" = pure Me
|
|
readArtistFilter "not-me" = pure NotMe
|
|
readArtistFilter "all" = pure AllA
|
|
readArtistFilter _ = empty
|
|
|
|
matchArtist :: ArtistFilter -> Info -> Bool
|
|
matchArtist Me i = isNothing i.artist
|
|
matchArtist NotMe i = isJust i.artist
|
|
matchArtist AllA _ = True
|
|
|
|
noFilters :: GalleryFilters
|
|
noFilters =
|
|
GalleryFilters {nsfw = AllN, artist = AllA, require = [], exclude = []}
|
|
|
|
matchFilters :: GalleryFilters -> Info -> Bool
|
|
matchFilters (GalleryFilters {nsfw, artist, require, exclude}) i =
|
|
matchNsfw nsfw i && matchArtist artist i &&
|
|
all (\t -> HashSet.member t i.tags) require &&
|
|
all (\t -> not $ HashSet.member t i.tags) exclude
|
|
|
|
|
|
instance FromYAML GalleryInfo where
|
|
parseYAML = YAML.withMap "gallery info" \m -> do
|
|
checkKeys m ["title", "desc", "prefix", "filters", "hidden"]
|
|
GalleryInfo <$> m .: "title"
|
|
<*> m .: "desc"
|
|
<*> m .: "prefix"
|
|
<*> m .:? "filters" .!= noFilters
|
|
<*> m .:? "hidden" .!= mempty
|
|
|
|
instance FromYAML GalleryFilters where
|
|
parseYAML = YAML.withMap "gallery filters" \m -> do
|
|
checkKeys m ["nsfw", "artist", "require", "exclude"]
|
|
GalleryFilters <$> m .:? "nsfw" .!= AllN
|
|
<*> m .:? "artist" .!= AllA
|
|
<*> m .:? "require" .!= []
|
|
<*> m .:? "exclude" .!= []
|
|
|
|
instance FromYAML ArtistFilter where
|
|
parseYAML = YAML.withStr "artist filter" readArtistFilter
|
|
|
|
|
|
data IndexInfo =
|
|
IndexInfo {
|
|
title :: !Text,
|
|
desc :: !Text,
|
|
galleries :: ![GalleryInfo],
|
|
links :: ![Link],
|
|
footer :: !(Maybe Text),
|
|
tags :: !TagTransforms
|
|
}
|
|
deriving Show
|
|
|
|
instance FromYAML IndexInfo where
|
|
parseYAML = YAML.withMap "index info" \m -> do
|
|
checkKeys m ["title", "desc", "galleries", "links", "footer", "tags"]
|
|
IndexInfo <$> m .: "title"
|
|
<*> m .: "desc"
|
|
<*> m .:? "galleries" .!= []
|
|
<*> m .:? "links" .!= []
|
|
<*> m .:? "footer"
|
|
<*> m .:? "tags" .!= emptyTransforms
|
|
|
|
data TagTransforms =
|
|
TagTransforms {
|
|
implies :: !(HashMap ImpliesKey [Text]),
|
|
replace :: !(HashMap Text Text),
|
|
replaceWarn :: !(HashMap Text Text),
|
|
warn :: !(HashSet Text)
|
|
}
|
|
deriving Show
|
|
|
|
data ImpliesKey = RegexIK Text Regex | LiteralIK Text
|
|
|
|
instance Eq ImpliesKey where
|
|
RegexIK s _ == RegexIK t _ = s == t
|
|
LiteralIK s == LiteralIK t = s == t
|
|
_ == _ = False
|
|
|
|
instance Show ImpliesKey where
|
|
showsPrec d (RegexIK s _) =
|
|
showParen (d > 10) $
|
|
showString "RegexIK " . showsPrec 11 s . showString " _"
|
|
showsPrec d (LiteralIK s) =
|
|
showParen (d > 10) $ showString "LiteralIK " . showsPrec 11 s
|
|
|
|
instance Hashable ImpliesKey where
|
|
hashWithSalt s (RegexIK str _) = hashWithSalt s ('R', str)
|
|
hashWithSalt s (LiteralIK str) = hashWithSalt s ('L', str)
|
|
|
|
emptyTransforms :: TagTransforms
|
|
emptyTransforms = TagTransforms [] [] [] []
|
|
|
|
instance FromYAML TagTransforms where
|
|
parseYAML = YAML.withMap "tag transforms" \m -> do
|
|
checkKeys m ["implies", "replace", "replace-warn", "warn"]
|
|
TagTransforms <$> m .:? "implies" .!= []
|
|
<*> m .:? "replace" .!= []
|
|
<*> m .:? "replace-warn" .!= []
|
|
<*> m .:? "warn" .!= []
|
|
|
|
instance FromYAML ImpliesKey where
|
|
parseYAML = YAML.withStr "string or regex" \str -> pure
|
|
if Text.length str > 2 &&
|
|
Text.head str == '/' &&
|
|
Text.last str == '/'
|
|
then
|
|
let body = Text.drop 1 $ Text.dropEnd 1 str in
|
|
RegexIK body (Regex.makeRegex body)
|
|
else LiteralIK str
|
|
|
|
|
|
data Pair a b = Pair !a !b
|
|
|
|
instance (FromYAML a, FromYAML b) => FromYAML (Pair a b) where
|
|
parseYAML = YAML.withMap "single-pair map" \m ->
|
|
case Map.toList m of
|
|
[(a, b)] -> Pair <$> parseYAML a <*> parseYAML b
|
|
_ -> fail "expected exactly one pair"
|
|
|
|
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
|
|
|
|
|
|
instance {-# OVERLAPPING #-} FromYAML String where
|
|
parseYAML y = Text.unpack <$> parseYAML y
|
|
|
|
instance (FromYAML a, Eq a, Hashable a) => FromYAML (HashSet a) where
|
|
parseYAML y = HashSet.fromList <$> parseYAML y
|
|
|
|
instance (FromYAML k, Eq k, Hashable k, FromYAML v) =>
|
|
FromYAML (HashMap k v) where
|
|
parseYAML = YAML.withMap "mapping" $
|
|
fmap HashMap.fromList .
|
|
traverse (bitraverse parseYAML parseYAML) .
|
|
Map.toList
|