{-# 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
  { ChildCollector a -> [Node] -> Either Text ([Node], a)
runChildCollector :: [Node] -> Either Text ([Node], a)
  }

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

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

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

instance Monad ChildCollector where
  return :: a -> ChildCollector a
return = a -> ChildCollector a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ChildCollector [Node] -> Either Text ([Node], a)
f >>= :: ChildCollector a -> (a -> ChildCollector b) -> ChildCollector b
>>= a -> ChildCollector b
g = ([Node] -> Either Text ([Node], b)) -> ChildCollector b
forall a. ([Node] -> Either Text ([Node], a)) -> ChildCollector a
ChildCollector (([Node] -> Either Text ([Node], b)) -> ChildCollector b)
-> ([Node] -> Either Text ([Node], b)) -> ChildCollector b
forall a b. (a -> b) -> a -> b
$ \[Node]
ns ->
    (Text -> Either Text ([Node], b))
-> (([Node], a) -> Either Text ([Node], b))
-> Either Text ([Node], a)
-> Either Text ([Node], b)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Either Text ([Node], b)
forall a b. a -> Either a b
Left (\(![Node]
ns', a
f') -> ChildCollector b -> [Node] -> Either Text ([Node], b)
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 :: Either Text a -> ChildCollector a
toChildCollector Either Text a
unlifted =
  case Either Text a
unlifted of
    Right a
a -> a -> ChildCollector a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    Left Text
e -> ([Node] -> Either Text ([Node], a)) -> ChildCollector a
forall a. ([Node] -> Either Text ([Node], a)) -> ChildCollector a
ChildCollector (([Node] -> Either Text ([Node], a)) -> ChildCollector a)
-> ([Node] -> Either Text ([Node], a)) -> ChildCollector a
forall a b. (a -> b) -> a -> b
$ \[Node]
_ -> Text -> Either Text ([Node], a)
forall a b. a -> Either a b
Left Text
e

collectChildren :: Node -> ChildCollector a -> Either Text a
collectChildren :: Node -> ChildCollector a -> Either Text a
collectChildren Node
n ChildCollector a
c = ([Node], a) -> a
forall a b. (a, b) -> b
snd (([Node], a) -> a) -> Either Text ([Node], a) -> Either Text a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChildCollector a -> [Node] -> Either Text ([Node], a)
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 =
  ([Node] -> Either Text ([Node], Maybe Node))
-> ChildCollector (Maybe Node)
forall a. ([Node] -> Either Text ([Node], a)) -> ChildCollector a
ChildCollector (([Node] -> Either Text ([Node], Maybe Node))
 -> ChildCollector (Maybe Node))
-> ([Node] -> Either Text ([Node], Maybe Node))
-> ChildCollector (Maybe Node)
forall a b. (a -> b) -> a -> b
$ \case
    (Node
n:[Node]
ns)
      | Node -> ByteString
name Node
n ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
nm -> ([Node], Maybe Node) -> Either Text ([Node], Maybe Node)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Node]
ns, Node -> Maybe Node
forall a. a -> Maybe a
Just Node
n)
    [Node]
ns -> ([Node], Maybe Node) -> Either Text ([Node], Maybe Node)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Node]
ns, Maybe Node
forall a. Maybe a
Nothing)

requireChild :: ByteString -> ChildCollector Node
requireChild :: ByteString -> ChildCollector Node
requireChild ByteString
nm =
  ([Node] -> Either Text ([Node], Node)) -> ChildCollector Node
forall a. ([Node] -> Either Text ([Node], a)) -> ChildCollector a
ChildCollector (([Node] -> Either Text ([Node], Node)) -> ChildCollector Node)
-> ([Node] -> Either Text ([Node], Node)) -> ChildCollector Node
forall a b. (a -> b) -> a -> b
$ \case
    (Node
n:[Node]
ns)
      | Node -> ByteString
name Node
n ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
nm -> ([Node], Node) -> Either Text ([Node], Node)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Node]
ns, Node
n)
    [Node]
_ ->
      Text -> Either Text ([Node], Node)
forall a b. a -> Either a b
Left (Text -> Either Text ([Node], Node))
-> Text -> Either Text ([Node], Node)
forall a b. (a -> b) -> a -> b
$ Text
"required element " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ByteString -> String
forall a. Show a => a -> String
show ByteString
nm) Text -> Text -> Text
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
nNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:) ([Node] -> [Node])
-> ChildCollector [Node] -> ChildCollector [Node]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> ChildCollector [Node]
childList ByteString
nm
    Maybe Node
Nothing -> [Node] -> ChildCollector [Node]
forall (m :: * -> *) a. Monad m => a -> m a
return []

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

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

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

maybeParse :: ByteString -> (Node -> Either Text a) -> ChildCollector (Maybe a)
maybeParse :: ByteString -> (Node -> Either Text a) -> ChildCollector (Maybe a)
maybeParse ByteString
nm Node -> Either Text a
parse = ByteString -> ChildCollector (Maybe Node)
maybeChild ByteString
nm ChildCollector (Maybe Node)
-> (Maybe Node -> ChildCollector (Maybe a))
-> ChildCollector (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Either Text (Maybe a) -> ChildCollector (Maybe a)
forall a. Either Text a -> ChildCollector a
toChildCollector (Either Text (Maybe a) -> ChildCollector (Maybe a))
-> (Maybe Node -> Either Text (Maybe a))
-> Maybe Node
-> ChildCollector (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node -> Either Text a) -> Maybe Node -> Either Text (Maybe a)
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 :: ByteString -> (Node -> Either Text a) -> ChildCollector a
requireAndParse ByteString
nm Node -> Either Text a
parse = ByteString -> ChildCollector Node
requireChild ByteString
nm ChildCollector Node
-> (Node -> ChildCollector a) -> ChildCollector a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Either Text a -> ChildCollector a
forall a. Either Text a -> ChildCollector a
toChildCollector (Either Text a -> ChildCollector a)
-> (Node -> Either Text a) -> Node -> ChildCollector a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> Either Text a
parse)

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

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

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

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

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

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

maybeAttrBs :: ByteString -> AttrParser (Maybe ByteString)
maybeAttrBs :: ByteString -> AttrParser (Maybe ByteString)
maybeAttrBs ByteString
attrName = ([(ByteString, ByteString)]
 -> Either Text ([(ByteString, ByteString)], Maybe ByteString))
-> AttrParser (Maybe ByteString)
forall a.
([(ByteString, ByteString)]
 -> Either Text ([(ByteString, ByteString)], a))
-> AttrParser a
AttrParser (([(ByteString, ByteString)]
  -> Either Text ([(ByteString, ByteString)], Maybe ByteString))
 -> AttrParser (Maybe ByteString))
-> ([(ByteString, ByteString)]
    -> Either Text ([(ByteString, ByteString)], Maybe ByteString))
-> AttrParser (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(ByteString, ByteString)]
-> Either Text ([(ByteString, ByteString)], Maybe ByteString)
forall a c a.
([(ByteString, a)] -> c)
-> [(ByteString, a)] -> Either a (c, Maybe a)
go [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> a
id
  where
    go :: ([(ByteString, a)] -> c)
-> [(ByteString, a)] -> Either a (c, Maybe a)
go [(ByteString, a)] -> c
front [] = (c, Maybe a) -> Either a (c, Maybe a)
forall a b. b -> Either a b
Right ([(ByteString, a)] -> c
front [], Maybe a
forall a. Maybe a
Nothing)
    go [(ByteString, a)] -> c
front (a :: (ByteString, a)
a@(ByteString
nm, a
val):[(ByteString, a)]
as) =
      if ByteString
nm ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
attrName
        then (c, Maybe a) -> Either a (c, Maybe a)
forall a b. b -> Either a b
Right ([(ByteString, a)] -> c
front [(ByteString, a)]
as, a -> Maybe a
forall a. a -> Maybe a
Just a
val)
        else ([(ByteString, a)] -> c)
-> [(ByteString, a)] -> Either a (c, Maybe a)
go ([(ByteString, a)] -> c
front ([(ByteString, a)] -> c)
-> ([(ByteString, a)] -> [(ByteString, a)])
-> [(ByteString, a)]
-> c
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 -> ByteString -> AttrParser ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
val
    Maybe ByteString
Nothing -> Text -> AttrParser ByteString
forall a. Text -> AttrParser a
attrError (Text -> AttrParser ByteString) -> Text -> AttrParser ByteString
forall a b. (a -> b) -> a -> b
$ Text
"attribute " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ByteString -> String
forall a. Show a => a -> String
show ByteString
nm) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is required"

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

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

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

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

parseAttributes :: Node -> AttrParser a -> Either Text a
parseAttributes :: Node -> AttrParser a -> Either Text a
parseAttributes Node
n AttrParser a
attrParser =
  case AttrParser a
-> [(ByteString, ByteString)]
-> Either Text ([(ByteString, ByteString)], a)
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 -> Text -> Either Text a
forall a b. a -> Either a b
Left Text
e
    Right ([(ByteString, ByteString)]
_, a
a) -> a -> Either Text 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 = ByteString -> Either Text ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance FromAttrBs Bool where
    fromAttrBs :: ByteString -> Either Text Bool
fromAttrBs ByteString
x | ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"1" Bool -> Bool -> Bool
|| ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"true"  = Bool -> Either Text Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                 | ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"0" Bool -> Bool -> Bool
|| ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"false" = Bool -> Either Text Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                 | Bool
otherwise                = Text -> ByteString -> Either Text Bool
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 = (String -> Text) -> Either String Int -> Either Text Int
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
T.pack (Either String Int -> Either Text Int)
-> (ByteString -> Either String Int)
-> ByteString
-> Either Text Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String Int
forall a. Integral a => Text -> Either String a
eitherDecimal (Text -> Either String Int)
-> (ByteString -> Text) -> ByteString -> Either String Int
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 = (String -> Text) -> Either String Double -> Either Text Double
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
T.pack (Either String Double -> Either Text Double)
-> (ByteString -> Either String Double)
-> ByteString
-> Either Text Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String Double
eitherRational (Text -> Either String Double)
-> (ByteString -> Text) -> ByteString -> Either String Double
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 (ByteString -> Text)
-> ([ByteString] -> ByteString) -> [ByteString] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
BS.concat ([ByteString] -> Text)
-> Either Text [ByteString] -> Either Text Text
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 [ByteString] -> Either Text [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return [] else [ByteString] -> Either Text [ByteString]
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
textByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:) ([ByteString] -> [ByteString])
-> Either Text [ByteString] -> Either Text [ByteString]
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
index Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3 -> do
                          Word8
entity <- Int -> Int -> Either Text Word8
forall a. (Num a, Enum a) => Int -> Int -> Either Text a
checkElementVal (Int
index Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
fromSemi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
index Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                          (Word8 -> ByteString
BS.singleton Word8
entityByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:) ([ByteString] -> [ByteString])
-> Either Text [ByteString] -> Either Text [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Either Text [ByteString]
findAmp (Int
fromSemi Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        Maybe Int
_ -> Text -> Either Text [ByteString]
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
108 -- l
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
1 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
116 -- t
            -> a -> Either Text a
forall (m :: * -> *) a. Monad m => a -> m a
return a
60 -- '<'
         | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
103 -- g
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
1 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
116 -- t
            -> a -> Either Text a
forall (m :: * -> *) a. Monad m => a -> m a
return a
62 -- '>'
         | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
==  Word8
97 -- a
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
1 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
109 -- m
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
2 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
112 -- p
            -> a -> Either Text a
forall (m :: * -> *) a. Monad m => a -> m a
return a
38 -- '&'
         | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
113 -- q
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
1 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
117 -- u
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
2 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
111 -- o
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
3 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
116 -- t
            -> a -> Either Text a
forall (m :: * -> *) a. Monad m => a -> m a
return a
34 -- '"'
         | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
==  Word8
97 -- a
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
1 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
112 -- p
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
2 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
111 -- o
           Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
s_index ByteString
this Int
3 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
115 -- s
           -> a -> Either Text a
forall (m :: * -> *) a. Monad m => a -> m a
return a
39 -- '\''
         |    ByteString -> Int -> Word8
s_index ByteString
this Int
0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
35  -- '#'
           ->
           if ByteString -> Int -> Word8
s_index ByteString
this Int
1 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
120 -- 'x'
              then Int -> a
forall a. Enum a => Int -> a
toEnum (Int -> a) -> Either Text Int -> Either Text a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> Either Text Int
checkHexadecimal (Int
index Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)
              else Int -> a
forall a. Enum a => Int -> a
toEnum (Int -> a) -> Either Text Int -> Either Text a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> Either Text Int
checkDecimal (Int
index Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
         | Bool
otherwise -> Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text
"Bad entity " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ByteString -> String
forall a. Show a => a -> String
show (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ (ByteString -> Int -> Int -> ByteString
substring ByteString
str (Int
indexInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int
indexInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
lenInt -> Int -> Int
forall 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 = (Either Text Int -> Word8 -> Either Text Int)
-> Either Text Int -> ByteString -> Either Text Int
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' Either Text Int -> Word8 -> Either Text Int
go (Int -> Either Text Int
forall a b. b -> Either a b
Right Int
0) (ByteString -> Int -> Int -> ByteString
substring ByteString
str Int
index (Int
index Int -> Int -> Int
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 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
48 Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
57
            then Int -> Either Text Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Either Text Int) -> Int -> Either Text Int
forall a b. (a -> b) -> a -> b
$ Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
c Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
48)
            else Text -> Either Text Int
forall a b. a -> Either a b
Left (Text -> Either Text Int) -> Text -> Either Text Int
forall a b. (a -> b) -> a -> b
$ Text
"Expected decimal digit but encountered " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Char -> String
forall a. Show a => a -> String
show (Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
c))
    checkHexadecimal :: Int -> Int -> Either Text Int
checkHexadecimal Int
index Int
len = (Either Text Int -> Word8 -> Either Text Int)
-> Either Text Int -> ByteString -> Either Text Int
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' Either Text Int -> Word8 -> Either Text Int
go (Int -> Either Text Int
forall a b. b -> Either a b
Right Int
0) (ByteString -> Int -> Int -> ByteString
substring ByteString
str Int
index (Int
index Int -> Int -> Int
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 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
48 Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
57
               -> Int -> Either Text Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Either Text Int) -> Int -> Either Text Int
forall a b. (a -> b) -> a -> b
$ (Int
a Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
4) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
c Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
48)
             | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
97 Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
122
               -> Int -> Either Text Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Either Text Int) -> Int -> Either Text Int
forall a b. (a -> b) -> a -> b
$ (Int
a Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
4) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
c Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
87)
             | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
65 Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
90
               -> Int -> Either Text Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Either Text Int) -> Int -> Either Text Int
forall a b. (a -> b) -> a -> b
$ (Int
a Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
4) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
c Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
55)
             | Bool
otherwise
               ->
               Text -> Either Text Int
forall a b. a -> Either a b
Left (Text -> Either Text Int) -> Text -> Either Text Int
forall a b. (a -> b) -> a -> b
$ Text
"Expected hexadecimal digit but encountered " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Char -> String
forall a. Show a => a -> String
show (Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Word8 -> Int
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
(Int -> EntityReplaceException -> ShowS)
-> (EntityReplaceException -> String)
-> ([EntityReplaceException] -> ShowS)
-> Show EntityReplaceException
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0             = EntityReplaceException -> Word8
forall a e. Exception e => e -> a
throw EntityReplaceException
EntityReplaceException
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= ByteString -> Int
BS.length ByteString
ps = EntityReplaceException -> Word8
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 = (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Int -> Int
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 Int -> Int -> Int
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 ([(ByteString, ByteString)] -> NsPrefixes)
-> (((ByteString, ByteString) -> Maybe (ByteString, ByteString))
    -> [(ByteString, ByteString)])
-> ((ByteString, ByteString) -> Maybe (ByteString, ByteString))
-> NsPrefixes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((ByteString, ByteString) -> Maybe (ByteString, ByteString))
 -> [(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(ByteString, ByteString)]
-> ((ByteString, ByteString) -> Maybe (ByteString, ByteString))
-> [(ByteString, ByteString)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((ByteString, ByteString) -> Maybe (ByteString, ByteString))
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Node -> [(ByteString, ByteString)]
attributes Node
root) (((ByteString, ByteString) -> Maybe (ByteString, ByteString))
 -> NsPrefixes)
-> ((ByteString, ByteString) -> Maybe (ByteString, ByteString))
-> NsPrefixes
forall a b. (a -> b) -> a -> b
$ \(ByteString
nm, ByteString
val) ->
    (ByteString
val, ) (ByteString -> (ByteString, ByteString))
-> Maybe ByteString -> Maybe (ByteString, ByteString)
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 =
  (ByteString -> ByteString)
-> (ByteString -> ByteString -> ByteString)
-> Maybe ByteString
-> ByteString
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString -> ByteString
forall a. a -> a
id (\ByteString
prefix ByteString
nm -> [ByteString] -> ByteString
BS.concat [ByteString
prefix, ByteString
":", ByteString
nm]) (Maybe ByteString -> ByteString -> ByteString)
-> Maybe ByteString -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
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 ([ByteString] -> ByteString)
-> ([Content] -> [ByteString]) -> [Content] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Content -> ByteString) -> [Content] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Content -> ByteString
toBs ([Content] -> ByteString) -> [Content] -> ByteString
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 (ByteString -> Either Text Text)
-> (Node -> ByteString) -> Node -> Either Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> ByteString
contentBs