Completed untested Flattening implementation

5 files changed, 87 insertions, 7 deletions

diff --git a/src/Data/JLD.hs b/src/Data/JLD.hs
index c5c28eb..d7688d0 100644
--- a/src/Data/JLD.hs
+++ b/src/Data/JLD.hs
@@ -5,6 +5,7 @@ module Data.JLD (
     JLDExpansionParams (..),
     JLDExpansionState (..),
     expand,
+    flatten,
 ) where
 
 import Data.JLD.Prelude
@@ -15,6 +16,7 @@ import Data.JLD.Expansion (JLDEParams (..))
 import Data.JLD.Expansion qualified as E (expand)
 import Data.JLD.Expansion.Context (buildActiveContext)
 import Data.JLD.Expansion.Global (JLDExpansionEnv (..), JLDExpansionState (..))
+import Data.JLD.Flattening qualified as F (flatten)
 import Data.JLD.Mime
 import Data.JLD.Model.ActiveContext (ActiveContext (..), newActiveContext)
 import Data.JLD.Model.Keyword (Keyword (..))
@@ -97,3 +99,10 @@ expand document baseUrl paramsFn = do
             Left err -> Left err
 
     pure (result', state')
+
+flatten :: Monad m => Value -> URI -> (JLDExpansionParams () m -> JLDExpansionParams e m) -> m (Either (JLDError e) Value, JLDExpansionState)
+flatten document baseUrl paramsFn = do
+    (result, state') <- expand document baseUrl paramsFn
+    case result of
+        Left err -> pure (Left err, state')
+        Right expanded -> fmap (,state') <. runExceptT <| F.flatten expanded
diff --git a/src/Data/JLD/Flattening.hs b/src/Data/JLD/Flattening.hs
new file mode 100644
index 0000000..2bfd8dd
--- /dev/null
+++ b/src/Data/JLD/Flattening.hs
@@ -0,0 +1,44 @@
+module Data.JLD.Flattening (flatten) where
+
+import Data.JLD.Prelude
+
+import Data.JLD.Flattening.NodeMap (buildNodeMap)
+
+import Data.Aeson (Array, Value (..))
+import Data.Foldable.WithIndex (FoldableWithIndex (..))
+import Data.JLD.Flattening.Global (JLDFlatteningT)
+import Data.JLD.Model.Keyword (Keyword (..))
+import Data.JLD.Model.NodeMap (PropertyMap, SubjectMap, propsToKeyMap)
+import Data.Map qualified as M (insert, lookup, member, singleton, size)
+import Data.Vector qualified as V
+
+collectGraphsStep :: Text -> SubjectMap -> SubjectMap -> SubjectMap
+collectGraphsStep graphName dg graph
+    | graphName == show KeywordDefault = dg
+    | otherwise = M.insert (Just graphName) entry' dg
+  where
+    -- 4.1. 4.2.
+    entry = case M.lookup (Just graphName) dg of
+        Just e -> e
+        Nothing -> M.singleton (Just <| show KeywordId) (String graphName)
+
+    graphArray = Array <| foldl' collectNodesStep mempty graph
+
+    entry' = M.insert (Just <| show KeywordGraph) graphArray entry
+
+collectNodesStep :: Array -> PropertyMap -> Array
+collectNodesStep ar node
+    | M.size node == 1 && M.member (Just <| show KeywordId) node = ar
+    | otherwise = V.snoc ar (Object <| propsToKeyMap node)
+
+flatten :: Monad m => Value -> JLDFlatteningT e m Value
+flatten element = do
+    -- 1. 2.
+    nodeMap <- fst <$> buildNodeMap element id
+
+    -- 3. 4.
+    let defaultGraph = fromMaybe mempty <| M.lookup (show KeywordDefault) nodeMap
+        defaultGraph' = ifoldl' collectGraphsStep defaultGraph nodeMap
+
+    -- 5. 6. 7.
+    pure <. Array <| foldl' collectNodesStep mempty defaultGraph'
diff --git a/src/Data/JLD/Flattening/Global.hs b/src/Data/JLD/Flattening/Global.hs
new file mode 100644
index 0000000..591d3ad
--- /dev/null
+++ b/src/Data/JLD/Flattening/Global.hs
@@ -0,0 +1,7 @@
+module Data.JLD.Flattening.Global (JLDFlatteningT) where
+
+import Data.JLD.Prelude
+
+import Data.JLD.Error (JLDError)
+
+type JLDFlatteningT e m = ExceptT (JLDError e) m
diff --git a/src/Data/JLD/Flattening/NodeMap.hs b/src/Data/JLD/Flattening/NodeMap.hs
index 919aec7..65db9ab 100644
--- a/src/Data/JLD/Flattening/NodeMap.hs
+++ b/src/Data/JLD/Flattening/NodeMap.hs
@@ -2,8 +2,9 @@ module Data.JLD.Flattening.NodeMap (NodeMap, BNMParams (..), buildNodeMap, merge
 
 import Data.JLD.Prelude
 
-import Data.JLD.Control.Monad.RES (REST, execREST, withErrorRES')
+import Data.JLD.Control.Monad.RES (REST, runREST, withErrorRES')
 import Data.JLD.Error (JLDError (..))
+import Data.JLD.Flattening.Global (JLDFlatteningT)
 import Data.JLD.Model.IRI (isBlankIri)
 import Data.JLD.Model.Keyword (Keyword (..), isKeywordLike, isNotKeyword)
 import Data.JLD.Model.NodeMap (NodeMap, PropertyMap)
@@ -12,7 +13,7 @@ import Data.JLD.Model.NodeObject (isNodeObject)
 import Data.JLD.Util (valueIsScalar, valueToArray, valueToNonNullArray)
 
 import Control.Monad.Except (MonadError (..))
-import Data.Aeson (Array, Key, Object, Value (..))
+import Data.Aeson (Array, 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 (FoldableWithIndex (..), iforM_)
@@ -85,7 +86,10 @@ bnmBuildNodeMap value paramsFn = do
                     , bnmParamsActiveSubject = bnmEnvActiveSubject
                     , bnmParamsActiveProperty = bnmEnvActiveProperty
                     }
-    (nodeMap', list) <- buildNodeMap value params
+    (nodeMap', list) <-
+        buildNodeMap value params |> runExceptT >=> \case
+            Left err -> throwError <| Left err
+            Right a -> pure a
     bnmModifyNodeMap <| const nodeMap'
     pure list
 
@@ -269,10 +273,12 @@ buildNodeMap' element = case element of
     --
     _ -> pure ()
 
-buildNodeMap :: Monad m => Value -> (BNMParams -> BNMParams) -> m (NodeMap, Maybe Array)
+buildNodeMap :: Monad m => Value -> (BNMParams -> BNMParams) -> JLDFlatteningT e m (NodeMap, Maybe Array)
 buildNodeMap document paramsFn = do
-    BNMState{..} <- buildNodeMap' document |> execREST env st
-    pure (bnmStateNodeMap, bnmStateList)
+    (result, BNMState{..}) <- buildNodeMap' document |> runREST env st
+    case result of
+        Left (Left err) -> throwError err
+        _ -> pure (bnmStateNodeMap, bnmStateList)
   where
     BNMParams{..} =
         paramsFn
diff --git a/src/Data/JLD/Model/NodeMap.hs b/src/Data/JLD/Model/NodeMap.hs
index d0fb2f9..f76c662 100644
--- a/src/Data/JLD/Model/NodeMap.hs
+++ b/src/Data/JLD/Model/NodeMap.hs
@@ -10,13 +10,18 @@ module Data.JLD.Model.NodeMap (
     hasKey2,
     hasKey3,
     memberArray,
+    propsToKeyMap,
 ) where
 
 import Data.JLD.Prelude hiding (modify)
 
 import Data.Aeson (Array, Value (..))
+import Data.Aeson.Key qualified as K
+import Data.Aeson.KeyMap (KeyMap)
+import Data.Aeson.KeyMap qualified as KM
+import Data.Foldable.WithIndex (FoldableWithIndex (..))
 import Data.JLD.Util (valueToArray)
-import Data.Map.Strict qualified as M (alter, insert, lookup, member)
+import Data.Map.Strict qualified as M (alter, insert, lookup, member, toList)
 
 type PropertyKey = Maybe Text
 type PropertyMap = Map PropertyKey Value
@@ -55,3 +60,12 @@ memberArray :: GraphKey -> SubjectKey -> PropertyKey -> Value -> NodeMap -> Bool
 memberArray graphName subject property value nodeMap = case lookup3 graphName subject property nodeMap of
     Just (Array a) -> value `elem` a
     _ -> False
+
+propsToKeyMap :: PropertyMap -> KeyMap Value
+propsToKeyMap =
+    ifoldl'
+        ( \maybeKey km value -> case maybeKey of
+            Just key -> KM.insert (K.fromText key) value km
+            Nothing -> km
+        )
+        mempty