module XmlParser.AstParser
  ( -- * Execution
    parseElement,
    renderElementError,
    ElementError (..),
    NodeType (..),

    -- * Parsers by context

    -- ** Element
    Element,
    elementName,
    elementNameIs,
    children,
    childrenByName,
    attributesByName,
    astElement,

    -- ** Nodes
    Nodes,
    elementNode,
    contentNode,

    -- ** ByName
    ByName,
    byName,

    -- ** Content
    Content,
    textContent,
    narrowedContent,
    refinedContent,
    enumContent,
    attoparsedContent,
    qNameContent,
  )
where

import qualified Data.Attoparsec.Text as Attoparsec
import qualified Data.HashMap.Strict as HashMap
import qualified Data.List as List
import qualified Text.Builder as Tb
import qualified Text.XML as Xml
import qualified XmlParser.Attoparsec as Attoparsec
import qualified XmlParser.ElementDestructionState as ElementDestructionState
import qualified XmlParser.NameMap as NameMap
import qualified XmlParser.NamespaceRegistry as NamespaceRegistry
import qualified XmlParser.NodeConsumerState as NodeConsumerState
import XmlParser.Prelude

-- |
-- Parse an \"xml-conduit\" element AST.
parseElement :: Element a -> Xml.Element -> Either ElementError a
parseElement :: forall a. Element a -> Element -> Either ElementError a
parseElement (Element NamespaceRegistry
-> Element
-> ElementDestructionState
-> Either ElementError (a, ElementDestructionState)
run) Element
element =
  NamespaceRegistry
-> Element
-> ElementDestructionState
-> Either ElementError (a, ElementDestructionState)
run
    (Map Name Text -> NamespaceRegistry -> NamespaceRegistry
NamespaceRegistry.interpretAttributes (Element -> Map Name Text
Xml.elementAttributes Element
element) NamespaceRegistry
NamespaceRegistry.new)
    Element
element
    ElementDestructionState
ElementDestructionState.new
    forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst

renderElementError :: ElementError -> Text
renderElementError :: ElementError -> Text
renderElementError =
  Builder -> Text
Tb.run forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (\([Builder]
a, Builder
b) -> Builder
"/" forall a. Semigroup a => a -> a -> a
<> forall (foldable :: * -> *).
Foldable foldable =>
Builder -> foldable Builder -> Builder
Tb.intercalate Builder
"/" (forall a. [a] -> [a]
reverse [Builder]
a) forall a. Semigroup a => a -> a -> a
<> Builder
": " forall a. Semigroup a => a -> a -> a
<> Builder
b) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ElementError -> ([Builder], Builder)
simplifyElementError

simplifyElementError :: ElementError -> ([Tb.Builder], Tb.Builder)
simplifyElementError :: ElementError -> ([Builder], Builder)
simplifyElementError =
  [Builder] -> ElementError -> ([Builder], Builder)
elementError []
  where
    sortedList :: (a -> Builder) -> [a] -> Builder
sortedList a -> Builder
renderer =
      forall a. Monoid a => a -> a -> a
mappend Builder
"[" forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Monoid a => a -> a -> a
mappend Builder
"]" forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (foldable :: * -> *).
Foldable foldable =>
Builder -> foldable Builder -> Builder
Tb.intercalate Builder
", " forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Builder
renderer forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Ord a => [a] -> [a]
sort
    name :: Maybe a -> Text -> Builder
name Maybe a
a Text
b =
      case Maybe a
a of
        Just a
_ -> Text -> Builder
Tb.text Text
b
        Maybe a
Nothing -> Text -> Builder
Tb.text Text
b
    elementError :: [Builder] -> ElementError -> ([Builder], Builder)
elementError [Builder]
collectedPath = \case
      NoneOfChildrenFoundByNameElementError [(Maybe Text, Text)]
a [(Maybe Text, Text)]
b ->
        ( [Builder]
collectedPath,
          Builder
"None of following child element names found: "
            forall a. Semigroup a => a -> a -> a
<> forall {a}. Ord a => (a -> Builder) -> [a] -> Builder
sortedList (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall {a}. Maybe a -> Text -> Builder
name) [(Maybe Text, Text)]
a
            forall a. Semigroup a => a -> a -> a
<> Builder
". Names available: "
            forall a. Semigroup a => a -> a -> a
<> forall {a}. Ord a => (a -> Builder) -> [a] -> Builder
sortedList (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall {a}. Maybe a -> Text -> Builder
name) [(Maybe Text, Text)]
b
        )
      ChildByNameElementError Maybe Text
a Text
b ElementError
c ->
        [Builder] -> ElementError -> ([Builder], Builder)
elementError (forall {a}. Maybe a -> Text -> Builder
name Maybe Text
a Text
b forall a. a -> [a] -> [a]
: [Builder]
collectedPath) ElementError
c
      ChildAtOffsetElementError Int
a NodeError
b ->
        [Builder] -> NodeError -> ([Builder], Builder)
nodeError (forall a. Integral a => a -> Builder
Tb.decimal Int
a forall a. a -> [a] -> [a]
: [Builder]
collectedPath) NodeError
b
      AttributeByNameElementError Maybe Text
a Text
b Maybe ContentError
c ->
        ((Builder
"@" forall a. Semigroup a => a -> a -> a
<> forall {a}. Maybe a -> Text -> Builder
name Maybe Text
a Text
b) forall a. a -> [a] -> [a]
: [Builder]
collectedPath, Maybe ContentError -> Builder
maybeContentError Maybe ContentError
c)
      NoneOfAttributesFoundByNameElementError [(Maybe Text, Text)]
a [(Maybe Text, Text)]
b ->
        ( [Builder]
collectedPath,
          Builder
"Found none of the following attributes: " forall a. Semigroup a => a -> a -> a
<> forall {a}. Ord a => (a -> Builder) -> [a] -> Builder
sortedList (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall {a}. Maybe a -> Text -> Builder
name) [(Maybe Text, Text)]
a
            forall a. Semigroup a => a -> a -> a
<> Builder
". The following are available: "
            forall a. Semigroup a => a -> a -> a
<> forall {a}. Ord a => (a -> Builder) -> [a] -> Builder
sortedList (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall {a}. Maybe a -> Text -> Builder
name) [(Maybe Text, Text)]
b
        )
      NameElementError Text
a ->
        ([Builder]
collectedPath, Text -> Builder
Tb.text Text
a)
      UserElementError Text
a ->
        ([Builder]
collectedPath, Text -> Builder
Tb.text Text
a)
    nodeError :: [Builder] -> NodeError -> ([Builder], Builder)
nodeError [Builder]
collectedPath = \case
      UnexpectedNodeTypeNodeError NodeType
a NodeType
b ->
        ( [Builder]
collectedPath,
          Builder
"Unexpected node type. Got " forall a. Semigroup a => a -> a -> a
<> forall {a}. IsString a => NodeType -> a
nodeType NodeType
b forall a. Semigroup a => a -> a -> a
<> Builder
", but expected " forall a. Semigroup a => a -> a -> a
<> forall {a}. IsString a => NodeType -> a
nodeType NodeType
a
        )
      NodeError
NotAvailableNodeError ->
        ([Builder]
collectedPath, Builder
"No nodes left")
      ElementNodeError ElementError
a ->
        [Builder] -> ElementError -> ([Builder], Builder)
elementError [Builder]
collectedPath ElementError
a
      TextNodeError Maybe ContentError
a ->
        ([Builder]
collectedPath, Maybe ContentError -> Builder
maybeContentError Maybe ContentError
a)
    nodeType :: NodeType -> a
nodeType = \case
      NodeType
ElementNodeType -> a
"element"
      NodeType
InstructionNodeType -> a
"instruction"
      NodeType
ContentNodeType -> a
"content"
      NodeType
CommentNodeType -> a
"comment"
    maybeContentError :: Maybe ContentError -> Builder
maybeContentError = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
"Empty alternative" ContentError -> Builder
contentError
    contentError :: ContentError -> Builder
contentError = \case
      UserContentError Text
a ->
        Text -> Builder
Tb.text Text
a
      ParsingContentError Text
a ->
        Text -> Builder
Tb.text Text
a
      NamespaceNotFoundContentError Text
a ->
        Builder
"Namespace not found: " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Tb.text Text
a
      UnexpectedValueContentError Text
a ->
        Builder
"Unexpected value: " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Tb.text Text
a
      EnumContentError [Text]
a Text
b ->
        Builder
"Unexpected value: " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Tb.text Text
b forall a. Semigroup a => a -> a -> a
<> Builder
". Expecting one of the following: " forall a. Semigroup a => a -> a -> a
<> forall {a}. Ord a => (a -> Builder) -> [a] -> Builder
sortedList Text -> Builder
Tb.text [Text]
a

-- |
-- Error in the context of an element.
--
-- It has a tree structure specifying the context of containing operations.
data ElementError
  = AttributeByNameElementError
      (Maybe Text)
      Text
      (Maybe ContentError)
  | NoneOfAttributesFoundByNameElementError
      [(Maybe Text, Text)]
      -- ^ Not found.
      [(Maybe Text, Text)]
      -- ^ Out of.
  | NoneOfChildrenFoundByNameElementError
      [(Maybe Text, Text)]
      -- ^ Not found.
      [(Maybe Text, Text)]
      -- ^ Out of.
  | ChildByNameElementError
      (Maybe Text)
      -- ^ Namespace.
      Text
      -- ^ Name.
      ElementError
      -- ^ Reason. Not 'NodeError' because only element nodes can be looked up by name.
  | ChildAtOffsetElementError
      Int
      -- ^ Offset.
      NodeError
      -- ^ Reason.
  | NameElementError Text
  | -- | Error raised by the user of this library.
    UserElementError Text

data NodeError
  = UnexpectedNodeTypeNodeError
      NodeType
      -- ^ Expected.
      NodeType
      -- ^ Actual.
  | NotAvailableNodeError
  | ElementNodeError ElementError
  | TextNodeError (Maybe ContentError)

data ContentError
  = ParsingContentError Text
  | NamespaceNotFoundContentError Text
  | UnexpectedValueContentError Text
  | EnumContentError
      [Text]
      -- ^ List of expected values.
      Text
      -- ^ Actual value
  | UserContentError Text

data NodeType
  = ElementNodeType
  | InstructionNodeType
  | ContentNodeType
  | CommentNodeType

-- |
-- Parse in the context of an element node.
newtype Element a
  = Element
      ( NamespaceRegistry.NamespaceRegistry ->
        Xml.Element ->
        ElementDestructionState.ElementDestructionState ->
        Either ElementError (a, ElementDestructionState.ElementDestructionState)
      )
  deriving
    (forall a b. a -> Element b -> Element a
forall a b. (a -> b) -> Element a -> Element b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Element b -> Element a
$c<$ :: forall a b. a -> Element b -> Element a
fmap :: forall a b. (a -> b) -> Element a -> Element b
$cfmap :: forall a b. (a -> b) -> Element a -> Element b
Functor, Functor Element
forall a. a -> Element a
forall a b. Element a -> Element b -> Element a
forall a b. Element a -> Element b -> Element b
forall a b. Element (a -> b) -> Element a -> Element b
forall a b c. (a -> b -> c) -> Element a -> Element b -> Element c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Element a -> Element b -> Element a
$c<* :: forall a b. Element a -> Element b -> Element a
*> :: forall a b. Element a -> Element b -> Element b
$c*> :: forall a b. Element a -> Element b -> Element b
liftA2 :: forall a b c. (a -> b -> c) -> Element a -> Element b -> Element c
$cliftA2 :: forall a b c. (a -> b -> c) -> Element a -> Element b -> Element c
<*> :: forall a b. Element (a -> b) -> Element a -> Element b
$c<*> :: forall a b. Element (a -> b) -> Element a -> Element b
pure :: forall a. a -> Element a
$cpure :: forall a. a -> Element a
Applicative, Applicative Element
forall a. a -> Element a
forall a b. Element a -> Element b -> Element b
forall a b. Element a -> (a -> Element b) -> Element b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Element a
$creturn :: forall a. a -> Element a
>> :: forall a b. Element a -> Element b -> Element b
$c>> :: forall a b. Element a -> Element b -> Element b
>>= :: forall a b. Element a -> (a -> Element b) -> Element b
$c>>= :: forall a b. Element a -> (a -> Element b) -> Element b
Monad)
    via ( ReaderT
            (NamespaceRegistry.NamespaceRegistry)
            ( ReaderT
                Xml.Element
                ( StateT
                    ElementDestructionState.ElementDestructionState
                    (Except ElementError)
                )
            )
        )

instance MonadFail Element where
  fail :: forall a. String -> Element a
fail = forall a. IsString a => String -> a
fromString forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Text -> ElementError
UserElementError forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a b. a -> Either a b
Left forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a b. a -> b -> a
const forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a b. a -> b -> a
const forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a b. a -> b -> a
const forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a.
(NamespaceRegistry
 -> Element
 -> ElementDestructionState
 -> Either ElementError (a, ElementDestructionState))
-> Element a
Element

-- |
-- Parse namespace and name with the given function.
elementName :: (Maybe Text -> Text -> Either Text a) -> Element a
elementName :: forall a. (Maybe Text -> Text -> Either Text a) -> Element a
elementName Maybe Text -> Text -> Either Text a
parse =
  forall a.
(NamespaceRegistry
 -> Element
 -> ElementDestructionState
 -> Either ElementError (a, ElementDestructionState))
-> Element a
Element forall a b. (a -> b) -> a -> b
$ \NamespaceRegistry
nreg (Xml.Element Name
name Map Name Text
_ [Node]
_) ElementDestructionState
state ->
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,ElementDestructionState
state) forall a b. (a -> b) -> a -> b
$ case Name -> NamespaceRegistry -> Maybe (Maybe Text, Text)
NamespaceRegistry.resolveElementName Name
name NamespaceRegistry
nreg of
      Maybe (Maybe Text, Text)
Nothing -> forall a b. a -> Either a b
Left (Text -> ElementError
NameElementError (Text
"Unresolvable name: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall a. Show a => a -> String
show Name
name)))
      Just (Maybe Text
ns, Text
name) -> Maybe Text -> Text -> Either Text a
parse Maybe Text
ns Text
name forall a b. a -> (a -> b) -> b
& forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> ElementError
NameElementError

-- |
-- Fail if the namespace and name don't match the provided.
elementNameIs :: Maybe Text -> Text -> Element ()
elementNameIs :: Maybe Text -> Text -> Element ()
elementNameIs Maybe Text
ns Text
name =
  forall a. (Maybe Text -> Text -> Either Text a) -> Element a
elementName forall a b. (a -> b) -> a -> b
$ \Maybe Text
actualNs Text
actualName ->
    if Maybe Text
actualNs forall a. Eq a => a -> a -> Bool
== Maybe Text
ns
      then
        if Text
actualName forall a. Eq a => a -> a -> Bool
== Text
name
          then forall a b. b -> Either a b
Right ()
          else forall a b. a -> Either a b
Left (Text
"Unexpected name: \"" forall a. Semigroup a => a -> a -> a
<> Text
actualName forall a. Semigroup a => a -> a -> a
<> Text
"\". Expecting: \"" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"\"")
      else forall a b. a -> Either a b
Left (Text
"Unexpected namespace: \"" forall a. Semigroup a => a -> a -> a
<> (forall a. IsString a => String -> a
fromString forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Show a => a -> String
show) Maybe Text
actualNs forall a. Semigroup a => a -> a -> a
<> Text
"\". Expecting: \"" forall a. Semigroup a => a -> a -> a
<> (forall a. IsString a => String -> a
fromString forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Show a => a -> String
show) Maybe Text
ns forall a. Semigroup a => a -> a -> a
<> Text
"\"")

-- |
-- Look up elements by name and parse them.
childrenByName :: ByName Element a -> Element a
childrenByName :: forall a. ByName Element a -> Element a
childrenByName (ByName forall content deeperError.
NameMap content
-> (content -> forall x. Element x -> Either deeperError x)
-> ByNameResult deeperError content a
runByName) =
  forall a.
(NamespaceRegistry
 -> Element
 -> ElementDestructionState
 -> Either ElementError (a, ElementDestructionState))
-> Element a
Element forall a b. (a -> b) -> a -> b
$ \NamespaceRegistry
nreg element :: Element
element@(Xml.Element Name
_ Map Name Text
attributes [Node]
_) ElementDestructionState
state ->
    case ElementDestructionContext
-> ElementDestructionState
-> (NameMap Element, ElementDestructionState)
ElementDestructionState.resolveChildNames (NamespaceRegistry -> Element -> ElementDestructionContext
ElementDestructionState.ElementDestructionContext NamespaceRegistry
nreg Element
element) ElementDestructionState
state of
      (NameMap Element
nameMap, ElementDestructionState
state) ->
        case forall content deeperError.
NameMap content
-> (content -> forall x. Element x -> Either deeperError x)
-> ByNameResult deeperError content a
runByName NameMap Element
nameMap (\Element
element (Element NamespaceRegistry
-> Element
-> ElementDestructionState
-> Either ElementError (x, ElementDestructionState)
run) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst (NamespaceRegistry
-> Element
-> ElementDestructionState
-> Either ElementError (x, ElementDestructionState)
run NamespaceRegistry
deeperNreg Element
element ElementDestructionState
ElementDestructionState.new)) of
          OkByNameResult NameMap Element
_ a
res -> forall a b. b -> Either a b
Right (a
res, ElementDestructionState
state)
          NotFoundByNameResult [(Maybe Text, Text)]
unfoundNames ->
            let availNames :: [(Maybe Text, Text)]
availNames = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a. NameMap a -> [(Maybe Text, Text)]
NameMap.extractNames NameMap Element
nameMap
             in forall a b. a -> Either a b
Left ([(Maybe Text, Text)] -> [(Maybe Text, Text)] -> ElementError
NoneOfChildrenFoundByNameElementError [(Maybe Text, Text)]
unfoundNames [(Maybe Text, Text)]
availNames)
          FailedDeeperByNameResult Maybe Text
ns Text
name ElementError
err ->
            forall a b. a -> Either a b
Left (Maybe Text -> Text -> ElementError -> ElementError
ChildByNameElementError Maybe Text
ns Text
name ElementError
err)
        where
          deeperNreg :: NamespaceRegistry
deeperNreg = Map Name Text -> NamespaceRegistry -> NamespaceRegistry
NamespaceRegistry.interpretAttributes Map Name Text
attributes NamespaceRegistry
nreg

-- |
-- Look up the last attribute by name and parse it.
attributesByName :: ByName Content a -> Element a
attributesByName :: forall a. ByName Content a -> Element a
attributesByName (ByName forall content deeperError.
NameMap content
-> (content -> forall x. Content x -> Either deeperError x)
-> ByNameResult deeperError content a
runByName) =
  forall a.
(NamespaceRegistry
 -> Element
 -> ElementDestructionState
 -> Either ElementError (a, ElementDestructionState))
-> Element a
Element forall a b. (a -> b) -> a -> b
$ \NamespaceRegistry
nreg Element
element ElementDestructionState
state ->
    case ElementDestructionContext
-> ElementDestructionState
-> (NameMap Text, ElementDestructionState)
ElementDestructionState.resolveAttributeNames (NamespaceRegistry -> Element -> ElementDestructionContext
ElementDestructionState.ElementDestructionContext NamespaceRegistry
nreg Element
element) ElementDestructionState
state of
      (NameMap Text
nameMap, ElementDestructionState
state) -> case forall content deeperError.
NameMap content
-> (content -> forall x. Content x -> Either deeperError x)
-> ByNameResult deeperError content a
runByName NameMap Text
nameMap (\Text
content (Content (Text -> Maybe Text) -> Text -> Either (Maybe ContentError) x
parseContent) -> (Text -> Maybe Text) -> Text -> Either (Maybe ContentError) x
parseContent (\Text
ns -> Text -> NamespaceRegistry -> Maybe Text
NamespaceRegistry.lookup Text
ns NamespaceRegistry
nreg) Text
content) of
        OkByNameResult NameMap Text
_ a
res -> forall a b. b -> Either a b
Right (a
res, ElementDestructionState
state)
        NotFoundByNameResult [(Maybe Text, Text)]
unfoundNames ->
          let availNames :: [(Maybe Text, Text)]
availNames = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a. NameMap a -> [(Maybe Text, Text)]
NameMap.extractNames NameMap Text
nameMap
           in forall a b. a -> Either a b
Left ([(Maybe Text, Text)] -> [(Maybe Text, Text)] -> ElementError
NoneOfAttributesFoundByNameElementError [(Maybe Text, Text)]
unfoundNames [(Maybe Text, Text)]
availNames)
        FailedDeeperByNameResult Maybe Text
ns Text
name Maybe ContentError
err ->
          forall a b. a -> Either a b
Left (Maybe Text -> Text -> Maybe ContentError -> ElementError
AttributeByNameElementError Maybe Text
ns Text
name Maybe ContentError
err)

-- |
-- Children sequence by order.
children :: Nodes a -> Element a
children :: forall a. Nodes a -> Element a
children (Nodes NodeConsumerState -> Either ElementError (a, NodeConsumerState)
runNodes) =
  forall a.
(NamespaceRegistry
 -> Element
 -> ElementDestructionState
 -> Either ElementError (a, ElementDestructionState))
-> Element a
Element forall a b. (a -> b) -> a -> b
$ \NamespaceRegistry
nreg (Xml.Element Name
_ Map Name Text
_ [Node]
nodes) ElementDestructionState
state ->
    NodeConsumerState -> Either ElementError (a, NodeConsumerState)
runNodes ([Node] -> NamespaceRegistry -> NodeConsumerState
NodeConsumerState.new [Node]
nodes NamespaceRegistry
nreg)
      forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst
      forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,ElementDestructionState
state)

-- |
-- Expose the element's AST.
astElement :: Element Xml.Element
astElement :: Element Element
astElement =
  forall a.
(NamespaceRegistry
 -> Element
 -> ElementDestructionState
 -> Either ElementError (a, ElementDestructionState))
-> Element a
Element forall a b. (a -> b) -> a -> b
$ \NamespaceRegistry
_ Element
element ElementDestructionState
state -> forall a b. b -> Either a b
Right (Element
element, ElementDestructionState
state)

-- |
-- Parser in the context of a sequence of nodes.
newtype Nodes a
  = Nodes (NodeConsumerState.NodeConsumerState -> Either ElementError (a, NodeConsumerState.NodeConsumerState))
  deriving
    (forall a b. a -> Nodes b -> Nodes a
forall a b. (a -> b) -> Nodes a -> Nodes b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Nodes b -> Nodes a
$c<$ :: forall a b. a -> Nodes b -> Nodes a
fmap :: forall a b. (a -> b) -> Nodes a -> Nodes b
$cfmap :: forall a b. (a -> b) -> Nodes a -> Nodes b
Functor, Functor Nodes
forall a. a -> Nodes a
forall a b. Nodes a -> Nodes b -> Nodes a
forall a b. Nodes a -> Nodes b -> Nodes b
forall a b. Nodes (a -> b) -> Nodes a -> Nodes b
forall a b c. (a -> b -> c) -> Nodes a -> Nodes b -> Nodes c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Nodes a -> Nodes b -> Nodes a
$c<* :: forall a b. Nodes a -> Nodes b -> Nodes a
*> :: forall a b. Nodes a -> Nodes b -> Nodes b
$c*> :: forall a b. Nodes a -> Nodes b -> Nodes b
liftA2 :: forall a b c. (a -> b -> c) -> Nodes a -> Nodes b -> Nodes c
$cliftA2 :: forall a b c. (a -> b -> c) -> Nodes a -> Nodes b -> Nodes c
<*> :: forall a b. Nodes (a -> b) -> Nodes a -> Nodes b
$c<*> :: forall a b. Nodes (a -> b) -> Nodes a -> Nodes b
pure :: forall a. a -> Nodes a
$cpure :: forall a. a -> Nodes a
Applicative, Applicative Nodes
forall a. a -> Nodes a
forall a b. Nodes a -> Nodes b -> Nodes b
forall a b. Nodes a -> (a -> Nodes b) -> Nodes b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Nodes a
$creturn :: forall a. a -> Nodes a
>> :: forall a b. Nodes a -> Nodes b -> Nodes b
$c>> :: forall a b. Nodes a -> Nodes b -> Nodes b
>>= :: forall a b. Nodes a -> (a -> Nodes b) -> Nodes b
$c>>= :: forall a b. Nodes a -> (a -> Nodes b) -> Nodes b
Monad)
    via (StateT NodeConsumerState.NodeConsumerState (Either ElementError))

-- |
-- Consume the next node expecting it to be element and parse its contents.
elementNode :: Element a -> Nodes a
elementNode :: forall a. Element a -> Nodes a
elementNode (Element NamespaceRegistry
-> Element
-> ElementDestructionState
-> Either ElementError (a, ElementDestructionState)
runElement) =
  forall a.
(NodeConsumerState -> Either ElementError (a, NodeConsumerState))
-> Nodes a
Nodes forall a b. (a -> b) -> a -> b
$ \NodeConsumerState
x ->
    case NodeConsumerState -> Maybe (Node, NodeConsumerState)
NodeConsumerState.fetchNode NodeConsumerState
x of
      Just (Node
node, NodeConsumerState
x) -> case Node
node of
        Xml.NodeElement Element
element ->
          forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap
            (Int -> NodeError -> ElementError
ChildAtOffsetElementError (NodeConsumerState -> Int
NodeConsumerState.getOffset NodeConsumerState
x) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ElementError -> NodeError
ElementNodeError)
            (,NodeConsumerState -> NodeConsumerState
NodeConsumerState.bumpOffset NodeConsumerState
x)
            (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst (NamespaceRegistry
-> Element
-> ElementDestructionState
-> Either ElementError (a, ElementDestructionState)
runElement (NodeConsumerState -> NamespaceRegistry
NodeConsumerState.getNamespaceRegistry NodeConsumerState
x) Element
element ElementDestructionState
ElementDestructionState.new))
        Xml.NodeInstruction Instruction
_ -> NodeType -> Either ElementError (a, NodeConsumerState)
failWithUnexpectedNodeType NodeType
InstructionNodeType
        Xml.NodeContent Text
_ -> NodeType -> Either ElementError (a, NodeConsumerState)
failWithUnexpectedNodeType NodeType
ContentNodeType
        Xml.NodeComment Text
_ -> NodeType -> Either ElementError (a, NodeConsumerState)
failWithUnexpectedNodeType NodeType
CommentNodeType
        where
          failWithUnexpectedNodeType :: NodeType -> Either ElementError (a, NodeConsumerState)
failWithUnexpectedNodeType NodeType
actualType =
            forall a b. a -> Either a b
Left
              ( Int -> NodeError -> ElementError
ChildAtOffsetElementError
                  (NodeConsumerState -> Int
NodeConsumerState.getOffset NodeConsumerState
x)
                  (NodeType -> NodeType -> NodeError
UnexpectedNodeTypeNodeError NodeType
ElementNodeType NodeType
actualType)
              )
      Maybe (Node, NodeConsumerState)
_ -> forall a b. a -> Either a b
Left (Int -> NodeError -> ElementError
ChildAtOffsetElementError (NodeConsumerState -> Int
NodeConsumerState.getOffset NodeConsumerState
x) NodeError
NotAvailableNodeError)

-- |
-- Consume the next node expecting it to be textual and parse its contents.
contentNode :: Content content -> Nodes content
contentNode :: forall content. Content content -> Nodes content
contentNode (Content (Text -> Maybe Text) -> Text -> Either (Maybe ContentError) content
parseContent) =
  forall a.
(NodeConsumerState -> Either ElementError (a, NodeConsumerState))
-> Nodes a
Nodes forall a b. (a -> b) -> a -> b
$ \NodeConsumerState
x ->
    case NodeConsumerState -> Maybe (Node, NodeConsumerState)
NodeConsumerState.fetchNode NodeConsumerState
x of
      Just (Node
node, NodeConsumerState
x) -> case Node
node of
        Xml.NodeContent Text
content ->
          case (Text -> Maybe Text) -> Text -> Either (Maybe ContentError) content
parseContent (\Text
ns -> Text -> NodeConsumerState -> Maybe Text
NodeConsumerState.lookupNamespace Text
ns NodeConsumerState
x) Text
content of
            Right content
parsedContent ->
              forall a b. b -> Either a b
Right (content
parsedContent, NodeConsumerState -> NodeConsumerState
NodeConsumerState.bumpOffset NodeConsumerState
x)
            Left Maybe ContentError
contentError ->
              forall a b. a -> Either a b
Left
                ( Int -> NodeError -> ElementError
ChildAtOffsetElementError
                    (NodeConsumerState -> Int
NodeConsumerState.getOffset NodeConsumerState
x)
                    (Maybe ContentError -> NodeError
TextNodeError Maybe ContentError
contentError)
                )
        Xml.NodeElement Element
_ -> NodeType -> Either ElementError (content, NodeConsumerState)
failWithUnexpectedNodeType NodeType
ElementNodeType
        Xml.NodeInstruction Instruction
_ -> NodeType -> Either ElementError (content, NodeConsumerState)
failWithUnexpectedNodeType NodeType
InstructionNodeType
        Xml.NodeComment Text
_ -> NodeType -> Either ElementError (content, NodeConsumerState)
failWithUnexpectedNodeType NodeType
CommentNodeType
        where
          failWithUnexpectedNodeType :: NodeType -> Either ElementError (content, NodeConsumerState)
failWithUnexpectedNodeType NodeType
actualType =
            forall a b. a -> Either a b
Left
              ( Int -> NodeError -> ElementError
ChildAtOffsetElementError
                  (NodeConsumerState -> Int
NodeConsumerState.getOffset NodeConsumerState
x)
                  (NodeType -> NodeType -> NodeError
UnexpectedNodeTypeNodeError NodeType
ContentNodeType NodeType
actualType)
              )
      Maybe (Node, NodeConsumerState)
_ ->
        case NodeConsumerState -> Int
NodeConsumerState.getOffset NodeConsumerState
x of
          Int
0 ->
            case (Text -> Maybe Text) -> Text -> Either (Maybe ContentError) content
parseContent (\Text
ns -> Text -> NodeConsumerState -> Maybe Text
NodeConsumerState.lookupNamespace Text
ns NodeConsumerState
x) forall a. Monoid a => a
mempty of
              Right content
parsedContent ->
                forall a b. b -> Either a b
Right (content
parsedContent, NodeConsumerState -> NodeConsumerState
NodeConsumerState.bumpOffset NodeConsumerState
x)
              Left Maybe ContentError
contentError ->
                forall a b. a -> Either a b
Left (Int -> NodeError -> ElementError
ChildAtOffsetElementError Int
0 (Maybe ContentError -> NodeError
TextNodeError Maybe ContentError
contentError))
          Int
offset ->
            forall a b. a -> Either a b
Left (Int -> NodeError -> ElementError
ChildAtOffsetElementError Int
offset NodeError
NotAvailableNodeError)

-- * Content

-- |
-- Parser in the context of decoded textual content,
-- which can be the value of an attribute or a textual node.
newtype Content content
  = -- | Parser in the context of an xml namespace URI by alias lookup function.
    Content ((Text -> Maybe Text) -> Text -> Either (Maybe ContentError) content)
  deriving
    (forall a b. a -> Content b -> Content a
forall a b. (a -> b) -> Content a -> Content b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Content b -> Content a
$c<$ :: forall a b. a -> Content b -> Content a
fmap :: forall a b. (a -> b) -> Content a -> Content b
$cfmap :: forall a b. (a -> b) -> Content a -> Content b
Functor, Functor Content
forall a. a -> Content a
forall a b. Content a -> Content b -> Content a
forall a b. Content a -> Content b -> Content b
forall a b. Content (a -> b) -> Content a -> Content b
forall a b c. (a -> b -> c) -> Content a -> Content b -> Content c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Content a -> Content b -> Content a
$c<* :: forall a b. Content a -> Content b -> Content a
*> :: forall a b. Content a -> Content b -> Content b
$c*> :: forall a b. Content a -> Content b -> Content b
liftA2 :: forall a b c. (a -> b -> c) -> Content a -> Content b -> Content c
$cliftA2 :: forall a b c. (a -> b -> c) -> Content a -> Content b -> Content c
<*> :: forall a b. Content (a -> b) -> Content a -> Content b
$c<*> :: forall a b. Content (a -> b) -> Content a -> Content b
pure :: forall a. a -> Content a
$cpure :: forall a. a -> Content a
Applicative, Applicative Content
forall a. a -> Content a
forall a b. Content a -> Content b -> Content b
forall a b. Content a -> (a -> Content b) -> Content b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Content a
$creturn :: forall a. a -> Content a
>> :: forall a b. Content a -> Content b -> Content b
$c>> :: forall a b. Content a -> Content b -> Content b
>>= :: forall a b. Content a -> (a -> Content b) -> Content b
$c>>= :: forall a b. Content a -> (a -> Content b) -> Content b
Monad, Applicative Content
forall a. Content a
forall a. Content a -> Content [a]
forall a. Content a -> Content a -> Content a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
many :: forall a. Content a -> Content [a]
$cmany :: forall a. Content a -> Content [a]
some :: forall a. Content a -> Content [a]
$csome :: forall a. Content a -> Content [a]
<|> :: forall a. Content a -> Content a -> Content a
$c<|> :: forall a. Content a -> Content a -> Content a
empty :: forall a. Content a
$cempty :: forall a. Content a
Alternative, Monad Content
Alternative Content
forall a. Content a
forall a. Content a -> Content a -> Content a
forall (m :: * -> *).
Alternative m
-> Monad m
-> (forall a. m a)
-> (forall a. m a -> m a -> m a)
-> MonadPlus m
mplus :: forall a. Content a -> Content a -> Content a
$cmplus :: forall a. Content a -> Content a -> Content a
mzero :: forall a. Content a
$cmzero :: forall a. Content a
MonadPlus)
    via (ReaderT (Text -> Maybe Text) (ExceptT (Last ContentError) ((->) Text)))

instance MonadFail Content where
  fail :: forall a. String -> Content a
fail = forall a. IsString a => String -> a
fromString forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Text -> ContentError
UserContentError forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. a -> Maybe a
Just forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a b. a -> Either a b
Left forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a b. a -> b -> a
const forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a b. a -> b -> a
const forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall content.
((Text -> Maybe Text)
 -> Text -> Either (Maybe ContentError) content)
-> Content content
Content

-- |
-- Return the content as it is.
textContent :: Content Text
textContent :: Content Text
textContent =
  forall content.
((Text -> Maybe Text)
 -> Text -> Either (Maybe ContentError) content)
-> Content content
Content (forall a b. a -> b -> a
const forall (f :: * -> *) a. Applicative f => a -> f a
pure)

-- |
-- Map the content to a type if it's valid.
narrowedContent :: (Text -> Maybe a) -> Content a
narrowedContent :: forall a. (Text -> Maybe a) -> Content a
narrowedContent Text -> Maybe a
mapper =
  forall content.
((Text -> Maybe Text)
 -> Text -> Either (Maybe ContentError) content)
-> Content content
Content (forall a b. a -> b -> a
const (\Text
x -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left (forall a. a -> Maybe a
Just (Text -> ContentError
UnexpectedValueContentError Text
x))) forall a b. b -> Either a b
Right (Text -> Maybe a
mapper Text
x)))

-- |
-- Parse the content with a possibly failing function.
refinedContent :: (Text -> Either Text a) -> Content a
refinedContent :: forall a. (Text -> Either Text a) -> Content a
refinedContent Text -> Either Text a
refine =
  forall content.
((Text -> Maybe Text)
 -> Text -> Either (Maybe ContentError) content)
-> Content content
Content (forall a b. a -> b -> a
const (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. a -> Maybe a
Just forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ContentError
ParsingContentError) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Either Text a
refine))

-- |
-- Map the content using a dictionary.
enumContent :: [(Text, a)] -> Content a
enumContent :: forall a. [(Text, a)] -> Content a
enumContent [(Text, a)]
mappingList =
  let !expectedKeysList :: [Text]
expectedKeysList =
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst [(Text, a)]
mappingList
      mappingListLength :: Int
mappingListLength =
        forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, a)]
mappingList
      !narrow :: Text -> Maybe a
narrow =
        if Int
mappingListLength forall a. Ord a => a -> a -> Bool
> Int
512
          then
            let !hashMap :: HashMap Text a
hashMap = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [(Text, a)]
mappingList
             in forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup HashMap Text a
hashMap
          else forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup [(Text, a)]
mappingList
      extract :: Text -> Either (Maybe ContentError) a
extract Text
a =
        case Text -> Maybe a
narrow Text
a of
          Just a
b -> forall a b. b -> Either a b
Right a
b
          Maybe a
_ -> forall a b. a -> Either a b
Left (forall a. a -> Maybe a
Just ([Text] -> Text -> ContentError
EnumContentError [Text]
expectedKeysList Text
a))
   in forall content.
((Text -> Maybe Text)
 -> Text -> Either (Maybe ContentError) content)
-> Content content
Content (forall a b. a -> b -> a
const Text -> Either (Maybe ContentError) a
extract)

-- |
-- Parse the content using the \"attoparsec\" parser.
attoparsedContent :: Attoparsec.Parser a -> Content a
attoparsedContent :: forall a. Parser a -> Content a
attoparsedContent Parser a
parser =
  forall content.
((Text -> Maybe Text)
 -> Text -> Either (Maybe ContentError) content)
-> Content content
Content (forall a b. a -> b -> a
const (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. a -> Maybe a
Just forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ContentError
ParsingContentError forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. IsString a => String -> a
fromString) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Parser a -> Text -> Either String a
Attoparsec.parseOnly Parser a
parser))

-- |
-- Parse the content as XML Schema QName,
-- automatically resolving the namespace as URI and failing,
-- if none is associated.
--
-- Produces a URI associated with the namespace and name.
-- If the content does not contain colon, produces an unnamespaced name.
--
-- Refs:
--
-- - https://www.w3.org/2001/tag/doc/qnameids.html#sec-qnames-xml
-- - https://en.wikipedia.org/wiki/QName
qNameContent :: Content (Maybe Text, Text)
qNameContent :: Content (Maybe Text, Text)
qNameContent =
  forall content.
((Text -> Maybe Text)
 -> Text -> Either (Maybe ContentError) content)
-> Content content
Content forall a b. (a -> b) -> a -> b
$ \Text -> Maybe Text
lookup Text
content -> case forall a. Parser a -> Text -> Either Text a
Attoparsec.parseStripped Parser (Maybe Text, Text)
Attoparsec.qName Text
content of
    Right (Maybe Text
ns, Text
name) -> case Maybe Text
ns of
      Just Text
ns -> case Text -> Maybe Text
lookup Text
ns of
        Just Text
uri -> forall a b. b -> Either a b
Right (forall a. a -> Maybe a
Just Text
uri, Text
name)
        Maybe Text
Nothing -> forall a b. a -> Either a b
Left (forall a. a -> Maybe a
Just (Text -> ContentError
NamespaceNotFoundContentError Text
ns))
      Maybe Text
Nothing -> forall a b. b -> Either a b
Right (forall a. Maybe a
Nothing, Text
name)
    Left Text
err -> forall a b. a -> Either a b
Left (forall a. a -> Maybe a
Just (Text -> ContentError
ParsingContentError Text
err))

-- * ByName

data ByNameResult deeperError content a
  = NotFoundByNameResult [(Maybe Text, Text)]
  | FailedDeeperByNameResult (Maybe Text) Text deeperError
  | OkByNameResult (NameMap.NameMap content) a
  deriving (forall a b.
a
-> ByNameResult deeperError content b
-> ByNameResult deeperError content a
forall a b.
(a -> b)
-> ByNameResult deeperError content a
-> ByNameResult deeperError content b
forall deeperError content a b.
a
-> ByNameResult deeperError content b
-> ByNameResult deeperError content a
forall deeperError content a b.
(a -> b)
-> ByNameResult deeperError content a
-> ByNameResult deeperError content b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b.
a
-> ByNameResult deeperError content b
-> ByNameResult deeperError content a
$c<$ :: forall deeperError content a b.
a
-> ByNameResult deeperError content b
-> ByNameResult deeperError content a
fmap :: forall a b.
(a -> b)
-> ByNameResult deeperError content a
-> ByNameResult deeperError content b
$cfmap :: forall deeperError content a b.
(a -> b)
-> ByNameResult deeperError content a
-> ByNameResult deeperError content b
Functor)

-- |
-- Composable extension to a parser, which looks up its input by name.
--
-- Useful for searching elements and attributes by name.
--
-- Alternative and MonadPlus alternate only on lookup errors.
-- When lookup is successful, but the deeper parser fails,
-- the error propagates.
--
-- Monad and Applicative sequentially fetch contents by matching names.
newtype ByName parser a
  = ByName
      ( forall content deeperError.
        NameMap.NameMap content ->
        (content -> forall x. parser x -> Either deeperError x) ->
        ByNameResult deeperError content a
      )

instance Functor (ByName parser) where
  fmap :: forall a b. (a -> b) -> ByName parser a -> ByName parser b
fmap a -> b
fn (ByName forall content deeperError.
NameMap content
-> (content -> forall x. parser x -> Either deeperError x)
-> ByNameResult deeperError content a
run) =
    forall (parser :: * -> *) a.
(forall content deeperError.
 NameMap content
 -> (content -> forall x. parser x -> Either deeperError x)
 -> ByNameResult deeperError content a)
-> ByName parser a
ByName forall a b. (a -> b) -> a -> b
$ \NameMap content
map content -> forall x. parser x -> Either deeperError x
parse -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
fn (forall content deeperError.
NameMap content
-> (content -> forall x. parser x -> Either deeperError x)
-> ByNameResult deeperError content a
run NameMap content
map content -> forall x. parser x -> Either deeperError x
parse)

instance Applicative (ByName parser) where
  pure :: forall a. a -> ByName parser a
pure a
x =
    forall (parser :: * -> *) a.
(forall content deeperError.
 NameMap content
 -> (content -> forall x. parser x -> Either deeperError x)
 -> ByNameResult deeperError content a)
-> ByName parser a
ByName forall a b. (a -> b) -> a -> b
$ \NameMap content
map content -> forall x. parser x -> Either deeperError x
_ -> forall deeperError content a.
NameMap content -> a -> ByNameResult deeperError content a
OkByNameResult NameMap content
map a
x
  ByName forall content deeperError.
NameMap content
-> (content -> forall x. parser x -> Either deeperError x)
-> ByNameResult deeperError content (a -> b)
runL <*> :: forall a b.
ByName parser (a -> b) -> ByName parser a -> ByName parser b
<*> ByName forall content deeperError.
NameMap content
-> (content -> forall x. parser x -> Either deeperError x)
-> ByNameResult deeperError content a
runR =
    forall (parser :: * -> *) a.
(forall content deeperError.
 NameMap content
 -> (content -> forall x. parser x -> Either deeperError x)
 -> ByNameResult deeperError content a)
-> ByName parser a
ByName forall a b. (a -> b) -> a -> b
$ \NameMap content
map content -> forall x. parser x -> Either deeperError x
parse -> case forall content deeperError.
NameMap content
-> (content -> forall x. parser x -> Either deeperError x)
-> ByNameResult deeperError content (a -> b)
runL NameMap content
map content -> forall x. parser x -> Either deeperError x
parse of
      OkByNameResult NameMap content
map a -> b
lRes -> forall content deeperError.
NameMap content
-> (content -> forall x. parser x -> Either deeperError x)
-> ByNameResult deeperError content a
runR NameMap content
map content -> forall x. parser x -> Either deeperError x
parse forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
lRes
      NotFoundByNameResult [(Maybe Text, Text)]
unfoundNames -> forall deeperError content a.
[(Maybe Text, Text)] -> ByNameResult deeperError content a
NotFoundByNameResult [(Maybe Text, Text)]
unfoundNames
      FailedDeeperByNameResult Maybe Text
ns Text
name deeperError
err -> forall deeperError content a.
Maybe Text
-> Text -> deeperError -> ByNameResult deeperError content a
FailedDeeperByNameResult Maybe Text
ns Text
name deeperError
err

instance Monad (ByName parser) where
  return :: forall a. a -> ByName parser a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ByName forall content deeperError.
NameMap content
-> (content -> forall x. parser x -> Either deeperError x)
-> ByNameResult deeperError content a
runL >>= :: forall a b.
ByName parser a -> (a -> ByName parser b) -> ByName parser b
>>= a -> ByName parser b
k =
    forall (parser :: * -> *) a.
(forall content deeperError.
 NameMap content
 -> (content -> forall x. parser x -> Either deeperError x)
 -> ByNameResult deeperError content a)
-> ByName parser a
ByName forall a b. (a -> b) -> a -> b
$ \NameMap content
map content -> forall x. parser x -> Either deeperError x
parse -> case forall content deeperError.
NameMap content
-> (content -> forall x. parser x -> Either deeperError x)
-> ByNameResult deeperError content a
runL NameMap content
map content -> forall x. parser x -> Either deeperError x
parse of
      OkByNameResult NameMap content
map a
lRes -> case a -> ByName parser b
k a
lRes of ByName forall content deeperError.
NameMap content
-> (content -> forall x. parser x -> Either deeperError x)
-> ByNameResult deeperError content b
runR -> forall content deeperError.
NameMap content
-> (content -> forall x. parser x -> Either deeperError x)
-> ByNameResult deeperError content b
runR NameMap content
map content -> forall x. parser x -> Either deeperError x
parse
      NotFoundByNameResult [(Maybe Text, Text)]
unfoundNames -> forall deeperError content a.
[(Maybe Text, Text)] -> ByNameResult deeperError content a
NotFoundByNameResult [(Maybe Text, Text)]
unfoundNames
      FailedDeeperByNameResult Maybe Text
ns Text
name deeperError
err -> forall deeperError content a.
Maybe Text
-> Text -> deeperError -> ByNameResult deeperError content a
FailedDeeperByNameResult Maybe Text
ns Text
name deeperError
err

instance Alternative (ByName parser) where
  empty :: forall a. ByName parser a
empty =
    forall (parser :: * -> *) a.
(forall content deeperError.
 NameMap content
 -> (content -> forall x. parser x -> Either deeperError x)
 -> ByNameResult deeperError content a)
-> ByName parser a
ByName forall a b. (a -> b) -> a -> b
$ \NameMap content
_ content -> forall x. parser x -> Either deeperError x
_ -> forall deeperError content a.
[(Maybe Text, Text)] -> ByNameResult deeperError content a
NotFoundByNameResult []
  ByName forall content deeperError.
NameMap content
-> (content -> forall x. parser x -> Either deeperError x)
-> ByNameResult deeperError content a
runL <|> :: forall a. ByName parser a -> ByName parser a -> ByName parser a
<|> ByName forall content deeperError.
NameMap content
-> (content -> forall x. parser x -> Either deeperError x)
-> ByNameResult deeperError content a
runR =
    forall (parser :: * -> *) a.
(forall content deeperError.
 NameMap content
 -> (content -> forall x. parser x -> Either deeperError x)
 -> ByNameResult deeperError content a)
-> ByName parser a
ByName forall a b. (a -> b) -> a -> b
$ \NameMap content
map content -> forall x. parser x -> Either deeperError x
parse -> case forall content deeperError.
NameMap content
-> (content -> forall x. parser x -> Either deeperError x)
-> ByNameResult deeperError content a
runL NameMap content
map content -> forall x. parser x -> Either deeperError x
parse of
      OkByNameResult NameMap content
map a
lRes -> forall deeperError content a.
NameMap content -> a -> ByNameResult deeperError content a
OkByNameResult NameMap content
map a
lRes
      NotFoundByNameResult [(Maybe Text, Text)]
unfoundNamesL -> case forall content deeperError.
NameMap content
-> (content -> forall x. parser x -> Either deeperError x)
-> ByNameResult deeperError content a
runR NameMap content
map content -> forall x. parser x -> Either deeperError x
parse of
        NotFoundByNameResult [(Maybe Text, Text)]
unfoundNamesR -> forall deeperError content a.
[(Maybe Text, Text)] -> ByNameResult deeperError content a
NotFoundByNameResult ([(Maybe Text, Text)]
unfoundNamesL forall a. Semigroup a => a -> a -> a
<> [(Maybe Text, Text)]
unfoundNamesR)
        ByNameResult deeperError content a
resR -> ByNameResult deeperError content a
resR
      FailedDeeperByNameResult Maybe Text
ns Text
name deeperError
err -> forall deeperError content a.
Maybe Text
-> Text -> deeperError -> ByNameResult deeperError content a
FailedDeeperByNameResult Maybe Text
ns Text
name deeperError
err

instance MonadPlus (ByName parser) where
  mzero :: forall a. ByName parser a
mzero = forall (f :: * -> *) a. Alternative f => f a
empty
  mplus :: forall a. ByName parser a -> ByName parser a -> ByName parser a
mplus = forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

-- |
-- Execute a parser on the result of looking up a content by namespace and name.
byName :: Maybe Text -> Text -> parser a -> ByName parser a
byName :: forall (parser :: * -> *) a.
Maybe Text -> Text -> parser a -> ByName parser a
byName Maybe Text
ns Text
name parser a
parser =
  forall (parser :: * -> *) a.
(forall content deeperError.
 NameMap content
 -> (content -> forall x. parser x -> Either deeperError x)
 -> ByNameResult deeperError content a)
-> ByName parser a
ByName forall a b. (a -> b) -> a -> b
$ \NameMap content
map content -> forall x. parser x -> Either deeperError x
parse ->
    case forall a. Maybe Text -> Text -> NameMap a -> Maybe (a, NameMap a)
NameMap.fetch Maybe Text
ns Text
name NameMap content
map of
      Just (content
content, NameMap content
map) -> case content -> forall x. parser x -> Either deeperError x
parse content
content parser a
parser of
        Right a
a -> forall deeperError content a.
NameMap content -> a -> ByNameResult deeperError content a
OkByNameResult NameMap content
map a
a
        Left deeperError
err -> forall deeperError content a.
Maybe Text
-> Text -> deeperError -> ByNameResult deeperError content a
FailedDeeperByNameResult Maybe Text
ns Text
name deeperError
err
      Maybe (content, NameMap content)
Nothing -> forall deeperError content a.
[(Maybe Text, Text)] -> ByNameResult deeperError content a
NotFoundByNameResult [(Maybe Text
ns, Text
name)]