{-# 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 -- ^ indent
           | TokenEndElement TName
           | TokenContent Content
           | TokenComment 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
";"

-- | What usage are we escaping for?
data EscapeContext = ECContent   -- ^ <el>..</el>
                   | ECDoubleArg -- ^ <el arg=".." />
                   | ECSingleArg -- ^ <el arg='..' />
  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
$           -- &lt;
    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
$           -- &gt;
                          (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
$      -- &amp;
    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
$ -- &quot;
    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
$ -- &apos;
    (forall a. FixedPrim a -> BoundedPrim a
E.liftFixedToBounded FixedPrim Word8
E.word8)         -- fallback for Chars smaller than '>'
  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 -- l
    _t :: Word8
_t  = Word8
116 -- t
    _g :: Word8
_g  = Word8
103 -- g
    _a :: Word8
_a  = Word8
97  -- a
    _m :: Word8
_m  = Word8
109 -- m
    _p :: Word8
_p  = Word8
112 -- p
    _o :: Word8
_o  = Word8
111 -- o
    _s :: Word8
_s  = Word8
115 -- s
    _q :: Word8
_q  = Word8
113 -- q
    _u :: Word8
_u  = Word8
117 -- u
    _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 -- ^ before
          -> [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)