From 77447e837f7461a337eec09845ad4b24dea1cce4 Mon Sep 17 00:00:00 2001 From: Volpeon Date: Sat, 24 Jun 2023 11:14:19 +0200 Subject: Update --- README.md | 4 +- src/Data/JLD/Compaction/IRI.hs | 539 ++++++++++++++++++----------------- src/Data/JLD/Model/InverseContext.hs | 2 +- 3 files changed, 285 insertions(+), 260 deletions(-) diff --git a/README.md b/README.md index 82ac774..b4e5b77 100644 --- a/README.md +++ b/README.md @@ -9,5 +9,5 @@ Tests are generated from the [official test suite](https://github.com/w3c/json-l | Feature | Tests | Pass | Status | | ---------- | ----- | ---- | ------ | | Expansion | 371 | 371 | 100% | -| Compaction | 55 | 54 | 98% | -| Flattening | ? | 0 | 0% | +| Flattening | 55 | 54 | 98% | +| Compaction | ? | 0 | 0% | diff --git a/src/Data/JLD/Compaction/IRI.hs b/src/Data/JLD/Compaction/IRI.hs index 208643f..414c7de 100644 --- a/src/Data/JLD/Compaction/IRI.hs +++ b/src/Data/JLD/Compaction/IRI.hs @@ -12,17 +12,18 @@ import Data.JLD.Model.InverseContext (InverseContext, selectTerm) import Control.Monad.Except (MonadError (..)) import Data.Aeson (Value (..)) import Data.Aeson.KeyMap qualified as KM (lookup, member, size) +import Data.Foldable.WithIndex (FoldableWithIndex (..)) import Data.JLD.Model.GraphObject (isGraphObject', isNotGraphObject') import Data.JLD.Model.Keyword (Keyword (..)) import Data.JLD.Model.Language (Language (..)) import Data.JLD.Model.ListObject (isListObject') -import Data.JLD.Model.TermDefinition (TermDefinition (termDefinitionIriMapping)) +import Data.JLD.Model.TermDefinition (TermDefinition (termDefinitionIriMapping, termDefinitionPrefixFlag)) import Data.JLD.Model.ValueObject (isValueObject') import Data.JLD.Util (valueToArray) -import Data.Map qualified as M (lookup) +import Data.Map qualified as M (lookup, member) import Data.Set qualified as S (insert) import Data.Text (toLower) -import Data.Text qualified as T (drop, findIndex) +import Data.Text qualified as T (drop, findIndex, isPrefixOf, length) import Data.Vector (Vector, (!?)) import Data.Vector qualified as V (cons) @@ -85,272 +86,296 @@ compactIri' var = do CIEnv{..} <- ask let ActiveContext{..} = ciEnvActiveContext - -- 4.1. - let defaultLanguage = case (activeContextDefaultLanguage, activeContextDefaultBaseDirection) of - (Just (Language language), Just dir) -> language <> show dir - (Nothing, Just dir) -> "_" <> show dir - _ -> show KeywordNone - - -- 4.2. - value = case ciEnvValue of - Just v@(Object o) -> case KM.lookup (show KeywordPreserve) o of - Just Null -> Just v - Just preserve -> valueToArray preserve !? 0 - _ -> Just v - _ -> Nothing - - -- 4.5. - case value of - Just (Object o) - | KM.member (show KeywordIndex) o && isNotGraphObject' o -> - ciModifyContainers - <| S.insert (show KeywordIndex) - .> S.insert (show KeywordIndex <> show KeywordSet) - _ -> pure () - - case value of - -- 4.6. - _ | ciEnvReverse -> do - ciPutTypeLanguage KeywordType - ciPutTypeLanguageValue <| show KeywordReverse - -- - Just (Object o) - -- 4.7. - | isListObject' o - , Just (Array list) <- KM.lookup (show KeywordList) o -> do - -- 4.7.1. - unless (KM.member (show KeywordIndex) o) <| ciModifyContainers (S.insert (show KeywordList)) - - -- 4.7.4. - let go (commonType, commonLanguage) item - -- 4.7.4.8. - | commonLanguage == Just (show KeywordNone) - , commonType == Just (show KeywordNone) = - (commonType, commonLanguage) - -- - | otherwise = (Just commonType', Just commonLanguage') - where - (itemLanguage, itemType) = case item of - Object objectItem - | KM.member (show KeywordValue) objectItem -> - if - -- 4.7.4.2.1. - | Just (String dir) <- KM.lookup (show KeywordDirection) objectItem - , Just (String lang) <- KM.lookup (show KeywordLanguage) objectItem -> - (toLower lang <> "_" <> toLower dir, show KeywordId) - | Just (String dir) <- KM.lookup (show KeywordDirection) objectItem -> - ("_" <> toLower dir, show KeywordId) - -- 4.7.4.2.2. - | Just (String lang) <- KM.lookup (show KeywordLanguage) objectItem -> - (toLower lang, show KeywordId) - -- 4.7.4.2.3. - | Just (String type') <- KM.lookup (show KeywordType) objectItem -> - (show KeywordNone, type') - -- 4.7.4.2.4. - | otherwise -> - (show KeywordNone, show KeywordId) - -- 4.7.4.2.4. - _ -> (show KeywordNone, show KeywordId) - - commonLanguage' = case commonLanguage of - -- 4.7.4.4. - Nothing -> itemLanguage - -- 4.7.4.5. - Just lang - | itemLanguage /= lang - , Object itemObject <- item - , KM.member (show KeywordValue) itemObject -> - show KeywordNone - | otherwise -> lang - - commonType' = case commonType of - Nothing -> itemType - Just it - | itemType /= it -> show KeywordNone - | otherwise -> it - - -- 4.7.3. 4.7.5. 4.7.6. - (commonType'', commonLanguage'') = - list - |> foldl' go (Nothing, if null list then Just defaultLanguage else Nothing) - .> bimap (fromMaybe (show KeywordNone)) (fromMaybe (show KeywordNone)) - - -- 4.7.7. - if commonType'' /= show KeywordNone - then do - ciPutTypeLanguage KeywordType - ciPutTypeLanguageValue (show commonType'') - else -- 4.7.8. - ciPutTypeLanguageValue (show commonLanguage'') - -- 4.8. - | isGraphObject' o -> do - -- 4.8.1. - when (KM.member (show KeywordIndex) o) do - ciModifyContainers - <| S.insert (show KeywordGraph <> show KeywordIndex) - .> S.insert (show KeywordGraph <> show KeywordIndex <> show KeywordSet) - -- 4.8.2. - when (KM.member (show KeywordId) o) do + -- 4. + when (M.member var ciEnvInverseContext) do + -- 4.1. + let defaultLanguage = case (activeContextDefaultLanguage, activeContextDefaultBaseDirection) of + (Just (Language language), Just dir) -> language <> show dir + (Nothing, Just dir) -> "_" <> show dir + _ -> show KeywordNone + + -- 4.2. + value = case ciEnvValue of + Just v@(Object o) -> case KM.lookup (show KeywordPreserve) o of + Just Null -> Just v + Just preserve -> valueToArray preserve !? 0 + _ -> Just v + _ -> Nothing + + -- 4.5. + case value of + Just (Object o) + | KM.member (show KeywordIndex) o && isNotGraphObject' o -> ciModifyContainers - <| S.insert (show KeywordGraph <> show KeywordId) - .> S.insert (show KeywordGraph <> show KeywordId <> show KeywordSet) - -- 4.8.3. - ciModifyContainers - <| S.insert (show KeywordGraph) - .> S.insert (show KeywordGraph <> show KeywordSet) - .> S.insert (show KeywordSet) - -- 4.8.4. - unless (KM.member (show KeywordIndex) o) do + <| S.insert (show KeywordIndex) + .> S.insert (show KeywordIndex <> show KeywordSet) + _ -> pure () + + case value of + -- 4.6. + _ | ciEnvReverse -> do + ciPutTypeLanguage KeywordType + ciPutTypeLanguageValue <| show KeywordReverse + -- + Just (Object o) + -- 4.7. + | isListObject' o + , Just (Array list) <- KM.lookup (show KeywordList) o -> do + -- 4.7.1. + unless (KM.member (show KeywordIndex) o) <| ciModifyContainers (S.insert (show KeywordList)) + + -- 4.7.4. + let go (commonType, commonLanguage) item + -- 4.7.4.8. + | commonLanguage == Just (show KeywordNone) + , commonType == Just (show KeywordNone) = + (commonType, commonLanguage) + -- + | otherwise = (Just commonType', Just commonLanguage') + where + (itemLanguage, itemType) = case item of + Object objectItem + | KM.member (show KeywordValue) objectItem -> + if + -- 4.7.4.2.1. + | Just (String dir) <- KM.lookup (show KeywordDirection) objectItem + , Just (String lang) <- KM.lookup (show KeywordLanguage) objectItem -> + (toLower lang <> "_" <> toLower dir, show KeywordId) + | Just (String dir) <- KM.lookup (show KeywordDirection) objectItem -> + ("_" <> toLower dir, show KeywordId) + -- 4.7.4.2.2. + | Just (String lang) <- KM.lookup (show KeywordLanguage) objectItem -> + (toLower lang, show KeywordId) + -- 4.7.4.2.3. + | Just (String type') <- KM.lookup (show KeywordType) objectItem -> + (show KeywordNone, type') + -- 4.7.4.2.4. + | otherwise -> + (show KeywordNone, show KeywordId) + -- 4.7.4.2.4. + _ -> (show KeywordNone, show KeywordId) + + commonLanguage' = case commonLanguage of + -- 4.7.4.4. + Nothing -> itemLanguage + -- 4.7.4.5. + Just lang + | itemLanguage /= lang + , Object itemObject <- item + , KM.member (show KeywordValue) itemObject -> + show KeywordNone + | otherwise -> lang + + commonType' = case commonType of + Nothing -> itemType + Just it + | itemType /= it -> show KeywordNone + | otherwise -> it + + -- 4.7.3. 4.7.5. 4.7.6. + (commonType'', commonLanguage'') = + list + |> foldl' go (Nothing, if null list then Just defaultLanguage else Nothing) + .> bimap (fromMaybe (show KeywordNone)) (fromMaybe (show KeywordNone)) + + -- 4.7.7. + if commonType'' /= show KeywordNone + then do + ciPutTypeLanguage KeywordType + ciPutTypeLanguageValue (show commonType'') + else -- 4.7.8. + ciPutTypeLanguageValue (show commonLanguage'') + -- 4.8. + | isGraphObject' o -> do + -- 4.8.1. + when (KM.member (show KeywordIndex) o) do + ciModifyContainers + <| S.insert (show KeywordGraph <> show KeywordIndex) + .> S.insert (show KeywordGraph <> show KeywordIndex <> show KeywordSet) + -- 4.8.2. + when (KM.member (show KeywordId) o) do + ciModifyContainers + <| S.insert (show KeywordGraph <> show KeywordId) + .> S.insert (show KeywordGraph <> show KeywordId <> show KeywordSet) + -- 4.8.3. ciModifyContainers - <| S.insert (show KeywordGraph <> show KeywordIndex) - .> S.insert (show KeywordGraph <> show KeywordIndex <> show KeywordSet) - -- 4.8.5. - unless (KM.member (show KeywordId) o) do + <| S.insert (show KeywordGraph) + .> S.insert (show KeywordGraph <> show KeywordSet) + .> S.insert (show KeywordSet) + -- 4.8.4. + unless (KM.member (show KeywordIndex) o) do + ciModifyContainers + <| S.insert (show KeywordGraph <> show KeywordIndex) + .> S.insert (show KeywordGraph <> show KeywordIndex <> show KeywordSet) + -- 4.8.5. + unless (KM.member (show KeywordId) o) do + ciModifyContainers + <| S.insert (show KeywordGraph <> show KeywordId) + .> S.insert (show KeywordGraph <> show KeywordId <> show KeywordSet) + -- 4.8.6. ciModifyContainers - <| S.insert (show KeywordGraph <> show KeywordId) - .> S.insert (show KeywordGraph <> show KeywordId <> show KeywordSet) - -- 4.8.6. - ciModifyContainers - <| S.insert (show KeywordIndex) - .> S.insert (show KeywordIndex <> show KeywordSet) - -- 4.8.7. + <| S.insert (show KeywordIndex) + .> S.insert (show KeywordIndex <> show KeywordSet) + -- 4.8.7. + ciPutTypeLanguage KeywordType + ciPutTypeLanguageValue (show KeywordId) + -- 4.9. 4.9.1. + | isValueObject' o -> do + if + -- 4.9.1.1. + | Just (String dir) <- KM.lookup (show KeywordDirection) o + , Just (String lang) <- KM.lookup (show KeywordLanguage) o + , not (KM.member (show KeywordIndex) o) -> do + ciPutTypeLanguageValue (toLower lang <> "_" <> toLower dir) + ciModifyContainers + <| S.insert (show KeywordLanguage) + .> S.insert (show KeywordLanguage <> show KeywordSet) + | Just (String dir) <- KM.lookup (show KeywordDirection) o + , not (KM.member (show KeywordIndex) o) -> do + ciPutTypeLanguageValue ("_" <> toLower dir) + ciModifyContainers + <| S.insert (show KeywordLanguage) + .> S.insert (show KeywordLanguage <> show KeywordSet) + -- 4.9.1.2. + | Just (String lang) <- KM.lookup (show KeywordLanguage) o + , not (KM.member (show KeywordIndex) o) -> do + ciPutTypeLanguageValue (toLower lang) + ciModifyContainers + <| S.insert (show KeywordLanguage) + .> S.insert (show KeywordLanguage <> show KeywordSet) + -- 4.9.1.3. + | Just (String type') <- KM.lookup (show KeywordType) o -> do + ciPutTypeLanguage KeywordType + ciPutTypeLanguageValue type' + -- + | otherwise -> pure () + -- 4.9.3. + ciModifyContainers <| S.insert (show KeywordSet) + -- 4.9.2. + _ -> do ciPutTypeLanguage KeywordType ciPutTypeLanguageValue (show KeywordId) - -- 4.9. 4.9.1. - | isValueObject' o -> do - if - -- 4.9.1.1. - | Just (String dir) <- KM.lookup (show KeywordDirection) o - , Just (String lang) <- KM.lookup (show KeywordLanguage) o - , not (KM.member (show KeywordIndex) o) -> do - ciPutTypeLanguageValue (toLower lang <> "_" <> toLower dir) - ciModifyContainers - <| S.insert (show KeywordLanguage) - .> S.insert (show KeywordLanguage <> show KeywordSet) - | Just (String dir) <- KM.lookup (show KeywordDirection) o - , not (KM.member (show KeywordIndex) o) -> do - ciPutTypeLanguageValue ("_" <> toLower dir) - ciModifyContainers - <| S.insert (show KeywordLanguage) - .> S.insert (show KeywordLanguage <> show KeywordSet) - -- 4.9.1.2. - | Just (String lang) <- KM.lookup (show KeywordLanguage) o - , not (KM.member (show KeywordIndex) o) -> do - ciPutTypeLanguageValue (toLower lang) - ciModifyContainers - <| S.insert (show KeywordLanguage) - .> S.insert (show KeywordLanguage <> show KeywordSet) - -- 4.9.1.3. - | Just (String type') <- KM.lookup (show KeywordType) o -> do - ciPutTypeLanguage KeywordType - ciPutTypeLanguageValue type' - -- - | otherwise -> pure () -- 4.9.3. - ciModifyContainers <| S.insert (show KeywordSet) - -- 4.9.2. - _ -> do - ciPutTypeLanguage KeywordType - ciPutTypeLanguageValue (show KeywordId) - -- 4.9.3. - ciModifyContainers - <| S.insert (show KeywordId) - .> S.insert (show KeywordId <> show KeywordSet) - .> S.insert (show KeywordType) - .> S.insert (show KeywordSet <> show KeywordType) - .> S.insert (show KeywordSet) - - -- 4.10. - ciModifyContainers <| S.insert (show KeywordNone) - - -- 4.11. - case value of - Just (Object o) - | jldCompactionEnvProcessingMode ciEnvGlobal /= JLD1_0 - , not (KM.member (show KeywordIndex) o) -> - ciModifyContainers - <| S.insert (show KeywordIndex) - .> S.insert (show KeywordIndex <> show KeywordSet) - _ - | jldCompactionEnvProcessingMode ciEnvGlobal /= JLD1_0 -> - ciModifyContainers - <| S.insert (show KeywordIndex) - .> S.insert (show KeywordIndex <> show KeywordSet) - -- - | otherwise -> pure () - - -- 4.12. - case value of - Just (Object o) - | jldCompactionEnvProcessingMode ciEnvGlobal /= JLD1_0 - , KM.member (show KeywordIndex) o - , KM.size o == 1 -> ciModifyContainers - <| S.insert (show KeywordLanguage) - .> S.insert (show KeywordLanguage <> show KeywordSet) - -- - _ -> pure () + <| S.insert (show KeywordId) + .> S.insert (show KeywordId <> show KeywordSet) + .> S.insert (show KeywordType) + .> S.insert (show KeywordSet <> show KeywordType) + .> S.insert (show KeywordSet) - -- 4.15. - typeLanguageValue <- gets ciStateTypeLanguageValue - when (typeLanguageValue == show KeywordReverse) <| ciModifyPreferredValues (V.cons (show KeywordReverse)) - - -- 4.16. - case value of - Just (Object o) - | typeLanguageValue == show KeywordReverse || typeLanguageValue == show KeywordId - , Just idValue <- KM.lookup (show KeywordId) o -> case idValue of - -- 4.16.1. - String idValue' -> do - compactedIdValue <- ciCompactIri idValue' - case M.lookup compactedIdValue activeContextTerms of - Just term - | termDefinitionIriMapping term == Just idValue' -> - ciModifyPreferredValues - <| V.cons (show KeywordVocab) - .> V.cons (show KeywordId) - -- 4.16.2. - _ -> - ciModifyPreferredValues - <| V.cons (show KeywordId) - .> V.cons (show KeywordVocab) - ciModifyPreferredValues <| V.cons (show KeywordNone) + -- 4.10. + ciModifyContainers <| S.insert (show KeywordNone) + + -- 4.11. + case value of + Just (Object o) + | jldCompactionEnvProcessingMode ciEnvGlobal /= JLD1_0 + , not (KM.member (show KeywordIndex) o) -> + ciModifyContainers + <| S.insert (show KeywordIndex) + .> S.insert (show KeywordIndex <> show KeywordSet) + _ + | jldCompactionEnvProcessingMode ciEnvGlobal /= JLD1_0 -> + ciModifyContainers + <| S.insert (show KeywordIndex) + .> S.insert (show KeywordIndex <> show KeywordSet) -- - _ -> throwError <. Left <| InvalidKeywordValue KeywordId idValue - -- 4.17. - | Just (Array a) <- KM.lookup (show KeywordList) o - , null a -> do + | otherwise -> pure () + + -- 4.12. + case value of + Just (Object o) + | jldCompactionEnvProcessingMode ciEnvGlobal /= JLD1_0 + , KM.member (show KeywordIndex) o + , KM.size o == 1 -> + ciModifyContainers + <| S.insert (show KeywordLanguage) + .> S.insert (show KeywordLanguage <> show KeywordSet) + -- + _ -> pure () + + -- 4.15. + typeLanguageValue <- gets ciStateTypeLanguageValue + when (typeLanguageValue == show KeywordReverse) <| ciModifyPreferredValues (V.cons (show KeywordReverse)) + + -- 4.16. + case value of + Just (Object o) + | typeLanguageValue == show KeywordReverse || typeLanguageValue == show KeywordId + , Just idValue <- KM.lookup (show KeywordId) o -> case idValue of + -- 4.16.1. + String idValue' -> do + compactedIdValue <- ciCompactIri idValue' + case M.lookup compactedIdValue activeContextTerms of + Just term + | termDefinitionIriMapping term == Just idValue' -> + ciModifyPreferredValues + <| V.cons (show KeywordVocab) + .> V.cons (show KeywordId) + -- 4.16.2. + _ -> + ciModifyPreferredValues + <| V.cons (show KeywordId) + .> V.cons (show KeywordVocab) + ciModifyPreferredValues <| V.cons (show KeywordNone) + -- + _ -> throwError <. Left <| InvalidKeywordValue KeywordId idValue + -- 4.17. + | Just (Array a) <- KM.lookup (show KeywordList) o + , null a -> do + ciModifyPreferredValues + <| V.cons typeLanguageValue + .> V.cons (show KeywordNone) + ciPutTypeLanguage KeywordAny + _ -> do ciModifyPreferredValues <| V.cons typeLanguageValue .> V.cons (show KeywordNone) - ciPutTypeLanguage KeywordAny - _ -> do - ciModifyPreferredValues - <| V.cons typeLanguageValue - .> V.cons (show KeywordNone) - - -- 4.18. - ciModifyPreferredValues <| V.cons (show KeywordAny) - - -- 4.19. - gets ciStatePreferredValues >>= mapM_ \preferredValue -> case T.findIndex (== ':') preferredValue of - Just idx -> ciModifyPreferredValues <| V.cons (T.drop idx preferredValue) - Nothing -> pure () - - -- 4.20. - maybeTerm <- - liftA3 - (\containers typeLanguage preferredValues -> selectTerm var containers typeLanguage preferredValues ciEnvInverseContext) - (gets ciStateContainers) - (gets ciStateTypeLanguage) - (gets ciStatePreferredValues) - - -- 4.21. - case maybeTerm of - Just term -> throwError <| Right term - Nothing -> pure () - - -- + + -- 4.18. + ciModifyPreferredValues <| V.cons (show KeywordAny) + + -- 4.19. + gets ciStatePreferredValues >>= mapM_ \preferredValue -> case T.findIndex (== ':') preferredValue of + Just idx -> ciModifyPreferredValues <| V.cons (T.drop idx preferredValue) + Nothing -> pure () + + -- 4.20. + maybeTerm <- + liftA3 + (\containers typeLanguage preferredValues -> selectTerm var containers typeLanguage preferredValues ciEnvInverseContext) + (gets ciStateContainers) + (gets ciStateTypeLanguage) + (gets ciStatePreferredValues) + + -- 4.21. + case maybeTerm of + Just term -> throwError <| Right term + Nothing -> pure () + + -- 5. + case activeContextVocabularyMapping of + Just vocabMapping + | ciEnvVocab && T.isPrefixOf vocabMapping var && T.length var > T.length vocabMapping + , suffix <- T.drop (T.length vocabMapping) var + , not (M.member suffix activeContextTerms) -> + throwError <| Right suffix + _ -> pure () + + -- 6. + let go key ci term = case termDefinitionIriMapping term of + Nothing -> ci + Just iriMapping + | var == iriMapping + || not (T.isPrefixOf iriMapping var) + || not (termDefinitionPrefixFlag term) -> + ci + -- + | otherwise -> do + + compactIri = ifoldl' go Nothing activeContextTerms + + -- 11. pure var compactIri :: Monad m => ActiveContext -> Text -> (CIParams -> CIParams) -> JLDCompactionT e m (Text, InverseContext) diff --git a/src/Data/JLD/Model/InverseContext.hs b/src/Data/JLD/Model/InverseContext.hs index ee85ce9..95cdeb8 100644 --- a/src/Data/JLD/Model/InverseContext.hs +++ b/src/Data/JLD/Model/InverseContext.hs @@ -12,7 +12,7 @@ type InverseContext = Map Text (Map Text (Map Keyword (Map Text Text))) hasKey3 :: Text -> Text -> Keyword -> InverseContext -> Bool hasKey3 var container type' inverseContext = - M.lookup var inverseContext >>= M.lookup container >>= M.lookup type' |> isJust + M.lookup var inverseContext >>= M.lookup container |> maybe False (M.member type') lookup4 :: Text -> Text -> Keyword -> Text -> InverseContext -> Maybe Text lookup4 var container type' typeMapping inverseContext = -- cgit v1.2.3-70-g09d2