110 lines
2.8 KiB
Haskell
110 lines
2.8 KiB
Haskell
{-# OPTIONS_GHC -Wno-orphans #-}
|
|
module Info
|
|
(Info (..), Image (..), Link (..),
|
|
-- ** Reexports
|
|
Day (..), Text, Vector)
|
|
where
|
|
|
|
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 Data.Vector (Vector)
|
|
import qualified Data.Vector as Vector
|
|
import qualified Data.Map.Strict as Map
|
|
import Control.Applicative
|
|
import Text.Read (readMaybe)
|
|
|
|
|
|
data Info =
|
|
Info {
|
|
date :: !Day,
|
|
title :: !Text,
|
|
tags :: !(Vector Text),
|
|
description :: !Text,
|
|
images :: !(Vector Image),
|
|
thumb :: !Text,
|
|
links :: !(Vector Link)
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
data Image =
|
|
Image {
|
|
label :: !Text,
|
|
path :: !Text,
|
|
nsfw :: !Bool
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
data Link =
|
|
Link {
|
|
title :: !Text,
|
|
url :: !Text,
|
|
nsfw :: !Bool
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
|
|
instance FromYAML Info where
|
|
parseYAML = YAML.withMap "info" \m ->
|
|
Info <$> m .: "date"
|
|
<*> m .: "title"
|
|
<*> m .: "tags"
|
|
<*> m .: "description"
|
|
<*> m .: "images"
|
|
<*> m .: "thumb"
|
|
<*> m .: "links"
|
|
|
|
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"
|
|
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 FromYAML a => FromYAML (Vector a) where
|
|
parseYAML = YAML.withSeq "seq" $ fmap Vector.fromList . traverse parseYAML
|