From 22185e30205ca125337daa4ef97d340315411c3b Mon Sep 17 00:00:00 2001 From: Rhiannon Morris Date: Mon, 13 Jul 2020 04:01:31 +0200 Subject: [PATCH] make quasiquoter for text building --- make-pages/BuildVar.hs | 160 ++++++++++++++++++++++++++++++ make-pages/SinglePage.hs | 187 +++++++++++++++++++----------------- make-pages/make-pages.cabal | 10 +- 3 files changed, 265 insertions(+), 92 deletions(-) create mode 100644 make-pages/BuildVar.hs diff --git a/make-pages/BuildVar.hs b/make-pages/BuildVar.hs new file mode 100644 index 0000000..ff5e368 --- /dev/null +++ b/make-pages/BuildVar.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE TemplateHaskell #-} +module BuildVar (b) where + +import Data.Char (isLower, isSpace, isDigit, isAlphaNum) +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Data.Text.Lazy.Builder + (Builder, fromText, fromString, singleton, toLazyText) +import Text.Read (readMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Lazy (toStrict) +import Data.Foldable +import Data.Semigroup + +data ChunkType = Lit | Var VarType deriving Show +data VarType = + Plain + | FromText + | Show + | Reindent !Int + | ReindentList !Int + deriving Show +type Chunk = (ChunkType, Text) + +indent :: Int -> Text -> Builder +indent i str + | Text.all isSpace str = "" + | otherwise = replicateB i ' ' <> fromText str + +reindent :: Int -> Text -> Builder +reindent i str = + fold $ mapInit (<> "\n") $ + map2 (fromText . dropIndent) (indent i . dropIndent) ls + where + ls = dropWhile (Text.all isSpace) $ Text.lines str + ls' = filter (Text.any $ not . isSpace) ls + + dropIndent = Text.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 _ = 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 + + -- $*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 (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 + go acc cs ('$' :. rest@(d :. _)) | isDigit d = + go "" ((Var ty, var) : lit acc : cs) rest3 + where + (n', c :. rest2) = Text.span isDigit rest + n = read $ Text.unpack n' + (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) = + 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, s') <- Text.span isAlphaNum s, + isLower (Text.head var) + = (var, s') + splitVar _ = error "invalid variable name" + + 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 = toStrict . toLazyText + + +chunksToExpQ :: [Chunk] -> ExpQ +chunksToExpQ cs = [|$expr :: Builder|] where + expr = foldl1 (\x y -> [|$x <> $y|]) $ map chunk1 cs + chunk1 (Lit, lit) = stringE $ Text.unpack lit + chunk1 (Var t, name) = case t of + Plain -> var + FromText -> [|fromText $var|] + Show -> [|fromString $ show $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, + quotePat = error "can't use in a pattern", + quoteType = error "can't use in a type", + quoteDec = error "can't use at top level" + } + + +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 #-} diff --git a/make-pages/SinglePage.hs b/make-pages/SinglePage.hs index 807ed91..7f968b4 100644 --- a/make-pages/SinglePage.hs +++ b/make-pages/SinglePage.hs @@ -1,6 +1,8 @@ module SinglePage (make) where import Info hiding (Text) +import BuildVar + import Control.Exception import qualified Data.Text as Strict import qualified Data.Text.Lazy as Lazy @@ -26,80 +28,88 @@ make includeNsfw = toLazyText . make' includeNsfw make' :: Bool -> Info -> Builder make' includeNsfw (Info {date, title, tags, nsfwTags, - description, images, links}) = - "\n" <> - "\n" <> - "\n" <> - "\n\n" <> - ifJust title (\t -> "" <> esc t <> "\n\n") <> - "
\n" <> - ifJust title (\t -> "

" <> esc t <> "

\n") <> - "

" <> formatDate date <> "

\n" <> - buttonBar title' includeNsfw images <> - "
\n\n" <> - "
\n" <> - " path0 <> "\">\n\n" <> - ifJust description (\d -> - "
\n" <> - "

description

\n" <> - indent 4 d <> - "
\n") <> "\n" <> - makeTags includeNsfw tags nsfwTags <> - extLinks includeNsfw links <> - "
\n\n" <> - "\n" - where - path0' = let Image {path} = head images in path - path0 = fromText path0' - title' = fromMaybe path0' title + description, images, links}) = [b|@0 + + + + $titleTag + +
+ $titleHeader +

$formattedDate + $buttonBar +

+ +
+ + + $descSection + + $tagsList + + $linksList +
+ + + |] + where + titleTag = ifJust title \t -> [b|$*t|] + titleHeader = ifJust title \t -> [b|

$*t

|] + formattedDate = formatDate date + buttonBar = makeButtonBar (fromMaybe path0 title) includeNsfw images + path0 = let Image {path} = head images in path + + descSection = ifJust description makeDesc + tagsList = makeTags includeNsfw tags nsfwTags + linksList = extLinks includeNsfw links + +makeDesc :: Strict.Text -> Builder +makeDesc desc = [b|@2 +
+

description

+ $4*desc +
+ |] ifJust :: Monoid b => Maybe a -> (a -> b) -> b ifJust x f = maybe mempty f x -esc :: Strict.Text -> Builder -esc = foldMap esc1 . Strict.unpack where - esc1 '<' = "<" - esc1 '>' = ">" - esc1 '&' = "&" - esc1 '"' = """ - esc1 '\'' = "&squot;" - esc1 c = singleton c - formatDate :: Day -> Builder formatDate = fromString . formatTime defaultTimeLocale "%e %#B %Y" -buttonBar :: Strict.Text -> Bool -> [Image] -> Builder -buttonBar title includeNsfw allImages = - if null images then - throw $ NoEligibleImages title - else if length images == 1 then - mempty - else - " \n" +makeButtonBar :: Strict.Text -> Bool -> [Image] -> Builder +makeButtonBar title includeNsfw allImages = + case length images of + 0 -> throw $ NoEligibleImages title + 1 -> "" + _ -> [b|@2 + + |] where images | includeNsfw = allImages | otherwise = filter (\Image {nsfw} -> not nsfw) allImages iimages = zip [0..] images + alts = map (uncurry altButton) iimages altButton :: Int -> Image -> Builder -altButton i (Image {label, path, nsfw}) = - " nsfwClass <> ">\n" <> - " checked <> "id=\"" <> idLabel <> "\" " <> - "name=variant autocomplete=off\n" <> - " value=\"" <> fromText path <> "\">\n" <> - " \n" +altButton i (Image {label, path, nsfw}) = [b|@6 + + + + |] where nsfwClass = if nsfw then " class=nsfw" else "" - checked = if i == 0 then "checked " else "" + checked = if i == 0 then " checked" else "" idLabel = escId label escId :: Strict.Text -> Builder @@ -109,41 +119,40 @@ escId = foldMap esc1 . Strict.unpack where | c < 'ΓΏ' && not (Char.isAlphaNum c || c == '-') = "_" | otherwise = singleton c -indent :: Int -> Strict.Text -> Builder -indent n txt = spaces <> go (Strict.unpack txt) where - go "" = mempty - go "\n" = "\n" - go ('\n':cs) = singleton '\n' <> spaces <> go cs - go (c:cs) = singleton c <> go cs - spaces = fromString $ replicate n ' ' - makeTags :: Bool -> [Strict.Text] -> [Strict.Text] -> Builder makeTags includeNsfw sfwTags nsfwTags = - if null tags then mempty else - "
\n" <> - "

tags

\n" <> - "
    \n" <> foldMap makeTag tags <> "
\n" <> - "
\n\n" + if null tags then "" else [b|@2 +
+

tags

+
    + $6.tagList +
+
+ |] where + tagList = map makeTag tags + makeTag t = [b|
  • $*t|] tags = List.nub $ if includeNsfw then sfwTags else sfwTags <> nsfwTags - makeTag t = "
  • " <> fromText t <> "\n" extLinks :: Bool -> [Link] -> Builder -extLinks includeNsfw links = - let links' = - if includeNsfw then links - else filter (\Link {nsfw} -> not nsfw) links in - if null links' then mempty else - "
    \n" <> - "

    links

    \n" <> - "
      \n" <> - foldMap extLink links' <> - "
    \n" <> - "
    \n" +extLinks includeNsfw allLinks = + if null links then "" else [b|@2 +
    +

    links

    +
      + $6.linkList +
    +
    + |] + where + links | includeNsfw = allLinks + | otherwise = filter (\Link {nsfw} -> not nsfw) allLinks + linkList = map extLink links extLink :: Link -> Builder -extLink (Link {title, url}) = - "
  • \n" <> - " fromText url <> "\">\n" <> - " " <> fromText title <> "\n" <> - " \n" +extLink (Link {title, url}) = [b|@6 +
  • + + $*title + + |] diff --git a/make-pages/make-pages.cabal b/make-pages/make-pages.cabal index 97a8b64..29064ec 100644 --- a/make-pages/make-pages.cabal +++ b/make-pages/make-pages.cabal @@ -9,7 +9,7 @@ maintainer: Rhiannon Morris executable make-pages hs-source-dirs: . main-is: Main.hs - other-modules: Info, SinglePage + other-modules: Info, SinglePage, BuildVar default-language: Haskell2010 default-extensions: BlockArguments, @@ -18,7 +18,10 @@ executable make-pages DuplicateRecordFields, LambdaCase, NamedFieldPuns, - OverloadedStrings + OverloadedStrings, + PatternSynonyms, + QuasiQuotes, + ViewPatterns build-depends: base >= 4.12.0.0 && < 4.15, containers ^>= 0.6.0.1, @@ -26,6 +29,7 @@ executable make-pages bytestring ^>= 0.10.8.2, text ^>= 1.2.3.1, HsYAML ^>= 0.2.1.0, - optparse-applicative ^>= 0.15.1.0 + optparse-applicative ^>= 0.15.1.0, + template-haskell ^>= 2.16.0.0 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N