gallery/make-pages/Main.hs

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

import qualified Data.ByteString.Lazy as ByteString
import Data.ByteString.Lazy (ByteString)
import qualified Data.YAML as YAML
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy.IO as Text
import qualified Options.Applicative as Opt
import System.IO (hPrint, stderr)
import System.FilePath (makeRelative)
import Text.Printf (printf)
import Control.Applicative
import Control.Monad
import SinglePage
import Depend

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

data Options =
    Options {
      verbose :: Bool,
      mode    :: ModeOptions
    }
  deriving Show

data ModeOptions =
    SinglePage {
      file   :: FilePath,
      nsfw   :: Bool,
      output :: Maybe FilePath
    }
  | GalleryPage {
      files  :: [FilePath],
      nsfw   :: Bool,
      output :: Maybe FilePath
    }
  | DependSingle {
      file     :: FilePath,
      nsfw     :: Bool,
      output   :: Maybe FilePath,
      buildDir :: FilePath,
      dataDir  :: FilePath
    }
  deriving Show

optionsParser :: Opt.ParserInfo Options
optionsParser = globalOpts `Opt.info` mainInfo where
  globalOpts = Options <$> verboseOpt <*> subcommands <**> Opt.helper
  verboseOpt = Opt.switch $
    Opt.short 'v' <> Opt.long "verbose" <>
    Opt.help "print extra stuff to stderr"
  subcommands = Opt.hsubparser $
    single <> gallery <> dependSingle

  single = Opt.command "single" $ singleOpts `Opt.info` singleInfo
  singleOpts = SinglePage <$> file <*> nsfwS <*> output
  file = Opt.strArgument $
    Opt.metavar "FILE" <> Opt.help "yaml file to read"
  nsfwS = Opt.switch $
    Opt.short 'n' <> Opt.long "nsfw" <>
    Opt.help "include nsfw versions"
  output = Opt.option (Just <$> Opt.str) $
    Opt.short 'o' <> Opt.long "output" <> Opt.metavar "FILE" <>
    Opt.value Nothing <>
    Opt.help "output file (default: stdout)"
  singleInfo = Opt.progDesc "generate a page for a single work"

  gallery = Opt.command "gallery" $ galleryOpts `Opt.info` galleryInfo
  galleryOpts = GalleryPage <$> files <*> nsfwG <*> output
  files = many $ Opt.strArgument $
    Opt.metavar "FILE..." <> Opt.help "yaml files to read"
  nsfwG = Opt.switch $
    Opt.short 'n' <> Opt.long "nsfw" <>
    Opt.help "include works with no sfw versions"
  galleryInfo = Opt.progDesc "generate a gallery page"

  dependSingle = Opt.command "depend-single" $ dsOpts `Opt.info` dsInfo
  dsOpts = DependSingle <$> file <*> nsfwS <*> output <*> buildDir <*> dataDir
  buildDir = Opt.strOption $
    Opt.short 'B' <> Opt.long "build-dir" <> Opt.metavar "DIR" <>
    Opt.value "_build" <>
    Opt.help "build directory (default: _build)"
  dataDir = Opt.strOption $
    Opt.short 'D' <> Opt.long "data-dir" <> Opt.metavar "DIR" <>
    Opt.value "data" <>
    Opt.help "data directory (default: data)"
  dsInfo = Opt.progDesc "generate makefile dependencies for a single page"

  mainInfo = Opt.progDesc "static gallery site generator" <> Opt.fullDesc


main :: IO ()
main = do
  opts <- Opt.execParser optionsParser
  printV opts $ "options" :- opts
  main2 opts

main2 :: Options -> IO ()
main2 opts@(Options {mode = SinglePage {file, nsfw, output}}) = do
  info <- readYAML file
  printV opts $ "contents" :- info
  let page = make nsfw info
  writeOutput output page

main2 (Options {mode = GalleryPage {}}) = do
  error "surprise! this doesn't exist yet"

main2 opts@(Options
    {mode = DependSingle {file, nsfw, output, buildDir, dataDir}}) = do
  info <- readYAML file
  printV opts $ "contents" :- info
  let path = makeRelative dataDir file
  printV opts $ "path" :- path
  let deps = dependSingle' path info buildDir nsfw
  writeOutput output deps


printV :: Show a => Options -> a -> IO ()
printV (Options {verbose}) x = when verbose $ hPrint stderr x

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 (YAML.Pos {posLine, posColumn}, err) ->
      fail $ printf "%s:%i:%i: %s" file posLine posColumn 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