lang/langfilter/Glosses.hs

87 lines
3 KiB
Haskell
Raw Normal View History

module Glosses (glosses) where
import Lang
import LaantasImage
2021-05-20 16:15:24 -04:00
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)
2021-04-29 13:02:20 -04:00
import qualified Data.Text as Text
glosses :: Vars => Block -> IO [Block]
glosses = \case
2021-04-29 13:02:20 -04:00
Div (i, cs, _) blocks | "glosses" `elem` cs -> do
tables <- traverse glossTable blocks
pure $
2021-04-29 13:02:20 -04:00
[RawBlock (Format "html") $ "<figure" <> id <> classes <> ">"] ++
catMaybes tables ++
[RawBlock (Format "html") "</figure>"]
2021-04-29 13:02:20 -04:00
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')
2021-05-20 16:15:24 -04:00
underlines :: [Inline] -> [Inline]
underlines = concatMap \case
Str txt -> Spans.underlines txt
i -> [i]