gallery/make-pages/Info.hs

{-# OPTIONS_GHC -fdefer-typed-holes #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Info
  (Info (..), Artist (..), Image (..), Link (..),
   GalleryInfo (..), GalleryFilters (..), Whose (..),
   IndexInfo (..),
   readWhose, matchWhose, matchNsfw, matchFilters,
   -- ** Reexports
   Day (..), Text)
where

import Records

import Control.Applicative
import Data.Foldable (find)
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust, isNothing)
import Data.String (IsString)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time.Calendar (Day (..), toGregorian)
import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
import qualified Data.YAML as YAML
import Text.Read (readMaybe)


data Info =
  Info {
    date        :: !Day,
    title       :: !(Maybe Text),
    artist      :: !(Maybe Artist), -- nothing = me, obv
    tags        :: ![Text],
    nsfwTags    :: ![Text],
    description :: !(Maybe Text),
    images      :: ![Image],
    background  :: !(Maybe Text),
    thumb'      :: !(Maybe FilePath),
    links       :: ![Link]
  }
  deriving (Eq, Show)

data Artist =
  Artist {
    name :: !Text,
    url  :: !(Maybe Text)
  }
  deriving (Eq, Show)

data Image =
  Image {
    label   :: !Text,
    path    :: !FilePath,
    nsfw    :: !Bool,
    warning :: !(Maybe Text)
  }
  deriving (Eq, Show)

data Link =
  Link {
    title :: !Text,
    url   :: !Text,
    nsfw  :: !Bool
  }
  deriving (Eq, Show)

instance HasField "sfw"  Image Bool where getField = not . #nsfw
instance HasField "sfw"  Link  Bool where getField = not . #nsfw

instance HasField "sfwImages" Info [Image] where
  getField = filter #sfw . #images
instance HasField "nsfwImages" Info [Image] where
  getField = filter #nsfw . #images
instance HasField "allNsfw" Info Bool where getField = null . #sfwImages
instance HasField "allSfw" Info Bool where getField = null . #nsfwImages
instance HasField "anySfw" Info Bool where getField = not . #allNsfw
instance HasField "anyNsfw" Info Bool where getField = not . #allSfw

instance HasField "thumb" Info (Maybe FilePath) where
  getField (Info {thumb', images}) = thumb' <|> #path <$> find #sfw images

instance HasField "mine"    Info Bool where getField = isNothing . #artist
instance HasField "notMine" Info Bool where getField = isJust    . #artist

instance HasField "dmy" Info (Integer, Int, Int) where
  getField = toGregorian . #date
instance HasField "year"  Info Integer where getField = #first  . #dmy
instance HasField "month" Info Int     where getField = #second . #dmy
instance HasField "day"   Info Int     where getField = #third  . #dmy


instance FromYAML Info where
  parseYAML = YAML.withMap "info" \m ->
    Info <$> m .:  "date"
         <*> m .:? "title"
         <*> m .:? "artist"
         <*> m .:? "tags" .!= []
         <*> m .:? "nsfw-tags" .!= []
         <*> m .:? "description"
         <*> (m .:  "images" >>= imageList)
         <*> m .:? "background"
         <*> 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"

imageList :: YAML.Node YAML.Pos -> YAML.Parser [Image]
imageList y = pure <$> unlabelledImage y <|> parseYAML y

instance FromYAML Image where
  parseYAML y = unlabelledImage y <|> labelled y where
    labelled y' = do
      Pair label rest <- parseYAML y'
      i <- unlabelledImage rest
      pure $ i {label}

unlabelledImage :: YAML.Node YAML.Pos -> YAML.Parser Image
unlabelledImage y = asStr y <|> asObj y
 where
  asStr = YAML.withStr "path" \(Text.unpack -> path) ->
    pure $ Image {label = "", path, nsfw = False, warning = Nothing}
  asObj = YAML.withMap "image info" \m -> do
    path    <- m .:  "path"
    nsfw    <- m .:? "nsfw" .!= False
    warning <- m .:? "warning"
    pure $ Image {label = "", path, nsfw, warning}

instance FromYAML Link where
  parseYAML y = do
    Pair title rest <- parseYAML y
    asStr title rest <|> asObj title rest
   where
    asStr title = YAML.withStr "url" \url ->
      pure $ Link {title, url, nsfw = False}
    asObj title = YAML.withMap "link info" \m -> do
      url  <- m .:  "url"
      nsfw <- m .:? "nsfw" .!= False
      pure $ Link {title, url, nsfw}


data GalleryInfo =
  GalleryInfo {
    title    :: !Text,
    prefix   :: !FilePath,
    filters  :: !GalleryFilters
  }
  deriving (Eq, Show)

data GalleryFilters =
  GalleryFilters {
    nsfw  :: Maybe Bool,
    whose :: Whose
  }
  deriving (Eq, Show)

data Whose = Mine | NotMine | All deriving (Eq, Show)


matchNsfw :: Maybe Bool -> Info -> Bool
matchNsfw Nothing     _ = True
matchNsfw (Just nsfw) i = #allNsfw i == nsfw

readWhose :: (IsString str, Eq str, Alternative f) => str -> f Whose
readWhose "mine"     = pure Mine
readWhose "not-mine" = pure NotMine
readWhose "all"      = pure All
readWhose _          = empty

matchWhose :: Whose -> Info -> Bool
matchWhose Mine    = #mine
matchWhose NotMine = #notMine
matchWhose All     = const True

noFilters :: GalleryFilters
noFilters = GalleryFilters {nsfw = Nothing, whose = All}

matchFilters :: GalleryFilters -> Info -> Bool
matchFilters (GalleryFilters {nsfw, whose}) i =
  matchNsfw nsfw i && matchWhose whose i


instance FromYAML GalleryInfo where
  parseYAML = YAML.withMap "gallery info" \m ->
    GalleryInfo <$> m .:  "title"
                <*> m .:  "prefix"
                <*> m .:? "filters" .!= noFilters

instance FromYAML GalleryFilters where
  parseYAML = YAML.withMap "gallery filters" \m ->
    GalleryFilters <$> m .:? "nsfw"
                   <*> m .:? "whose" .!= All

instance FromYAML Whose where parseYAML = YAML.withStr "whose" readWhose


data IndexInfo =
  IndexInfo {
    galleries :: ![GalleryInfo],
    footer    :: !Text
  }
  deriving Show

instance FromYAML IndexInfo where
  parseYAML = YAML.withMap "index info" \m ->
    IndexInfo <$> m .:? "galleries" .!= []
              <*> m .:? "footer"    .!= ""


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"


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 {-# OVERLAPPING #-} FromYAML String where
  parseYAML y = Text.unpack <$> parseYAML y