Added Node Map Merging algorithm

4 files changed, 58 insertions, 25 deletions

diff --git a/src/Data/JLD/Expansion.hs b/src/Data/JLD/Expansion.hs
index 79a992d..beb10a3 100644
--- a/src/Data/JLD/Expansion.hs
+++ b/src/Data/JLD/Expansion.hs
@@ -167,7 +167,7 @@ eo1314ExpandValue activeProperty value = do
     expandValue activeProperty value
         |> withStateRES eo1314StateJlde (\eo1314 jld -> eo1314{eo1314StateJlde = jld})
 
-eo1314ExpandKeywordItem :: Monad m => Maybe Text -> Key -> Keyword -> Value -> EO1314T e m ()
+eo1314ExpandKeywordItem :: forall e m. Monad m => Maybe Text -> Key -> Keyword -> Value -> EO1314T e m ()
 eo1314ExpandKeywordItem inputType key keyword value = do
     JLDEEnv{..} <- ask
     let JLDExpansionEnv{..} = jldeEnvGlobal
@@ -335,15 +335,14 @@ eo1314ExpandKeywordItem inputType key keyword value = do
 
                         -- 13.4.13.4.
                         unless (KM.size expandedObjectValue == 1 && KM.member (show KeywordReverse) expandedObjectValue) do
+                            let go key' reverseMap (Array item) | key' /= show KeywordReverse = foldlM (go' key') reverseMap item
+                                go _ reverseMap _ = pure reverseMap
+
+                                go' _ _ item | isListObject item || isValueObject item = throwError <| InvalidReversePropertyValue
+                                go' key' reverseMap item = pure <| mapAddValue key' item True reverseMap
+
                             reverseMap <- gets <| getMapDefault (show KeywordReverse) <. eo1314StateResult
-                            reverseMap' <-
-                                (\fn -> ifoldlM fn reverseMap expandedObjectValue) <| \key' rm -> \case
-                                    Array item | key' /= show KeywordReverse -> do
-                                        (\fn -> foldlM fn rm item) <| \rm' i ->
-                                            if isListObject i || isValueObject i
-                                                then throwError <| InvalidReversePropertyValue
-                                                else pure <| mapAddValue key' i True rm'
-                                    _ -> pure rm
+                            reverseMap' <- ifoldlM go reverseMap expandedObjectValue
 
                             if KM.null reverseMap'
                                 then eo1314ModifyResult <| KM.delete (show KeywordReverse)
@@ -555,16 +554,12 @@ eo1314ExpandNonKeywordItem key expandedProperty value = do
         -- 13.13.
         if maybe False termDefinitionReversePropertyFlag keyTermDefinition
             then do
-                reverseMap <- gets <| getMapDefault (show KeywordReverse) <. eo1314StateResult
-
                 -- 13.13.3. 13.13.4.
-                reverseMap' <-
-                    (\fn -> foldlM fn reverseMap (valueToArray expandedValue'')) <| \rm item ->
-                        if isListObject item || isValueObject item
-                            then -- 13.13.4.1.
-                                throwError InvalidReversePropertyValue
-                            else -- 13.13.4.3.
-                                pure <| mapAddValue (K.fromText expandedProperty) item True rm
+                let go _ item | isListObject item || isValueObject item = throwError InvalidReversePropertyValue
+                    go reverseMap item = pure <| mapAddValue (K.fromText expandedProperty) item True reverseMap
+
+                reverseMap <- gets <| getMapDefault (show KeywordReverse) <. eo1314StateResult
+                reverseMap' <- foldlM go reverseMap (valueToArray expandedValue'')
 
                 eo1314ModifyResult <| KM.insert (show KeywordReverse) (Object reverseMap')
             else -- 13.14.
diff --git a/src/Data/JLD/Flattening/NodeMap.hs b/src/Data/JLD/Flattening/NodeMap.hs
index 3747402..919aec7 100644
--- a/src/Data/JLD/Flattening/NodeMap.hs
+++ b/src/Data/JLD/Flattening/NodeMap.hs
@@ -1,21 +1,21 @@
-module Data.JLD.Flattening.NodeMap (NodeMap, BNMParams (..), buildNodeMap) where
+module Data.JLD.Flattening.NodeMap (NodeMap, BNMParams (..), buildNodeMap, mergeNodeMaps) where
 
 import Data.JLD.Prelude
 
 import Data.JLD.Control.Monad.RES (REST, execREST, withErrorRES')
 import Data.JLD.Error (JLDError (..))
 import Data.JLD.Model.IRI (isBlankIri)
-import Data.JLD.Model.Keyword (Keyword (..), isNotKeyword)
-import Data.JLD.Model.NodeMap (NodeMap)
-import Data.JLD.Model.NodeMap qualified as N (hasKey2, hasKey3, insert, lookup3, memberArray, modifyArray)
+import Data.JLD.Model.Keyword (Keyword (..), isKeywordLike, isNotKeyword)
+import Data.JLD.Model.NodeMap (NodeMap, PropertyMap)
+import Data.JLD.Model.NodeMap qualified as N (hasKey2, hasKey3, insert, lookup2, lookup3, memberArray, modifyArray)
 import Data.JLD.Model.NodeObject (isNodeObject)
 import Data.JLD.Util (valueIsScalar, valueToArray, valueToNonNullArray)
 
 import Control.Monad.Except (MonadError (..))
-import Data.Aeson (Array, Object, Value (..))
+import Data.Aeson (Array, Key, Object, Value (..))
 import Data.Aeson.Key qualified as K (toText)
 import Data.Aeson.KeyMap qualified as KM (filterWithKey, insert, lookup, member, singleton)
-import Data.Foldable.WithIndex (iforM_)
+import Data.Foldable.WithIndex (FoldableWithIndex (..), iforM_)
 import Data.Map.Strict qualified as M (insert, lookup)
 import Data.Vector qualified as V (singleton, snoc, uniq)
 
@@ -300,3 +300,26 @@ buildNodeMap document paramsFn = do
             , bnmStateIdentifierCounter = 1
             , bnmStateIdentifierMap = mempty
             }
+
+mergeNodeMaps :: NodeMap -> NodeMap
+mergeNodeMaps = foldl' (ifoldl' go) mempty
+  where
+    go :: Maybe Text -> NodeMap -> PropertyMap -> NodeMap
+    go subjectKey result = ifoldl' (go' subjectKey) result'
+      where
+        result' = case N.lookup2 (show KeywordMerged) subjectKey result of
+            Just _ -> result
+            Nothing -> N.insert (show KeywordMerged) subjectKey (Just <| show KeywordId) (maybe Null String subjectKey) result
+
+    go' :: Maybe Text -> Maybe Text -> NodeMap -> Value -> NodeMap
+    go' subjectKey propertyKey result property
+        | propertyKey /= Just (show KeywordType) && maybe False isKeywordLike propertyKey =
+            N.insert (show KeywordMerged) subjectKey propertyKey property result
+        | otherwise =
+            N.insert (show KeywordMerged) subjectKey propertyKey array result
+      where
+        array =
+            Array
+                <. (<> valueToArray property)
+                <. maybe mempty valueToArray
+                <| N.lookup3 (show KeywordMerged) subjectKey propertyKey result
diff --git a/src/Data/JLD/Model/Keyword.hs b/src/Data/JLD/Model/Keyword.hs
index 10835a9..ab86164 100644
--- a/src/Data/JLD/Model/Keyword.hs
+++ b/src/Data/JLD/Model/Keyword.hs
@@ -32,6 +32,7 @@ data Keyword
     | KeywordJson
     | KeywordLanguage
     | KeywordList
+    | KeywordMerged
     | KeywordNest
     | KeywordNone
     | KeywordNull
@@ -68,6 +69,7 @@ instance Show Keyword where
         KeywordJson -> "@json"
         KeywordLanguage -> "@language"
         KeywordList -> "@list"
+        KeywordMerged -> "@merged"
         KeywordNest -> "@nest"
         KeywordNone -> "@none"
         KeywordNull -> "@null"
@@ -103,6 +105,7 @@ parseKeyword = \case
     "@json" -> Just KeywordJson
     "@language" -> Just KeywordLanguage
     "@list" -> Just KeywordList
+    "@merged" -> Just KeywordMerged
     "@nest" -> Just KeywordNest
     "@none" -> Just KeywordNone
     "@null" -> Just KeywordNull
diff --git a/src/Data/JLD/Model/NodeMap.hs b/src/Data/JLD/Model/NodeMap.hs
index 48db17e..d0fb2f9 100644
--- a/src/Data/JLD/Model/NodeMap.hs
+++ b/src/Data/JLD/Model/NodeMap.hs
@@ -1,4 +1,16 @@
-module Data.JLD.Model.NodeMap (NodeMap, lookup, lookup2, lookup3, insert, modifyArray, hasKey2, hasKey3, memberArray) where
+module Data.JLD.Model.NodeMap (
+    NodeMap,
+    SubjectMap,
+    PropertyMap,
+    lookup,
+    lookup2,
+    lookup3,
+    insert,
+    modifyArray,
+    hasKey2,
+    hasKey3,
+    memberArray,
+) where
 
 import Data.JLD.Prelude hiding (modify)