From b2c846b0daf9d6e26e1e2a07fecc848b4732baa0 Mon Sep 17 00:00:00 2001 From: Volpeon Date: Sun, 28 May 2023 10:18:49 +0200 Subject: Fixed flattening errors --- src/Data/JLD.hs | 40 ++++++++++++++++++- src/Data/JLD/Flattening.hs | 2 +- src/Data/JLD/Flattening/NodeMap.hs | 78 ++++++++++++++++++++++++-------------- 3 files changed, 88 insertions(+), 32 deletions(-) (limited to 'src') diff --git a/src/Data/JLD.hs b/src/Data/JLD.hs index d7688d0..a7042dc 100644 --- a/src/Data/JLD.hs +++ b/src/Data/JLD.hs @@ -4,6 +4,7 @@ module Data.JLD ( module Data.JLD.Options, JLDExpansionParams (..), JLDExpansionState (..), + JLDFlatteningParams (..), expand, flatten, ) where @@ -100,9 +101,44 @@ expand document baseUrl paramsFn = do pure (result', state') -flatten :: Monad m => Value -> URI -> (JLDExpansionParams () m -> JLDExpansionParams e m) -> m (Either (JLDError e) Value, JLDExpansionState) +data JLDFlatteningParams e m = JLDFlatteningParams + { jldFlatteningParamsDocumentLoader :: DocumentLoader e m + , jldFlatteningParamsProcessingMode :: JLDVersion + , jldFlatteningParamsMaxRemoteContexts :: Int + , jldFlatteningParamsExpandContext :: Maybe Value + , jldFlatteningParamsFrameExpansion :: Bool + , jldFlatteningParamsState :: JLDExpansionState + , jldFlatteningParamsCompactArrays :: Bool + } + deriving (Show) + +flatten :: Monad m => Value -> URI -> (JLDFlatteningParams () m -> JLDFlatteningParams e m) -> m (Either (JLDError e) Value, JLDExpansionState) flatten document baseUrl paramsFn = do - (result, state') <- expand document baseUrl paramsFn + let JLDFlatteningParams{..} = + paramsFn + JLDFlatteningParams + { jldFlatteningParamsDocumentLoader = DocumentLoader <. const <. pure <| Left () + , jldFlatteningParamsProcessingMode = JLD1_1 + , jldFlatteningParamsMaxRemoteContexts = 20 + , jldFlatteningParamsExpandContext = Nothing + , jldFlatteningParamsFrameExpansion = False + , jldFlatteningParamsState = + JLDExpansionState + { jldExpansionStateContextCache = mempty + , jldExpansionStateDocumentCache = mempty + } + , jldFlatteningParamsCompactArrays = True + } + expansionParams = + JLDExpansionParams + { jldExpansionParamsDocumentLoader = jldFlatteningParamsDocumentLoader + , jldExpansionParamsProcessingMode = jldFlatteningParamsProcessingMode + , jldExpansionParamsMaxRemoteContexts = jldFlatteningParamsMaxRemoteContexts + , jldExpansionParamsExpandContext = jldFlatteningParamsExpandContext + , jldExpansionParamsFrameExpansion = jldFlatteningParamsFrameExpansion + , jldExpansionParamsState = jldFlatteningParamsState + } + (result, state') <- expand document baseUrl (const expansionParams) 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 index 2bfd8dd..3a8c726 100644 --- a/src/Data/JLD/Flattening.hs +++ b/src/Data/JLD/Flattening.hs @@ -34,7 +34,7 @@ collectNodesStep ar node flatten :: Monad m => Value -> JLDFlatteningT e m Value flatten element = do -- 1. 2. - nodeMap <- fst <$> buildNodeMap element id + (nodeMap, _, _, _) <- buildNodeMap element id -- 3. 4. let defaultGraph = fromMaybe mempty <| M.lookup (show KeywordDefault) nodeMap diff --git a/src/Data/JLD/Flattening/NodeMap.hs b/src/Data/JLD/Flattening/NodeMap.hs index 65db9ab..6c35302 100644 --- a/src/Data/JLD/Flattening/NodeMap.hs +++ b/src/Data/JLD/Flattening/NodeMap.hs @@ -19,6 +19,7 @@ import Data.Aeson.KeyMap qualified as KM (filterWithKey, insert, lookup, member, import Data.Foldable.WithIndex (FoldableWithIndex (..), iforM_) import Data.Map.Strict qualified as M (insert, lookup) import Data.Vector qualified as V (singleton, snoc, uniq) +import Debug.Pretty.Simple (pTraceShowM) type BNMT e m = REST BNMEnv (Either (JLDError e) ()) BNMState m @@ -45,6 +46,8 @@ data BNMParams = BNMParams , bnmParamsActiveProperty :: Maybe Text , bnmParamsList :: Maybe Array , bnmParamsReferenceNode :: Maybe Object + , bnmParamsIdentifierCounter :: Int + , bnmParamsIdentifierMap :: Map Text Text } deriving (Show, Eq) @@ -78,19 +81,26 @@ bnmBuildNodeMap :: Monad m => Value -> (BNMParams -> BNMParams) -> BNMT e m (May bnmBuildNodeMap value paramsFn = do BNMEnv{..} <- ask nodeMap <- gets bnmStateNodeMap + identifierCounter <- gets bnmStateIdentifierCounter + identifierMap <- gets bnmStateIdentifierMap let params p = paramsFn p { bnmParamsNodeMap = nodeMap , bnmParamsActiveGraph = bnmEnvActiveGraph - , bnmParamsActiveSubject = bnmEnvActiveSubject - , bnmParamsActiveProperty = bnmEnvActiveProperty + , bnmParamsIdentifierCounter = identifierCounter + , bnmParamsIdentifierMap = identifierMap } - (nodeMap', list) <- + (nodeMap', list, identifierCounter', identifierMap') <- buildNodeMap value params |> runExceptT >=> \case Left err -> throwError <| Left err Right a -> pure a - bnmModifyNodeMap <| const nodeMap' + modify \st -> + st + { bnmStateNodeMap = nodeMap' + , bnmStateIdentifierCounter = identifierCounter' + , bnmStateIdentifierMap = identifierMap' + } pure list buildNodeMap' :: Monad m => Value -> BNMT e m () @@ -138,7 +148,14 @@ buildNodeMap' element = case element of -- 5. | Just elemList <- KM.lookup (show KeywordList) elementObject' -> do -- 5.1. 5.2. - subList <- listToObject <$> bnmBuildNodeMap elemList id + subList <- + listToObject <$> bnmBuildNodeMap elemList \params -> + params + { bnmParamsActiveSubject = bnmEnvActiveSubject + , bnmParamsActiveProperty = bnmEnvActiveProperty + , bnmParamsList = Just mempty + , bnmParamsReferenceNode = bnmEnvReferenceNode + } gets bnmStateList >>= \case -- 5.3. @@ -152,24 +169,25 @@ buildNodeMap' element = case element of | isNodeObject (Object elementObject') -> do id' <- case KM.lookup (show KeywordId) elementObject' of -- 6.1. - Just (String idValue) | isBlankIri idValue -> bnmCreateIdentifier <| Just idValue + Just (String idValue) + | isBlankIri idValue -> bnmCreateIdentifier (Just idValue) + | otherwise -> pure idValue Just _ -> throwError <| Right () -- 6.2. Nothing -> bnmCreateIdentifier Nothing -- 6.3. - nodeMap <- gets bnmStateNodeMap - when (N.hasKey2 bnmEnvActiveGraph (Just id') nodeMap) do - bnmModifyNodeMap <| N.insert bnmEnvActiveGraph (Just id') (Just <| show KeywordId) (String id') + bnmModifyNodeMap \nodeMap -> + if N.hasKey2 bnmEnvActiveGraph (Just id') nodeMap + then nodeMap + else N.insert bnmEnvActiveGraph (Just id') (Just <| show KeywordId) (String id') nodeMap - nodeMap' <- gets bnmStateNodeMap if -- 6.5. - | Just referenceNode <- bnmEnvReferenceNode -> - unless (N.memberArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty (Object referenceNode) nodeMap') do - bnmModifyNodeMap - <. N.modifyArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty - <| flip V.snoc (Object referenceNode) + | Just referenceNode <- bnmEnvReferenceNode -> bnmModifyNodeMap \nodeMap -> + if N.memberArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty (Object referenceNode) nodeMap + then nodeMap + else N.modifyArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty (`V.snoc` Object referenceNode) nodeMap -- 6.6. | isJust bnmEnvActiveProperty -> do -- 6.6.1. @@ -177,11 +195,10 @@ buildNodeMap' element = case element of gets bnmStateList >>= \case -- 6.6.2. - Nothing -> - unless (N.memberArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty reference nodeMap') do - bnmModifyNodeMap - <. N.modifyArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty - <| flip V.snoc reference + Nothing -> bnmModifyNodeMap \nodeMap -> + if N.memberArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty reference nodeMap + then nodeMap + else N.modifyArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty (`V.snoc` reference) nodeMap -- 6.6.3. Just stateList -> bnmModifyList <. const <. Just <| V.snoc stateList reference -- @@ -202,10 +219,10 @@ buildNodeMap' element = case element of Nothing -> pure () -- 6.8. - nodeMap'' <- gets bnmStateNodeMap + nodeMap' <- gets bnmStateNodeMap case KM.lookup (show KeywordIndex) elementObject' of Just indexValue - | N.hasKey3 bnmEnvActiveGraph (Just id') (Just <| show KeywordIndex) nodeMap'' -> throwError <| Left ConflictingIndexes + | N.hasKey3 bnmEnvActiveGraph (Just id') (Just <| show KeywordIndex) nodeMap' -> throwError <| Left ConflictingIndexes | otherwise -> bnmModifyNodeMap <| N.insert bnmEnvActiveGraph (Just id') (Just <| show KeywordType) indexValue -- Nothing -> pure () @@ -257,9 +274,10 @@ buildNodeMap' element = case element of else pure property -- 6.12.2. - gets (bnmStateNodeMap .> N.hasKey3 bnmEnvActiveGraph (Just id') (Just property')) >>= \case - True -> pure () - False -> bnmModifyNodeMap <| N.insert bnmEnvActiveGraph (Just id') (Just property') (Array mempty) + bnmModifyNodeMap \nodeMap -> + if N.hasKey3 bnmEnvActiveGraph (Just id') (Just property') nodeMap + then nodeMap + else N.insert bnmEnvActiveGraph (Just id') (Just property') (Array mempty) nodeMap void <| bnmBuildNodeMap value \params -> params @@ -273,12 +291,12 @@ buildNodeMap' element = case element of -- _ -> pure () -buildNodeMap :: Monad m => Value -> (BNMParams -> BNMParams) -> JLDFlatteningT e m (NodeMap, Maybe Array) +buildNodeMap :: Monad m => Value -> (BNMParams -> BNMParams) -> JLDFlatteningT e m (NodeMap, Maybe Array, Int, Map Text Text) buildNodeMap document paramsFn = do (result, BNMState{..}) <- buildNodeMap' document |> runREST env st case result of Left (Left err) -> throwError err - _ -> pure (bnmStateNodeMap, bnmStateList) + _ -> pure (bnmStateNodeMap, bnmStateList, bnmStateIdentifierCounter, bnmStateIdentifierMap) where BNMParams{..} = paramsFn @@ -289,6 +307,8 @@ buildNodeMap document paramsFn = do , bnmParamsActiveProperty = Nothing , bnmParamsList = mempty , bnmParamsReferenceNode = Nothing + , bnmParamsIdentifierCounter = 0 + , bnmParamsIdentifierMap = mempty } env = @@ -303,8 +323,8 @@ buildNodeMap document paramsFn = do BNMState { bnmStateNodeMap = bnmParamsNodeMap , bnmStateList = bnmParamsList - , bnmStateIdentifierCounter = 1 - , bnmStateIdentifierMap = mempty + , bnmStateIdentifierCounter = bnmParamsIdentifierCounter + , bnmStateIdentifierMap = bnmParamsIdentifierMap } mergeNodeMaps :: NodeMap -> NodeMap -- cgit v1.2.3-70-g09d2