{-# LANGUAGE OverloadedStrings #-}
module HSP.XML.PCDATA (
escape
, escaper
, xmlEscapeChars
) where
import Data.Monoid ((<>), mempty)
import Data.Text.Lazy (Text, uncons)
import qualified Data.Text.Lazy as Text
import Data.Text.Lazy.Builder (Builder, fromLazyText, singleton)
escape :: Text -> Builder
escape :: Text -> Builder
escape = [(Char, Builder)] -> Text -> Builder
escaper [(Char, Builder)]
xmlEscapeChars
escaper :: [(Char, Builder)]
-> Text
-> Builder
escaper :: [(Char, Builder)] -> Text -> Builder
escaper [(Char, Builder)]
escapeTable = Text -> Builder
go
where
escapeChars :: [Char]
escapeChars = ((Char, Builder) -> Char) -> [(Char, Builder)] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map (Char, Builder) -> Char
forall a b. (a, b) -> a
fst [(Char, Builder)]
escapeTable
go :: Text -> Builder
go Text
txt | Text -> Bool
Text.null Text
txt = Builder
forall a. Monoid a => a
mempty
go Text
txt =
case (Char -> Bool) -> Text -> (Text, Text)
Text.break (Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
escapeChars) Text
txt of
(Text
hd,Text
tl) ->
case Text -> Maybe (Char, Text)
uncons Text
tl of
Maybe (Char, Text)
Nothing -> Text -> Builder
fromLazyText Text
hd
(Just (Char
c, Text
tl')) -> Text -> Builder
fromLazyText Text
hd Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [(Char, Builder)] -> Char -> Builder
pChar [(Char, Builder)]
escapeTable Char
c Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
go Text
tl'
pChar :: [(Char, Builder)]
-> Char
-> Builder
pChar :: [(Char, Builder)] -> Char -> Builder
pChar [(Char, Builder)]
escapeChars Char
c =
case Char -> [(Char, Builder)] -> Maybe Builder
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Char
c [(Char, Builder)]
escapeChars of
Maybe Builder
Nothing -> Char -> Builder
singleton Char
c
Just Builder
s -> Char -> Builder
singleton Char
'&' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
';'
xmlEscapeChars :: [(Char, Builder)]
xmlEscapeChars :: [(Char, Builder)]
xmlEscapeChars = [
(Char
'&', Builder
"amp" ),
(Char
'\"', Builder
"quot" ),
(Char
'\'', Builder
"apos" ),
(Char
'<', Builder
"lt" ),
(Char
'>', Builder
"gt" )
]