From 7745722009e371a71f5fd6f8048234b8f7303a10 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 18 Aug 2024 07:37:58 +0200 Subject: [PATCH] remove the reindent stuff. it does not matter --- make-pages/BuilderQQ.hs | 189 ++++++++------------------------------ make-pages/Depend.hs | 38 ++++---- make-pages/GalleryPage.hs | 20 ++-- make-pages/IndexPage.hs | 24 ++--- make-pages/NsfwWarning.hs | 2 +- make-pages/RSS.hs | 14 +-- make-pages/SinglePage.hs | 74 +++++++-------- 7 files changed, 123 insertions(+), 238 deletions(-) diff --git a/make-pages/BuilderQQ.hs b/make-pages/BuilderQQ.hs index 46112cd..e9633ad 100644 --- a/make-pages/BuilderQQ.hs +++ b/make-pages/BuilderQQ.hs @@ -1,184 +1,72 @@ {-# LANGUAGE PatternSynonyms, TemplateHaskell #-} module BuilderQQ - (b, - Builder, toStrictText, toLazyText, fromText, fromString, fromChar, - textMap, ifJust, escId, escAttr, CanBuild (..)) + (b, Builder, toStrictText, toLazyText, fromText, fromString, + ifJust, escId, escAttr, CanBuild (..)) where -import Data.Char (isLower, isSpace, isDigit, isAlphaNum) +import Data.Char (isSpace, isAlphaNum) import Language.Haskell.TH import Language.Haskell.TH.Quote -import Data.List (intersperse) +import Data.List (dropWhileEnd) import Data.Maybe (mapMaybe, fromMaybe) import Data.Text.Lazy.Builder (Builder, fromText, fromLazyText, fromString, singleton, toLazyText) -import Text.Read (readMaybe) -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Lazy as LText +import qualified Data.Text as Strict +import qualified Data.Text.Lazy as Lazy import Data.Text.Lazy (toStrict) -import Data.Foldable -import Data.Semigroup -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty, toList) -data ChunkType = Lit | Var VarType deriving Show -data VarType = - Plain - | Reindent !Int - deriving Show -type Chunk = (ChunkType, Text) +data Chunk = Lit String | Var String -indent :: Int -> LText.Text -> Builder -indent i str - | LText.all isSpace str = "" - | otherwise = replicateB i ' ' <> fromLazyText str +parseB :: String -> ExpQ +parseB = toExpQ . reverse . go "" [] . dropWhileEnd isSpace where + go acc cs [] = addLit acc cs + go acc cs ('$':'&':rest) = go acc cs rest -- $&: expands to nothing + go acc cs ('$':'$':rest) = go ('$' : acc) cs rest -- $$: expands to one $ + go acc cs ('$':rest) = go "" (Var var : addLit acc cs) rest' -- $var + where (var, rest') = span isIdChar rest + go acc cs (c:rest) = go (c : acc) cs rest -reindentB :: Int -> Builder -> Builder -reindentB i (toLazyText -> str) = - fold $ intersperse "\n" $ - map2 (fromLazyText . dropIndent) (indent i . dropIndent) ls - where - ls = dropWhile (LText.all isSpace) $ LText.lines str - ls' = filter (LText.any $ not . isSpace) ls + addLit l cs = if null l then cs else Lit (reverse l) : cs + isIdChar c = isAlphaNum c || c `elem` ("_'" :: String) - dropIndent = LText.drop minIndent - - minIndent = - getMin $ fromMaybe 0 $ foldMap (Just . Min . indentOf) ls' - - indentOf = go 0 where - go n (' ' :.. cs) = go (n + 1) cs - go n ('\t' :.. cs) = go (((n `mod` 8) + 1) * 8) cs - go n _ = n - - map2 _ _ [] = [] - map2 f g (x:xs) = f x : map g xs + toExpQ cs = [|mconcat $(listE $ mapMaybe chunk1 cs) :: Builder|] + chunk1 (Lit lit) = Just $ stringE lit + chunk1 (Var name) = Just $ [|build $(varE $ mkName name)|] -chunks :: Text -> [Chunk] -chunks = reverse . go "" [] . trimEnd where - go acc cs NilT = if Text.null acc' then cs else (Lit, acc') : cs - where acc' = toStrictText acc - - -- $&: expands to nothing - go acc cs ('$' :. '&' :. rest) = go acc cs rest - - -- $$: expands to one $ - go acc cs ('$' :. '$' :. rest) = go (acc <> "$") cs rest - - -- $n.var (n a number): expands to builder var indented by n - go acc cs ('$' :. rest@(d :. _)) | isDigit d = - go "" ((Var (Reindent n), var) : lit acc : cs) rest3 - where - (read . Text.unpack -> n, rest2) = Text.span isDigit rest - (var, rest3) = splitVar $ Text.tail rest2 - - -- $var: expands to that var's contents - go acc cs ('$' :. rest) = - go "" ((Var Plain, var) : lit acc : cs) rest2 - where (var, rest2) = splitVar rest - - go acc cs (c :. rest) = go (acc <> singleton c) cs rest - - splitVar s - | (var@(v :. _), s') <- Text.span isIdChar s, - isLower v || v == '_' - = (var, s') - splitVar _ = error "invalid variable name" - - isIdChar c = isAlphaNum c || c `elem` ("_'" :: String) - - lit s = (Lit, toStrictText s) - - trimEnd = Text.dropWhileEnd isSpace - -chunksWithReindent :: String -> [Chunk] -chunksWithReindent ('@':str) - | [(n',rest)] <- lex str, - Just n <- readMaybe n' - = chunks $ toStrictText $ reindent n $ Text.pack rest -chunksWithReindent str = chunks $ Text.pack str - -toStrictText :: Builder -> Text +toStrictText :: Builder -> Strict.Text toStrictText = toStrict . toLazyText - -chunksToExpQ :: [Chunk] -> ExpQ -chunksToExpQ cs = [|mconcat $es :: Builder|] where - es = listE $ mapMaybe chunk1 cs - chunk1 (Lit, "") = Nothing - chunk1 (Lit, lit) = Just $ stringE $ Text.unpack lit - chunk1 (Var t, name) = Just $ case t of - Plain -> [|build $var|] - Reindent n -> [|reindent n $var|] - where var = varE (mkName $ Text.unpack name) - -replicateB :: Int -> Char -> Builder -replicateB n c = fromText $ Text.replicate n $ Text.singleton c - b :: QuasiQuoter -b = QuasiQuoter { - quoteExp = chunksToExpQ . chunksWithReindent, - quotePat = error "can't use in a pattern", - quoteType = error "can't use in a type", - quoteDec = error "can't use at top level" - } +b = QuasiQuoter parseB undefined undefined undefined -pattern NilT :: Text -pattern NilT <- (Text.null -> True) - where NilT = "" - -infixr 5 :. -pattern (:.) :: Char -> Text -> Text -pattern c :. t <- (Text.uncons -> Just (c, t)) - where c :. t = Text.cons c t - -{-# COMPLETE NilT, (:.) :: Text #-} - -infixr 5 :.. -pattern (:..) :: Char -> LText.Text -> LText.Text -pattern c :.. t <- (LText.uncons -> Just (c, t)) - where c :.. t = LText.cons c t - - -fromChar :: Char -> Builder -fromChar = singleton - -textMap :: (Char -> Builder) -> Text -> Builder -textMap f = Text.foldl' (\buf c -> buf <> f c) mempty - ifJust :: Monoid b => Maybe a -> (a -> b) -> b ifJust x f = maybe mempty f x -escId :: Text -> Builder -escId = foldMap esc1 . Text.unpack where +escId :: Strict.Text -> Builder +escId = foldMap esc1 . Strict.unpack where esc1 c | isSpace c = "" | latin1Special c = "_" - | otherwise = fromChar c + | otherwise = singleton c latin1Special c = c <= 'ΓΏ' && not (isAlphaNum c) && c /= '-' -escAttr :: Text -> Builder -escAttr = foldMap esc1 . Text.unpack where - esc1 '<' = "<" - esc1 '>' = ">" - esc1 '"' = """ - esc1 '\'' = "'" - esc1 c = fromChar c +escAttr :: Strict.Text -> Builder +escAttr = foldMap esc1 . Strict.unpack where + esc1 c = fromMaybe (singleton c) $ lookup c + [('<', "<"), ('>', ">"), ('"', """), ('\'', "'")] -class CanBuild a where - build :: a -> Builder - reindent :: Int -> a -> Builder - reindent i = reindentB i . build +class CanBuild a where build :: a -> Builder -instance CanBuild Builder where build = id -instance CanBuild Text where build = fromText -instance CanBuild LText.Text where build = fromLazyText -instance CanBuild Char where build = singleton -instance CanBuild String where build = fromString +instance CanBuild Builder where build = id +instance CanBuild Strict.Text where build = fromText +instance CanBuild Lazy.Text where build = fromLazyText +instance CanBuild Char where build = singleton +instance CanBuild String where build = fromString newtype ShowBuild a = ShowBuild a deriving newtype Show instance Show a => CanBuild (ShowBuild a) where build = build . show @@ -188,8 +76,5 @@ deriving via ShowBuild Integer instance CanBuild Integer instance {-# OVERLAPPABLE #-} CanBuild a => CanBuild [a] where build = foldMap \x -> build x <> "\n" - reindent n = fold . intersperse ("\n" <> replicateB n ' ') . map build -instance CanBuild a => CanBuild (NonEmpty a) where - build = build . toList - reindent n = reindent n . toList +instance CanBuild a => CanBuild (NonEmpty a) where build = build . toList diff --git a/make-pages/Depend.hs b/make-pages/Depend.hs index 18632ee..0869e01 100644 --- a/make-pages/Depend.hs +++ b/make-pages/Depend.hs @@ -56,19 +56,19 @@ dependGallery ginfo index infos build data_ tmp = dependGallery' :: GalleryInfo -> FilePath -> [(FilePath, Info)] -> FilePath -> FilePath -> FilePath -> Builder dependGallery' (GalleryInfo {prefix, filters}) - indexFile infos' build data_ tmp = [b|@0 - $index: $gallery + indexFile infos' build data_ tmp = [b| +$index: $gallery - $gallery: $pages' $files' $rss $indexFile $$(MAKEPAGES) - $$(call gallery,$indexFile,$prefix) +$gallery: $pages' $files' $rss $indexFile $$(MAKEPAGES) + $$(call gallery,$indexFile,$prefix) - $rss: $files' $indexFile $$(MAKEPAGES) - $$(call rss,$indexFile,$prefix,$data_) +$rss: $files' $indexFile $$(MAKEPAGES) + $$(call rss,$indexFile,$prefix,$data_) - $rules +$rules - $incs - |] +$incs +|] where infos = filter (matchFilters filters . snd) infos' @@ -96,19 +96,19 @@ makeRules :: FilePath -- ^ prefix -> FilePath -- ^ data dir -> FilePath -- ^ tmp dir -> Builder -makeRules prefix indexFile filters build data_ tmp = [b|@0 - $buildPrefix/%/index.html: $data_/%/info.yaml $$(MAKEPAGES) - $$(call single,$data_,$prefix,$indexFile,$flags) +makeRules prefix indexFile filters build data_ tmp = [b| +$buildPrefix/%/index.html: $data_/%/info.yaml $$(MAKEPAGES) + $$(call single,$data_,$prefix,$indexFile,$flags) - $tmpPrefix/%.mk: $data_/%/info.yaml $$(MAKEPAGES) - $$(call depend-single,$prefix,$indexFile,$build,$data_,$flags) +$tmpPrefix/%.mk: $data_/%/info.yaml $$(MAKEPAGES) + $$(call depend-single,$prefix,$indexFile,$build,$data_,$flags) - $buildPrefix/%: $tmp/% - $$(call copy,-l) +$buildPrefix/%: $tmp/% + $$(call copy,-l) - $buildPrefix/%: $data_/% - $$(call copy) - |] +$buildPrefix/%: $data_/% + $$(call copy) +|] where buildPrefix = build prefix tmpPrefix = tmp prefix diff --git a/make-pages/GalleryPage.hs b/make-pages/GalleryPage.hs index 54b3243..ae2a1bd 100644 --- a/make-pages/GalleryPage.hs +++ b/make-pages/GalleryPage.hs @@ -22,7 +22,7 @@ make root ginfo infos = toLazyText $ make' root ginfo infos make' :: Text -> GalleryInfo -> [(FilePath, Info)] -> Builder -make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0 +make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b| @@ -42,11 +42,11 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0 - $0.nsfwScript + $nsfwScript $title - $0.nsfwDialog + $nsfwDialog
@@ -61,12 +61,12 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0

show only

    - $10.requireFilters + $requireFilters

exclude

    - $10.excludeFilters + $excludeFilters
    @@ -81,7 +81,7 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0
      - $6.items + $items
@@ -121,7 +121,7 @@ groupOnKey f (x:xs) = (fx, x:yes) : groupOnKey f no where (yes, no) = span (\y -> fx == f y) xs makeFilter :: Text -> HashSet Text -> Text -> Int -> Builder -makeFilter prefix initial tag count = [b|@0 +makeFilter prefix initial tag count = [b| @@ -136,17 +136,17 @@ makeYearItems :: Bool -- ^ nsfw -> Int -- ^ year -> [(FilePath, Info)] -> Builder -makeYearItems nsfw year infos = [b|@0 +makeYearItems nsfw year infos = [b|
  • $year' - $0.items + $items |] where items = map (uncurry $ makeItem nsfw) infos year' = show year & foldMap \c -> [b|$c|] makeItem :: Bool -> FilePath -> Info -> Builder -makeItem nsfw file info@(Info {bg}) = [b|@0 +makeItem nsfw file info@(Info {bg}) = [b|
  • diff --git a/make-pages/IndexPage.hs b/make-pages/IndexPage.hs index c18e86d..3efce99 100644 --- a/make-pages/IndexPage.hs +++ b/make-pages/IndexPage.hs @@ -9,7 +9,7 @@ make :: Text -> IndexInfo -> Lazy.Text make root info = toLazyText $ make' root info make' :: Text -> IndexInfo -> Builder -make' root (IndexInfo {title, desc, galleries, links, footer}) = [b|@0 +make' root (IndexInfo {title, desc, galleries, links, footer}) = [b| @@ -37,47 +37,47 @@ make' root (IndexInfo {title, desc, galleries, links, footer}) = [b|@0
    • - $4.galleryList - $4.linkList + $galleryList + $linkList
    - $2.footer' + $footer'
    |] where - galleryList = if null galleries then "" else [b|@0 + galleryList = if null galleries then "" else [b| |] where items = map makeItem galleries - linkList = if null links then "" else [b|@0 + linkList = if null links then "" else [b| |] where items = map makeLink links footer' = case footer of Nothing -> "" - Just f -> [b|@0 + Just f -> [b|
    - $2.f + $f
    |] url = [b|$root|] makeItem :: GalleryInfo -> Builder -makeItem (GalleryInfo {title, desc, prefix, filters}) = [b|@0 +makeItem (GalleryInfo {title, desc, prefix, filters}) = [b|     $title |] where nsfw = if hasNsfw filters then [b| class=nsfw|] else "" makeLink :: Link -> Builder -makeLink (Link {title, url, nsfw}) = [b|@0 +makeLink (Link {title, url, nsfw}) = [b| $title |] where nsfw' = if nsfw then [b| class=nsfw|] else "" diff --git a/make-pages/NsfwWarning.hs b/make-pages/NsfwWarning.hs index db02958..b7539b1 100644 --- a/make-pages/NsfwWarning.hs +++ b/make-pages/NsfwWarning.hs @@ -16,7 +16,7 @@ script (Just _) = [b||] dialog :: Maybe What -> Builder dialog Nothing = "" -dialog (Just what) = [b|@0 +dialog (Just what) = [b|

    cw: lewd art

    diff --git a/make-pages/RSS.hs b/make-pages/RSS.hs index 87a0305..dfa0e0e 100644 --- a/make-pages/RSS.hs +++ b/make-pages/RSS.hs @@ -24,7 +24,7 @@ make root name ginfo output infos = make' :: Strict.Text -> Strict.Text -> GalleryInfo -> Maybe FilePath -> [(FilePath, Info)] -> Builder -make' root name ginfo@(GalleryInfo {title, desc, prefix}) output infos = [b|@0 +make' root name ginfo@(GalleryInfo {title, desc, prefix}) output infos = [b| @@ -33,7 +33,7 @@ make' root name ginfo@(GalleryInfo {title, desc, prefix}) output infos = [b|@0 $desc $selflink - $4.items + $items |] @@ -48,7 +48,7 @@ make' root name ginfo@(GalleryInfo {title, desc, prefix}) output infos = [b|@0 Just o -> [b||] makeItem :: Strict.Text -> FilePath -> Bool -> FilePath -> Info -> Builder -makeItem root prefix nsfw path info@(Info {title}) = [b|@4 +makeItem root prefix nsfw path info@(Info {title}) = [b| $title$suffix $link @@ -58,11 +58,11 @@ makeItem root prefix nsfw path info@(Info {title}) = [b|@4 |] where - body = [b|@6 + body = [b| |] diff --git a/make-pages/SinglePage.hs b/make-pages/SinglePage.hs index 2852716..a4e6c9a 100644 --- a/make-pages/SinglePage.hs +++ b/make-pages/SinglePage.hs @@ -66,7 +66,7 @@ make' root siteName prefix nsfw _dataDir dir where path' = bigFile img let prefetches = map makePrefetch otherImages - let makeWarning w = [b|@0 + let makeWarning w = [b|
    $w
    @@ -77,7 +77,7 @@ make' root siteName prefix nsfw _dataDir dir let bgStyle = case bg of Default -> "" - NoBorder -> [b|@0 + NoBorder -> [b| |] - Other col -> [b|@0 + Other col -> [b| |] @@ -104,18 +104,18 @@ make' root siteName prefix nsfw _dataDir dir let nsfwDialog = NsfwWarning.dialog nsfw' let imageMeta = case previewImage info of - Just (PFull (Image {path})) -> [b|@0 + Just (PFull (Image {path})) -> [b| |] - Just (PThumb path) -> [b|@0 + Just (PThumb path) -> [b| |] Nothing -> throw $ NoThumb dir - pure [b|@0 + pure [b| @@ -136,7 +136,7 @@ make' root siteName prefix nsfw _dataDir dir $nsfwScript $bgStyle - $0.prefetches + $prefetches $title @@ -153,7 +153,7 @@ make' root siteName prefix nsfw _dataDir dir - $2.buttonBar + $buttonBar
    @@ -164,15 +164,15 @@ make' root siteName prefix nsfw _dataDir dir
    - $6.artistSection + $artistSection - $6.descSection + $descSection - $6.updatesList + $updatesList - $6.linksList + $linksList - $6.tagsList + $tagsList
    @@ -187,7 +187,7 @@ last' xs = if null xs then Nothing else Just $ last xs makeArtist :: Maybe Artist -> Builder makeArtist Nothing = "" -makeArtist (Just (Artist {name, url})) = [b|@0 +makeArtist (Just (Artist {name, url})) = [b|

    by

    $artistLink
    @@ -200,25 +200,25 @@ makeArtist (Just (Artist {name, url})) = [b|@0 makeDesc :: Desc -> Builder makeDesc NoDesc = "" -makeDesc (TextDesc desc) = [b|@0 +makeDesc (TextDesc desc) = [b|

    about

    - $4.desc + $desc
    |] -makeDesc (LongDesc fs) = [b|@0 +makeDesc (LongDesc fs) = [b|
    - $2.fields + $fields
    |] where fields = map makeField fs - makeField (DescField {name, text}) = [b|@0 + makeField (DescField {name, text}) = [b|

    $name

    - $4.text + $text
    |] @@ -262,25 +262,25 @@ makeButtonBar title images = makeNav "cat" $ fmap (uncurry makeCat) cats where makeNav :: CanBuild b => Text -> b -> Builder - makeNav cls inner = [b|@0 + makeNav cls inner = [b| |] - makeCat lbl imgs = [b|@0 + makeCat lbl imgs = [b|

    $lbl

    - $0.alts + $alts
    |] where alts = makeAlts imgs - makeAlts imgs = [b|@0 + makeAlts imgs = [b|
      - $2.elems + $elems
    |] where elems = fmap (uncurry altButton) imgs skipAll = if any (isJust . (.warning) . fst) images then - [b|@0 + [b|
    @@ -294,7 +294,7 @@ flatten = fmap (\(t, is) -> fmap (\(i, _) -> i {label = t}) is) altButton :: Image -> Text -> Builder -altButton img i = [b|@0 +altButton img i = [b| @@ -310,11 +310,11 @@ altButton img i = [b|@0 makeTags :: FilePath -> [Strict.Text] -> Builder makeTags undir tags = - if null tags then "" else [b|@0 + if null tags then "" else [b| |] @@ -325,18 +325,18 @@ makeTags undir tags = extLinks :: [Link] -> Builder extLinks links = - if null links then "" else [b|@0 + if null links then "" else [b| |] where linkList = map extLink links extLink :: Link -> Builder -extLink (Link {title, url}) = [b|@8 +extLink (Link {title, url}) = [b|
  • $title @@ -345,18 +345,18 @@ extLink (Link {title, url}) = [b|@8 makeUpdates :: [(Date, NonEmpty Update)] -> Builder makeUpdates ups = - if all (null . snd) ups then "" else [b|@4 + if all (null . snd) ups then "" else [b|

    updates

    - $8.updateList + $updateList
    |] where updateList = fmap (uncurry makeUpdate) ups makeUpdate :: Date -> NonEmpty Update -> Builder -makeUpdate date ups = [b|@8 +makeUpdate date ups = [b|
    $date'
    $desc |] where