gallery/make-pages/Info.hs

{-# OPTIONS_GHC -Wno-orphans #-}
module Info
  (Info (..), Artist (..), Image (..), Link (..),
   -- ** Reexports
   Day (..), Text)
where

import Records

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),
    artist      :: !(Maybe Artist), -- nothing = me, obv
    warning     :: !(Maybe Text),
    tags        :: ![Text],
    nsfwTags    :: ![Text],
    description :: !(Maybe Text),
    images      :: ![Image],
    thumb       :: !Text,
    links       :: ![Link]
  }
  deriving (Eq, Show)

data Artist =
  Artist {
    name :: !Text,
    url  :: !(Maybe Text)
  }
  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 HasField "nsfw" Info  Bool where getField = all #nsfw . #images
instance HasField "sfw"  Info  Bool where getField = not . #nsfw
instance HasField "sfw"  Image Bool where getField = not . #nsfw
instance HasField "sfw"  Link  Bool where getField = not . #nsfw


instance FromYAML Info where
  parseYAML = YAML.withMap "info" \m ->
    Info <$> m .:  "date"
         <*> m .:? "title"
         <*> m .:? "artist"
         <*> m .:? "warning"
         <*> m .:? "tags" .!= []
         <*> m .:? "nsfw-tags" .!= []
         <*> m .:? "description"
         <*> m .:  "images"
         <*> m .:  "thumb"
         <*> m .:? "links" .!= []

instance FromYAML Artist where
  parseYAML y = justName y <|> withUrl y where
    justName = YAML.withStr "name" \name -> pure $ Artist {name, url = Nothing}
    withUrl  = YAML.withMap "full info" \m ->
      Artist <$> m .: "name" <*> m .:? "url"

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