{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Codec.Xlsx.Parser.Internal.Fast
  ( FromXenoNode(..)
  , collectChildren
  , maybeChild
  , requireChild
  , childList
  , maybeFromChild
  , fromChild
  , fromChildList
  , maybeParse
  , requireAndParse
  , childListAny
  , maybeElementVal
  , toAttrParser
  , parseAttributes
  , FromAttrBs(..)
  , unexpectedAttrBs
  , maybeAttrBs
  , maybeAttr
  , fromAttr
  , fromAttrDef
  , contentBs
  , contentX
  , nsPrefixes
  , addPrefix
  ) where

import Control.Applicative
import Control.Arrow (second)
import Control.Exception (Exception, throw)
import Control.Monad (ap, forM, join, liftM)
import Data.Bifunctor (first)
import Data.Bits ((.|.), shiftL)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as SU
import Data.Char (chr)
import Data.Maybe
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Word (Word8)
import Xeno.DOM hiding (parse)

import Codec.Xlsx.Parser.Internal.Util

class FromXenoNode a where
  fromXenoNode :: Node -> Either Text a

newtype ChildCollector a = ChildCollector
  { forall a. ChildCollector a -> [Node] -> Either Text ([Node], a)
runChildCollector :: [Node] -> Either Text ([Node], a)
  }

instance Functor ChildCollector where
  fmap :: forall a b. (a -> b) -> ChildCollector a -> ChildCollector b
fmap a -> b
f ChildCollector a
a = forall a. ([Node] -> Either Text ([Node], a)) -> ChildCollector a
ChildCollector forall a b. (a -> b) -> a -> b
$ \[Node]
ns ->
    forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ChildCollector a -> [Node] -> Either Text ([Node], a)
runChildCollector ChildCollector a
a [Node]
ns

instance Applicative ChildCollector where
  pure :: forall a. a -> ChildCollector a
pure a
a = forall a. ([Node] -> Either Text ([Node], a)) -> ChildCollector a
ChildCollector forall a b. (a -> b) -> a -> b
$ \[Node]
ns ->
    forall (m :: * -> *) a. Monad m => a -> m a
return ([Node]
ns, a
a)
  ChildCollector (a -> b)
cf <*> :: forall a b.
ChildCollector (a -> b) -> ChildCollector a -> ChildCollector b
<*> ChildCollector a
ca = forall a. ([Node] -> Either Text ([Node], a)) -> ChildCollector a
ChildCollector forall a b. (a -> b) -> a -> b
$ \[Node]
ns -> do
    ([Node]
ns', a -> b
f) <- forall a. ChildCollector a -> [Node] -> Either Text ([Node], a)
runChildCollector ChildCollector (a -> b)
cf [Node]
ns
    ([Node]
ns'', a
a) <- forall a. ChildCollector a -> [Node] -> Either Text ([Node], a)
runChildCollector ChildCollector a
ca [Node]
ns'
    forall (m :: * -> *) a. Monad m => a -> m a
return ([Node]
ns'', a -> b
f a
a)

instance Alternative ChildCollector where
  empty :: forall a. ChildCollector a
empty = forall a. ([Node] -> Either Text ([Node], a)) -> ChildCollector a
ChildCollector forall a b. (a -> b) -> a -> b
$ \[Node]
_ -> forall a b. a -> Either a b
Left Text
"ChildCollector.empty"
  ChildCollector [Node] -> Either Text ([Node], a)
f <|> :: forall a. ChildCollector a -> ChildCollector a -> ChildCollector a
<|> ChildCollector [Node] -> Either Text ([Node], a)
g = forall a. ([Node] -> Either Text ([Node], a)) -> ChildCollector a
ChildCollector forall a b. (a -> b) -> a -> b
$ \[Node]
ns ->
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ [Node] -> Either Text ([Node], a)
g [Node]
ns) forall a b. b -> Either a b
Right ([Node] -> Either Text ([Node], a)
f [Node]
ns)

instance Monad ChildCollector where
  return :: forall a. a -> ChildCollector a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ChildCollector [Node] -> Either Text ([Node], a)
f >>= :: forall a b.
ChildCollector a -> (a -> ChildCollector b) -> ChildCollector b
>>= a -> ChildCollector b
g = forall a. ([Node] -> Either Text ([Node], a)) -> ChildCollector a
ChildCollector forall a b. (a -> b) -> a -> b
$ \[Node]
ns ->
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a b. a -> Either a b
Left (\(![Node]
ns', a
f') -> forall a. ChildCollector a -> [Node] -> Either Text ([Node], a)
runChildCollector (a -> ChildCollector b
g a
f') [Node]
ns') ([Node] -> Either Text ([Node], a)
f [Node]
ns)

toChildCollector :: Either Text a -> ChildCollector a
toChildCollector :: forall a. Either Text a -> ChildCollector a
toChildCollector Either Text a
unlifted =
  case Either Text a
unlifted of
    Right a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    Left Text
e -> forall a. ([Node] -> Either Text ([Node], a)) -> ChildCollector a
ChildCollector forall a b. (a -> b) -> a -> b
$ \[Node]
_ -> forall a b. a -> Either a b
Left Text
e

collectChildren :: Node -> ChildCollector a -> Either Text a
collectChildren :: forall a. Node -> ChildCollector a -> Either Text a
collectChildren Node
n ChildCollector a
c = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ChildCollector a -> [Node] -> Either Text ([Node], a)
runChildCollector ChildCollector a
c (Node -> [Node]
children Node
n)

maybeChild :: ByteString -> ChildCollector (Maybe Node)
maybeChild :: ByteString -> ChildCollector (Maybe Node)
maybeChild ByteString
nm =
  forall a. ([Node] -> Either Text ([Node], a)) -> ChildCollector a
ChildCollector forall a b. (a -> b) -> a -> b
$ \case
    (Node
n:[Node]
ns)
      | Node -> ByteString
name Node
n forall a. Eq a => a -> a -> Bool
== ByteString
nm -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Node]
ns, forall a. a -> Maybe a
Just Node
n)
    [Node]
ns -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Node]
ns, forall a. Maybe a
Nothing)

requireChild :: ByteString -> ChildCollector Node
requireChild :: ByteString -> ChildCollector Node
requireChild ByteString
nm =
  forall a. ([Node] -> Either Text ([Node], a)) -> ChildCollector a
ChildCollector forall a b. (a -> b) -> a -> b
$ \case
    (Node
n:[Node]
ns)
      | Node -> ByteString
name Node
n forall a. Eq a => a -> a -> Bool
== ByteString
nm -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Node]
ns, Node
n)
    [Node]
_ ->
      forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"required element " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show ByteString
nm) forall a. Semigroup a => a -> a -> a
<> Text
" was not found"

childList :: ByteString -> ChildCollector [Node]
childList :: ByteString -> ChildCollector [Node]
childList ByteString
nm = do
  Maybe Node
mNode <- ByteString -> ChildCollector (Maybe Node)
maybeChild ByteString
nm
  case Maybe Node
mNode of
    Just Node
n -> (Node
nforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> ChildCollector [Node]
childList ByteString
nm
    Maybe Node
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []

maybeFromChild :: (FromXenoNode a) => ByteString -> ChildCollector (Maybe a)
maybeFromChild :: forall a. FromXenoNode a => ByteString -> ChildCollector (Maybe a)
maybeFromChild ByteString
nm = do
  Maybe Node
mNode <- ByteString -> ChildCollector (Maybe Node)
maybeChild ByteString
nm
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. Either Text a -> ChildCollector a
toChildCollector forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromXenoNode a => Node -> Either Text a
fromXenoNode) Maybe Node
mNode

fromChild :: (FromXenoNode a) => ByteString -> ChildCollector a
fromChild :: forall a. FromXenoNode a => ByteString -> ChildCollector a
fromChild ByteString
nm = do
  Node
n <- ByteString -> ChildCollector Node
requireChild ByteString
nm
  case forall a. FromXenoNode a => Node -> Either Text a
fromXenoNode Node
n of
    Right a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    Left Text
e -> forall a. ([Node] -> Either Text ([Node], a)) -> ChildCollector a
ChildCollector forall a b. (a -> b) -> a -> b
$ \[Node]
_ -> forall a b. a -> Either a b
Left Text
e

fromChildList :: (FromXenoNode a) => ByteString -> ChildCollector [a]
fromChildList :: forall a. FromXenoNode a => ByteString -> ChildCollector [a]
fromChildList ByteString
nm = do
  Maybe a
mA <- forall a. FromXenoNode a => ByteString -> ChildCollector (Maybe a)
maybeFromChild ByteString
nm
  case Maybe a
mA of
    Just a
a -> (a
aforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromXenoNode a => ByteString -> ChildCollector [a]
fromChildList ByteString
nm
    Maybe a
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []

maybeParse :: ByteString -> (Node -> Either Text a) -> ChildCollector (Maybe a)
maybeParse :: forall a.
ByteString -> (Node -> Either Text a) -> ChildCollector (Maybe a)
maybeParse ByteString
nm Node -> Either Text a
parse = ByteString -> ChildCollector (Maybe Node)
maybeChild ByteString
nm forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a. Either Text a -> ChildCollector a
toChildCollector forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Node -> Either Text a
parse)

requireAndParse :: ByteString -> (Node -> Either Text a) -> ChildCollector a
requireAndParse :: forall a. ByteString -> (Node -> Either Text a) -> ChildCollector a
requireAndParse ByteString
nm Node -> Either Text a
parse = ByteString -> ChildCollector Node
requireChild ByteString
nm forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a. Either Text a -> ChildCollector a
toChildCollector forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> Either Text a
parse)

childListAny :: (FromXenoNode a) => Node -> Either Text [a]
childListAny :: forall a. FromXenoNode a => Node -> Either Text [a]
childListAny = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. FromXenoNode a => Node -> Either Text a
fromXenoNode forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> [Node]
children

maybeElementVal :: (FromAttrBs a) => ByteString -> ChildCollector (Maybe a)
maybeElementVal :: forall a. FromAttrBs a => ByteString -> ChildCollector (Maybe a)
maybeElementVal ByteString
nm = do
  Maybe Node
mN <- ByteString -> ChildCollector (Maybe Node)
maybeChild ByteString
nm
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Node
mN forall a b. (a -> b) -> a -> b
$ \Node
n ->
    forall a. Either Text a -> ChildCollector a
toChildCollector forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Node -> AttrParser a -> Either Text a
parseAttributes Node
n forall a b. (a -> b) -> a -> b
$ forall a. FromAttrBs a => ByteString -> AttrParser (Maybe a)
maybeAttr ByteString
"val"

-- Stolen from XML Conduit
newtype AttrParser a = AttrParser
  { forall a.
AttrParser a
-> [(ByteString, ByteString)]
-> Either Text ([(ByteString, ByteString)], a)
runAttrParser :: [(ByteString, ByteString)] -> Either Text ( [( ByteString
                                                                  , ByteString)]
                                                               , a)
  }

instance Monad AttrParser where
  return :: forall a. a -> AttrParser a
return a
a = forall a.
([(ByteString, ByteString)]
 -> Either Text ([(ByteString, ByteString)], a))
-> AttrParser a
AttrParser forall a b. (a -> b) -> a -> b
$ \[(ByteString, ByteString)]
as -> forall a b. b -> Either a b
Right ([(ByteString, ByteString)]
as, a
a)
  (AttrParser [(ByteString, ByteString)]
-> Either Text ([(ByteString, ByteString)], a)
f) >>= :: forall a b. AttrParser a -> (a -> AttrParser b) -> AttrParser b
>>= a -> AttrParser b
g =
    forall a.
([(ByteString, ByteString)]
 -> Either Text ([(ByteString, ByteString)], a))
-> AttrParser a
AttrParser forall a b. (a -> b) -> a -> b
$ \[(ByteString, ByteString)]
as ->
      forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a b. a -> Either a b
Left (\([(ByteString, ByteString)]
as', a
f') -> forall a.
AttrParser a
-> [(ByteString, ByteString)]
-> Either Text ([(ByteString, ByteString)], a)
runAttrParser (a -> AttrParser b
g a
f') [(ByteString, ByteString)]
as') ([(ByteString, ByteString)]
-> Either Text ([(ByteString, ByteString)], a)
f [(ByteString, ByteString)]
as)
instance Applicative AttrParser where
    pure :: forall a. a -> AttrParser a
pure = forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: forall a b. AttrParser (a -> b) -> AttrParser a -> AttrParser b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Functor AttrParser where
  fmap :: forall a b. (a -> b) -> AttrParser a -> AttrParser b
fmap = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

attrError :: Text -> AttrParser a
attrError :: forall a. Text -> AttrParser a
attrError Text
err = forall a.
([(ByteString, ByteString)]
 -> Either Text ([(ByteString, ByteString)], a))
-> AttrParser a
AttrParser forall a b. (a -> b) -> a -> b
$ \[(ByteString, ByteString)]
_ -> forall a b. a -> Either a b
Left Text
err

toAttrParser :: Either Text a -> AttrParser a
toAttrParser :: forall a. Either Text a -> AttrParser a
toAttrParser Either Text a
unlifted =
  case Either Text a
unlifted of
    Right a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    Left Text
e -> forall a.
([(ByteString, ByteString)]
 -> Either Text ([(ByteString, ByteString)], a))
-> AttrParser a
AttrParser forall a b. (a -> b) -> a -> b
$ \[(ByteString, ByteString)]
_ -> forall a b. a -> Either a b
Left Text
e

maybeAttrBs :: ByteString -> AttrParser (Maybe ByteString)
maybeAttrBs :: ByteString -> AttrParser (Maybe ByteString)
maybeAttrBs ByteString
attrName = forall a.
([(ByteString, ByteString)]
 -> Either Text ([(ByteString, ByteString)], a))
-> AttrParser a
AttrParser forall a b. (a -> b) -> a -> b
$ forall {a} {c} {a}.
([(ByteString, a)] -> c)
-> [(ByteString, a)] -> Either a (c, Maybe a)
go forall a. a -> a
id
  where
    go :: ([(ByteString, a)] -> c)
-> [(ByteString, a)] -> Either a (c, Maybe a)
go [(ByteString, a)] -> c
front [] = forall a b. b -> Either a b
Right ([(ByteString, a)] -> c
front [], forall a. Maybe a
Nothing)
    go [(ByteString, a)] -> c
front (a :: (ByteString, a)
a@(ByteString
nm, a
val):[(ByteString, a)]
as) =
      if ByteString
nm forall a. Eq a => a -> a -> Bool
== ByteString
attrName
        then forall a b. b -> Either a b
Right ([(ByteString, a)] -> c
front [(ByteString, a)]
as, forall a. a -> Maybe a
Just a
val)
        else ([(ByteString, a)] -> c)
-> [(ByteString, a)] -> Either a (c, Maybe a)
go ([(ByteString, a)] -> c
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) (ByteString, a)
a) [(ByteString, a)]
as

requireAttrBs :: ByteString -> AttrParser ByteString
requireAttrBs :: ByteString -> AttrParser ByteString
requireAttrBs ByteString
nm = do
  Maybe ByteString
mVal <- ByteString -> AttrParser (Maybe ByteString)
maybeAttrBs ByteString
nm
  case Maybe ByteString
mVal of
    Just ByteString
val -> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
val
    Maybe ByteString
Nothing -> forall a. Text -> AttrParser a
attrError forall a b. (a -> b) -> a -> b
$ Text
"attribute " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show ByteString
nm) forall a. Semigroup a => a -> a -> a
<> Text
" is required"

unexpectedAttrBs :: Text -> ByteString -> Either Text a
unexpectedAttrBs :: forall a. Text -> ByteString -> Either Text a
unexpectedAttrBs Text
typ ByteString
val =
  forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Unexpected value for " forall a. Semigroup a => a -> a -> a
<> Text
typ forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show ByteString
val)

fromAttr :: FromAttrBs a => ByteString -> AttrParser a
fromAttr :: forall a. FromAttrBs a => ByteString -> AttrParser a
fromAttr ByteString
nm = do
  ByteString
bs <- ByteString -> AttrParser ByteString
requireAttrBs ByteString
nm
  forall a. Either Text a -> AttrParser a
toAttrParser forall a b. (a -> b) -> a -> b
$ forall a. FromAttrBs a => ByteString -> Either Text a
fromAttrBs ByteString
bs

maybeAttr :: FromAttrBs a => ByteString -> AttrParser (Maybe a)
maybeAttr :: forall a. FromAttrBs a => ByteString -> AttrParser (Maybe a)
maybeAttr ByteString
nm = do
  Maybe ByteString
mBs <- ByteString -> AttrParser (Maybe ByteString)
maybeAttrBs ByteString
nm
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe ByteString
mBs (forall a. Either Text a -> AttrParser a
toAttrParser forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromAttrBs a => ByteString -> Either Text a
fromAttrBs)

fromAttrDef :: FromAttrBs a => ByteString -> a -> AttrParser a
fromAttrDef :: forall a. FromAttrBs a => ByteString -> a -> AttrParser a
fromAttrDef ByteString
nm a
defVal = forall a. a -> Maybe a -> a
fromMaybe a
defVal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromAttrBs a => ByteString -> AttrParser (Maybe a)
maybeAttr ByteString
nm

parseAttributes :: Node -> AttrParser a -> Either Text a
parseAttributes :: forall a. Node -> AttrParser a -> Either Text a
parseAttributes Node
n AttrParser a
attrParser =
  case forall a.
AttrParser a
-> [(ByteString, ByteString)]
-> Either Text ([(ByteString, ByteString)], a)
runAttrParser AttrParser a
attrParser (Node -> [(ByteString, ByteString)]
attributes Node
n) of
    Left Text
e -> forall a b. a -> Either a b
Left Text
e
    Right ([(ByteString, ByteString)]
_, a
a) -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a

class FromAttrBs a where
  fromAttrBs :: ByteString -> Either Text a

instance FromAttrBs ByteString where
  fromAttrBs :: ByteString -> Either Text ByteString
fromAttrBs = forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance FromAttrBs Bool where
    fromAttrBs :: ByteString -> Either Text Bool
fromAttrBs ByteString
x | ByteString
x forall a. Eq a => a -> a -> Bool
== ByteString
"1" Bool -> Bool -> Bool
|| ByteString
x forall a. Eq a => a -> a -> Bool
== ByteString
"true"  = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                 | ByteString
x forall a. Eq a => a -> a -> Bool
== ByteString
"0" Bool -> Bool -> Bool
|| ByteString
x forall a. Eq a => a -> a -> Bool
== ByteString
"false" = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                 | Bool
otherwise                = forall a. Text -> ByteString -> Either Text a
unexpectedAttrBs Text
"boolean" ByteString
x

instance FromAttrBs Int where
  -- it appears that parser in text is more optimized than the one in
  -- attoparsec at least as of text-1.2.2.2 and attoparsec-0.13.1.0
  fromAttrBs :: ByteString -> Either Text Int
fromAttrBs = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => Text -> Either String a
eitherDecimal forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeLatin1

instance FromAttrBs Double where
  -- as for rationals
  fromAttrBs :: ByteString -> Either Text Double
fromAttrBs = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String Double
eitherRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeLatin1

instance FromAttrBs Text where
  fromAttrBs :: ByteString -> Either Text Text
fromAttrBs = ByteString -> Either Text Text
replaceEntititesBs

replaceEntititesBs :: ByteString -> Either Text Text
replaceEntititesBs :: ByteString -> Either Text Text
replaceEntititesBs ByteString
str =
  ByteString -> Text
T.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
BS.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Either Text [ByteString]
findAmp Int
0
  where
    findAmp :: Int -> Either Text [ByteString]
    findAmp :: Int -> Either Text [ByteString]
findAmp Int
index =
      case Word8 -> ByteString -> Int -> Maybe Int
elemIndexFrom Word8
ampersand ByteString
str Int
index of
        Maybe Int
Nothing -> if ByteString -> Bool
BS.null ByteString
text then forall (m :: * -> *) a. Monad m => a -> m a
return [] else forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString
text]
          where text :: ByteString
text = Int -> ByteString -> ByteString
BS.drop Int
index ByteString
str
        Just Int
fromAmp ->
          if ByteString -> Bool
BS.null ByteString
text
             then Int -> Either Text [ByteString]
checkEntity Int
fromAmp
             else (ByteString
textforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Either Text [ByteString]
checkEntity Int
fromAmp
          where text :: ByteString
text = ByteString -> Int -> Int -> ByteString
substring ByteString
str Int
index Int
fromAmp
    checkEntity :: Int -> Either Text [ByteString]
checkEntity Int
index =
      case Word8 -> ByteString -> Int -> Maybe Int
elemIndexFrom Word8
semicolon ByteString
str Int
index of
        Just Int
fromSemi | Int
fromSemi forall a. Ord a => a -> a -> Bool
>= Int
index forall a. Num a => a -> a -> a
+ Int
3 -> do
                          Word8
entity <- forall {a}. (Num a, Enum a) => Int -> Int -> Either Text a
checkElementVal (Int
index forall a. Num a => a -> a -> a
+ Int
1) (Int
fromSemi forall a. Num a => a -> a -> a
- Int
index forall a. Num a => a -> a -> a
- Int
1)
                          (Word8 -> ByteString
BS.singleton Word8
entityforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Either Text [ByteString]
findAmp (Int
fromSemi forall a. Num a => a -> a -> a
+ Int
1)
        Maybe Int
_ -> forall a b. a -> Either a b
Left Text
"Unending entity"
    checkElementVal :: Int -> Int -> Either Text a
checkElementVal Int
index Int
len =
      if | Int
len forall a. Eq a => a -> a -> Bool
== Int
2
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
0 forall a. Eq a => a -> a -> Bool
== Word8
108 -- l
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
1 forall a. Eq a => a -> a -> Bool
== Word8
116 -- t
            -> forall (m :: * -> *) a. Monad m => a -> m a
return a
60 -- '<'
         | Int
len forall a. Eq a => a -> a -> Bool
== Int
2
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
0 forall a. Eq a => a -> a -> Bool
== Word8
103 -- g
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
1 forall a. Eq a => a -> a -> Bool
== Word8
116 -- t
            -> forall (m :: * -> *) a. Monad m => a -> m a
return a
62 -- '>'
         | Int
len forall a. Eq a => a -> a -> Bool
== Int
3
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
0 forall a. Eq a => a -> a -> Bool
==  Word8
97 -- a
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
1 forall a. Eq a => a -> a -> Bool
== Word8
109 -- m
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
2 forall a. Eq a => a -> a -> Bool
== Word8
112 -- p
            -> forall (m :: * -> *) a. Monad m => a -> m a
return a
38 -- '&'
         | Int
len forall a. Eq a => a -> a -> Bool
== Int
4
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
0 forall a. Eq a => a -> a -> Bool
== Word8
113 -- q
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
1 forall a. Eq a => a -> a -> Bool
== Word8
117 -- u
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
2 forall a. Eq a => a -> a -> Bool
== Word8
111 -- o
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
3 forall a. Eq a => a -> a -> Bool
== Word8
116 -- t
            -> forall (m :: * -> *) a. Monad m => a -> m a
return a
34 -- '"'
         | Int
len forall a. Eq a => a -> a -> Bool
== Int
4
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
0 forall a. Eq a => a -> a -> Bool
==  Word8
97 -- a
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
1 forall a. Eq a => a -> a -> Bool
== Word8
112 -- p
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
2 forall a. Eq a => a -> a -> Bool
== Word8
111 -- o
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
3 forall a. Eq a => a -> a -> Bool
== Word8
115 -- s
           -> forall (m :: * -> *) a. Monad m => a -> m a
return a
39 -- '\''
         |    ByteString -> Int -> Word8
s_index ByteString
this Int
0 forall a. Eq a => a -> a -> Bool
== Word8
35  -- '#'
           ->
           if ByteString -> Int -> Word8
s_index ByteString
this Int
1 forall a. Eq a => a -> a -> Bool
== Word8
120 -- 'x'
              then forall a. Enum a => Int -> a
toEnum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> Either Text Int
checkHexadecimal (Int
index forall a. Num a => a -> a -> a
+ Int
2) (Int
len forall a. Num a => a -> a -> a
- Int
2)
              else forall a. Enum a => Int -> a
toEnum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> Either Text Int
checkDecimal (Int
index forall a. Num a => a -> a -> a
+ Int
1) (Int
len forall a. Num a => a -> a -> a
- Int
1)
         | Bool
otherwise -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Bad entity " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ (ByteString -> Int -> Int -> ByteString
substring ByteString
str (Int
indexforall a. Num a => a -> a -> a
-Int
1) (Int
indexforall a. Num a => a -> a -> a
+Int
lenforall a. Num a => a -> a -> a
+Int
1)))
      where
        this :: ByteString
this = Int -> ByteString -> ByteString
BS.drop Int
index ByteString
str
    checkDecimal :: Int -> Int -> Either Text Int
checkDecimal Int
index Int
len = forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' Either Text Int -> Word8 -> Either Text Int
go (forall a b. b -> Either a b
Right Int
0) (ByteString -> Int -> Int -> ByteString
substring ByteString
str Int
index (Int
index forall a. Num a => a -> a -> a
+ Int
len))
      where
        go :: Either Text Int -> Word8 -> Either Text Int
        go :: Either Text Int -> Word8 -> Either Text Int
go Either Text Int
prev Word8
c = do
          Int
a <- Either Text Int
prev
          if Word8
c forall a. Ord a => a -> a -> Bool
>= Word8
48 Bool -> Bool -> Bool
&& Word8
c forall a. Ord a => a -> a -> Bool
<= Word8
57
            then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
a forall a. Num a => a -> a -> a
* Int
10 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
c forall a. Num a => a -> a -> a
- Word8
48)
            else forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Expected decimal digit but encountered " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show (Int -> Char
chr forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
c))
    checkHexadecimal :: Int -> Int -> Either Text Int
checkHexadecimal Int
index Int
len = forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' Either Text Int -> Word8 -> Either Text Int
go (forall a b. b -> Either a b
Right Int
0) (ByteString -> Int -> Int -> ByteString
substring ByteString
str Int
index (Int
index forall a. Num a => a -> a -> a
+ Int
len))
      where
        go :: Either Text Int -> Word8 -> Either Text Int
        go :: Either Text Int -> Word8 -> Either Text Int
go Either Text Int
prev Word8
c = do
          Int
a <- Either Text Int
prev
          if | Word8
c forall a. Ord a => a -> a -> Bool
>= Word8
48 Bool -> Bool -> Bool
&& Word8
c forall a. Ord a => a -> a -> Bool
<= Word8
57
               -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Int
a forall a. Bits a => a -> Int -> a
`shiftL` Int
4) forall a. Bits a => a -> a -> a
.|. forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
c forall a. Num a => a -> a -> a
- Word8
48)
             | Word8
c forall a. Ord a => a -> a -> Bool
>= Word8
97 Bool -> Bool -> Bool
&& Word8
c forall a. Ord a => a -> a -> Bool
<= Word8
122
               -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Int
a forall a. Bits a => a -> Int -> a
`shiftL` Int
4) forall a. Bits a => a -> a -> a
.|. forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
c forall a. Num a => a -> a -> a
- Word8
87)
             | Word8
c forall a. Ord a => a -> a -> Bool
>= Word8
65 Bool -> Bool -> Bool
&& Word8
c forall a. Ord a => a -> a -> Bool
<= Word8
90
               -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Int
a forall a. Bits a => a -> Int -> a
`shiftL` Int
4) forall a. Bits a => a -> a -> a
.|. forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
c forall a. Num a => a -> a -> a
- Word8
55)
             | Bool
otherwise
               ->
               forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Expected hexadecimal digit but encountered " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show (Int -> Char
chr forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
c))
    ampersand :: Word8
ampersand = Word8
38
    semicolon :: Word8
semicolon = Word8
59

data EntityReplaceException = EntityReplaceException deriving Int -> EntityReplaceException -> ShowS
[EntityReplaceException] -> ShowS
EntityReplaceException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EntityReplaceException] -> ShowS
$cshowList :: [EntityReplaceException] -> ShowS
show :: EntityReplaceException -> String
$cshow :: EntityReplaceException -> String
showsPrec :: Int -> EntityReplaceException -> ShowS
$cshowsPrec :: Int -> EntityReplaceException -> ShowS
Show

instance Exception EntityReplaceException

-- | /O(1)/ 'ByteString' index (subscript) operator, starting from 0.
s_index :: ByteString -> Int -> Word8
s_index :: ByteString -> Int -> Word8
s_index ByteString
ps Int
n
    | Int
n forall a. Ord a => a -> a -> Bool
< Int
0             = forall a e. Exception e => e -> a
throw EntityReplaceException
EntityReplaceException
    | Int
n forall a. Ord a => a -> a -> Bool
>= ByteString -> Int
BS.length ByteString
ps = forall a e. Exception e => e -> a
throw EntityReplaceException
EntityReplaceException
    | Bool
otherwise         = ByteString
ps ByteString -> Int -> Word8
`SU.unsafeIndex` Int
n
{-# INLINE s_index #-}

-- | Get index of an element starting from offset.
elemIndexFrom :: Word8 -> ByteString -> Int -> Maybe Int
elemIndexFrom :: Word8 -> ByteString -> Int -> Maybe Int
elemIndexFrom Word8
c ByteString
str Int
offset = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
+ Int
offset) (Word8 -> ByteString -> Maybe Int
BS.elemIndex Word8
c (Int -> ByteString -> ByteString
BS.drop Int
offset ByteString
str))
-- Without the INLINE below, the whole function is twice as slow and
-- has linear allocation. See git commit with this comment for
-- results.
{-# INLINE elemIndexFrom #-}

-- | Get a substring of a string.
substring :: ByteString -> Int -> Int -> ByteString
substring :: ByteString -> Int -> Int -> ByteString
substring ByteString
s Int
start Int
end = Int -> ByteString -> ByteString
BS.take (Int
end forall a. Num a => a -> a -> a
- Int
start) (Int -> ByteString -> ByteString
BS.drop Int
start ByteString
s)
{-# INLINE substring #-}

newtype NsPrefixes = NsPrefixes [(ByteString, ByteString)]

nsPrefixes :: Node -> NsPrefixes
nsPrefixes :: Node -> NsPrefixes
nsPrefixes Node
root =
  [(ByteString, ByteString)] -> NsPrefixes
NsPrefixes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Node -> [(ByteString, ByteString)]
attributes Node
root) forall a b. (a -> b) -> a -> b
$ \(ByteString
nm, ByteString
val) ->
    (ByteString
val, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
"xmlns:" ByteString
nm

addPrefix :: NsPrefixes -> ByteString -> (ByteString -> ByteString)
addPrefix :: NsPrefixes -> ByteString -> ByteString -> ByteString
addPrefix (NsPrefixes [(ByteString, ByteString)]
prefixes) ByteString
ns =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\ByteString
prefix ByteString
nm -> [ByteString] -> ByteString
BS.concat [ByteString
prefix, ByteString
":", ByteString
nm]) forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup ByteString
ns [(ByteString, ByteString)]
prefixes

contentBs :: Node -> ByteString
contentBs :: Node -> ByteString
contentBs Node
n = [ByteString] -> ByteString
BS.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Content -> ByteString
toBs forall a b. (a -> b) -> a -> b
$ Node -> [Content]
contents Node
n
  where
    toBs :: Content -> ByteString
toBs (Element Node
_) = ByteString
BS.empty
    toBs (Text ByteString
bs) = ByteString
bs
    toBs (CData ByteString
bs) = ByteString
bs

contentX :: Node -> Either Text Text
contentX :: Node -> Either Text Text
contentX = ByteString -> Either Text Text
replaceEntititesBs forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> ByteString
contentBs