From 2adee9ee8e560936474c50798c4b10f755c0a4b5 Mon Sep 17 00:00:00 2001 From: Rhiannon Morris Date: Sun, 30 Aug 2020 19:13:40 +0200 Subject: [PATCH] use class instead of twigils for builder --- make-pages/BuilderQQ.hs | 114 +++++++++++++++--------------------- make-pages/Depend.hs | 26 ++++---- make-pages/GalleryPage.hs | 36 ++++++------ make-pages/IndexPage.hs | 24 ++++---- make-pages/Info.hs | 3 +- make-pages/RSS.hs | 18 +++--- make-pages/SinglePage.hs | 71 +++++++++++----------- make-pages/make-pages.cabal | 3 + 8 files changed, 140 insertions(+), 155 deletions(-) diff --git a/make-pages/BuilderQQ.hs b/make-pages/BuilderQQ.hs index 7c05879..6f8eb78 100644 --- a/make-pages/BuilderQQ.hs +++ b/make-pages/BuilderQQ.hs @@ -8,12 +8,14 @@ where import Data.Char (isLower, isSpace, isDigit, isAlphaNum) import Language.Haskell.TH import Language.Haskell.TH.Quote +import Data.List (intersperse) import Data.Maybe (mapMaybe) import Data.Text.Lazy.Builder - (Builder, fromText, fromString, singleton, toLazyText) + (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 Data.Text.Lazy (toStrict) import Data.Foldable import Data.Semigroup @@ -21,36 +23,31 @@ import Data.Semigroup data ChunkType = Lit | Var VarType deriving Show data VarType = Plain - | FromText - | FromString - | FromChar - | Show | Reindent !Int - | ReindentList !Int deriving Show type Chunk = (ChunkType, Text) -indent :: Int -> Text -> Builder +indent :: Int -> LText.Text -> Builder indent i str - | Text.all isSpace str = "" - | otherwise = replicateB i ' ' <> fromText str + | LText.all isSpace str = "" + | otherwise = replicateB i ' ' <> fromLazyText str -reindent :: Int -> Text -> Builder -reindent i str = - fold $ mapInit (<> "\n") $ - map2 (fromText . dropIndent) (indent i . dropIndent) ls +reindentB :: Int -> Builder -> Builder +reindentB i (toLazyText -> str) = + fold $ intersperse "\n" $ + map2 (fromLazyText . dropIndent) (indent i . dropIndent) ls where - ls = dropWhile (Text.all isSpace) $ Text.lines str - ls' = filter (Text.any $ not . isSpace) ls + ls = dropWhile (LText.all isSpace) $ LText.lines str + ls' = filter (LText.any $ not . isSpace) ls - dropIndent = Text.drop minIndent + dropIndent = LText.drop minIndent minIndent = getMin $ option 0 id $ foldMap (Option . 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 (' ' :.. cs) = go (n + 1) cs + go n ('\t' :.. cs) = go (((n `mod` 8) + 1) * 8) cs go n _ = n map2 _ _ [] = [] @@ -68,38 +65,12 @@ chunks = reverse . go "" [] . trimEnd where -- $$: expands to one $ go acc cs ('$' :. '$' :. rest) = go (acc <> "$") cs rest - -- $*var: expands to (fromText $var) - go acc cs ('$' :. '*' :. rest) = - go "" ((Var FromText, var) : lit acc : cs) rest2 - where (var, rest2) = splitVar rest - - -- $@var: expands to (fromString $var) - go acc cs ('$' :. '@' :. rest) = - go "" ((Var FromString, var) : lit acc : cs) rest2 - where (var, rest2) = splitVar rest - - -- $'var: expands to (singleton $var) - go acc cs ('$' :. '\'' :. rest) = - go "" ((Var FromChar, var) : lit acc : cs) rest2 - where (var, rest2) = splitVar rest - - -- $^var: expands to (fromString (show $var)) - go acc cs ('$' :. '^' :. rest) = - go "" ((Var Show, var) : lit acc : cs) rest2 - where (var, rest2) = splitVar rest - - -- $n*var (n a number): expands to builder var indented by n - -- $n.var: same but var is a list + -- $n.var (n a number): expands to builder var indented by n go acc cs ('$' :. rest@(d :. _)) | isDigit d = - go "" ((Var ty, var) : lit acc : cs) rest3 + go "" ((Var (Reindent n), var) : lit acc : cs) rest3 where - (n', c :. rest2) = Text.span isDigit rest - n = read $ Text.unpack n' + ((read . Text.unpack -> n), '.' :. rest2) = Text.span isDigit rest (var, rest3) = splitVar rest2 - ty = case c of - '*' -> Reindent n - '.' -> ReindentList n - _ -> error $ "unknown reindent type " ++ show c -- $var: expands to that var's contents go acc cs ('$' :. rest) = @@ -132,35 +103,18 @@ toStrictText = toStrict . toLazyText chunksToExpQ :: [Chunk] -> ExpQ -chunksToExpQ cs = [|mconcat $es|] where +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 -> var - FromText -> [|fromText $var|] - FromString -> [|fromString $var|] - FromChar -> [|singleton $var|] - Show -> [|fromString $ show $var|] + Plain -> [|build $var|] Reindent n -> [|reindent n $var|] - ReindentList n -> [|reindentList n $var|] where var = varE (mkName $ Text.unpack name) -reindentList :: Int -> [Builder] -> Builder -reindentList n = fold . mapInit (<> "\n") . mapTail (replicateB n ' ' <>) - replicateB :: Int -> Char -> Builder replicateB n c = fromText $ Text.replicate n $ Text.singleton c -mapInit :: (a -> a) -> [a] -> [a] -mapInit _ [] = [] -mapInit _ [x] = [x] -mapInit f (x:xs) = f x : mapInit f xs - -mapTail :: (a -> a) -> [a] -> [a] -mapTail _ [] = [] -mapTail f (x:xs) = x : map f xs - b :: QuasiQuoter b = QuasiQuoter { quoteExp = chunksToExpQ . chunksWithReindent, @@ -181,6 +135,12 @@ pattern c :. t <- (Text.uncons -> Just (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 @@ -198,3 +158,25 @@ escId = foldMap esc1 . Text.unpack where | otherwise = fromChar c latin1Special c = c <= 'ΓΏ' && not (isAlphaNum c) && c /= '-' + + +class CanBuild a where + build :: a -> Builder + reindent :: Int -> a -> Builder + reindent i = reindentB i . build + +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 + +newtype ShowBuild a = ShowBuild a deriving newtype Show +instance Show a => CanBuild (ShowBuild a) where build = build . show + +deriving via ShowBuild Int instance CanBuild Int +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 diff --git a/make-pages/Depend.hs b/make-pages/Depend.hs index 9b5d035..df3db9c 100644 --- a/make-pages/Depend.hs +++ b/make-pages/Depend.hs @@ -23,7 +23,7 @@ dependSingle yamlDir info prefix build nsfw = dependSingle' :: FilePath -> Info -> FilePath -> FilePath -> Bool -> Builder dependSingle' yamlDir info prefix build nsfw = - [b|$@page: $@deps $$(MAKEPAGES)|] + [b|$page: $deps $$(MAKEPAGES)|] where images = if nsfw then #images info else #sfwImages info @@ -50,13 +50,13 @@ dependGallery' :: GalleryInfo -> FilePath -> [(FilePath, Info)] -> FilePath -> FilePath -> FilePath -> Builder dependGallery' (GalleryInfo {prefix, filters}) indexFile infos' build data_ tmp = [b|@0 - $@index: $@gallery + $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 @@ -80,7 +80,7 @@ dependGallery' (GalleryInfo {prefix, filters}) inc d = tmp prefix takeDirectory d <.> "mk" incFiles = unwords $ map inc files - incs = if null infos then "" else [b|include $@incFiles|] + incs = if null infos then "" else [b|include $incFiles|] makeRules :: FilePath -- ^ prefix -> GalleryFilters @@ -89,16 +89,16 @@ makeRules :: FilePath -- ^ prefix -> FilePath -- ^ tmp dir -> Builder makeRules prefix filters build data_ tmp = [b|@0 - $@buildPrefix/%/index.html: $@data_/%/info.yaml $$(MAKEPAGES) - $$(call single,$@data_,$@prefix,$flags) + $buildPrefix/%/index.html: $data_/%/info.yaml $$(MAKEPAGES) + $$(call single,$data_,$prefix,$flags) - $@tmpPrefix/%.mk: $@data_/%/info.yaml $$(MAKEPAGES) - $$(call depend-single,$@prefix,$@build,$@data_,$flags) + $tmpPrefix/%.mk: $data_/%/info.yaml $$(MAKEPAGES) + $$(call depend-single,$prefix,$build,$data_,$flags) - $@buildPrefix/%: $@tmp/% + $buildPrefix/%: $tmp/% $$(call copy,-l) - $@buildPrefix/%: $@data_/% + $buildPrefix/%: $data_/% $$(call copy) |] where diff --git a/make-pages/GalleryPage.hs b/make-pages/GalleryPage.hs index 5b16cf0..f9c3263 100644 --- a/make-pages/GalleryPage.hs +++ b/make-pages/GalleryPage.hs @@ -28,20 +28,20 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0 - - - - + + + + - $*title + $title
-

$*title

+

$title

rss

@@ -74,7 +74,7 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0 |] where @@ -100,7 +100,7 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0 nsfw = #nsfw filters /= NoNsfw - url = [b|$*root/$@prefix|] + url = [b|$root/$prefix|] imagepath0 | (_, (p0, i0) : _) : _ <- infosByYear = getThumb (takeDirectory p0) i0 | otherwise = "/style/card.png" @@ -108,13 +108,13 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0 makeFilter :: Text -> HashSet Text -> Text -> Int -> Builder makeFilter prefix initial tag _count = [b|@8
  • - - + + |] where - id' = [b|$*prefix$&_$tag'|] + id' = [b|$prefix$&_$tag'|] tag' = escId tag - checked = if HashSet.member tag initial then " checked" else "" + checked = if HashSet.member tag initial then [b| checked|] else "" makeYearItems :: Bool -- ^ nsfw -> Integer -- ^ year @@ -127,21 +127,21 @@ makeYearItems nsfw year infos = [b|@4 |] where items = map (uncurry $ makeItem nsfw) infos - year' = show year & foldMap \c -> [b|$'c|] + year' = show year & foldMap \c -> [b|$c|] makeItem :: Bool -> FilePath -> Info -> Builder makeItem nsfw file info@(Info {title, bg}) = [b|@4
  • - - + + -
    $*title
    +
    $title
    |] where dir = takeDirectory file thumb = getThumb dir info - nsfw' = if nsfw && #anyNsfw info then " nsfw" else "" + nsfw' = if nsfw && #anyNsfw info then [b| nsfw|] else "" tags' = fold $ intersperse ";" $ map fromText $ tagsFor nsfw info - bgStyle = ifJust bg \col -> [b| style="background: $*col"|] + bgStyle = ifJust bg \col -> [b| style="background: $col"|] diff --git a/make-pages/IndexPage.hs b/make-pages/IndexPage.hs index e77f3ba..30db347 100644 --- a/make-pages/IndexPage.hs +++ b/make-pages/IndexPage.hs @@ -17,18 +17,18 @@ make' root (IndexInfo {title, desc, galleries, links, footer}) = [b|@0 - - - - + + + + - $*title + $title
    -

    $*title

    +

    $title

    @@ -59,22 +59,22 @@ make' root (IndexInfo {title, desc, galleries, links, footer}) = [b|@0 Nothing -> "" Just f -> [b|@0
    - $2*f + $2.f
    |] - url = [b|$*root|] + url = [b|$root|] makeItem :: GalleryInfo -> Builder makeItem (GalleryInfo {title, desc, prefix, filters}) = [b|@6 - $*title
    • + $title |] - where nsfw = if hasNsfw filters then " class=nsfw" else "" + where nsfw = if hasNsfw filters then [b| class=nsfw|] else "" makeLink :: Link -> Builder makeLink (Link {title, url, nsfw}) = [b|@6 - $*title + $title |] - where nsfw' = if nsfw then " class=nsfw" else "" + where nsfw' = if nsfw then [b| class=nsfw|] else "" hasNsfw :: GalleryFilters -> Bool hasNsfw (GalleryFilters {nsfw}) = nsfw /= NoNsfw diff --git a/make-pages/Info.hs b/make-pages/Info.hs index 2a1cce9..6cebea4 100644 --- a/make-pages/Info.hs +++ b/make-pages/Info.hs @@ -21,6 +21,7 @@ import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import qualified Data.Map.Strict as Map import Data.Maybe (isJust, isNothing) +import Data.List (nub) import Data.Ord (comparing) import Data.String (IsString) import Data.Text (Text) @@ -108,7 +109,7 @@ descFor :: Bool -> Info -> Maybe Text descFor nsfw (Info {desc, nsfwDesc}) = desc <> (guard nsfw *> nsfwDesc) tagsFor :: Bool -> Info -> [Text] -tagsFor nsfw i = if nsfw then #tags i <> #nsfwTags i else #tags i +tagsFor nsfw i = if nsfw then nub (#tags i <> #nsfwTags i) else #tags i imagesFor :: Bool -> Info -> [Image] imagesFor nsfw = if nsfw then #images else #sfwImages diff --git a/make-pages/RSS.hs b/make-pages/RSS.hs index 44b2cb4..370ee64 100644 --- a/make-pages/RSS.hs +++ b/make-pages/RSS.hs @@ -27,9 +27,9 @@ make' root (GalleryInfo {title, desc, prefix}) output infos = [b|@0 - $*title + $title $link - $*desc + $desc $selflink $4.items @@ -37,16 +37,16 @@ make' root (GalleryInfo {title, desc, prefix}) output infos = [b|@0 |] where - link = [b|$*root/$@prefix|] + link = [b|$root/$prefix|] items = map (uncurry $ makeItem root prefix) $ sortOn (Down . #second) infos selflink = case output of Nothing -> "" - Just o -> [b||] + Just o -> [b||] makeItem :: Strict.Text -> FilePath -> FilePath -> Info -> Builder makeItem root prefix path (Info {title, desc, date, artist}) = [b|@4 - $*title + $title $link $link $descArtist' @@ -55,11 +55,11 @@ makeItem root prefix path (Info {title, desc, date, artist}) = [b|@4 |] where dir = takeDirectory path - link = [b|$*root/$@prefix/$@dir|] + link = [b|$root/$prefix/$dir|] artist' = ifJust artist \case - Artist {name, url = Nothing} -> [b|

    by $*name|] - Artist {name, url = Just url} -> [b|

    by $*name|] - desc' = ifJust desc \d -> [b|$10*d|] + Artist {name, url = Nothing} -> [b|

    by $name|] + Artist {name, url = Just url} -> [b|

    by $name|] + desc' = ifJust desc \d -> [b|$10.d|] descArtist' = if isJust desc || isJust artist then [b|@6 |] + let makePrefetch (Image {path}) = [b||] let prefetches = map (makePrefetch . #first) $ tail images let warning' = ifJust (#warning image0) \w -> [b|@4

    - cw: $*w + cw: $w
    |] let bgStyle = ifJust bg \col -> [b|@0 - + |] - let url = [b|$*root/$@prefix/$@dir|] + let url = [b|$root/$prefix/$dir|] let desc = case artist of - Just (Artist {name}) -> [b|by $*name|] + Just (Artist {name}) -> [b|by $name|] Nothing -> "by niss" let thumb = getThumb "" info @@ -82,10 +82,10 @@ make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do - - + + - + @@ -95,10 +95,10 @@ make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do $0.prefetches - $*title + $title
    -

    $*title

    +

    $title

    $artistTag

    $formattedDate

    @@ -106,11 +106,10 @@ make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do $buttonBar
    -
    +
    $warning' - - + +
    @@ -124,7 +123,7 @@ make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do
    |] @@ -133,15 +132,15 @@ makeArtist (Artist {name, url}) = [b|

    by $artistLink

    |] where artistLink = case url of - Just u -> [b|$*name|] - Nothing -> [b|$*name|] + Just u -> [b|$name|] + Nothing -> [b|$name|] makeDesc :: Maybe Strict.Text -> Builder makeDesc mdesc = ifJust mdesc \desc -> [b|@4

    about

    - $8*desc + $8.desc
    |] @@ -163,18 +162,18 @@ makeButtonBar title images = altButton :: Int -> Image -> Size -> Builder altButton i (Image {label, path, nsfw, warning}) (Size {width, height}) = [b|@4 - - + + |] where - nsfwClass = if nsfw then " class=nsfw" else "" - nsfwLabelClass = if nsfw then " class=nsfw-label" else "" - checked = if i == 0 then " checked" else "" + nsfwClass = if nsfw then [b| class=nsfw|] else "" + nsfwLabelClass = if nsfw then [b| class=nsfw-label|] else "" + checked = if i == 0 then [b| checked|] else "" idLabel = escId label path' = pageFile path - warning' = ifJust warning \w -> [b| data-warning="$*w"|] + warning' = ifJust warning \w -> [b| data-warning="$w"|] makeTags :: FilePath -> [Strict.Text] -> Builder makeTags undir tags = @@ -188,7 +187,7 @@ makeTags undir tags = |] where tagList = map makeTag tags - makeTag tag = [b|
  • $*tag|] + makeTag tag = [b|
  • $tag|] where tag' = escId tag extLinks :: [Link] -> Builder @@ -206,13 +205,13 @@ extLinks links = extLink :: Link -> Builder extLink (Link {title, url}) = [b|@8
  • - - $*title + + $title |] formatDate :: Day -> Builder -formatDate date = [b|$*week $day $*month $^year|] where +formatDate date = [b|$week $day $month $year|] where (year, month', day') = Time.toGregorian date week' = Time.dayOfWeek date day = nth day' @@ -222,12 +221,12 @@ formatDate date = [b|$*week $day $*month $^year|] where week = Strict.words "mon tue wed thu fri sat sun" !! (fromEnum week' - 1) nth :: Int -> Builder -nth n = [b|$^n$suf|] where - suf | n >= 10, n <= 19 = "th" - | n `mod` 10 == 1 = "st" - | n `mod` 10 == 2 = "nd" - | n `mod` 10 == 3 = "rd" - | otherwise = "th" +nth n = [b|$n$suf|] where + suf | n >= 10, n <= 19 = [b|th|] + | n `mod` 10 == 1 = [b|st|] + | n `mod` 10 == 2 = [b|nd|] + | n `mod` 10 == 3 = [b|rd|] + | otherwise = [b|th|] data Size = Size {width, height :: !Int} deriving (Eq, Show) diff --git a/make-pages/make-pages.cabal b/make-pages/make-pages.cabal index 651c4cb..0e127f1 100644 --- a/make-pages/make-pages.cabal +++ b/make-pages/make-pages.cabal @@ -31,8 +31,10 @@ executable make-pages DataKinds, DeriveAnyClass, DerivingStrategies, + DerivingVia, DuplicateRecordFields, FlexibleInstances, + GeneralizedNewtypeDeriving, LambdaCase, NamedFieldPuns, OverloadedLabels, @@ -41,6 +43,7 @@ executable make-pages PatternSynonyms, QuasiQuotes, RankNTypes, + StandaloneDeriving, TupleSections, TypeSynonymInstances, ViewPatterns