134 lines
3.6 KiB
Haskell
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
|