gallery/make-pages/Info.hs

240 lines
6.8 KiB
Haskell

{-# OPTIONS_GHC -fdefer-typed-holes #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Info
(Info (..), Artist (..), Image (..), Link (..),
GalleryInfo (..), GalleryFilters (..), Whose (..),
IndexInfo (..),
readWhose, matchWhose, matchNsfw, matchFilters,
-- ** Reexports
Day (..), Text)
where
import Records
import Control.Applicative
import Data.Foldable (find)
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust, isNothing)
import Data.Ord (comparing)
import Data.String (IsString)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time.Calendar (Day (..), toGregorian)
import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
import qualified Data.YAML as YAML
import Text.Read (readMaybe)
data Info =
Info {
date :: !Day,
title :: !Text,
artist :: !(Maybe Artist), -- nothing = me, obv
tags :: ![Text],
nsfwTags :: ![Text],
description :: !(Maybe Text),
images :: ![Image],
thumb' :: !(Maybe FilePath),
links :: ![Link]
}
deriving (Eq, Show)
data Artist =
Artist {
name :: !Text,
url :: !(Maybe Text)
}
deriving (Eq, Show)
data Image =
Image {
label :: !Text,
path :: !FilePath,
download :: !(Maybe FilePath),
nsfw :: !Bool,
warning :: !(Maybe Text)
}
deriving (Eq, Show)
data Link =
Link {
title :: !Text,
url :: !Text,
nsfw :: !Bool
}
deriving (Eq, Show)
instance HasField "sfw" Image Bool where getField = not . #nsfw
instance HasField "sfw" Link Bool where getField = not . #nsfw
instance HasField "sfwImages" Info [Image] where
getField = filter #sfw . #images
instance HasField "nsfwImages" Info [Image] where
getField = filter #nsfw . #images
instance HasField "allNsfw" Info Bool where getField = null . #sfwImages
instance HasField "allSfw" Info Bool where getField = null . #nsfwImages
instance HasField "anySfw" Info Bool where getField = not . #allNsfw
instance HasField "anyNsfw" Info Bool where getField = not . #allSfw
instance HasField "thumb" Info (Maybe FilePath) where
getField (Info {thumb', images}) = thumb' <|> #path <$> find #sfw images
instance HasField "mine" Info Bool where getField = isNothing . #artist
instance HasField "notMine" Info Bool where getField = isJust . #artist
instance HasField "dmy" Info (Integer, Int, Int) where
getField = toGregorian . #date
instance HasField "year" Info Integer where getField = #first . #dmy
instance HasField "month" Info Int where getField = #second . #dmy
instance HasField "day" Info Int where getField = #third . #dmy
instance Ord Info where
compare = comparing \Info {date, title} -> (date, title)
instance FromYAML Info where
parseYAML = YAML.withMap "info" \m ->
Info <$> m .: "date"
<*> m .: "title"
<*> m .:? "artist"
<*> m .:? "tags" .!= []
<*> m .:? "nsfw-tags" .!= []
<*> m .:? "description"
<*> (m .: "images" >>= imageList)
<*> m .:? "thumb"
<*> m .:? "links" .!= []
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 ->
Artist <$> m .: "name" <*> m .:? "url"
imageList :: YAML.Node YAML.Pos -> YAML.Parser [Image]
imageList y = pure <$> unlabelledImage y <|> parseYAML y
instance FromYAML Image where
parseYAML y = unlabelledImage y <|> labelled y where
labelled y' = do
Pair label rest <- parseYAML y'
i <- unlabelledImage rest
pure $ i {label}
unlabelledImage :: YAML.Node YAML.Pos -> YAML.Parser Image
unlabelledImage y = asStr y <|> asObj y
where
asStr = YAML.withStr "path" \(Text.unpack -> path) ->
pure $ Image {label = "", path, download = Nothing,
nsfw = False, warning = Nothing}
asObj = YAML.withMap "image info" \m -> do
path <- m .: "path"
download <- m .:? "download"
nsfw <- m .:? "nsfw" .!= False
warning <- m .:? "warning"
pure $ Image {label = "", path, download, nsfw, warning}
instance FromYAML Link where
parseYAML y = do
Pair title rest <- parseYAML y
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
url <- m .: "url"
nsfw <- m .:? "nsfw" .!= False
pure $ Link {title, url, nsfw}
data GalleryInfo =
GalleryInfo {
title :: !Text,
description :: !Text,
prefix :: !FilePath,
filters :: !GalleryFilters
}
deriving (Eq, Show)
data GalleryFilters =
GalleryFilters {
nsfw :: Maybe Bool,
whose :: Whose
}
deriving (Eq, Show)
data Whose = Mine | NotMine | All deriving (Eq, Show)
matchNsfw :: Maybe Bool -> Info -> Bool
matchNsfw Nothing _ = True
matchNsfw (Just nsfw) i = #allNsfw i == nsfw
readWhose :: (IsString str, Eq str, Alternative f) => str -> f Whose
readWhose "mine" = pure Mine
readWhose "not-mine" = pure NotMine
readWhose "all" = pure All
readWhose _ = empty
matchWhose :: Whose -> Info -> Bool
matchWhose Mine = #mine
matchWhose NotMine = #notMine
matchWhose All = const True
noFilters :: GalleryFilters
noFilters = GalleryFilters {nsfw = Nothing, whose = All}
matchFilters :: GalleryFilters -> Info -> Bool
matchFilters (GalleryFilters {nsfw, whose}) i =
matchNsfw nsfw i && matchWhose whose i
instance FromYAML GalleryInfo where
parseYAML = YAML.withMap "gallery info" \m ->
GalleryInfo <$> m .: "title"
<*> m .: "description"
<*> m .: "prefix"
<*> m .:? "filters" .!= noFilters
instance FromYAML GalleryFilters where
parseYAML = YAML.withMap "gallery filters" \m ->
GalleryFilters <$> m .:? "nsfw"
<*> m .:? "whose" .!= All
instance FromYAML Whose where parseYAML = YAML.withStr "whose" readWhose
data IndexInfo =
IndexInfo {
title :: !Text,
galleries :: ![GalleryInfo],
links :: ![Link],
footer :: !(Maybe Text)
}
deriving Show
instance FromYAML IndexInfo where
parseYAML = YAML.withMap "index info" \m ->
IndexInfo <$> m .: "title"
<*> m .:? "galleries" .!= []
<*> m .:? "links" .!= []
<*> m .:? "footer"
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"
instance FromYAML Day where
parseYAML = YAML.withStr "date" \str ->
case readMaybe $ Text.unpack str of
Just d -> pure d
Nothing -> fail $ "couldn't parse date " ++ show str
instance {-# OVERLAPPING #-} FromYAML String where
parseYAML y = Text.unpack <$> parseYAML y