lang/langfilter/Main.hs
Rhiannon Morris 99f4d7eac0 fix attrs for implicit figures
the syntax `![caption](path){.class}` (when interpreted as an implicit
figure) attaches `class` to the `<img>` tag. this moves it to the
`<figure>`
2024-09-25 23:03:00 +02:00

95 lines
2.7 KiB
Haskell

{-# LANGUAGE TupleSections #-}
import Lang
import Ebnf
import Spans
import Glosses
import Text.Pandoc.Definition
import Text.Pandoc.JSON
import Text.Pandoc.Walk
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as Text
import Control.Applicative
import Control.Monad
import System.Environment
main :: IO ()
main = toJSONFilter filter where
filter p@(Pandoc (Meta m) _) = do
lang <- toLang $ Map.lookup "conlang" m
defColor <- getDefColor m
let ?lang = lang
let ?defColor = defColor
fmap (walk fixFigureClass .
walk makeEbnf .
walk makeQuotes .
walk (concatMap makeBlocks) .
walk inlineLetterList) $
walkM spans =<<
walkM (fmap concat . traverse glosses) p
getDefColor :: Map Text MetaValue -> IO Text
getDefColor m = do
res <- toText $ Map.lookup "lang-color" m
case res of
Just col -> pure col
Nothing -> do
env <- lookupEnv "LANG_COLOR"
pure $ maybe "black" Text.pack env
pluck :: Eq a => a -> [a] -> Maybe [a]
pluck _ [] = Nothing
pluck x (y:ys) | x == y = Just ys
| otherwise = (x :) <$> pluck x ys
pluck1 :: Eq a => [a] -> [a] -> Maybe (a, [a])
pluck1 [] _ = Nothing
pluck1 (x:xs) ys = (x,) <$> pluck x ys <|> pluck1 xs ys
fixFigureClass :: Block -> Block
fixFigureClass (Figure (_, c1, a1) cap [Plain [Image (i, c2, a2) alt path]]) =
Figure (i, c1 ++ c2, a1 ++ a2) cap [Plain [Image ("", [], []) alt path]]
fixFigureClass b = b
makeBlocks :: Block -> [Block]
makeBlocks (Div ("", clss, []) blks)
| Just (cls, rest) <- pluck1 ["figure", "aside"] clss =
let html = RawBlock $ Format "html"
open = if null rest then
html $ "<" <> cls <> ">"
else
html $ "<" <> cls <> " class='" <> Text.unwords rest <> "'>"
close = html $ "</" <> cls <> ">"
in
[open] ++ blks ++ [close]
makeBlocks b = [b]
makeQuotes :: Block -> Block
makeQuotes para@(Para b) = fromMaybe para $ do
inner <- split b
return (BlockQuote [Para inner])
where
isDelim str = str == "\"\"\"" || str == "““”" -- lol
split (Str begin:SoftBreak:rest) = guard (isDelim begin) *> checkEnd rest
split _ = empty
checkEnd [SoftBreak, Str end] = [] <$ guard (isDelim end)
checkEnd (start:rest) = (start :) <$> checkEnd rest
checkEnd _ = empty
makeQuotes other = other
inlineLetterList :: Block -> Block
inlineLetterList (Div a@(_, cs, _) blks)
| "letter-list" `elem` cs = Div a (walk go blks)
where
go (Para xs) = Plain xs
go b = b
inlineLetterList b = b