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 =
  forall a.
(Name -> Maybe (Maybe Text, Text)) -> [(Name, a)] -> NameMap a
fromReverseList (forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> NamespaceRegistry -> Maybe (Maybe Text, Text)
NamespaceRegistry.resolveElementName NamespaceRegistry
nreg) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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) 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 =
  forall a.
(Name -> Maybe (Maybe Text, Text)) -> [(Name, a)] -> NameMap a
fromList (forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> NamespaceRegistry -> Maybe (Maybe Text, Text)
NamespaceRegistry.resolveAttributeName NamespaceRegistry
nreg) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k a. Map k a -> [(k, a)]
Map.toList

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

fromReverseList :: (Xml.Name -> Maybe (Maybe Text, Text)) -> [(Xml.Name, a)] -> NameMap a
fromReverseList :: forall a.
(Name -> Maybe (Maybe Text, Text)) -> [(Name, a)] -> NameMap a
fromReverseList Name -> Maybe (Maybe Text, Text)
resolve [(Name, a)]
list =
  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 forall a.
TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a
NameMap [(Name, a)]
list forall k1 k2 v. TupleHashMap k1 k2 v
TupleHashMap.empty 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 (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 (forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HashMap.insertWith forall a. [a] -> [a] -> [a]
(++) Text
name [a
contents] HashMap Text [a]
map2)

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

insert :: Maybe Text -> Text -> a -> NameMap a -> NameMap a
insert :: forall a. 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 ->
      forall a.
TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a
NameMap (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 ->
      forall a.
TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a
NameMap TupleHashMap Text Text [a]
map1 (forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HashMap.insertWith forall a. [a] -> [a] -> [a]
(++) Text
name [a
contents] HashMap Text [a]
map2)

fetch :: Maybe Text -> Text -> NameMap a -> Maybe (a, NameMap a)
fetch :: forall a. 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 ->
      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
                  [] -> forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (forall a. a -> Maybe a
Just (a
head, forall a. Maybe a
Nothing))
                  [a]
_ -> forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (forall a. a -> Maybe a
Just (a
head, forall a. a -> Maybe a
Just [a]
tail))
                [a]
_ -> forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose forall a. Maybe a
Nothing
            Maybe [a]
Nothing ->
              forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose forall a. Maybe a
Nothing
        )
        Text
ns
        Text
name
        TupleHashMap Text Text [a]
map1
        forall a b. a -> (a -> b) -> b
& forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose
        forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a.
TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a
NameMap HashMap Text [a]
map2))
    Maybe Text
Nothing ->
      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
                  [] -> forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (forall a. a -> Maybe a
Just (a
head, forall a. Maybe a
Nothing))
                  [a]
_ -> forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (forall a. a -> Maybe a
Just (a
head, forall a. a -> Maybe a
Just [a]
tail))
                [a]
_ -> forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose forall a. Maybe a
Nothing
            Maybe [a]
Nothing ->
              forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose forall a. Maybe a
Nothing
        )
        Text
name
        HashMap Text [a]
map2
        forall a b. a -> (a -> b) -> b
& forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose
        forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a.
TupleHashMap Text Text [a] -> HashMap Text [a] -> NameMap a
NameMap TupleHashMap Text Text [a]
map1))

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