gallery/make-pages/Info.hs

145 lines
4 KiB
Haskell

{-# OPTIONS_GHC -Wno-orphans #-}
module Info
(Info (..), Artist (..), Image (..), Link (..),
-- ** 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.Text (Text)
import qualified Data.Text as Text
import Data.Time.Calendar (Day (..))
import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
import qualified Data.YAML as YAML
import Text.Read (readMaybe)
data Info =
Info {
date :: !Day,
title :: !(Maybe Text),
artist :: !(Maybe Artist), -- nothing = me, obv
warning :: !(Maybe Text),
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,
nsfw :: !Bool
}
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 "allNsfw" Info Bool where getField = null . #sfwImages
instance HasField "anySfw" Info Bool where getField = not . #allNsfw
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 FromYAML Info where
parseYAML = YAML.withMap "info" \m ->
Info <$> m .: "date"
<*> m .:? "title"
<*> m .:? "artist"
<*> m .:? "warning"
<*> m .:? "tags" .!= []
<*> m .:? "nsfw-tags" .!= []
<*> m .:? "description"
<*> m .: "images"
<*> 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"
instance FromYAML Image where
parseYAML = labelledOptNsfw Image "path" "path"
instance FromYAML Link where
parseYAML = labelledOptNsfw Link "url" "url"
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"
data OptNsfw a = NoNsfw !a | WithNsfw !a !Bool
appOptNsfw :: (a -> Bool -> b) -> OptNsfw a -> b
appOptNsfw f (NoNsfw x) = f x False
appOptNsfw f (WithNsfw x n) = f x n
labelledOptNsfw :: FromYAML a
=> (Text -> a -> Bool -> b)
-> String -- ^ name in \"expected\" message
-> Text -- ^ field name
-> YAML.Node YAML.Pos -> YAML.Parser b
labelledOptNsfw f name field y = do
Pair l n' <- parseYAML y
n <- parseOptNsfw name field n'
pure $ appOptNsfw (f l) n
parseOptNsfw :: FromYAML a
=> String -- ^ name in \"expected\" message
-> Text -- ^ field name
-> YAML.Node YAML.Pos -> YAML.Parser (OptNsfw a)
parseOptNsfw name field y = yes y <|> no y where
yes = YAML.withMap (name <> " & nsfw") \m ->
WithNsfw <$> m .: field
<*> m .:? "nsfw" .!= False
no = fmap NoNsfw . parseYAML
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