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") $ " id <> classes <> ">"] ++ catMaybes tables ++ [RawBlock (Format "html") ""] 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