{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module Text.XML.Stream.Token
( tokenToBuilder
, TName (..)
, Token (..)
, TAttribute
, NSLevel (..)
) where
import Data.XML.Types (Instruction (..), Content (..), ExternalID (..))
import qualified Data.Text as T
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8Builder, encodeUtf8BuilderEscaped)
import Data.String (IsString (fromString))
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder.Prim as E
import Data.ByteString.Builder.Prim ((>*<), (>$<), condB)
import Data.Monoid (mconcat, mempty, (<>))
import Data.Map (Map)
import qualified Data.Set as Set
import Data.List (foldl')
import Control.Arrow (first)
import Data.Word (Word8)
oneSpace :: Builder
oneSpace :: Builder
oneSpace = Builder
" "
data Token = TokenXMLDeclaration [TAttribute]
| TokenInstruction Instruction
| TokenBeginElement TName [TAttribute] Bool Int
| TokenEndElement TName
| TokenContent Content
| Text
| TokenDoctype Text (Maybe ExternalID) [(Text, Text)]
| TokenCDATA Text
deriving Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show
tokenToBuilder :: Token -> Builder
tokenToBuilder :: Token -> Builder
tokenToBuilder (TokenXMLDeclaration [TAttribute]
attrs) =
Builder
"<?xml" forall a. Semigroup a => a -> a -> a
<>
Builder -> [TAttribute] -> Builder
foldAttrs Builder
oneSpace [TAttribute]
attrs forall a. Semigroup a => a -> a -> a
<>
Builder
"?>"
tokenToBuilder (TokenInstruction (Instruction Text
target Text
data_)) =
Builder
"<?" forall a. Semigroup a => a -> a -> a
<>
Text -> Builder
encodeUtf8Builder Text
target forall a. Semigroup a => a -> a -> a
<>
Builder
" " forall a. Semigroup a => a -> a -> a
<>
Text -> Builder
encodeUtf8Builder Text
data_ forall a. Semigroup a => a -> a -> a
<>
Builder
"?>"
tokenToBuilder (TokenBeginElement TName
name [TAttribute]
attrs' Bool
isEmpty Int
indent) =
Builder
"<" forall a. Semigroup a => a -> a -> a
<>
TName -> Builder
tnameToText TName
name forall a. Semigroup a => a -> a -> a
<>
Builder -> [TAttribute] -> Builder
foldAttrs
(if Int
indent forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| forall {a}. [a] -> Bool
lessThan3 [TAttribute]
attrs
then Builder
oneSpace
else forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ (Builder
"\n" forall a. a -> [a] -> [a]
: forall a. Int -> a -> [a]
replicate Int
indent Builder
" "))
[TAttribute]
attrs forall a. Semigroup a => a -> a -> a
<>
(if Bool
isEmpty then Builder
"/>" else Builder
">")
where
attrs :: [TAttribute]
attrs = [TAttribute] -> [TAttribute]
nubAttrs forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first TName -> TName
splitTName) [TAttribute]
attrs'
lessThan3 :: [a] -> Bool
lessThan3 [] = Bool
True
lessThan3 [a
_] = Bool
True
lessThan3 [a
_, a
_] = Bool
True
lessThan3 [a]
_ = Bool
False
tokenToBuilder (TokenEndElement TName
name) = Builder
"</" forall a. Semigroup a => a -> a -> a
<> TName -> Builder
tnameToText TName
name forall a. Semigroup a => a -> a -> a
<> Builder
">"
tokenToBuilder (TokenContent Content
c) = Content -> Builder
contentToText Content
c
tokenToBuilder (TokenCDATA Text
t) = Builder
"<![CDATA[" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
escCDATA Text
t forall a. Semigroup a => a -> a -> a
<> Builder
"]]>"
tokenToBuilder (TokenComment Text
t) = Builder
"<!--" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
encodeUtf8Builder Text
t forall a. Semigroup a => a -> a -> a
<> Builder
"-->"
tokenToBuilder (TokenDoctype Text
name Maybe ExternalID
eid [(Text, Text)]
_) =
Builder
"<!DOCTYPE " forall a. Semigroup a => a -> a -> a
<>
Text -> Builder
encodeUtf8Builder Text
name forall a. Semigroup a => a -> a -> a
<>
Maybe ExternalID -> Builder
go Maybe ExternalID
eid forall a. Semigroup a => a -> a -> a
<>
Builder
">"
where
go :: Maybe ExternalID -> Builder
go Maybe ExternalID
Nothing = forall a. Monoid a => a
mempty
go (Just (SystemID Text
uri)) = Builder
" SYSTEM \"" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
encodeUtf8Builder Text
uri forall a. Semigroup a => a -> a -> a
<> Builder
"\""
go (Just (PublicID Text
pid Text
uri)) =
Builder
" PUBLIC \"" forall a. Semigroup a => a -> a -> a
<>
Text -> Builder
encodeUtf8Builder Text
pid forall a. Semigroup a => a -> a -> a
<>
Builder
"\" \"" forall a. Semigroup a => a -> a -> a
<>
Text -> Builder
encodeUtf8Builder Text
uri forall a. Semigroup a => a -> a -> a
<>
Builder
"\""
data TName = TName (Maybe Text) Text
deriving (Int -> TName -> ShowS
[TName] -> ShowS
TName -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TName] -> ShowS
$cshowList :: [TName] -> ShowS
show :: TName -> String
$cshow :: TName -> String
showsPrec :: Int -> TName -> ShowS
$cshowsPrec :: Int -> TName -> ShowS
Show, TName -> TName -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TName -> TName -> Bool
$c/= :: TName -> TName -> Bool
== :: TName -> TName -> Bool
$c== :: TName -> TName -> Bool
Eq, Eq TName
TName -> TName -> Bool
TName -> TName -> Ordering
TName -> TName -> TName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TName -> TName -> TName
$cmin :: TName -> TName -> TName
max :: TName -> TName -> TName
$cmax :: TName -> TName -> TName
>= :: TName -> TName -> Bool
$c>= :: TName -> TName -> Bool
> :: TName -> TName -> Bool
$c> :: TName -> TName -> Bool
<= :: TName -> TName -> Bool
$c<= :: TName -> TName -> Bool
< :: TName -> TName -> Bool
$c< :: TName -> TName -> Bool
compare :: TName -> TName -> Ordering
$ccompare :: TName -> TName -> Ordering
Ord)
tnameToText :: TName -> Builder
tnameToText :: TName -> Builder
tnameToText (TName Maybe Text
Nothing Text
name) = Text -> Builder
encodeUtf8Builder Text
name
tnameToText (TName (Just Text
prefix) Text
name) =
Text -> Builder
encodeUtf8Builder Text
prefix forall a. Semigroup a => a -> a -> a
<> Builder
":" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
encodeUtf8Builder Text
name
contentToText :: Content -> Builder
contentToText :: Content -> Builder
contentToText (ContentText Text
t) = BoundedPrim Word8 -> Text -> Builder
encodeUtf8BuilderEscaped (EscapeContext -> BoundedPrim Word8
charUtf8XmlEscaped EscapeContext
ECContent) Text
t
contentToText (ContentEntity Text
e) = Builder
"&" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
encodeUtf8Builder Text
e forall a. Semigroup a => a -> a -> a
<> Builder
";"
data EscapeContext = ECContent
| ECDoubleArg
| ECSingleArg
deriving (Int -> EscapeContext -> ShowS
[EscapeContext] -> ShowS
EscapeContext -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EscapeContext] -> ShowS
$cshowList :: [EscapeContext] -> ShowS
show :: EscapeContext -> String
$cshow :: EscapeContext -> String
showsPrec :: Int -> EscapeContext -> ShowS
$cshowsPrec :: Int -> EscapeContext -> ShowS
Show, EscapeContext -> EscapeContext -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EscapeContext -> EscapeContext -> Bool
$c/= :: EscapeContext -> EscapeContext -> Bool
== :: EscapeContext -> EscapeContext -> Bool
$c== :: EscapeContext -> EscapeContext -> Bool
Eq)
{-# INLINE charUtf8XmlEscaped #-}
charUtf8XmlEscaped :: EscapeContext -> E.BoundedPrim Word8
charUtf8XmlEscaped :: EscapeContext -> BoundedPrim Word8
charUtf8XmlEscaped EscapeContext
ec =
(forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (forall a. Ord a => a -> a -> Bool
> Word8
_gt) (forall a. FixedPrim a -> BoundedPrim a
E.liftFixedToBounded FixedPrim Word8
E.word8)) forall a b. (a -> b) -> a -> b
$
(forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (forall a. Eq a => a -> a -> Bool
== Word8
_lt) (forall {a}. (Word8, (Word8, (Word8, Word8))) -> BoundedPrim a
fixed4 (Word8
_am,(Word8
_l,(Word8
_t,Word8
_sc))))) forall a b. (a -> b) -> a -> b
$
forall a. EscapeContext -> (a -> a) -> a -> a
escapeFor EscapeContext
ECContent (forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (forall a. Eq a => a -> a -> Bool
== Word8
_gt) (forall {a}. (Word8, (Word8, (Word8, Word8))) -> BoundedPrim a
fixed4 (Word8
_am,(Word8
_g,(Word8
_t,Word8
_sc))))) forall a b. (a -> b) -> a -> b
$
(forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (forall a. Eq a => a -> a -> Bool
== Word8
_am) (forall {a}.
(Word8, (Word8, (Word8, (Word8, Word8)))) -> BoundedPrim a
fixed5 (Word8
_am,(Word8
_a,(Word8
_m,(Word8
_p,Word8
_sc)))))) forall a b. (a -> b) -> a -> b
$
forall a. EscapeContext -> (a -> a) -> a -> a
escapeFor EscapeContext
ECDoubleArg (forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (forall a. Eq a => a -> a -> Bool
== Word8
_dq) (forall {a}.
(Word8, (Word8, (Word8, (Word8, (Word8, Word8))))) -> BoundedPrim a
fixed6 (Word8
_am,(Word8
_q,(Word8
_u,(Word8
_o,(Word8
_t,Word8
_sc))))))) forall a b. (a -> b) -> a -> b
$
forall a. EscapeContext -> (a -> a) -> a -> a
escapeFor EscapeContext
ECSingleArg (forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (forall a. Eq a => a -> a -> Bool
== Word8
_sq) (forall {a}.
(Word8, (Word8, (Word8, (Word8, (Word8, Word8))))) -> BoundedPrim a
fixed6 (Word8
_am,(Word8
_a,(Word8
_p,(Word8
_o,(Word8
_s,Word8
_sc))))))) forall a b. (a -> b) -> a -> b
$
(forall a. FixedPrim a -> BoundedPrim a
E.liftFixedToBounded FixedPrim Word8
E.word8)
where
_gt :: Word8
_gt = Word8
62
_lt :: Word8
_lt = Word8
60
_am :: Word8
_am = Word8
38
_dq :: Word8
_dq = Word8
34
_sq :: Word8
_sq = Word8
39
_l :: Word8
_l = Word8
108
_t :: Word8
_t = Word8
116
_g :: Word8
_g = Word8
103
_a :: Word8
_a = Word8
97
_m :: Word8
_m = Word8
109
_p :: Word8
_p = Word8
112
_o :: Word8
_o = Word8
111
_s :: Word8
_s = Word8
115
_q :: Word8
_q = Word8
113
_u :: Word8
_u = Word8
117
_sc :: Word8
_sc = Word8
59
{-# INLINE escapeFor #-}
escapeFor :: EscapeContext -> (a -> a) -> a -> a
escapeFor :: forall a. EscapeContext -> (a -> a) -> a -> a
escapeFor EscapeContext
ec' a -> a
f a
a
| EscapeContext
ec forall a. Eq a => a -> a -> Bool
== EscapeContext
ec' = a -> a
f a
a
| Bool
otherwise = a
a
{-# INLINE fixed4 #-}
fixed4 :: (Word8, (Word8, (Word8, Word8))) -> BoundedPrim a
fixed4 (Word8, (Word8, (Word8, Word8)))
x = forall a. FixedPrim a -> BoundedPrim a
E.liftFixedToBounded forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (Word8, (Word8, (Word8, Word8)))
x forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$<
FixedPrim Word8
E.word8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Word8
E.word8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Word8
E.word8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Word8
E.word8
{-# INLINE fixed5 #-}
fixed5 :: (Word8, (Word8, (Word8, (Word8, Word8)))) -> BoundedPrim a
fixed5 (Word8, (Word8, (Word8, (Word8, Word8))))
x = forall a. FixedPrim a -> BoundedPrim a
E.liftFixedToBounded forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (Word8, (Word8, (Word8, (Word8, Word8))))
x forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$<
FixedPrim Word8
E.word8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Word8
E.word8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Word8
E.word8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Word8
E.word8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Word8
E.word8
{-# INLINE fixed6 #-}
fixed6 :: (Word8, (Word8, (Word8, (Word8, (Word8, Word8))))) -> BoundedPrim a
fixed6 (Word8, (Word8, (Word8, (Word8, (Word8, Word8)))))
x = forall a. FixedPrim a -> BoundedPrim a
E.liftFixedToBounded forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (Word8, (Word8, (Word8, (Word8, (Word8, Word8)))))
x forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$<
FixedPrim Word8
E.word8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Word8
E.word8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Word8
E.word8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Word8
E.word8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Word8
E.word8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Word8
E.word8
type TAttribute = (TName, [Content])
foldAttrs :: Builder
-> [TAttribute]
-> Builder
foldAttrs :: Builder -> [TAttribute] -> Builder
foldAttrs Builder
before =
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall {t :: * -> *}. Foldable t => (TName, t Content) -> Builder
go
where
go :: (TName, t Content) -> Builder
go (TName
key, t Content
val) =
Builder
before forall a. Semigroup a => a -> a -> a
<>
TName -> Builder
tnameToText TName
key forall a. Semigroup a => a -> a -> a
<>
Builder
"=\"" forall a. Semigroup a => a -> a -> a
<>
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Content -> Builder
go' t Content
val forall a. Semigroup a => a -> a -> a
<>
Builder
"\""
go' :: Content -> Builder
go' (ContentText Text
t) =
BoundedPrim Word8 -> Text -> Builder
encodeUtf8BuilderEscaped (EscapeContext -> BoundedPrim Word8
charUtf8XmlEscaped EscapeContext
ECDoubleArg) Text
t
go' (ContentEntity Text
t) = Builder
"&" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
encodeUtf8Builder Text
t forall a. Semigroup a => a -> a -> a
<> Builder
";"
instance IsString TName where
fromString :: String -> TName
fromString = Maybe Text -> Text -> TName
TName forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
data NSLevel = NSLevel
{ NSLevel -> Maybe Text
defaultNS :: Maybe Text
, NSLevel -> Map Text Text
prefixes :: Map Text Text
}
deriving Int -> NSLevel -> ShowS
[NSLevel] -> ShowS
NSLevel -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NSLevel] -> ShowS
$cshowList :: [NSLevel] -> ShowS
show :: NSLevel -> String
$cshow :: NSLevel -> String
showsPrec :: Int -> NSLevel -> ShowS
$cshowsPrec :: Int -> NSLevel -> ShowS
Show
nubAttrs :: [TAttribute] -> [TAttribute]
nubAttrs :: [TAttribute] -> [TAttribute]
nubAttrs [TAttribute]
orig =
[TAttribute] -> [TAttribute]
front []
where
([TAttribute] -> [TAttribute]
front, Set TName
_) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a} {b} {c}.
Ord a =>
([(a, b)] -> c, Set a) -> (a, b) -> ([(a, b)] -> c, Set a)
go (forall a. a -> a
id, forall a. Set a
Set.empty) [TAttribute]
orig
go :: ([(a, b)] -> c, Set a) -> (a, b) -> ([(a, b)] -> c, Set a)
go ([(a, b)] -> c
dlist, Set a
used) (a
k, b
v)
| a
k forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
used = ([(a, b)] -> c
dlist, Set a
used)
| Bool
otherwise = ([(a, b)] -> c
dlist forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a
k, b
v)forall a. a -> [a] -> [a]
:), forall a. Ord a => a -> Set a -> Set a
Set.insert a
k Set a
used)
splitTName :: TName -> TName
splitTName :: TName -> TName
splitTName x :: TName
x@(TName Just{} Text
_) = TName
x
splitTName x :: TName
x@(TName Maybe Text
Nothing Text
t)
| Text -> Bool
T.null Text
b = TName
x
| Bool
otherwise = Maybe Text -> Text -> TName
TName (forall a. a -> Maybe a
Just Text
a) forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
1 Text
b
where
(Text
a, Text
b) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
':') Text
t
escCDATA :: Text -> Builder
escCDATA :: Text -> Builder
escCDATA Text
s = Text -> Builder
encodeUtf8Builder (Text -> Text -> Text -> Text
T.replace Text
"]]>" Text
"]]]]><![CDATA[>" Text
s)