librarify langfilter too

langfilter/lib/LangFilter.hs

@@ -0,0 +1,90 @@
+module LangFilter where
+
+import Lang
+import Ebnf
+import Spans
+import Glosses
+
+import Text.Pandoc.Definition
+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
+
+
+langFilter :: Pandoc -> IO Pandoc
+langFilter p@(Pandoc (Meta m) _) = do
+  lang <- toLang $ Map.lookup "conlang" m
+  defColor <- getDefColor m
+  let ?lang = lang
+  let ?defColor = defColor
+  let f = map (walk spans . fixFigureClass . makeEbnf .
+               makeQuotes . letterList) .
+          concatMap (makeBlocks <=< glosses)
+  pure $ walk f 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 = Text.length str == 3 && Text.all isQuote str
+    isQuote c = c == '"' || c == '“' || c == '”'
+
+    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
+
+letterList :: Block -> Block
+letterList (Div a@(_, cs, _) blks)
+  | "letter-list" `elem` cs = Div a (walk go blks)
+ where
+  go (Para xs) = Plain xs
+  go b         = b
+letterList b = b