{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
module Symantic.XML.Text where
import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq)
import Data.String (IsString(..), String)
import Text.Show (Show(..))
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Sequence as Seq
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import Symantic.XML.Namespace
data Escaped
= EscapedPlain TL.Text
| EscapedEntityRef EntityRef
| EscapedCharRef CharRef
deriving (Eq, Ord, Show)
data EntityRef
= EntityRef
{ entityRef_name :: NCName
, entityRef_value :: TL.Text
} deriving (Eq, Ord, Show)
entityRef_lt,
entityRef_gt,
entityRef_amp,
entityRef_quot,
entityRef_apos :: EntityRef
entityRef_lt = EntityRef (NCName "lt") "<"
entityRef_gt = EntityRef (NCName "gt") ">"
entityRef_amp = EntityRef (NCName "amp") "&"
entityRef_quot = EntityRef (NCName "quot") "\""
entityRef_apos = EntityRef (NCName "apos") "'"
newtype CharRef = CharRef Char
deriving (Eq, Ord, Show)
newtype EscapedText = EscapedText (Seq Escaped)
deriving (Eq, Ord, Show)
instance IsString EscapedText where
fromString = escapeText . fromString
unEscapedText :: EscapedText -> Seq Escaped
unEscapedText (EscapedText et) = et
{-# INLINE unEscapedText #-}
escapeText :: TL.Text -> EscapedText
escapeText s =
EscapedText $
case TL.span (`List.notElem` ("<&>"::String)) s of
(t, r) | TL.null t -> escape r
| otherwise -> EscapedPlain t Seq.<| escape r
where
escape t = case TL.uncons t of
Nothing -> mempty
Just (c, cs) -> escapeTextChar c Seq.<| et
where EscapedText et = escapeText cs
escapeTextChar :: Char -> Escaped
escapeTextChar = \case
'<' -> EscapedEntityRef entityRef_lt
'&' -> EscapedEntityRef entityRef_amp
'>' -> EscapedEntityRef entityRef_gt
c -> EscapedPlain $ TL.singleton c
unescapeText :: EscapedText -> TL.Text
unescapeText (EscapedText et) = (`foldMap` et) $ \case
EscapedPlain t -> t
EscapedEntityRef EntityRef{..} -> entityRef_value
EscapedCharRef (CharRef c) -> TL.singleton c
newtype EscapedAttr = EscapedAttr (Seq Escaped)
deriving (Eq, Ord, Show)
instance IsString EscapedAttr where
fromString = escapeAttr . fromString
unEscapedAttr :: EscapedAttr -> Seq Escaped
unEscapedAttr (EscapedAttr et) = et
{-# INLINE unEscapedAttr #-}
escapeAttr :: TL.Text -> EscapedAttr
escapeAttr s =
EscapedAttr $
case TL.span (`List.notElem` ("<&\""::String)) s of
(t, r) | TL.null t -> escape r
| otherwise -> EscapedPlain t Seq.<| escape r
where
escape t = case TL.uncons t of
Nothing -> mempty
Just (c, cs) -> escapeAttrChar c Seq.<| et
where EscapedAttr et = escapeAttr cs
escapeAttrChar :: Char -> Escaped
escapeAttrChar = \case
'<' -> EscapedEntityRef entityRef_lt
'&' -> EscapedEntityRef entityRef_amp
'"' -> EscapedEntityRef entityRef_quot
c -> EscapedPlain $ TL.singleton c
unescapeAttr :: EscapedAttr -> TL.Text
unescapeAttr (EscapedAttr et) = unescapeText (EscapedText et)
class Textify a where
textify :: a -> TLB.Builder
instance Textify Char.Char where
textify = TLB.singleton
instance Textify String where
textify = TLB.fromString
instance Textify TL.Text where
textify = TLB.fromLazyText
instance Textify NCName where
textify = textify . unNCName
instance Textify PName where
textify PName{..} =
case pNameSpace of
Nothing -> textify pNameLocal
Just p -> textify p<>":"<> textify pNameLocal
instance Textify Namespace where
textify = textify . unNamespace
instance Textify EntityRef where
textify EntityRef{..} = "&"<>textify entityRef_name<>";"
instance Textify CharRef where
textify (CharRef c) = "&#"<>textify (show (Char.ord c))<>";"
instance Textify EscapedText where
textify (EscapedText et) = (`foldMap` et) $ \case
EscapedPlain t -> textify t
EscapedEntityRef r -> textify r
EscapedCharRef r -> textify r
instance Textify EscapedAttr where
textify (EscapedAttr et) = "\""<>txt<>"\""
where
txt = (`foldMap` et) $ \case
EscapedPlain t -> textify t
EscapedEntityRef r -> textify r
EscapedCharRef r -> textify r
textifyAttr :: PName -> EscapedAttr -> TLB.Builder
textifyAttr n v = " "<>textify n<>"="<>textify v