gallery/make-pages/Main.hs

116 lines
3.3 KiB
Haskell
Raw Normal View History

2020-07-16 10:07:28 -04:00
{-# LANGUAGE CPP, ImplicitParams, TypeApplications #-}
2020-07-07 18:21:08 -04:00
module Main (main) where
2020-07-16 10:07:28 -04:00
import Control.Monad
2020-07-12 23:01:57 -04:00
import Data.ByteString.Lazy (ByteString)
2020-07-16 10:07:28 -04:00
import qualified Data.ByteString.Lazy as ByteString
import Data.List (intersperse)
import Data.Text.Lazy (Text)
2020-07-16 10:07:28 -04:00
import Data.Text.Lazy.Builder (toLazyText)
import qualified Data.Text.Lazy.IO as Text
2020-07-16 10:07:28 -04:00
import qualified Data.YAML as YAML
import System.FilePath (makeRelative, takeDirectory)
import System.FilePath.Find (find, always, fileName, (==?))
2020-07-15 06:07:04 -04:00
import System.IO (hPrint, stderr)
2020-07-15 14:06:19 -04:00
import Depend
2020-07-16 10:07:28 -04:00
import Info (Info)
import Options
import qualified SinglePage
import qualified GalleryPage
2020-07-16 10:29:32 -04:00
import qualified IndexPage
2020-07-09 00:20:57 -04:00
2020-07-15 05:43:57 -04:00
#ifdef PRETTY_VERBOSE
2020-07-15 06:07:04 -04:00
import qualified Text.PrettyPrint as PP
2020-07-16 10:07:28 -04:00
import qualified Text.Show.Pretty as PP
2020-07-15 05:43:57 -04:00
#endif
2020-07-09 00:20:57 -04:00
2020-07-15 14:06:19 -04:00
type HasVerbose = (?verbose :: Bool)
2020-07-16 05:47:34 -04:00
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
2020-07-07 18:21:08 -04:00
main :: IO ()
2020-07-12 23:01:57 -04:00
main = do
2020-07-15 14:06:19 -04:00
opts@(Options {verbose, mode}) <- parseOptions
2020-07-16 05:47:34 -04:00
withVerbose verbose do
printV $ "options" := opts
main2 mode
2020-07-09 00:20:57 -04:00
2020-07-15 14:06:19 -04:00
main2 :: HasVerbose => ModeOptions -> IO ()
main2 (SinglePage {file, nsfw, output}) = do
2020-07-12 23:01:57 -04:00
info <- readYAML file
2020-07-16 05:47:34 -04:00
printV $ "contents" := info
2020-07-16 10:07:28 -04:00
let page = SinglePage.make nsfw info
writeOutput output page
2020-07-16 10:07:28 -04:00
main2 (GalleryPage {title, files, output, dataDir}) = do
infos <- mapM (infoYAML dataDir) files
printV $ "infos" := infos
let page = GalleryPage.make title infos
writeOutput output page
2020-07-16 10:29:32 -04:00
main2 (IndexPage {file, output}) = do
ginfos <- readYAML file
printV $ "galleries" := ginfos
let page = IndexPage.make ginfos
writeOutput output page
2020-07-15 14:06:19 -04:00
main2 (DependSingle {file, nsfw, output, prefix, buildDir, dataDir}) = do
info <- readYAML file
2020-07-16 05:47:34 -04:00
printV $ "contents" := info
2020-07-16 10:07:28 -04:00
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
ginfos <- readYAML @[_] file
printV $ "galleries" := ginfos
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 ginfos
writeOutput output deps
2020-07-16 10:07:28 -04:00
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)
2020-07-15 05:43:57 -04:00
2020-07-12 23:01:57 -04:00
readYAML :: YAML.FromYAML a => FilePath -> IO a
2020-07-12 23:01:57 -04:00
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
2020-07-16 05:47:34 -04:00
Left (pos, err) ->
fail $ file ++ ":" ++ YAML.prettyPosWithSource pos txt " error:" ++ err
2020-07-15 05:43:57 -04:00
writeOutput :: Maybe FilePath -> Text -> IO ()
writeOutput (Just f) = Text.writeFile f
writeOutput Nothing = Text.putStrLn
2020-07-16 05:47:34 -04:00
data Tag a = String := a
2020-07-15 06:07:04 -04:00
instance Show a => Show (Tag a) where
2020-07-16 05:47:34 -04:00
show (tag := a) =
2020-07-15 06:07:04 -04:00
#ifdef PRETTY_VERBOSE
PP.render $ PP.hang (PP.text tag <> ":") 2 (PP.ppDoc a)
#else
tag ++ ": " ++ show a
#endif