gallery/make-pages/Info.hs

134 lines
3.6 KiB
Haskell

{-# OPTIONS_GHC -Wno-orphans #-}
module Info
(Info (..), Artist (..), Image (..), Link (..),
-- ** Reexports
Day (..), Text)
where
import Records
import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
import qualified Data.YAML as YAML
import Data.Time.Calendar (Day (..))
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Map.Strict as Map
import Control.Applicative
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 "nsfw" Info Bool where getField = all #nsfw . #images
instance HasField "sfw" Info Bool where getField = not . #nsfw
instance HasField "sfw" Image Bool where getField = not . #nsfw
instance HasField "sfw" Link Bool where getField = not . #nsfw
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