gallery/make-pages/Main.hs

{-# LANGUAGE CPP, ImplicitParams, TypeApplications #-}
module Main (main) where

import Control.Monad
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as ByteString
import Data.List (intersperse)
import Data.Text.Lazy (Text)
import Data.Text.Lazy.Builder (toLazyText)
import qualified Data.Text.Lazy.IO as Text
import qualified Data.YAML as YAML
import System.FilePath (makeRelative, takeDirectory, takeFileName)
import System.FilePath.Find (find, always, fileName, (==?))
import System.IO (hPrint, stderr)

import Depend
import Info (IndexInfo (..), Info)
import Options
import qualified SinglePage
import qualified GalleryPage
import qualified IndexPage
import qualified RSS

#ifdef PRETTY_VERBOSE
import qualified Text.PrettyPrint as PP
import qualified Text.Show.Pretty as PP
#endif


type HasVerbose = (?verbose :: Bool)

withVerbose :: Bool -> (HasVerbose => a) -> a
withVerbose v x = let ?verbose = v in x

printV :: (Show a, HasVerbose) => a -> IO ()
printV x = when ?verbose $ hPrint stderr x


main :: IO ()
main = do
  opts@(Options {verbose, mode}) <- parseOptions
  withVerbose verbose do
    printV $ "options" := opts
    main2 mode

main2 :: HasVerbose => ModeOptions -> IO ()
main2 (SinglePage {file, dataDir, nsfw, output}) = do
  info <- readYAML file
  printV $ "contents" := info
  let dir = takeDirectory $ makeRelative dataDir file
  let page = SinglePage.make nsfw dir info
  writeOutput output page

main2 (GalleryPage {title, prefix, files, nsfw, output, dataDir}) = do
  infos <- mapM (infoYAML dataDir) files
  printV $ "infos" := infos
  let page = GalleryPage.make title prefix nsfw infos
  writeOutput output page

main2 (IndexPage {file, output}) = do
  info <- readYAML file
  printV $ "info" := info
  let page = IndexPage.make info
  writeOutput output page

main2 (RSS {files, title, description, root, prefix, output, dataDir}) = do
  infos <- mapM (infoYAML dataDir) files
  printV $ "infos" := infos
  let output' = takeFileName <$> output
  let rss = RSS.make root title description prefix output' infos
  writeOutput output rss

main2 (DependSingle {file, nsfw, output, prefix, buildDir, dataDir}) = do
  info <- readYAML file
  printV $ "contents" := info
  let dir = takeDirectory $ makeRelative dataDir file
  printV $ "dir" := dir
  let deps = dependSingle dir info prefix buildDir nsfw
  writeOutput output deps

main2 (DependGallery {file, output, buildDir, dataDir, tmpDir, infoName}) = do
  IndexInfo {galleries} <- readYAML file
  printV $ "galleries" := galleries
  infos <- mapM (infoYAML dataDir) =<<
           find always (fileName ==? infoName) dataDir
  printV $ "info files" := infos
  let dependGallery0 g = dependGallery' g infos buildDir dataDir tmpDir
  let deps = toLazyText $ mconcat $ intersperse "\n\n\n" $
        map dependGallery0 galleries
  writeOutput output deps

infoYAML :: FilePath -- ^ data dir
         -> FilePath -- ^ yaml file
         -> IO (FilePath, Info) -- relative filename, contents
infoYAML dataDir f = do
  let f' = makeRelative dataDir f
  info <- readYAML f
  pure (f', info)


readYAML :: YAML.FromYAML a => FilePath -> IO a
readYAML file = ByteString.readFile file >>= decode1Must file

decode1Must :: YAML.FromYAML a => FilePath -> ByteString -> IO a
decode1Must file txt =
  case YAML.decode1 txt of
    Right val -> pure val
    Left (pos, err) ->
      fail $ file ++ ":" ++ YAML.prettyPosWithSource pos txt " error:" ++ err

writeOutput :: Maybe FilePath -> Text -> IO ()
writeOutput (Just f) = Text.writeFile f
writeOutput Nothing  = Text.putStrLn


data Tag a = String := a

instance Show a => Show (Tag a) where
  show (tag := a) =
#ifdef PRETTY_VERBOSE
    PP.render $ PP.hang (PP.text tag <> ":") 2 (PP.ppDoc a)
#else
    tag ++ ": " ++ show a
#endif