gallery/make-pages/Info.hs

106 lines
2.6 KiB
Haskell
Raw Normal View History

2020-07-07 20:52:01 -04:00
{-# OPTIONS_GHC -Wno-orphans #-}
module Info
(Info (..), Image (..), Link (..),
-- ** Reexports
Day (..), Text)
2020-07-07 20:52:01 -04:00
where
import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
2020-07-07 20:52:01 -04:00
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 {
2020-07-07 23:27:38 -04:00
date :: !Day,
title :: !(Maybe Text),
tags :: ![Text],
description :: !(Maybe Text),
images :: ![Image],
2020-07-07 23:27:38 -04:00
thumb :: !Text,
links :: ![Link]
2020-07-07 20:52:01 -04:00
}
deriving (Eq, Show)
data Image =
Image {
2020-07-07 23:27:38 -04:00
label :: !Text,
path :: !Text,
nsfw :: !Bool
2020-07-07 20:52:01 -04:00
}
deriving (Eq, Show)
data Link =
Link {
2020-07-07 23:27:38 -04:00
title :: !Text,
2020-07-09 15:45:57 -04:00
url :: !Text,
nsfw :: !Bool
2020-07-07 20:52:01 -04:00
}
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" .!= []
2020-07-07 20:52:01 -04:00
instance FromYAML Image where
2020-07-09 15:45:57 -04:00
parseYAML = labelledOptNsfw Image "path" "path"
2020-07-07 20:52:01 -04:00
instance FromYAML Link where
2020-07-09 15:45:57 -04:00
parseYAML = labelledOptNsfw Link "url" "url"
2020-07-07 20:52:01 -04:00
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"
2020-07-09 15:45:57 -04:00
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
2020-07-09 15:45:57 -04:00
no = fmap NoNsfw . parseYAML
2020-07-07 20:52:01 -04:00
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