lang/langfilter/Main.hs

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