lang/langfilter/Glosses.hs

module Glosses (glosses) where

import Lang
import LaantasImage
import Spans (abbrs)
import qualified Spans

import Text.Pandoc.Definition
import Text.Pandoc.Builder
import Text.Pandoc.Walk
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as Text


glosses :: Vars => Block -> IO [Block]
glosses = \case
  Div (i, cs, _) blocks | "glosses" `elem` cs -> do
    tables <- traverse glossTable blocks
    pure $
      [RawBlock (Format "html") $ "<figure" <> id <> classes <> ">"] ++
      catMaybes tables ++
      [RawBlock (Format "html") "</figure>"]
    where
      id = if i == "" then "" else " id=\"" <> i <> "\""
      classes = " class=\"" <> Text.unwords cs <> "\""
  b -> pure [b]

pattern Gloss l g w t = BulletList [[Plain l], [Plain g], [Plain w], [Plain t]]
pattern PGloss l p g w t =
  BulletList [[Plain l], [Plain p], [Plain g], [Plain w], [Plain t]]
pattern PNGloss l b n g w t =
  BulletList [[Plain l], [Plain b], [Plain n], [Plain g], [Plain w], [Plain t]]

glossTable :: Vars => Block -> IO (Maybe Block)
glossTable = \case
  Gloss   l     s g t -> Just <$> make l Nothing  Nothing  s g t
  PGloss  l p   s g t -> Just <$> make l (Just p) Nothing  s g t
  PNGloss l b n s g t -> Just <$> make l (Just b) (Just n) s g t
  HorizontalRule      -> pure Nothing
  b                   -> error $ "found " ++ show b ++ " in gloss section"
 where
  make l b n s g t = do
    let ℓ = length $ splitInlines s
    let colspecs = replicate ℓ (AlignDefault, ColWidthDefault)
    let l' = cell1 ℓ $ underlines $ noHash l
        b' = cell1 ℓ <$> b; n' = cell1 ℓ <$> n
    let ss = cells s; gs = cells g; t' = cell1 ℓ t
    img <- case ?lang of
      Just Lántas ->
        [Just $ cell1 ℓ [img] | img <- makeImage $ splitImage' $ stripInlines l]
      Nothing     -> pure Nothing
    pure $ Table ("", ["gloss"], []) (Caption Nothing []) colspecs
      (TableHead mempty [])
      [TableBody mempty (RowHeadColumns 0) [] $ concat
        [[row ["gloss-scr", "scr"] [i] | Just i <- [img]],
         [row ["gloss-lang", "lang"] [l']],
         [row ["gloss-pron", "ipa"] [b] | Just b <- [b']],
         [row ["gloss-pron", "ipa"] [n] | Just n <- [n']],
         [row ["gloss-split", "lang"] ss],
         [row ["gloss-gloss"] gs],
         [row ["gloss-trans"] [t']]]]
      (TableFoot mempty [])
  cell is = Cell mempty AlignDefault (RowSpan 1) (ColSpan 1) [Plain is]
  cell1 ℓ is = Cell mempty AlignDefault (RowSpan 1) (ColSpan ℓ) [Plain is]
  cells = map (cell . concatMap abbrs) . splitInlines
  row c = Row ("", c, [])

stripInlines :: [Inline] -> Text
stripInlines = query \case
  Str s -> s
  Space -> " "
  SoftBreak -> " "
  LineBreak -> " "
  _ -> ""

splitInlines :: [Inline] -> [Inlines]
splitInlines is = filter (not . null) $ go is where
  go [] = []
  go is =
    let (is1, is') = break (== Space) is in
    fromList is1 : splitInlines (dropWhile (== Space) is')

underlines :: [Inline] -> [Inline]
underlines = concatMap underlineStr . takeWhile (/= Str "|") where
  underlineStr = \case
    Str txt -> Spans.underlines txt
    i       -> [i]

noHash :: [Inline] -> [Inline]
noHash = walk \case
  Str str -> Str $ Text.filter (/= '#') str
  i       -> i