lang/langfilter/Spans.hs

92 lines
2.8 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 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'
i -> pure i
ipaA, ipaB, ipaN, abbr :: 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
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]