remove the reindent stuff. it does not matter

This commit is contained in:
rhiannon morris 2024-08-18 07:37:58 +02:00
parent 47d0d6a2cb
commit 7745722009
7 changed files with 123 additions and 238 deletions

View file

@ -1,182 +1,70 @@
{-# 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
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
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
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"
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
addLit l cs = if null l then cs else Lit (reverse l) : cs
isIdChar c = isAlphaNum c || c `elem` ("_'" :: String)
lit s = (Lit, toStrictText s)
toExpQ cs = [|mconcat $(listE $ mapMaybe chunk1 cs) :: Builder|]
chunk1 (Lit lit) = Just $ stringE lit
chunk1 (Var name) = Just $ [|build $(varE $ mkName name)|]
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 '<' = "&lt;"
esc1 '>' = "&gt;"
esc1 '"' = "&quot;"
esc1 '\'' = "&apos;"
esc1 c = fromChar c
escAttr :: Strict.Text -> Builder
escAttr = foldMap esc1 . Strict.unpack where
esc1 c = fromMaybe (singleton c) $ lookup c
[('<', "&lt;"), ('>', "&gt;"), ('"', "&quot;"), ('\'', "&apos;")]
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 Strict.Text where build = fromText
instance CanBuild Lazy.Text where build = fromLazyText
instance CanBuild Char where build = singleton
instance CanBuild String where build = fromString
@ -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

View file

@ -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)
$gallery: $pages' $files' $rss $indexFile $$(MAKEPAGES)
$$(call gallery,$indexFile,$prefix)
$rss: $files' $indexFile $$(MAKEPAGES)
$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)
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)
$tmpPrefix/%.mk: $data_/%/info.yaml $$(MAKEPAGES)
$$(call depend-single,$prefix,$indexFile,$build,$data_,$flags)
$buildPrefix/%: $tmp/%
$buildPrefix/%: $tmp/%
$$(call copy,-l)
$buildPrefix/%: $data_/%
$buildPrefix/%: $data_/%
$$(call copy)
|]
|]
where
buildPrefix = build </> prefix
tmpPrefix = tmp </> prefix

View file

@ -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|
<!DOCTYPE html>
<html lang=en>
<meta charset=utf-8>
@ -42,11 +42,11 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0
<meta name=robots content='noai,noimageai'>
<script src=/script/gallery.js type=module></script>
$0.nsfwScript
$nsfwScript
<title>$title</title>
$0.nsfwDialog
$nsfwDialog
<div class=page>
<header>
@ -61,12 +61,12 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0
<div>
<h3>show only</h3>
<ul id=require class=filterlist>
$10.requireFilters
$requireFilters
</ul>
<h3>exclude</h3>
<ul id=exclude class=filterlist>
$10.excludeFilters
$excludeFilters
</ul>
<ul id=filterstuff>
@ -81,7 +81,7 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0
<main>
<ul class=grid>
$6.items
$items
</ul>
</main>
</div>
@ -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|
<li$hidden>
<input type=checkbox id="$id'" value="$tag"$checked>
<label for="$id'" data-count=$count>$tag</label>
@ -136,17 +136,17 @@ makeYearItems :: Bool -- ^ nsfw
-> Int -- ^ year
-> [(FilePath, Info)]
-> Builder
makeYearItems nsfw year infos = [b|@0
makeYearItems nsfw year infos = [b|
<li class="item year-marker" id="marker-$year">
<span class=year-text>$year'</span>
$0.items
$items
|]
where
items = map (uncurry $ makeItem nsfw) infos
year' = show year & foldMap \c -> [b|<span class=y>$c</span>|]
makeItem :: Bool -> FilePath -> Info -> Builder
makeItem nsfw file info@(Info {bg}) = [b|@0
makeItem nsfw file info@(Info {bg}) = [b|
<li class="item post$nsfw'" data-year=$year' data-updated="$updated'"
data-tags="$tags'">
<a href="$dir">

View file

@ -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|
<!DOCTYPE html>
<html lang=en>
<meta charset=utf-8>
@ -37,47 +37,47 @@ make' root (IndexInfo {title, desc, galleries, links, footer}) = [b|@0
</header>
<main>
$4.galleryList
$4.linkList
$galleryList
$linkList
</main>
$2.footer'
$footer'
</div>
|]
where
galleryList = if null galleries then "" else [b|@0
galleryList = if null galleries then "" else [b|
<nav aria-label="gallery list">
<ul id=gallery-list class=list>
$4.items
$items
</ul>
</nav>
|]
where items = map makeItem galleries
linkList = if null links then "" else [b|@0
linkList = if null links then "" else [b|
<nav aria-label="other links">
<ul id=link-list class=list>
$4.items
$items
</ul>
</nav>
|]
where items = map makeLink links
footer' = case footer of
Nothing -> ""
Just f -> [b|@0
Just f -> [b|
<footer>
$2.f
$f
</footer>
|]
url = [b|$root|]
makeItem :: GalleryInfo -> Builder
makeItem (GalleryInfo {title, desc, prefix, filters}) = [b|@0
makeItem (GalleryInfo {title, desc, prefix, filters}) = [b|
<li$nsfw><a href=$prefix title="$desc">$title</a></li>
|]
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|
<li$nsfw'><a href=$url>$title</a>
|]
where nsfw' = if nsfw then [b| class=nsfw|] else ""

View file

@ -16,7 +16,7 @@ script (Just _) = [b|<script src=/script/nsfw-warning.js type=module></script>|]
dialog :: Maybe What -> Builder
dialog Nothing = ""
dialog (Just what) = [b|@0
dialog (Just what) = [b|
<dialog id=nsfw-dialog>
<h1>cw: lewd art</h1>
<img src=/style/stop_hand.svg>

View file

@ -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|
<?xml version="1.0" encoding="UTF-8"?>
<rss version="2.0">
<channel>
@ -33,7 +33,7 @@ make' root name ginfo@(GalleryInfo {title, desc, prefix}) output infos = [b|@0
<description>$desc</description>
$selflink
$4.items
$items
</channel>
</rss>
|]
@ -48,7 +48,7 @@ make' root name ginfo@(GalleryInfo {title, desc, prefix}) output infos = [b|@0
Just o -> [b|<link href="$link/$o" rel="self" />|]
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|
<item>
<title>$title$suffix</title>
<link>$link</link>
@ -58,11 +58,11 @@ makeItem root prefix nsfw path info@(Info {title}) = [b|@4
</item>
|]
where
body = [b|@6
body = [b|
<description> <![CDATA[
$8.image
$8.artist
$8.desc
$image
$artist
$desc
]]> </description>
|]

View file

@ -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|
<figcaption id=cw aria-role=button tabindex=0>
<span id=cw-text>$w</span>
</figcaption>
@ -77,7 +77,7 @@ make' root siteName prefix nsfw _dataDir dir
let bgStyle = case bg of
Default -> ""
NoBorder -> [b|@0
NoBorder -> [b|
<style>
#mainfig {
background: transparent;
@ -86,7 +86,7 @@ make' root siteName prefix nsfw _dataDir dir
}
</style>
|]
Other col -> [b|@0
Other col -> [b|
<style> #mainfig { background: $col; } </style>
|]
@ -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|
<meta property=og:image content="$url/$path">
<meta name=twitter:card content=summary_large_image>
<meta name=twitter:image content="$url/$path">
|]
Just (PThumb path) -> [b|@0
Just (PThumb path) -> [b|
<meta property=og:image content="$url/$path">
<meta name=twitter:card content=summary>
|]
Nothing -> throw $ NoThumb dir
pure [b|@0
pure [b|
<!DOCTYPE html>
<html lang=en>
<meta charset=utf-8>
@ -136,7 +136,7 @@ make' root siteName prefix nsfw _dataDir dir
$nsfwScript
$bgStyle
$0.prefetches
$prefetches
<title>$title</title>
@ -153,7 +153,7 @@ make' root siteName prefix nsfw _dataDir dir
</h2>
</header>
$2.buttonBar
$buttonBar
<main>
<figure id=mainfig>
@ -164,15 +164,15 @@ make' root siteName prefix nsfw _dataDir dir
</figure>
<div id=info>
$6.artistSection
$artistSection
$6.descSection
$descSection
$6.updatesList
$updatesList
$6.linksList
$linksList
$6.tagsList
$tagsList
</div>
</main>
</div>
@ -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|
<section id=desc class=info-section>
<h2>by</h2>
<div>$artistLink</div>
@ -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|
<section id=desc class=info-section>
<h2>about</h2>
<div>
$4.desc
$desc
</div>
</section>
|]
makeDesc (LongDesc fs) = [b|@0
makeDesc (LongDesc fs) = [b|
<section id=desc class=info-section>
$2.fields
$fields
</section>
|]
where
fields = map makeField fs
makeField (DescField {name, text}) = [b|@0
makeField (DescField {name, text}) = [b|
<h2>$name</h2>
<div>
$4.text
$text
</div>
|]
@ -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|
<nav id=alts class=$cls aria-label="alternate versions">
$2.inner
$2.skipAll
$inner
$skipAll
</nav> |]
makeCat lbl imgs = [b|@0
makeCat lbl imgs = [b|
<section>
<h3 class=alt-cat>$lbl</h3>
$0.alts
$alts
</section> |]
where alts = makeAlts imgs
makeAlts imgs = [b|@0
makeAlts imgs = [b|
<ul class="buttonbar bb-choice">
$2.elems
$elems
</ul> |]
where elems = fmap (uncurry altButton) imgs
skipAll =
if any (isJust . (.warning) . fst) images then
[b|@0
[b|
<div class=buttonbar id=skipAllDiv>
<input type=checkbox name=skipAll id=skipAll>
<label for=skipAll>skip warnings</label>
@ -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|
<li$nsfwClass>
<input type=radio name=variant id="$i" value="$path'"
data-link="$link"$warning'>
@ -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|
<nav id=tags class=info-section>
<h2>tags</h2>
<ul>
$4.tagList
$tagList
</ul>
</nav>
|]
@ -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|
<nav id=links class=info-section>
<h2>links</h2>
<ul>
$4.linkList
$linkList
</ul>
</nav>
|]
where linkList = map extLink links
extLink :: Link -> Builder
extLink (Link {title, url}) = [b|@8
extLink (Link {title, url}) = [b|
<li>
<a href="$url">
$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|
<section id=updates class=info-section>
<h2>updates</h2>
<dl>
$8.updateList
$updateList
</dl>
</section>
|]
where updateList = fmap (uncurry makeUpdate) ups
makeUpdate :: Date -> NonEmpty Update -> Builder
makeUpdate date ups = [b|@8
makeUpdate date ups = [b|
<dt>$date'
<dd>$desc
|] where