lang/langfilter/lib/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
import Data.Data (toConstr)


glosses :: Vars => Block -> [Block]
glosses = \case
  Div (i, cs, _) blocks | "glosses" `elem` cs ->
    let tables = map glossTable blocks in
    [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 -> [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 -> 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      -> Nothing
  BulletList xs | let ℓ = length xs, ℓ < 4 || ℓ > 6 ->
    fail $ "found list of length " ++ show ℓ ++
            " in gloss section (missing `---`?)"
  b -> fail $ "found unexpected " ++ show (toConstr b) ++ " in gloss section"
 where
  make l b n s g t =
    let ℓ = length $ splitInlines s
        colspecs = replicate ℓ (AlignDefault, ColWidthDefault)
        l' = cell1 ℓ $ underlines $ noHash l
        b' = cell1 ℓ <$> b; n' = cell1 ℓ <$> n
        ss = cells s; gs = cells g; t' = cell1 ℓ t
        img = case ?lang of
          Just Lántas -> Just $ cell1 ℓ [makeItem $ splitItem' $ stripInlines l]
          Nothing     -> Nothing
    in
    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