lang/langfilter/Spans.hs

95 lines
2.9 KiB
Haskell
Raw Normal View History

2021-05-20 16:15:24 -04:00
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
2023-10-30 04:43:05 -04:00
| Just ('\\', txt') <- Text.uncons txt -> pure $ Code attrs txt'
2021-06-03 23:38:15 -04:00
| 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'
2023-10-30 04:43:05 -04:00
| Just txt' <- enclosed "*" "*" txt -> pure $ mark txt'
i -> pure i
2023-10-30 04:43:05 -04:00
ipaA, ipaB, ipaN, abbr, mark :: Text -> Inline
2021-06-03 23:35:17 -04:00
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
2023-10-30 04:43:05 -04:00
mark txt = RawInline "html" $ "<mark>" <> txt <> "</mark>"
2021-06-03 23:38:15 -04:00
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, [])
2021-06-03 23:38:15 -04:00
enclosed :: Text -> Text -> Text -> Maybe Text
enclosed o c txt
2021-06-03 23:38:15 -04:00
| 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]