gallery/make-pages/Info.hs

238 lines
6.7 KiB
Haskell
Raw Normal View History

2020-07-17 06:29:13 -04:00
{-# OPTIONS_GHC -fdefer-typed-holes #-}
2020-07-07 20:52:01 -04:00
{-# OPTIONS_GHC -Wno-orphans #-}
module Info
2020-07-14 00:51:27 -04:00
(Info (..), Artist (..), Image (..), Link (..),
2020-07-16 10:07:28 -04:00
GalleryInfo (..), GalleryFilters (..), Whose (..),
2020-07-18 05:45:32 -04:00
IndexInfo (..),
2020-07-16 10:07:28 -04:00
readWhose, matchWhose, matchNsfw, matchFilters,
2020-07-07 20:52:01 -04:00
-- ** Reexports
Day (..), Text)
2020-07-07 20:52:01 -04:00
where
2020-07-13 02:33:27 -04:00
import Records
2020-07-15 14:07:51 -04:00
import Control.Applicative
import Data.Foldable (find)
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust, isNothing)
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-18 05:26:59 -04:00
import Data.Time.Calendar (Day (..), toGregorian)
2020-07-15 14:07:51 -04:00
import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
import qualified Data.YAML as YAML
2020-07-07 20:52:01 -04:00
import Text.Read (readMaybe)
data Info =
Info {
2020-07-07 23:27:38 -04:00
date :: !Day,
2020-07-19 11:58:19 -04:00
title :: !Text,
2020-07-12 22:38:37 -04:00
artist :: !(Maybe Artist), -- nothing = me, obv
tags :: ![Text],
2020-07-11 23:42:31 -04:00
nsfwTags :: ![Text],
description :: !(Maybe Text),
images :: ![Image],
2020-07-17 06:29:13 -04:00
background :: !(Maybe Text),
2020-07-15 14:07:51 -04:00
thumb' :: !(Maybe FilePath),
links :: ![Link]
2020-07-07 20:52:01 -04:00
}
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-17 06:29:13 -04:00
label :: !Text,
path :: !FilePath,
nsfw :: !Bool,
warning :: !(Maybe Text)
2020-07-07 20:52:01 -04:00
}
deriving (Eq, Show)
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-07-13 02:33:27 -04:00
instance HasField "sfw" Image Bool where getField = not . #nsfw
instance HasField "sfw" Link Bool where getField = not . #nsfw
2020-07-16 05:47:02 -04:00
instance HasField "sfwImages" Info [Image] where
getField = filter #sfw . #images
2020-07-18 05:27:27 -04:00
instance HasField "nsfwImages" Info [Image] where
getField = filter #nsfw . #images
2020-07-16 05:47:02 -04:00
instance HasField "allNsfw" Info Bool where getField = null . #sfwImages
2020-07-18 05:27:27 -04:00
instance HasField "allSfw" Info Bool where getField = null . #nsfwImages
2020-07-16 05:47:02 -04:00
instance HasField "anySfw" Info Bool where getField = not . #allNsfw
2020-07-18 05:27:27 -04:00
instance HasField "anyNsfw" Info Bool where getField = not . #allSfw
2020-07-16 05:47:02 -04:00
2020-07-15 14:07:51 -04:00
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
2020-07-18 05:26:59 -04:00
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
2020-07-19 11:55:54 -04:00
instance Ord Info where
compare = comparing \Info {date, title} -> (date, title)
2020-07-07 20:52:01 -04:00
instance FromYAML Info where
parseYAML = YAML.withMap "info" \m ->
Info <$> m .: "date"
2020-07-19 11:58:19 -04:00
<*> m .: "title"
2020-07-12 22:38:37 -04:00
<*> m .:? "artist"
<*> m .:? "tags" .!= []
2020-07-14 00:52:35 -04:00
<*> m .:? "nsfw-tags" .!= []
<*> m .:? "description"
<*> (m .: "images" >>= imageList)
2020-07-17 06:29:13 -04:00
<*> m .:? "background"
2020-07-15 05:34:56 -04:00
<*> m .:? "thumb"
<*> m .:? "links" .!= []
2020-07-07 20:52:01 -04:00
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}
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
2020-07-07 20:52:01 -04:00
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, nsfw = False, warning = Nothing}
asObj = YAML.withMap "image info" \m -> do
path <- m .: "path"
nsfw <- m .:? "nsfw" .!= False
warning <- m .:? "warning"
pure $ Image {label = "", path, nsfw, warning}
2020-07-07 20:52:01 -04:00
instance FromYAML Link where
2020-07-17 06:29:13 -04:00
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}
2020-07-07 20:52:01 -04:00
2020-07-16 05:48:09 -04:00
data GalleryInfo =
GalleryInfo {
2020-07-16 10:07:28 -04:00
title :: !Text,
2020-07-16 05:48:09 -04:00
prefix :: !FilePath,
2020-07-16 10:07:28 -04:00
filters :: !GalleryFilters
2020-07-16 05:48:09 -04:00
}
deriving (Eq, Show)
data GalleryFilters =
GalleryFilters {
2020-07-16 10:07:28 -04:00
nsfw :: Maybe Bool,
whose :: Whose
2020-07-16 05:48:09 -04:00
}
deriving (Eq, Show)
2020-07-16 10:07:28 -04:00
data Whose = Mine | NotMine | All deriving (Eq, Show)
2020-07-16 05:48:09 -04:00
matchNsfw :: Maybe Bool -> Info -> Bool
matchNsfw Nothing _ = True
matchNsfw (Just nsfw) i = #allNsfw i == nsfw
2020-07-16 10:07:28 -04:00
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
2020-07-16 05:48:09 -04:00
2020-07-16 10:07:28 -04:00
matchWhose :: Whose -> Info -> Bool
matchWhose Mine = #mine
matchWhose NotMine = #notMine
matchWhose All = const True
2020-07-16 05:48:09 -04:00
noFilters :: GalleryFilters
2020-07-16 10:07:28 -04:00
noFilters = GalleryFilters {nsfw = Nothing, whose = All}
2020-07-16 05:48:09 -04:00
matchFilters :: GalleryFilters -> Info -> Bool
2020-07-16 10:07:28 -04:00
matchFilters (GalleryFilters {nsfw, whose}) i =
matchNsfw nsfw i && matchWhose whose i
2020-07-16 05:48:09 -04:00
instance FromYAML GalleryInfo where
parseYAML = YAML.withMap "gallery info" \m ->
2020-07-16 10:07:28 -04:00
GalleryInfo <$> m .: "title"
<*> m .: "prefix"
<*> m .:? "filters" .!= noFilters
2020-07-16 05:48:09 -04:00
instance FromYAML GalleryFilters where
parseYAML = YAML.withMap "gallery filters" \m ->
GalleryFilters <$> m .:? "nsfw"
2020-07-16 10:07:28 -04:00
<*> m .:? "whose" .!= All
2020-07-16 05:48:09 -04:00
2020-07-16 10:07:28 -04:00
instance FromYAML Whose where parseYAML = YAML.withStr "whose" readWhose
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-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
parseYAML = YAML.withMap "index info" \m ->
2020-07-19 06:10:27 -04:00
IndexInfo <$> m .: "title"
<*> 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
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-09 15:45:57 -04:00
2020-07-07 20:52:01 -04:00
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
2020-07-15 05:35:32 -04:00
instance {-# OVERLAPPING #-} FromYAML String where
parseYAML y = Text.unpack <$> parseYAML y