gallery/make-pages/Info.hs

{-# 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