implement tag aliases, replacements, warnings
warnings are printed by `list-tags`
This commit is contained in:
parent
cae6400ec9
commit
67f0c3ded7
9 changed files with 319 additions and 118 deletions
7
Makefile
7
Makefile
|
|
@ -5,6 +5,7 @@ TMPDIR := _tmp
|
|||
BUILDDIR := _build
|
||||
INFONAME := info.yaml
|
||||
ROOT := https://gallery.niss.website
|
||||
INDEX := $(DATADIR)/index.yaml
|
||||
|
||||
# SMALL = thumbnails, MED = single pages (link to full size)
|
||||
SMALL := 200
|
||||
|
|
@ -28,7 +29,7 @@ BSCRIPTS = $(patsubst %.ts,$(BUILDDIR)/%.js,$(TSCRIPTS))
|
|||
all: build
|
||||
build: $(BUILDDIR)/index.html $(BSTATIC) $(BSCRIPTS)
|
||||
|
||||
$(BUILDDIR)/index.html: $(DATADIR)/index.yaml $(MAKEPAGES)
|
||||
$(BUILDDIR)/index.html: $(INDEX) $(MAKEPAGES)
|
||||
echo "[index] "$@
|
||||
mkdir -p $(dir $@)
|
||||
$(MAKEPAGES) $(MPFLAGS) index --root $(ROOT) $< --output $@
|
||||
|
|
@ -85,7 +86,7 @@ $(MAKEPAGES): make-pages/*.hs make-pages/make-pages.cabal
|
|||
-exec cp {} $@ \;
|
||||
|
||||
|
||||
$(TMPDIR)/index.mk: $(DATADIR)/index.yaml $(YAMLS) $(MAKEPAGES)
|
||||
$(TMPDIR)/index.mk: $(INDEX) $(YAMLS) $(MAKEPAGES)
|
||||
$(call depend-gallery)
|
||||
|
||||
NODEPS := mostlyclean clean distclean list-tags
|
||||
|
|
@ -109,7 +110,7 @@ distclean: clean
|
|||
|
||||
.PHONY: list-tags
|
||||
list-tags: $(MAKEPAGES)
|
||||
$(MAKEPAGES) list-tags --untagged --nsfw
|
||||
$(MAKEPAGES) list-tags --untagged --warnings --nsfw --index $(INDEX)
|
||||
|
||||
|
||||
HOST ?= gallery.niss.website
|
||||
|
|
|
|||
|
|
@ -1,15 +1,16 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
module GalleryPage (make) where
|
||||
|
||||
import BuilderQQ
|
||||
import Date
|
||||
import Info
|
||||
import qualified NsfwWarning
|
||||
import TagTransforms
|
||||
|
||||
import Control.Monad
|
||||
import Data.Foldable
|
||||
import Data.Function ((&))
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.HashSet (HashSet)
|
||||
import qualified Data.HashSet as HashSet
|
||||
import Data.List (intersperse, sort, sortOn)
|
||||
import Data.Maybe
|
||||
|
|
@ -17,12 +18,15 @@ import Data.Ord (Down (..))
|
|||
import qualified Data.Text.Lazy as Lazy
|
||||
import System.FilePath (takeDirectory, joinPath, splitPath)
|
||||
|
||||
make :: Text -> GalleryInfo -> [(FilePath, Info)] -> Lazy.Text
|
||||
make root ginfo infos = toLazyText $ make' root ginfo infos
|
||||
make :: Text -> IndexInfo -> GalleryInfo -> [(FilePath, Info)] -> Lazy.Text
|
||||
make root iinfo ginfo infos =
|
||||
toLazyText $ make' root ginfo $
|
||||
map (fmap $ transformInfoTags iinfo.tags) infos
|
||||
|
||||
|
||||
make' :: Text -> GalleryInfo -> [(FilePath, Info)] -> Builder
|
||||
make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|
|
||||
make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos =
|
||||
[b|
|
||||
<!DOCTYPE html>
|
||||
<html lang=en>
|
||||
<meta charset=utf-8>
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
{-# OPTIONS_GHC -fdefer-typed-holes #-}
|
||||
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
module Info
|
||||
(Info (..),
|
||||
anySfw, anyNsfw, allSfw, allNsfw,
|
||||
|
|
@ -20,18 +19,23 @@ module Info
|
|||
GalleryInfo (..), GalleryFilters (..), ArtistFilter (..), NsfwFilter (..),
|
||||
readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters,
|
||||
|
||||
TagTransforms (..), emptyTransforms,
|
||||
Implies (..), Replacement (..), Warning (..),
|
||||
|
||||
IndexInfo (..),
|
||||
|
||||
NoThumb (..), getThumb, thumbFile, pageFile, bigFile,
|
||||
-- ** Reexports
|
||||
Date (..), Day (..), Text, NonEmpty (..))
|
||||
Date (..), Day (..), Text, NonEmpty (..), Regex, HashSet, HashMap)
|
||||
where
|
||||
|
||||
import Date
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Data.Bitraversable (bitraverse)
|
||||
import Data.Char qualified as Char
|
||||
import Data.Foldable (find)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashMap.Strict qualified as HashMap
|
||||
|
|
@ -53,6 +57,7 @@ import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
|
|||
import Data.YAML qualified as YAML
|
||||
import GHC.Records
|
||||
import System.FilePath ((</>), takeBaseName, takeExtension, splitExtension)
|
||||
import Text.ParserCombinators.ReadP qualified as ReadP
|
||||
import Text.Regex.TDFA (Regex)
|
||||
import Text.Regex.TDFA qualified as Regex
|
||||
|
||||
|
|
@ -75,6 +80,7 @@ data Info =
|
|||
nsfwOnly :: !Bool,
|
||||
tags :: !(HashSet Text),
|
||||
nsfwTags :: !(HashSet Text),
|
||||
excludeTags :: !(HashSet Text), -- remove tags that would be implied
|
||||
desc :: !Desc,
|
||||
nsfwDesc :: !Desc,
|
||||
bg :: !Bg,
|
||||
|
|
@ -315,8 +321,8 @@ instance FromYAML Info where
|
|||
parseYAML = YAML.withMap "info" \m -> do
|
||||
checkKeys m ["date", "sort", "updates", "show-updated", "unlisted",
|
||||
"gallery-title", "title", "artist", "nsfw-only", "tags",
|
||||
"nsfw-tags", "desc", "nsfw-desc", "bg", "images", "thumb",
|
||||
"links", "extras"]
|
||||
"nsfw-tags", "exclude-tags", "desc", "nsfw-desc", "bg",
|
||||
"images", "thumb", "links", "extras"]
|
||||
Info <$> m .: "date"
|
||||
<*> m .:? "sort" .!= ""
|
||||
<*> (m .:? "updates" >>= updateList)
|
||||
|
|
@ -328,6 +334,7 @@ instance FromYAML Info where
|
|||
<*> m .:? "nsfw-only" .!= False
|
||||
<*> m .:? "tags" .!= []
|
||||
<*> m .:? "nsfw-tags" .!= []
|
||||
<*> m .:? "exclude-tags" .!= []
|
||||
<*> m .:? "desc" .!= NoDesc
|
||||
<*> m .:? "nsfw-desc" .!= NoDesc
|
||||
<*> m .:? "bg" .!= Default
|
||||
|
|
@ -517,6 +524,101 @@ instance FromYAML ArtistFilter where
|
|||
parseYAML = YAML.withStr "artist filter" readArtistFilter
|
||||
|
||||
|
||||
data TagTransforms =
|
||||
TagTransforms {
|
||||
implies :: ![Implies],
|
||||
replace :: !(HashMap Text Text),
|
||||
replaceWarn :: !(HashMap Text Text),
|
||||
warn :: ![Warning]
|
||||
} deriving Show
|
||||
|
||||
instance FromYAML TagTransforms where
|
||||
parseYAML = YAML.withMap "tag transforms" \m -> do
|
||||
checkKeys m ["implies", "replace", "replace-warn", "warn"]
|
||||
TagTransforms <$> m .:? "implies" .!= []
|
||||
<*> m .:? "replace" .!= []
|
||||
<*> m .:? "replace-warn" .!= []
|
||||
<*> m .:? "warn" .!= []
|
||||
|
||||
emptyTransforms :: TagTransforms
|
||||
emptyTransforms = TagTransforms [] [] [] []
|
||||
|
||||
|
||||
data SlashedRegex = SR Text Regex
|
||||
|
||||
regex :: MonadFail m => Text -> m Regex
|
||||
regex body =
|
||||
let comp = Regex.defaultCompOpt {Regex.caseSensitive = False}
|
||||
exec = Regex.defaultExecOpt in
|
||||
Regex.makeRegexOptsM comp exec body
|
||||
|
||||
withSR :: (Text -> Regex -> a) -> SlashedRegex -> a
|
||||
withSR f (SR t r) = f t r
|
||||
|
||||
instance FromYAML SlashedRegex where
|
||||
parseYAML = YAML.withStr "string or regex" \str -> do
|
||||
guard $ Text.length str > 2 &&
|
||||
Text.head str == '/' &&
|
||||
Text.last str == '/'
|
||||
let body = Text.drop 1 $ Text.dropEnd 1 str
|
||||
SR body <$> regex body
|
||||
|
||||
|
||||
data Implies = RegexI Text Regex [Replacement] | LiteralI Text [Text]
|
||||
|
||||
instance Show Implies where
|
||||
showsPrec d (RegexI s _ rhss) =
|
||||
showParen (d > 10) $
|
||||
showString "RegexI " . showsPrec 11 s . showString " _ " .
|
||||
showsPrec 10 rhss
|
||||
showsPrec d (LiteralI s rhss) =
|
||||
showParen (d > 10) $
|
||||
showString "LiteralI " . showsPrec 11 s . showChar ' ' .
|
||||
showsPrec 10 rhss
|
||||
|
||||
instance FromYAML Implies where
|
||||
parseYAML = withPairM \k v ->
|
||||
withSR RegexI <$> parseYAML k <*> parseYAML v
|
||||
<|> LiteralI <$> parseYAML k <*> parseYAML v
|
||||
|
||||
|
||||
data Warning = RegexW Text Regex | LiteralW Text
|
||||
|
||||
instance Show Warning where
|
||||
showsPrec d (RegexW s _) =
|
||||
showParen (d > 10) $
|
||||
showString "RegexI " . showsPrec 11 s . showString " _"
|
||||
showsPrec d (LiteralW s) =
|
||||
showParen (d > 10) $
|
||||
showString "LiteralI " . showsPrec 11 s
|
||||
|
||||
instance FromYAML Warning where
|
||||
parseYAML y = withSR RegexW <$> parseYAML y
|
||||
<|> LiteralW <$> parseYAML y
|
||||
|
||||
|
||||
data Replacement = Re Text [Either String Int] deriving Show
|
||||
|
||||
parseReplacement :: MonadFail m => Text -> m Replacement
|
||||
parseReplacement txt =
|
||||
case ReadP.readP_to_S parser (Text.unpack txt) of
|
||||
[(res, "")] -> pure $ Re txt res
|
||||
_ -> fail $
|
||||
"parse error in replacement string \"" <> Text.unpack txt <> "\""
|
||||
where
|
||||
parser = many (Left . pure <$> esc
|
||||
<|> Left <$> lit
|
||||
<|> Right . read <$> var) <* ReadP.eof
|
||||
esc = ReadP.char '\\' *> ReadP.get
|
||||
lit = ReadP.munch1 \c -> c /= '$' && c /= '\\'
|
||||
var = bareVar <|> braceVar where
|
||||
bareVar = ReadP.char '$' *> ReadP.munch1 Char.isDigit
|
||||
braceVar = ReadP.string "${" *> ReadP.munch1 Char.isDigit <* ReadP.char '}'
|
||||
|
||||
instance FromYAML Replacement where
|
||||
parseYAML = YAML.withStr "regex replacement string" parseReplacement
|
||||
|
||||
|
||||
data IndexInfo =
|
||||
IndexInfo {
|
||||
title :: !Text,
|
||||
|
|
@ -538,54 +640,6 @@ instance FromYAML IndexInfo where
|
|||
<*> m .:? "footer"
|
||||
<*> m .:? "tags" .!= emptyTransforms
|
||||
|
||||
data TagTransforms =
|
||||
TagTransforms {
|
||||
implies :: !(HashMap ImpliesKey [Text]),
|
||||
replace :: !(HashMap Text Text),
|
||||
replaceWarn :: !(HashMap Text Text),
|
||||
warn :: !(HashSet Text)
|
||||
}
|
||||
deriving Show
|
||||
|
||||
data ImpliesKey = RegexIK Text Regex | LiteralIK Text
|
||||
|
||||
instance Eq ImpliesKey where
|
||||
RegexIK s _ == RegexIK t _ = s == t
|
||||
LiteralIK s == LiteralIK t = s == t
|
||||
_ == _ = False
|
||||
|
||||
instance Show ImpliesKey where
|
||||
showsPrec d (RegexIK s _) =
|
||||
showParen (d > 10) $
|
||||
showString "RegexIK " . showsPrec 11 s . showString " _"
|
||||
showsPrec d (LiteralIK s) =
|
||||
showParen (d > 10) $ showString "LiteralIK " . showsPrec 11 s
|
||||
|
||||
instance Hashable ImpliesKey where
|
||||
hashWithSalt s (RegexIK str _) = hashWithSalt s ('R', str)
|
||||
hashWithSalt s (LiteralIK str) = hashWithSalt s ('L', str)
|
||||
|
||||
emptyTransforms :: TagTransforms
|
||||
emptyTransforms = TagTransforms [] [] [] []
|
||||
|
||||
instance FromYAML TagTransforms where
|
||||
parseYAML = YAML.withMap "tag transforms" \m -> do
|
||||
checkKeys m ["implies", "replace", "replace-warn", "warn"]
|
||||
TagTransforms <$> m .:? "implies" .!= []
|
||||
<*> m .:? "replace" .!= []
|
||||
<*> m .:? "replace-warn" .!= []
|
||||
<*> m .:? "warn" .!= []
|
||||
|
||||
instance FromYAML ImpliesKey where
|
||||
parseYAML = YAML.withStr "string or regex" \str -> pure
|
||||
if Text.length str > 2 &&
|
||||
Text.head str == '/' &&
|
||||
Text.last str == '/'
|
||||
then
|
||||
let body = Text.drop 1 $ Text.dropEnd 1 str in
|
||||
RegexIK body (Regex.makeRegex body)
|
||||
else LiteralIK str
|
||||
|
||||
|
||||
data Pair a b = Pair !a !b
|
||||
|
||||
|
|
|
|||
|
|
@ -2,12 +2,11 @@ module ListTags where
|
|||
|
||||
import Info
|
||||
import Options (TagSort (..))
|
||||
import TagTransforms
|
||||
|
||||
import Control.Monad
|
||||
import Data.Foldable
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.HashSet (HashSet)
|
||||
import qualified Data.HashSet as HashSet
|
||||
import Data.List (sort, sortBy)
|
||||
import Data.Ord (comparing)
|
||||
|
|
@ -17,44 +16,62 @@ import Text.Printf (printf)
|
|||
|
||||
type TagStats = HashMap Text Int
|
||||
type PathSet = HashSet FilePath
|
||||
type FileWarnings = [(FilePath, TagWarning)]
|
||||
|
||||
data Stats =
|
||||
Stats {
|
||||
tags :: TagStats,
|
||||
untagged :: PathSet
|
||||
untagged :: PathSet,
|
||||
warns :: FileWarnings
|
||||
}
|
||||
|
||||
instance Semigroup Stats where
|
||||
Stats {tags = t1, untagged = u1} <> Stats {tags = t2, untagged = u2} =
|
||||
Stats {tags = HashMap.unionWith (+) t1 t2, untagged = u1 <> u2}
|
||||
s1 <> s2 = Stats {
|
||||
tags = HashMap.unionWith (+) s1.tags s2.tags,
|
||||
untagged = s1.untagged <> s2.untagged,
|
||||
warns = s1.warns <> s2.warns
|
||||
}
|
||||
|
||||
instance Monoid Stats where
|
||||
mempty = Stats {tags = [], untagged = []}
|
||||
mempty = Stats {tags = [], untagged = [], warns = []}
|
||||
|
||||
|
||||
stats1 :: Bool -> FilePath -> Info -> Stats
|
||||
stats1 nsfw path (Info {tags, nsfwTags}) =
|
||||
let tags' = if nsfw then tags <> nsfwTags else tags in
|
||||
if null tags' then
|
||||
Stats {tags = [], untagged = [path]}
|
||||
stats1 :: TagTransforms -> Bool -> FilePath -> Info -> Stats
|
||||
stats1 tt nsfw path (Info {tags, nsfwTags}) =
|
||||
let startTags = if nsfw then tags <> nsfwTags else tags
|
||||
TR outTags warns = applyTransforms tt startTags
|
||||
in
|
||||
if null outTags then
|
||||
Stats {tags = [], untagged = [path], warns = map (path,) warns}
|
||||
else
|
||||
let tagMap = HashMap.fromList $ map (, 1) $ HashSet.toList tags' in
|
||||
Stats {tags = tagMap, untagged = []}
|
||||
let tagMap = HashMap.fromList $ map (, 1) $ HashSet.toList outTags in
|
||||
Stats {tags = tagMap, untagged = [], warns = map (path,) warns}
|
||||
|
||||
stats :: Bool -> [(FilePath, Info)] -> Stats
|
||||
stats nsfw = foldMap $ uncurry $ stats1 nsfw
|
||||
stats :: IndexInfo -> Bool -> [(FilePath, Info)] -> Stats
|
||||
stats iinfo nsfw = foldMap $ uncurry $ stats1 iinfo.tags nsfw
|
||||
|
||||
run :: Bool -> Bool -> TagSort -> [(FilePath, Info)] -> IO ()
|
||||
run nsfw listUntagged ts infos = do
|
||||
let Stats {tags, untagged} = stats nsfw infos
|
||||
run :: IndexInfo
|
||||
-> Bool -- ^ include nsfw?
|
||||
-> Bool -- ^ list files with no tags
|
||||
-> Bool -- ^ print tag warnings
|
||||
-> TagSort
|
||||
-> [(FilePath, Info)] ->
|
||||
IO ()
|
||||
run iinfo nsfw listUntagged showWarnings ts infos = do
|
||||
let Stats {tags, untagged, warns} = stats iinfo nsfw infos
|
||||
let sortedTags = sortBy (cmp ts) $ map swap $ HashMap.toList tags
|
||||
putStrLn "TAGS\n----"
|
||||
printf "%5d: [total]\n" (length infos)
|
||||
for_ sortedTags \(count, path) ->
|
||||
printf "%4d: %s\n" count path
|
||||
printf "%5d: %s\n" count path
|
||||
when (listUntagged && not (null untagged)) $ do
|
||||
let sortedUntagged = sort $ HashSet.toList untagged
|
||||
putStrLn "\nUNTAGGED FILES\n--------------"
|
||||
for_ sortedUntagged $ printf " - %s\n"
|
||||
when (showWarnings && not (null warns)) $ do
|
||||
let hdr :: String = printf "WARNINGS (%d)" (length warns)
|
||||
printf "\n%s\n%s\n" hdr (const '-' <$> hdr)
|
||||
for_ warns \(file, warn) -> putStrLn $ showWarning file warn
|
||||
|
||||
cmp :: TagSort -> (Int, Text) -> (Int, Text) -> Ordering
|
||||
cmp SortFreq = flip $ comparing fst
|
||||
|
|
|
|||
|
|
@ -24,10 +24,12 @@ import qualified GalleryPage
|
|||
import qualified IndexPage
|
||||
import qualified RSS
|
||||
import qualified ListTags
|
||||
import TagTransforms
|
||||
|
||||
#ifdef PRETTY_VERBOSE
|
||||
import qualified Text.PrettyPrint as PP
|
||||
import qualified Text.Show.Pretty as PP
|
||||
import Data.Function ((&))
|
||||
#endif
|
||||
|
||||
|
||||
|
|
@ -49,19 +51,20 @@ main = do
|
|||
|
||||
main2 :: HasVerbose => ModeOptions -> IO ()
|
||||
main2 (SinglePage {root, file, prefix, index, dataDir, nsfw, output}) = do
|
||||
siteName <- (.title) <$> readYAML @IndexInfo index
|
||||
info <- readYAML file
|
||||
iinfo <- readYAML index
|
||||
info <- transformInfoTags iinfo.tags <$> readYAML file
|
||||
printV $ "contents" := info
|
||||
let dir = takeDirectory $ makeRelative dataDir file
|
||||
page <- SinglePage.make root siteName prefix nsfw dataDir dir info
|
||||
page <- SinglePage.make root iinfo prefix nsfw dataDir dir info
|
||||
writeOutput output page
|
||||
|
||||
main2 (GalleryPage {root, files, prefix, index, output, dataDir}) = do
|
||||
(_, ginfo) <- galleryFromIndex index prefix
|
||||
(iinfo, _, ginfo) <- galleryFromIndex index prefix
|
||||
printV $ "gallery_info" := ginfo
|
||||
infos <- mapM (infoYAML dataDir) files
|
||||
infos <- traverse (infoYAML dataDir) files
|
||||
& fmap (fmap $ fmap $ transformInfoTags iinfo.tags)
|
||||
printV $ "infos" := infos
|
||||
let page = GalleryPage.make root ginfo infos
|
||||
let page = GalleryPage.make root iinfo ginfo infos
|
||||
writeOutput output page
|
||||
|
||||
main2 (IndexPage {root, file, output}) = do
|
||||
|
|
@ -71,9 +74,9 @@ main2 (IndexPage {root, file, output}) = do
|
|||
writeOutput output page
|
||||
|
||||
main2 (RSS {files, root, index, prefix, output, dataDir}) = do
|
||||
(name, ginfo) <- galleryFromIndex index prefix
|
||||
(_, name, ginfo) <- galleryFromIndex index prefix
|
||||
printV $ "gallery_info" := ginfo
|
||||
infos <- mapM (infoYAML dataDir) files
|
||||
infos <- traverse (infoYAML dataDir) files
|
||||
printV $ "infos" := infos
|
||||
let output' = takeFileName <$> output
|
||||
let rss = RSS.make root name ginfo output' infos
|
||||
|
|
@ -90,19 +93,24 @@ main2 (DependSingle {index, file, nsfw, output, prefix, buildDir, dataDir}) = do
|
|||
main2 (DependGallery {file, output, buildDir, dataDir, tmpDir, infoName}) = do
|
||||
IndexInfo {galleries} <- readYAML file
|
||||
printV $ "galleries" := galleries
|
||||
infos <- mapM (infoYAML dataDir) =<< findInfos dataDir infoName
|
||||
infos <- findInfos dataDir infoName
|
||||
>>= traverse (infoYAML dataDir)
|
||||
printV $ "info_files" := infos
|
||||
let dependGallery0 g = dependGallery' g file infos buildDir dataDir tmpDir
|
||||
let deps = toLazyText $ mconcat $ intersperse "\n\n\n" $
|
||||
map dependGallery0 galleries
|
||||
writeOutput output deps
|
||||
|
||||
main2 (ListTags {nsfw, listUntagged, dataDir, infoName, sortBy}) = do
|
||||
infos <- mapM (infoYAML dataDir) =<< findInfos dataDir infoName
|
||||
main2 (ListTags {nsfw, listUntagged, showWarnings, index,
|
||||
dataDir, infoName, sortBy}) = do
|
||||
printV $ "index" := index
|
||||
iinfo <- readYAML index
|
||||
infos <- findInfos dataDir infoName >>= traverse (infoYAML dataDir)
|
||||
printV $ "info_files" := infos
|
||||
ListTags.run nsfw listUntagged sortBy infos
|
||||
ListTags.run iinfo nsfw listUntagged showWarnings sortBy infos
|
||||
|
||||
|
||||
-- | applies tag transformations also
|
||||
infoYAML :: FilePath -- ^ data dir
|
||||
-> FilePath -- ^ yaml file
|
||||
-> IO (FilePath, Info) -- relative filename, contents
|
||||
|
|
@ -118,10 +126,12 @@ findInfos dataDir infoName =
|
|||
readYAML :: YAML.FromYAML a => FilePath -> IO a
|
||||
readYAML file = ByteString.readFile file >>= decode1Must file
|
||||
|
||||
galleryFromIndex :: FilePath -> FilePath -> IO (Strict.Text, GalleryInfo)
|
||||
galleryFromIndex :: FilePath -> FilePath ->
|
||||
IO (IndexInfo, Strict.Text, GalleryInfo)
|
||||
galleryFromIndex file prefix = do
|
||||
IndexInfo {title, galleries} <- readYAML file
|
||||
maybe (fail $ "no gallery with prefix " ++ prefix) (pure . (title,)) $
|
||||
iinfo@(IndexInfo {title, galleries}) <- readYAML file
|
||||
maybe (fail $ "no gallery with prefix " ++ prefix)
|
||||
(pure . (iinfo, title,)) $
|
||||
List.find (\g -> g.prefix == prefix) galleries
|
||||
|
||||
decode1Must :: YAML.FromYAML a => FilePath -> ByteString -> IO a
|
||||
|
|
|
|||
|
|
@ -61,8 +61,10 @@ data ModeOptions =
|
|||
| ListTags {
|
||||
dataDir :: FilePath,
|
||||
infoName :: FilePath,
|
||||
index :: FilePath,
|
||||
nsfw :: Bool,
|
||||
listUntagged :: Bool,
|
||||
showWarnings :: Bool,
|
||||
sortBy :: TagSort
|
||||
}
|
||||
deriving Show
|
||||
|
|
@ -148,14 +150,17 @@ optionsParser = globalOpts `info` mainInfo where
|
|||
dgInfo = progDesc "generate makefile dependencies for a gallery"
|
||||
|
||||
listTags = command "list-tags" $ ltOpts `info` ltInfo
|
||||
ltOpts = ListTags <$> dataDir <*> infoName <*> nsfwT
|
||||
<*> listUntagged_ <*> listSort
|
||||
ltOpts = ListTags <$> dataDir <*> infoName <*> indexFile <*> nsfwT
|
||||
<*> listUntagged <*> showWarnings <*> listSort
|
||||
nsfwT = switch $
|
||||
short 'n' <> long "nsfw" <>
|
||||
help "include nsfw tags"
|
||||
listUntagged_ = switch $
|
||||
listUntagged = switch $
|
||||
short 'U' <> long "untagged" <>
|
||||
help "list files with no tags"
|
||||
showWarnings = switch $
|
||||
short 'W' <> long "warnings" <>
|
||||
help "show tag warnings"
|
||||
listSort = fmap toSort $ switch $
|
||||
short 'a' <> long "alpha" <>
|
||||
help "sort alphabetically instead of by frequency"
|
||||
|
|
|
|||
|
|
@ -4,21 +4,21 @@ module SinglePage (make) where
|
|||
import Date
|
||||
import Info
|
||||
import BuilderQQ
|
||||
import qualified NsfwWarning
|
||||
import NsfwWarning qualified
|
||||
import TagTransforms
|
||||
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Data.Char (isSpace)
|
||||
import Data.Foldable
|
||||
import Data.HashSet qualified as HashSet
|
||||
import Data.List (sort, intersperse)
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import qualified Data.Text as Strict
|
||||
import qualified Data.Text.Lazy as Lazy
|
||||
import System.FilePath (joinPath, splitPath)
|
||||
import Data.HashSet (HashSet)
|
||||
import qualified Data.HashSet as HashSet
|
||||
import Data.Traversable
|
||||
import Data.Semigroup
|
||||
import Data.List.NonEmpty (toList)
|
||||
import Data.Char (isSpace)
|
||||
import Data.Text qualified as Strict
|
||||
import Data.Text.Lazy qualified as Lazy
|
||||
import Data.Traversable
|
||||
import System.FilePath (joinPath, splitPath)
|
||||
|
||||
|
||||
-- | e.g. only nsfw images are present for a non-nsfw page
|
||||
|
|
@ -32,22 +32,25 @@ instance Show NoEligibleImages where
|
|||
|
||||
|
||||
make :: Text -- ^ website root
|
||||
-> Text -- ^ website name
|
||||
-> IndexInfo
|
||||
-> FilePath -- ^ gallery prefix
|
||||
-> Bool -- ^ nsfw?
|
||||
-> FilePath -- ^ data dir
|
||||
-> FilePath -- ^ subdir of datadir containing this @info.yaml@
|
||||
-> Info -> IO Lazy.Text
|
||||
make root siteName prefix nsfw dataDir dir info =
|
||||
toLazyText <$> make' root siteName prefix nsfw dataDir dir info
|
||||
make root iinfo prefix nsfw dataDir dir info =
|
||||
fmap toLazyText $
|
||||
make' root iinfo prefix nsfw dataDir dir $
|
||||
transformInfoTags iinfo.tags info
|
||||
|
||||
make' :: Text -> Text -> FilePath -> Bool -> FilePath -> FilePath -> Info
|
||||
make' :: Text -> IndexInfo -> FilePath -> Bool -> FilePath -> FilePath -> Info
|
||||
-> IO Builder
|
||||
make' root siteName prefix nsfw _dataDir dir
|
||||
make' root iinfo prefix nsfw _dataDir dir
|
||||
info@(Info {date, title, artist, bg}) = do
|
||||
images <- maybe (throw $ NoEligibleImages title) pure $ imagesFor nsfw info
|
||||
|
||||
let undir = joinPath (replicate (length (splitPath dir)) "..")
|
||||
let siteName = iinfo.title
|
||||
|
||||
let formattedDate = formatLong date
|
||||
|
||||
|
|
@ -59,7 +62,8 @@ make' root siteName prefix nsfw _dataDir dir
|
|||
|
||||
let artistSection = makeArtist artist
|
||||
let descSection = makeDesc $ descFor nsfw info
|
||||
let tagsList = makeTags undir $ tagsFor nsfw info
|
||||
let tags = tagsFor nsfw info
|
||||
let tagsList = makeTags undir tags
|
||||
let linksList = extLinks $ linksFor nsfw info
|
||||
let updates = sort $ updatesFor nsfw info
|
||||
let updatesList = makeUpdates updates
|
||||
|
|
|
|||
103
make-pages/TagTransforms.hs
Normal file
103
make-pages/TagTransforms.hs
Normal file
|
|
@ -0,0 +1,103 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
module TagTransforms
|
||||
(TransformResult (..),
|
||||
TagWarning (..), showWarning, printWarning,
|
||||
matchWarning, applyImplies, applyTransforms1, applyTransforms,
|
||||
transformInfoTags)
|
||||
where
|
||||
|
||||
import Info
|
||||
import BuilderQQ qualified as Builder
|
||||
import Control.Monad
|
||||
import Data.Array (Array)
|
||||
import Data.Array.Base ((!?))
|
||||
import Data.HashMap.Strict qualified as HashMap
|
||||
import Data.HashSet qualified as HashSet
|
||||
import Text.Regex.TDFA qualified as Regex
|
||||
import System.IO (hPutStrLn, stderr)
|
||||
import Control.Applicative (Alternative(..), asum)
|
||||
import Control.Monad.Writer
|
||||
|
||||
|
||||
data TagWarning
|
||||
= ReplaceWarn Text Text
|
||||
| PresenceWarn Text
|
||||
| UndefinedCapture Int Text
|
||||
| ReplaceParseError Text
|
||||
deriving Show
|
||||
|
||||
data TransformResult = TR (HashSet Text) [TagWarning]
|
||||
deriving Show
|
||||
|
||||
instance Semigroup TransformResult where
|
||||
TR t1 w1 <> TR t2 w2 = TR (t1 <> t2) (w1 <> w2)
|
||||
instance Monoid TransformResult where
|
||||
mempty = TR [] []
|
||||
|
||||
showWarning :: FilePath -> TagWarning -> String
|
||||
showWarning file (ReplaceWarn from to) =
|
||||
file ++ ": contains tag " ++ show from ++
|
||||
" (replacing with " ++ show to ++ ")"
|
||||
showWarning file (PresenceWarn what) =
|
||||
file ++ ": contains tag " ++ show what
|
||||
showWarning file (UndefinedCapture i txt) =
|
||||
file ++ ": replacement string " ++ show txt ++
|
||||
" contains undefined capture group $" ++ show i
|
||||
showWarning file (ReplaceParseError txt) =
|
||||
file ++ ": cannot parse replacement string " ++ show txt
|
||||
|
||||
printWarning :: FilePath -> TagWarning -> IO ()
|
||||
printWarning f w =
|
||||
hPutStrLn stderr $ "[WARN] " ++ showWarning f w
|
||||
|
||||
matchWarning :: Text -> Warning -> Bool
|
||||
matchWarning txt (RegexW _ rx) = Regex.match rx txt
|
||||
matchWarning txt (LiteralW l) = l == txt
|
||||
|
||||
applyImplies1 :: Array Int Text -> Replacement -> TransformResult
|
||||
applyImplies1 subs (Re txt rhs) =
|
||||
case traverse app rhs of
|
||||
Left i -> TR [] [UndefinedCapture i txt]
|
||||
Right oks -> TR [Builder.toStrictText $ mconcat oks] []
|
||||
where
|
||||
app (Left str) = Right $ Builder.build str
|
||||
app (Right i) = case subs !? i of
|
||||
Just sub -> Right $ Builder.build sub
|
||||
Nothing -> Left i
|
||||
|
||||
applyImplies :: Text -> Implies -> Maybe TransformResult
|
||||
applyImplies tag (RegexI _ rx outs) =
|
||||
let res = Regex.mrSubs $ Regex.match rx tag in
|
||||
if null res then empty else pure $ foldMap (applyImplies1 res) outs
|
||||
applyImplies tag (LiteralI str outs) =
|
||||
TR (HashSet.fromList outs) [] <$ guard (tag == str)
|
||||
|
||||
ifJust :: Applicative m => Maybe a -> (a -> m ()) -> m Bool
|
||||
ifJust m f = maybe (pure False) (\x -> True <$ f x) m
|
||||
|
||||
applyTransforms1 :: TagTransforms -> Text -> TransformResult
|
||||
applyTransforms1 t = execWriter . go where
|
||||
go tag = do
|
||||
replacedW <- ifJust (HashMap.lookup tag t.replaceWarn) \out -> do
|
||||
tell $ TR [] [ReplaceWarn tag out]
|
||||
go out
|
||||
replaced <- ifJust (HashMap.lookup tag t.replace) go
|
||||
unless (replacedW || replaced) do
|
||||
tell $ TR [tag] []
|
||||
when (any (matchWarning tag) t.warn) do
|
||||
tell $ TR [] [PresenceWarn tag]
|
||||
forM_ (asum $ map (applyImplies tag) t.implies) \(TR tags ws) -> do
|
||||
tell $ TR [] ws
|
||||
forM_ tags go
|
||||
|
||||
applyTransforms :: Foldable f => TagTransforms -> f Text -> TransformResult
|
||||
applyTransforms t tags = foldMap (applyTransforms1 t) tags
|
||||
|
||||
transformInfoTags :: TagTransforms -> Info -> Info
|
||||
transformInfoTags t (Info {..}) =
|
||||
let TR tags' _ = applyTransforms t tags
|
||||
TR nsfwTags' _ = applyTransforms t nsfwTags in
|
||||
Info {
|
||||
tags = HashSet.difference tags' excludeTags,
|
||||
nsfwTags = HashSet.difference nsfwTags' excludeTags, ..
|
||||
}
|
||||
|
|
@ -17,6 +17,7 @@ executable make-pages
|
|||
BuilderQQ,
|
||||
Date,
|
||||
Info,
|
||||
TagTransforms,
|
||||
Depend,
|
||||
NsfwWarning,
|
||||
GalleryPage,
|
||||
|
|
@ -44,12 +45,14 @@ executable make-pages
|
|||
TemplateHaskell
|
||||
build-depends:
|
||||
base >= 4.16.4 && < 4.21,
|
||||
array == 0.5.7.*,
|
||||
bytestring >= 0.11.3.1 && < 0.14,
|
||||
containers >= 0.6.0.1 && < 0.8,
|
||||
filemanip ^>= 0.3.6.3,
|
||||
filepath >= 1.4.2.1 && < 1.6,
|
||||
hashable >= 1.3.0.0 && < 1.5,
|
||||
HsYAML ^>= 0.2.1.0,
|
||||
mtl == 2.3.1.*,
|
||||
optparse-applicative ^>= 0.15.1.0,
|
||||
process ^>= 1.6.8.2,
|
||||
regex-tdfa == 1.3.2.*,
|
||||
|
|
|
|||
Loading…
Reference in a new issue