93 lines
2.8 KiB
Haskell
93 lines
2.8 KiB
Haskell
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]
|