module XmlParser.NamespaceRegistry
  ( NamespaceRegistry,
    new,
    lookup,
    resolveElementName,
    resolveAttributeName,
    interpretAttribute,
    interpretAttributes,
  )
where

import qualified Data.Attoparsec.Text as Attoparsec
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map.Strict as Map
import qualified Text.XML as Xml
import qualified XmlParser.Attoparsec as Attoparsec
import XmlParser.Prelude hiding (insert, lookup)

data NamespaceRegistry
  = NamespaceRegistry
      (HashMap Text Text)
      (Maybe Text)

new :: NamespaceRegistry
new :: NamespaceRegistry
new = HashMap Text Text -> Maybe Text -> NamespaceRegistry
NamespaceRegistry HashMap Text Text
forall k v. HashMap k v
HashMap.empty Maybe Text
forall a. Maybe a
Nothing

lookup :: Text -> NamespaceRegistry -> Maybe Text
lookup :: Text -> NamespaceRegistry -> Maybe Text
lookup Text
ns (NamespaceRegistry HashMap Text Text
nsMap Maybe Text
_) =
  Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
ns HashMap Text Text
nsMap

resolveElementName :: Xml.Name -> NamespaceRegistry -> Maybe (Maybe Text, Text)
resolveElementName :: Name -> NamespaceRegistry -> Maybe (Maybe Text, Text)
resolveElementName = Bool -> Name -> NamespaceRegistry -> Maybe (Maybe Text, Text)
resolveName Bool
True

resolveAttributeName :: Xml.Name -> NamespaceRegistry -> Maybe (Maybe Text, Text)
resolveAttributeName :: Name -> NamespaceRegistry -> Maybe (Maybe Text, Text)
resolveAttributeName = Bool -> Name -> NamespaceRegistry -> Maybe (Maybe Text, Text)
resolveName Bool
False

resolveName :: Bool -> Xml.Name -> NamespaceRegistry -> Maybe (Maybe Text, Text)
resolveName :: Bool -> Name -> NamespaceRegistry -> Maybe (Maybe Text, Text)
resolveName Bool
useDef (Xml.Name Text
localName Maybe Text
uri Maybe Text
ns) (NamespaceRegistry HashMap Text Text
map Maybe Text
def) =
  case Maybe Text
uri of
    Just Text
uri -> (Maybe Text, Text) -> Maybe (Maybe Text, Text)
forall a. a -> Maybe a
Just (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
uri, Text
localName)
    Maybe Text
Nothing -> case Maybe Text
ns of
      Just Text
ns -> case Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
ns HashMap Text Text
map of
        Just Text
uri -> (Maybe Text, Text) -> Maybe (Maybe Text, Text)
forall a. a -> Maybe a
Just (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
uri, Text
localName)
        Maybe Text
Nothing -> Maybe (Maybe Text, Text)
forall a. Maybe a
Nothing
      Maybe Text
Nothing ->
        case Parser (Maybe Text, Text)
-> Text -> Either String (Maybe Text, Text)
forall a. Parser a -> Text -> Either String a
Attoparsec.parseOnly Parser (Maybe Text, Text)
Attoparsec.qName Text
localName of
          Right (Maybe Text
ns, Text
localName) -> case Maybe Text
ns of
            Just Text
ns -> case Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
ns HashMap Text Text
map of
              Just Text
uri -> (Maybe Text, Text) -> Maybe (Maybe Text, Text)
forall a. a -> Maybe a
Just (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
uri, Text
localName)
              Maybe Text
Nothing -> Maybe (Maybe Text, Text)
forall a. Maybe a
Nothing
            Maybe Text
Nothing ->
              (Maybe Text, Text) -> Maybe (Maybe Text, Text)
forall a. a -> Maybe a
Just (if Bool
useDef then Maybe Text
def else Maybe Text
forall a. Maybe a
Nothing, Text
localName)
          Either String (Maybe Text, Text)
_ -> Maybe (Maybe Text, Text)
forall a. Maybe a
Nothing

insert :: Text -> Text -> NamespaceRegistry -> NamespaceRegistry
insert :: Text -> Text -> NamespaceRegistry -> NamespaceRegistry
insert Text
alias Text
uri (NamespaceRegistry HashMap Text Text
map Maybe Text
def) =
  HashMap Text Text -> Maybe Text -> NamespaceRegistry
NamespaceRegistry (Text -> Text -> HashMap Text Text -> HashMap Text Text
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Text
alias Text
uri HashMap Text Text
map) Maybe Text
def

setDefault :: Text -> NamespaceRegistry -> NamespaceRegistry
setDefault :: Text -> NamespaceRegistry -> NamespaceRegistry
setDefault Text
uri (NamespaceRegistry HashMap Text Text
map Maybe Text
_) =
  HashMap Text Text -> Maybe Text -> NamespaceRegistry
NamespaceRegistry HashMap Text Text
map (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
uri)

-- |
-- Extend the registry by reading in the value if this is an \"xmlns\" attribute.
interpretAttribute :: Xml.Name -> Text -> NamespaceRegistry -> NamespaceRegistry
interpretAttribute :: Name -> Text -> NamespaceRegistry -> NamespaceRegistry
interpretAttribute (Xml.Name Text
localName Maybe Text
namespace Maybe Text
prefix) Text
uri =
  case Maybe Text
namespace of
    Maybe Text
Nothing -> case Maybe Text
prefix of
      Maybe Text
Nothing -> case Parser (Maybe Text, Text)
-> Text -> Either String (Maybe Text, Text)
forall a. Parser a -> Text -> Either String a
Attoparsec.parseOnly Parser (Maybe Text, Text)
Attoparsec.qName Text
localName of
        Right (Just Text
"xmlns", Text
name) -> Text -> Text -> NamespaceRegistry -> NamespaceRegistry
insert Text
name Text
uri
        Right (Maybe Text
Nothing, Text
"xmlns") -> Text -> NamespaceRegistry -> NamespaceRegistry
setDefault Text
uri
        Either String (Maybe Text, Text)
_ -> NamespaceRegistry -> NamespaceRegistry
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
      Maybe Text
_ -> NamespaceRegistry -> NamespaceRegistry
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
    Maybe Text
_ -> NamespaceRegistry -> NamespaceRegistry
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

-- |
-- Extend the registry by reading in the \"xmlns\" attributes of an element.
--
-- Useful when diving into an element
interpretAttributes :: Map Xml.Name Text -> NamespaceRegistry -> NamespaceRegistry
interpretAttributes :: Map Name Text -> NamespaceRegistry -> NamespaceRegistry
interpretAttributes Map Name Text
attributes NamespaceRegistry
x =
  (NamespaceRegistry -> Name -> Text -> NamespaceRegistry)
-> NamespaceRegistry -> Map Name Text -> NamespaceRegistry
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (\NamespaceRegistry
x Name
name Text
value -> Name -> Text -> NamespaceRegistry -> NamespaceRegistry
interpretAttribute Name
name Text
value NamespaceRegistry
x) NamespaceRegistry
x Map Name Text
attributes