From 8c49a30faa431b8b56a4b4926e7dae56b1311fea Mon Sep 17 00:00:00 2001 From: Volpeon Date: Sun, 28 May 2023 08:13:08 +0200 Subject: Completed untested Flattening implementation --- src/Data/JLD.hs | 9 ++++++++ src/Data/JLD/Flattening.hs | 44 ++++++++++++++++++++++++++++++++++++++ src/Data/JLD/Flattening/Global.hs | 7 ++++++ src/Data/JLD/Flattening/NodeMap.hs | 18 ++++++++++------ src/Data/JLD/Model/NodeMap.hs | 16 +++++++++++++- 5 files changed, 87 insertions(+), 7 deletions(-) create mode 100644 src/Data/JLD/Flattening.hs create mode 100644 src/Data/JLD/Flattening/Global.hs (limited to 'src') 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 -- cgit v1.2.3-70-g09d2