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 qualified Data.Map as Map
import Control.Applicative
import qualified Data.Text as Text


main :: IO ()
main = toJSONFilter filter where
  filter p@(Pandoc (Meta m) _) = do
    lang' <- toLang $ Map.lookup "conlang" m
    let ?lang = lang'
    fmap (walk makeEbnf .
          walk (concatMap makeBlocks) .
          walk inlineLetterList) $
      walkM spans =<<
      walkM (fmap concat . traverse glosses) p


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


makeBlocks :: Block -> [Block]
makeBlocks (Div ("", clss, []) blks)
  | Just (cls, rest) <- pluck1 ["figure", "aside"] clss =
      let html  = RawBlock $ Format "html"
          open  = html $ "<" <> cls <> " class='" <> Text.unwords rest <> "'>"
          close = html $ "</" <> cls <> ">"
      in
      [open] ++ blks ++ [close]
makeBlocks b = [b]


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