remove the reindent stuff. it does not matter

2024-08-18 07:37:58 +02:00 · 2024-08-18 07:37:58 +02:00 · 7745722009
commit 7745722009
parent 47d0d6a2cb
7 changed files with 123 additions and 238 deletions
--- a/make-pages/BuilderQQ.hs
+++ b/make-pages/BuilderQQ.hs
@ -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
--- a/make-pages/Depend.hs
+++ b/make-pages/Depend.hs
@ -56,7 +56,7 @@ 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
+               indexFile infos' build data_ tmp = [b|
 $index: $gallery

 $gallery: $pages' $files' $rss $indexFile $$(MAKEPAGES)
@ -96,7 +96,7 @@ makeRules :: FilePath -- ^ prefix
          -> FilePath -- ^ data dir
          -> FilePath -- ^ tmp dir
          -> Builder
-makeRules prefix indexFile filters build data_ tmp = [b|@0
+makeRules prefix indexFile filters build data_ tmp = [b|
 $buildPrefix/%/index.html: $data_/%/info.yaml $$(MAKEPAGES)
 	$$(call single,$data_,$prefix,$indexFile,$flags)

--- 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|
    <!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">
--- 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|
    <!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 ""
--- a/make-pages/NsfwWarning.hs
+++ b/make-pages/NsfwWarning.hs
@ -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>
--- 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|
    <?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>
    |]

--- 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|
        <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