lang/langfilter/Glosses.hs

87 lines
3 KiB
Haskell
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

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 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]