gallery/make-pages/Info.hs

105 lines
2.6 KiB
Haskell

{-# OPTIONS_GHC -Wno-orphans #-}
module Info
(Info (..), Image (..), Link (..),
-- ** Reexports
Day (..), Text)
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 qualified Data.Map.Strict as Map
import Control.Applicative
import Text.Read (readMaybe)
data Info =
Info {
date :: !Day,
title :: !(Maybe Text),
tags :: ![Text],
description :: !(Maybe Text),
images :: ![Image],
thumb :: !Text,
links :: ![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" .!= 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