gallery/make-pages/Info.hs

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