lang/langfilter/Main.hs

96 lines
2.7 KiB
Haskell
Raw Normal View History

2023-05-03 20:31:21 -04:00
{-# 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)
2023-05-03 20:31:21 -04:00
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 .
2022-03-16 13:30:46 -04:00
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
2023-05-03 20:31:21 -04:00
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
2022-03-16 13:30:46 -04:00
makeBlocks :: Block -> [Block]
2023-05-03 20:31:21 -04:00
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 <> "'>"
2023-05-03 20:31:21 -04:00
close = html $ "</" <> cls <> ">"
in
[open] ++ blks ++ [close]
2022-03-16 13:30:46 -04:00
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