97 lines
2.3 KiB
Haskell
97 lines
2.3 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 Data.Functor
|
|
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
|
|
}
|
|
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 y = parseYAML y <&> \(Pair l b) -> case b of
|
|
IBPath p -> Image l p False
|
|
IBFull p n -> Image l p n
|
|
|
|
|
|
data ImageBody = IBPath !Text | IBFull !Text !Bool
|
|
|
|
instance FromYAML ImageBody where
|
|
parseYAML y = path y <|> full y where
|
|
path = fmap IBPath . parseYAML
|
|
full = YAML.withMap "path & nsfw" \m ->
|
|
IBFull <$> m .: "path" <*> m .: "nsfw"
|
|
|
|
|
|
instance FromYAML Link where
|
|
parseYAML = fmap (uncurryP Link) . parseYAML
|
|
|
|
|
|
data Pair a b = Pair !a !b
|
|
|
|
uncurryP :: (a -> b -> c) -> Pair a b -> c
|
|
uncurryP f (Pair a b) = f 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"
|
|
|
|
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
|