lang/langfilter/lib/Spans.hs

module Spans (spans, ipaB, ipaN, abbr, abbrs, underlines) where

import LaantasImage hiding (text)
import Lang

import Text.Pandoc.Definition hiding (Image)
import Text.Pandoc.Builder hiding (Image)
import Data.Char (isUpper, isDigit)
import Data.Text (Text)
import qualified Data.Text as Text


spans :: Vars => Inline -> Inline
spans = \case
  Code attrs txt
    | Just ('\\', txt') <- Text.uncons txt        -> Code attrs txt'
    | Just txt'         <- enclosed "⫽"  "⫽"  txt -> ipaA txt'
    | Just txt'         <- enclosed "//" "//" txt -> ipaA txt'
    | Just _            <- enclosed "/"  "/"  txt -> ipaB txt
    | Just _            <- enclosed "["  "]"  txt -> ipaN txt
    | Just txt'         <- enclosed "{"  "}"  txt -> lang txt'
    | Just txt'         <- enclosed "!"  "!"  txt -> abbr txt'
    | Just txt'         <- enclosed "*"  "*"  txt -> mark txt'
    | Just txt'         <- enclosed "@"  "@"  txt -> dfn txt'
  i -> i

ipaA, ipaB, ipaN, abbr, mark :: Text -> Inline
ipaA = Span (cls ["ipa", "ipa-arch"])   . text' . surround "⫽"
ipaB = Span (cls ["ipa", "ipa-broad"])  . text'
ipaN = Span (cls ["ipa", "ipa-narrow"]) . text'
abbr = Span (cls ["abbr"])              . text' . endash
mark txt = RawInline "html" $ "<mark>" <> txt <> "</mark>"
dfn txt = RawInline "html" $ "<dfn>" <> txt <> "</dfn>"

surround :: Text -> Text -> Text
surround s txt = s <> txt <> s

text' :: Text -> [Inline]
text' = toList . text

lang :: Vars => Text -> Inline
lang = Span (cls ["lang"]) . lang'

lang' :: Vars => Text -> [Inline]
lang' txt₀ = case ?lang of
  Just Lántas
    | Just li@(Item {..}) <- splitItem txt₀,
      let label = Span (cls ["text"]) $ underlines title ->
        if showText then [makeItem li, Str " ", label] else [makeItem li]
  _ -> underlines txt₀

notBrace :: Char -> Bool
notBrace c = c /= '{' && c /= '}'

underlines :: Text -> [Inline]
underlines txt = case Text.uncons txt of
  Nothing          -> []
  Just ('{', txt') -> RawInline "html" "<u>"  : underlines txt'
  Just ('}', txt') -> RawInline "html" "</u>" : underlines txt'
  _                -> Str a : underlines b
    where (a, b) = Text.span notBrace txt

cls :: [Text] -> Attr
cls cs = ("", cs, [])


enclosed :: Text -> Text -> Text -> Maybe Text
enclosed o c txt
  | Text.length txt >= ℓo + ℓc,
    Text.take    ℓo txt == o,
    Text.takeEnd ℓc txt == c
  = Just $ Text.drop ℓo $ Text.dropEnd ℓc txt
  where ℓo = Text.length o; ℓc = Text.length c
enclosed _ _ _ = Nothing


endash :: Text -> Text
endash = Text.map \case '-' -> '–'; '_' -> ' '; c -> c


abbrs :: Inline -> [Inline]
abbrs (Str txt) = go $ endash txt where
  go "" = []
  go txt
    | (l, r) <- Text.span isAbbr txt,
      not $ Text.null l
    = abbr' l : go r
    | (l, r) <- Text.break isAbbr txt
    = Str l : go r
  abbr' txt = if Text.any (not . isDigit) txt then abbr txt else Str txt
  isAbbr c = isUpper c || isDigit c || c `elem` (",.;\\[]" :: String)
abbrs i = [i]