gallery/make-pages/Info.hs

132 lines
3.5 KiB
Haskell
Raw Normal View History

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-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
import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
2020-07-07 20:52:01 -04:00
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 {
2020-07-07 23:27:38 -04:00
date :: !Day,
title :: !(Maybe Text),
2020-07-12 22:38:37 -04:00
artist :: !(Maybe Artist), -- nothing = me, obv
2020-07-14 00:52:23 -04:00
warning :: !(Maybe Text),
tags :: ![Text],
2020-07-11 23:42:31 -04:00
nsfwTags :: ![Text],
description :: !(Maybe Text),
images :: ![Image],
2020-07-07 23:27:38 -04:00
thumb :: !Text,
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-07 23:27:38 -04:00
label :: !Text,
path :: !Text,
nsfw :: !Bool
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 "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
2020-07-07 20:52:01 -04:00
instance FromYAML Info where
parseYAML = YAML.withMap "info" \m ->
Info <$> m .: "date"
<*> m .:? "title"
2020-07-12 22:38:37 -04:00
<*> m .:? "artist"
2020-07-14 00:52:23 -04:00
<*> m .:? "warning"
<*> m .:? "tags" .!= []
2020-07-14 00:52:35 -04:00
<*> m .:? "nsfw-tags" .!= []
<*> m .:? "description"
<*> m .: "images"
<*> 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"
2020-07-07 20:52:01 -04:00
instance FromYAML Image where
2020-07-09 15:45:57 -04:00
parseYAML = labelledOptNsfw Image "path" "path"
2020-07-07 20:52:01 -04:00
instance FromYAML Link where
2020-07-09 15:45:57 -04:00
parseYAML = labelledOptNsfw Link "url" "url"
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
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
2020-07-09 15:45:57 -04:00
no = fmap NoNsfw . parseYAML
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