lang/langfilter/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 -> IO Inline
spans = \case
  Code attrs txt
    | Just ('\\', txt') <- Text.uncons txt        -> pure $ Code attrs txt'
    | Just txt'         <- enclosed "⫽"  "⫽"  txt -> pure $ ipaA txt'
    | Just txt'         <- enclosed "//" "//" txt -> pure $ ipaA txt'
    | Just _            <- enclosed "/"  "/"  txt -> pure $ ipaB txt
    | Just _            <- enclosed "["  "]"  txt -> pure $ ipaN txt
    | Just txt'         <- enclosed "{"  "}"  txt -> lang txt'
    | Just txt'         <- enclosed "!"  "!"  txt -> pure $ abbr txt'
    | Just txt'         <- enclosed "*"  "*"  txt -> pure $ mark txt'
    | Just txt'         <- enclosed "@"  "@"  txt -> pure $ dfn txt'
  i -> pure 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 -> IO Inline
lang = fmap (Span (cls ["lang"])) . lang'

lang' :: Vars => Text -> IO [Inline]
lang' txt₀ = case ?lang of
  Just Lántas
    | Just li@(Image {..}) <- splitImage txt₀ ->
        if showText then do
          img <- makeImage li
          pure $ [img, Span (cls ["text"]) $ underlines title]
        else
          pure <$> makeImage li
  _ ->
    pure $ 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.length txt == 1 then Str txt else abbr txt
  isAbbr c = isUpper c || isDigit c || c `elem` (",.;\\[]" :: String)
abbrs i = [i]