module XmlParser.NameMap
  ( NameMap,
    fromNodes,
    fromAttributes,
    empty,
    insert,
    fetch,
    extractNames,
  )
where

import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map.Strict as Map
import qualified Text.XML as Xml
import qualified XmlParser.NamespaceRegistry as NamespaceRegistry
import XmlParser.Prelude hiding (empty, fromList, insert, toList)
import qualified XmlParser.TupleHashMap as TupleHashMap

data NameMap a
  = NameMap
      (TupleHashMap.TupleHashMap Text Text [a])
      -- ^ Namespaced
      (HashMap Text [a])
      -- ^ Unnamespaced

fromNodes :: NamespaceRegistry.NamespaceRegistry -> [Xml.Node] -> NameMap Xml.Element
fromNodes :: NamespaceRegistry -> [Node] -> NameMap Element
fromNodes NamespaceRegistry
nreg =
  (Name -> Maybe (Maybe Text, Text))
-> [(Name, Element)] -> NameMap Element
forall a.
(Name -> Maybe (Maybe Text, Text)) -> [(Name, a)] -> NameMap a
fromReverseList ((Name -> NamespaceRegistry -> Maybe (Maybe Text, Text))
-> NamespaceRegistry -> Name -> Maybe (Maybe Text, Text)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> NamespaceRegistry -> Maybe (Maybe Text, Text)
NamespaceRegistry.resolveElementName NamespaceRegistry
nreg) ([(Name, Element)] -> NameMap Element)
-> ([Node] -> [(Name, Element)]) -> [Node] -> NameMap Element
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ([(Name, Element)] -> Node -> [(Name, Element)])
-> [(Name, Element)] -> [Node] -> [(Name, Element)]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [(Name, Element)] -> Node -> [(Name, Element)]
appendIfElement []
  where
    appendIfElement :: [(Name, Element)] -> Node -> [(Name, Element)]
appendIfElement [(Name, Element)]
list = \case
      Xml.NodeElement Element
element -> (Element -> Name
Xml.elementName Element
element, Element
element) (Name, Element) -> [(Name, Element)] -> [(Name, Element)]
forall a. a -> [a] -> [a]
: [(Name, Element)]
list
      Node
_ -> [(Name, Element)]
list

fromAttributes :: NamespaceRegistry.NamespaceRegistry -> Map Xml.Name Text -> NameMap Text
fromAttributes :: NamespaceRegistry -> Map Name Text -> NameMap Text
fromAttributes NamespaceRegistry
nreg =
  (Name -> Maybe (Maybe Text, Text))
-> [(Name, Text)] -> NameMap Text
forall a.
(Name -> Maybe (Maybe Text, Text)) -> [(Name, a)] -> NameMap a
fromList ((Name -> NamespaceRegistry -> Maybe (Maybe Text, Text))
-> NamespaceRegistry -> Name -> Maybe (Maybe Text, Text)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> NamespaceRegistry -> Maybe (Maybe Text, Text)
NamespaceRegistry.resolveAttributeName NamespaceRegistry
nreg) ([(Name, Text)] -> NameMap Text)
-> (Map Name Text -> [(Name, Text)])
-> Map Name Text
-> NameMap Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Map Name Text -> [(Name, Text)]
forall k a. Map k a -> [(k, a)]
Map.toList

fromList :: (Xml.Name -> Maybe (Maybe Text, Text)) -> [(Xml.Name, a)] -> NameMap a
fromList :: (Name -> Maybe (Maybe Text, Text)) -> [(Name, a)] -> NameMap a
fromList Name -> Maybe (Maybe Text, Text)
resolve =
  (Name -> Maybe (Maybe Text, Text)) -> [(Name, a)] -> NameMap a
forall a.
(Name -> Maybe (Maybe Text, Text)) -> [(Name, a)] -> NameMap a
fromReverseList Name -> Maybe (Maybe Text, Text)
resolve ([(Name, a)] -> NameMap a)
-> ([(Name, a)] -> [(Name, a)]) -> [(Name, a)] -> NameMap a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [(Name, a)] -> [(Name, a)]
forall a. [a] -> [a]
reverse

fromReverseList :: (Xml.Name -> Maybe (Maybe Text, Text)) -> [(Xml.Name, a)] -> NameMap a
fromReverseList :: (Name -> Maybe (Maybe Text, Text)) -> [(Name, a)] -> NameMap a
fromReverseList Name -> Maybe (Maybe Text, Text)
resolve [(Name, a)]
list =
  ((Name, a)
 -> (TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a)
 -> TupleHashMap Text Text [a]
 -> HashMap Text [a]
 -> NameMap a)
-> (TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a)
-> [(Name, a)]
-> TupleHashMap Text Text [a]
-> HashMap Text [a]
-> NameMap a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Name, a)
-> (TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a)
-> TupleHashMap Text Text [a]
-> HashMap Text [a]
-> NameMap a
step TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a
forall a.
TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a
NameMap [(Name, a)]
list TupleHashMap Text Text [a]
forall k1 k2 v. TupleHashMap k1 k2 v
TupleHashMap.empty HashMap Text [a]
forall k v. HashMap k v
HashMap.empty
  where
    step :: (Name, a)
-> (TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a)
-> TupleHashMap Text Text [a]
-> HashMap Text [a]
-> NameMap a
step (Name
name, a
contents) TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a
next !TupleHashMap Text Text [a]
map1 !HashMap Text [a]
map2 =
      case Name -> Maybe (Maybe Text, Text)
resolve Name
name of
        Maybe (Maybe Text, Text)
Nothing -> TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a
next TupleHashMap Text Text [a]
map1 HashMap Text [a]
map2
        Just (Maybe Text
ns, Text
name) ->
          case Maybe Text
ns of
            Just Text
ns -> TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a
next (Text
-> Text
-> [a]
-> TupleHashMap Text Text [a]
-> TupleHashMap Text Text [a]
forall v k1 k2.
(Semigroup v, KeyConstraints k1 k2) =>
k1 -> k2 -> v -> TupleHashMap k1 k2 v -> TupleHashMap k1 k2 v
TupleHashMap.insertSemigroup Text
ns Text
name [a
contents] TupleHashMap Text Text [a]
map1) HashMap Text [a]
map2
            Maybe Text
Nothing -> TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a
next TupleHashMap Text Text [a]
map1 (([a] -> [a] -> [a])
-> Text -> [a] -> HashMap Text [a] -> HashMap Text [a]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HashMap.insertWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) Text
name [a
contents] HashMap Text [a]
map2)

empty :: NameMap a
empty :: NameMap a
empty =
  TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a
forall a.
TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a
NameMap TupleHashMap Text Text [a]
forall k1 k2 v. TupleHashMap k1 k2 v
TupleHashMap.empty HashMap Text [a]
forall k v. HashMap k v
HashMap.empty

insert :: Maybe Text -> Text -> a -> NameMap a -> NameMap a
insert :: Maybe Text -> Text -> a -> NameMap a -> NameMap a
insert Maybe Text
ns Text
name a
contents (NameMap TupleHashMap Text Text [a]
map1 HashMap Text [a]
map2) =
  case Maybe Text
ns of
    Just Text
ns ->
      TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a
forall a.
TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a
NameMap (Text
-> Text
-> [a]
-> TupleHashMap Text Text [a]
-> TupleHashMap Text Text [a]
forall v k1 k2.
(Semigroup v, KeyConstraints k1 k2) =>
k1 -> k2 -> v -> TupleHashMap k1 k2 v -> TupleHashMap k1 k2 v
TupleHashMap.insertSemigroup Text
ns Text
name [a
contents] TupleHashMap Text Text [a]
map1) HashMap Text [a]
map2
    Maybe Text
Nothing ->
      TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a
forall a.
TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a
NameMap TupleHashMap Text Text [a]
map1 (([a] -> [a] -> [a])
-> Text -> [a] -> HashMap Text [a] -> HashMap Text [a]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HashMap.insertWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) Text
name [a
contents] HashMap Text [a]
map2)

fetch :: Maybe Text -> Text -> NameMap a -> Maybe (a, NameMap a)
fetch :: Maybe Text -> Text -> NameMap a -> Maybe (a, NameMap a)
fetch Maybe Text
ns Text
name (NameMap TupleHashMap Text Text [a]
map1 HashMap Text [a]
map2) =
  case Maybe Text
ns of
    Just Text
ns ->
      (Maybe [a] -> Compose Maybe ((,) a) (Maybe [a]))
-> Text
-> Text
-> TupleHashMap Text Text [a]
-> Compose Maybe ((,) a) (TupleHashMap Text Text [a])
forall (f :: * -> *) k1 k2 v.
(Functor f, KeyConstraints k1 k2) =>
(Maybe v -> f (Maybe v))
-> k1 -> k2 -> TupleHashMap k1 k2 v -> f (TupleHashMap k1 k2 v)
TupleHashMap.alterF
        ( \case
            Just [a]
list ->
              case [a]
list of
                a
head : [a]
tail -> case [a]
tail of
                  [] -> Maybe (a, Maybe [a]) -> Compose Maybe ((,) a) (Maybe [a])
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose ((a, Maybe [a]) -> Maybe (a, Maybe [a])
forall a. a -> Maybe a
Just (a
head, Maybe [a]
forall a. Maybe a
Nothing))
                  [a]
_ -> Maybe (a, Maybe [a]) -> Compose Maybe ((,) a) (Maybe [a])
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose ((a, Maybe [a]) -> Maybe (a, Maybe [a])
forall a. a -> Maybe a
Just (a
head, [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a]
tail))
                [a]
_ -> Maybe (a, Maybe [a]) -> Compose Maybe ((,) a) (Maybe [a])
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose Maybe (a, Maybe [a])
forall a. Maybe a
Nothing
            Maybe [a]
Nothing ->
              Maybe (a, Maybe [a]) -> Compose Maybe ((,) a) (Maybe [a])
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose Maybe (a, Maybe [a])
forall a. Maybe a
Nothing
        )
        Text
ns
        Text
name
        TupleHashMap Text Text [a]
map1
        Compose Maybe ((,) a) (TupleHashMap Text Text [a])
-> (Compose Maybe ((,) a) (TupleHashMap Text Text [a])
    -> Maybe (a, TupleHashMap Text Text [a]))
-> Maybe (a, TupleHashMap Text Text [a])
forall a b. a -> (a -> b) -> b
& Compose Maybe ((,) a) (TupleHashMap Text Text [a])
-> Maybe (a, TupleHashMap Text Text [a])
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose
        Maybe (a, TupleHashMap Text Text [a])
-> (Maybe (a, TupleHashMap Text Text [a]) -> Maybe (a, NameMap a))
-> Maybe (a, NameMap a)
forall a b. a -> (a -> b) -> b
& ((a, TupleHashMap Text Text [a]) -> (a, NameMap a))
-> Maybe (a, TupleHashMap Text Text [a]) -> Maybe (a, NameMap a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TupleHashMap Text Text [a] -> NameMap a)
-> (a, TupleHashMap Text Text [a]) -> (a, NameMap a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a)
-> HashMap Text [a] -> TupleHashMap Text Text [a] -> NameMap a
forall a b c. (a -> b -> c) -> b -> a -> c
flip TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a
forall a.
TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a
NameMap HashMap Text [a]
map2))
    Maybe Text
Nothing ->
      (Maybe [a] -> Compose Maybe ((,) a) (Maybe [a]))
-> Text
-> HashMap Text [a]
-> Compose Maybe ((,) a) (HashMap Text [a])
forall (f :: * -> *) k v.
(Functor f, Eq k, Hashable k) =>
(Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)
HashMap.alterF
        ( \case
            Just [a]
list ->
              case [a]
list of
                a
head : [a]
tail -> case [a]
tail of
                  [] -> Maybe (a, Maybe [a]) -> Compose Maybe ((,) a) (Maybe [a])
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose ((a, Maybe [a]) -> Maybe (a, Maybe [a])
forall a. a -> Maybe a
Just (a
head, Maybe [a]
forall a. Maybe a
Nothing))
                  [a]
_ -> Maybe (a, Maybe [a]) -> Compose Maybe ((,) a) (Maybe [a])
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose ((a, Maybe [a]) -> Maybe (a, Maybe [a])
forall a. a -> Maybe a
Just (a
head, [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a]
tail))
                [a]
_ -> Maybe (a, Maybe [a]) -> Compose Maybe ((,) a) (Maybe [a])
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose Maybe (a, Maybe [a])
forall a. Maybe a
Nothing
            Maybe [a]
Nothing ->
              Maybe (a, Maybe [a]) -> Compose Maybe ((,) a) (Maybe [a])
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose Maybe (a, Maybe [a])
forall a. Maybe a
Nothing
        )
        Text
name
        HashMap Text [a]
map2
        Compose Maybe ((,) a) (HashMap Text [a])
-> (Compose Maybe ((,) a) (HashMap Text [a])
    -> Maybe (a, HashMap Text [a]))
-> Maybe (a, HashMap Text [a])
forall a b. a -> (a -> b) -> b
& Compose Maybe ((,) a) (HashMap Text [a])
-> Maybe (a, HashMap Text [a])
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose
        Maybe (a, HashMap Text [a])
-> (Maybe (a, HashMap Text [a]) -> Maybe (a, NameMap a))
-> Maybe (a, NameMap a)
forall a b. a -> (a -> b) -> b
& ((a, HashMap Text [a]) -> (a, NameMap a))
-> Maybe (a, HashMap Text [a]) -> Maybe (a, NameMap a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((HashMap Text [a] -> NameMap a)
-> (a, HashMap Text [a]) -> (a, NameMap a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a
forall a.
TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a
NameMap TupleHashMap Text Text [a]
map1))

extractNames :: NameMap a -> [(Maybe Text, Text)]
extractNames :: NameMap a -> [(Maybe Text, Text)]
extractNames (NameMap TupleHashMap Text Text [a]
map1 HashMap Text [a]
map2) =
  ((Text, Text, [a]) -> (Maybe Text, Text))
-> [(Text, Text, [a])] -> [(Maybe Text, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Text
a, Text
b, [a]
_) -> (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
a, Text
b)) (TupleHashMap Text Text [a] -> [(Text, Text, [a])]
forall k1 k2 b. TupleHashMap k1 k2 b -> [(k1, k2, b)]
TupleHashMap.toList TupleHashMap Text Text [a]
map1)
    [(Maybe Text, Text)]
-> [(Maybe Text, Text)] -> [(Maybe Text, Text)]
forall a. Semigroup a => a -> a -> a
<> ((Text, [a]) -> (Maybe Text, Text))
-> [(Text, [a])] -> [(Maybe Text, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe Text
forall a. Maybe a
Nothing,) (Text -> (Maybe Text, Text))
-> ((Text, [a]) -> Text) -> (Text, [a]) -> (Maybe Text, Text)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Text, [a]) -> Text
forall a b. (a, b) -> a
fst) (HashMap Text [a] -> [(Text, [a])]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Text [a]
map2)