From b19440a4a30828f12f8eafaa7292152ecf733334 Mon Sep 17 00:00:00 2001 From: Volpeon Date: Sat, 24 Jun 2023 08:58:22 +0200 Subject: WIP: Compaction --- src/Data/JLD.hs | 5 +- src/Data/JLD/Compaction/Global.hs | 13 ++ src/Data/JLD/Compaction/IRI.hs | 342 ++++++++++++++++++++++++++++++ src/Data/JLD/Compaction/InverseContext.hs | 54 +++++ src/Data/JLD/Expansion.hs | 30 +-- src/Data/JLD/Expansion/Context.hs | 36 ++-- src/Data/JLD/Flattening/NodeMap.hs | 4 +- src/Data/JLD/Model/ActiveContext.hs | 6 +- src/Data/JLD/Model/GraphObject.hs | 19 +- src/Data/JLD/Model/ListObject.hs | 16 +- src/Data/JLD/Util.hs | 8 +- 11 files changed, 474 insertions(+), 59 deletions(-) create mode 100644 src/Data/JLD/Compaction/Global.hs create mode 100644 src/Data/JLD/Compaction/IRI.hs create mode 100644 src/Data/JLD/Compaction/InverseContext.hs (limited to 'src') diff --git a/src/Data/JLD.hs b/src/Data/JLD.hs index a7042dc..40abae1 100644 --- a/src/Data/JLD.hs +++ b/src/Data/JLD.hs @@ -26,8 +26,7 @@ import Data.JLD.Options import Data.JLD.Util (flattenSingletonArray, valueToArray) import Data.Aeson (Value (..)) -import Data.Aeson.KeyMap qualified as KM -import Data.Vector qualified as V (singleton) +import Data.Aeson.KeyMap qualified as KM (lookup, size) import Text.URI (URI) data JLDExpansionParams e m = JLDExpansionParams @@ -72,7 +71,7 @@ expand document baseUrl paramsFn = do jldExpansionParamsExpandContext <&> flattenSingletonArray .> \case Array expandedContext -> Array expandedContext (Object expandedContext) | Just ctx <- KM.lookup (show KeywordContext) expandedContext -> ctx - expandedContext -> Array <| V.singleton expandedContext + expandedContext -> Array <| pure expandedContext activeContext' <- case maybeExpandContext of Just expandContext -> diff --git a/src/Data/JLD/Compaction/Global.hs b/src/Data/JLD/Compaction/Global.hs new file mode 100644 index 0000000..76b2db7 --- /dev/null +++ b/src/Data/JLD/Compaction/Global.hs @@ -0,0 +1,13 @@ +module Data.JLD.Compaction.Global (JLDCompactionT, JLDCompactionEnv (..)) where + +import Data.JLD.Prelude + +import Data.JLD.Error (JLDError) +import Data.JLD.Options (JLDVersion (..)) + +type JLDCompactionT e m = ReaderT JLDCompactionEnv (ExceptT (JLDError e) m) + +newtype JLDCompactionEnv = JLDCompactionEnv + { jldCompactionEnvProcessingMode :: JLDVersion + } + deriving (Show) diff --git a/src/Data/JLD/Compaction/IRI.hs b/src/Data/JLD/Compaction/IRI.hs new file mode 100644 index 0000000..34379d2 --- /dev/null +++ b/src/Data/JLD/Compaction/IRI.hs @@ -0,0 +1,342 @@ +module Data.JLD.Compaction.IRI (compactIri) where + +import Data.JLD.Prelude + +import Data.JLD (JLDError (InvalidKeywordValue), JLDVersion (JLD1_0)) +import Data.JLD.Compaction.Global (JLDCompactionEnv (jldCompactionEnvProcessingMode), JLDCompactionT) +import Data.JLD.Compaction.InverseContext (buildInverseContext) +import Data.JLD.Control.Monad.RES (REST, evalREST, runREST, withEnvRES, withStateRES) +import Data.JLD.Model.ActiveContext (ActiveContext (..)) +import Data.JLD.Model.InverseContext (InverseContext) + +import Control.Monad.Except (MonadError (..)) +import Data.Aeson (Value (..)) +import Data.Aeson.KeyMap qualified as KM (lookup, member, size) +import Data.JLD.Model.Direction (Direction (..)) +import Data.JLD.Model.GraphObject (isGraphObject', isNotGraphObject, isNotGraphObject') +import Data.JLD.Model.Keyword (Keyword (..)) +import Data.JLD.Model.Language (Language (..)) +import Data.JLD.Model.ListObject (isListObject') +import Data.JLD.Model.ValueObject (isValueObject') +import Data.JLD.Util (valueToArray) +import Data.Set qualified as S +import Data.Text (toLower) +import Data.Text qualified as T (drop, findIndex, isPrefixOf, take) +import Data.Vector (Vector, (!?)) +import Data.Vector qualified as V (cons, snoc) + +type CIT e m = REST CIEnv (JLDError e) CIState m + +data CIEnv = CIEnv + { ciEnvGlobal :: JLDCompactionEnv + , ciEnvActiveContext :: ActiveContext + , ciEnvValue :: Maybe Value + , ciEnvVocab :: Bool + , ciEnvReverse :: Bool + } + deriving (Show) + +data CIState = CIState + { ciStateContainers :: Set Text + , ciStateTypeLanguage :: Keyword + , ciStateTypeLanguageValue :: Text + , ciStatePreferredValues :: Vector Text + } + deriving (Show, Eq) + +data CIParams = CIParams + { ciParamsActiveContext :: ActiveContext + , ciParamsValue :: Maybe Value + , ciParamsVocab :: Bool + , ciParamsReverse :: Bool + } + deriving (Show, Eq) + +ciModifyContainers :: Monad m => (Set Text -> Set Text) -> CIT e m () +ciModifyContainers fn = modify \s -> s{ciStateContainers = fn (ciStateContainers s)} + +ciModifyPreferredValues :: Monad m => (Vector Text -> Vector Text) -> CIT e m () +ciModifyPreferredValues fn = modify \s -> s{ciStatePreferredValues = fn (ciStatePreferredValues s)} + +ciPutTypeLanguage :: Monad m => Keyword -> CIT e m () +ciPutTypeLanguage v = modify \s -> s{ciStateTypeLanguage = v} + +ciPutTypeLanguageValue :: Monad m => Text -> CIT e m () +ciPutTypeLanguageValue v = modify \s -> s{ciStateTypeLanguageValue = v} + +compactIri4 :: Monad m => InverseContext -> Text -> CIT e m (Maybe Text) +compactIri4 inverseContext 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 + 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 + 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 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.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 () + + -- 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 + String idValue' -> pure () + _ -> throwError <| InvalidKeywordValue KeywordId idValue + -- + _ -> pure () + + -- + pure Nothing + +compactIri' :: Monad m => Text -> CIT e m (Text, InverseContext) +compactIri' var = do + CIEnv{..} <- ask + + -- 2. 3. + let inverseContext = case activeContextInverseContext ciEnvActiveContext of + Nothing -> buildInverseContext ciEnvActiveContext + Just ic -> ic + + compactIri4 inverseContext var >>= \case + Just var' -> pure (var', inverseContext) + Nothing -> pure (var, inverseContext) + +compactIri :: Monad m => ActiveContext -> Text -> (CIParams -> CIParams) -> JLDCompactionT e m (Text, InverseContext) +compactIri activeContext var paramsFn = do + envGlobal <- ask + result <- + compactIri' var + |> evalREST (env envGlobal) st + case result of + Left err -> throwError err + Right res -> pure res + where + CIParams{..} = + paramsFn + CIParams + { ciParamsActiveContext = activeContext + , ciParamsValue = Nothing + , ciParamsVocab = False + , ciParamsReverse = False + } + + env global = + CIEnv + { ciEnvGlobal = global + , ciEnvActiveContext = ciParamsActiveContext + , ciEnvValue = ciParamsValue + , ciEnvVocab = ciParamsVocab + , ciEnvReverse = ciParamsReverse + } + + st = + CIState + { ciStateContainers = mempty + , ciStateTypeLanguage = KeywordLanguage + , ciStateTypeLanguageValue = show KeywordNull + , ciStatePreferredValues = mempty + } diff --git a/src/Data/JLD/Compaction/InverseContext.hs b/src/Data/JLD/Compaction/InverseContext.hs new file mode 100644 index 0000000..b351e34 --- /dev/null +++ b/src/Data/JLD/Compaction/InverseContext.hs @@ -0,0 +1,54 @@ +module Data.JLD.Compaction.InverseContext (buildInverseContext) where + +import Data.JLD.Prelude + +import Data.JLD.Model.ActiveContext (ActiveContext (..)) +import Data.JLD.Model.Direction (Direction (..)) +import Data.JLD.Model.InverseContext (InverseContext) +import Data.JLD.Model.Keyword (Keyword (..)) +import Data.JLD.Model.Language (Language (Language)) +import Data.JLD.Model.TermDefinition (TermDefinition (..)) + +import Data.Map qualified as M + +processTerm :: Text -> InverseContext -> Text -> TermDefinition -> InverseContext +processTerm defaultLangDir out termName TermDefinition{..} + | Just variableName <- termDefinitionIriMapping = + out + |> M.insert (variableName, container, show KeywordAny, show KeywordNone) termName + .> if + | termDefinitionReversePropertyFlag -> + M.insert (variableName, container, show KeywordType, show KeywordReverse) termName + | termDefinitionTypeMapping == Just (show KeywordNone) -> + M.insert (variableName, container, show KeywordLanguage, show KeywordAny) termName + .> M.insert (variableName, container, show KeywordType, show KeywordAny) termName + | Just typeMapping <- termDefinitionTypeMapping -> + M.insert (variableName, container, show KeywordType, typeMapping) termName + | Just langDir <- maybeLangDir -> + M.insert (variableName, container, show KeywordLanguage, langDir) termName + | otherwise -> + M.insert (variableName, container, show KeywordLanguage, defaultLangDir) termName + .> M.insert (variableName, container, show KeywordLanguage, show KeywordNone) termName + .> M.insert (variableName, container, show KeywordType, show KeywordNone) termName + | otherwise = out + where + container = if null termDefinitionContainerMapping then show KeywordNone else fold termDefinitionContainerMapping + maybeLangDir = case (termDefinitionLanguageMapping, termDefinitionDirectionMapping) of + (Just (Language language), Just LTR) -> Just <| language <> "_ltr" + (Just (Language language), Just RTL) -> Just <| language <> "_rtl" + (Just (Language language), _) -> Just <| language + (Just _, Just LTR) -> Just "_ltr" + (Just _, Just RTL) -> Just "_rtl" + (Just _, _) -> Just <| show KeywordNull + (Nothing, Just LTR) -> Just "_ltr" + (Nothing, Just RTL) -> Just "_rtl" + (Nothing, Just NoDirection) -> Just <| show KeywordNone + (Nothing, Nothing) -> Nothing + +buildInverseContext :: ActiveContext -> InverseContext +buildInverseContext ActiveContext{..} = M.foldlWithKey (processTerm defaultLangDir) mempty activeContextTerms + where + defaultLangDir = case (activeContextDefaultBaseDirection, activeContextDefaultLanguage) of + (Just bd, Just (Language dl)) -> dl <> "_" <> show bd + (Just bd, _) -> "_" <> show bd + (_, _) -> show KeywordNone diff --git a/src/Data/JLD/Expansion.hs b/src/Data/JLD/Expansion.hs index beb10a3..983c126 100644 --- a/src/Data/JLD/Expansion.hs +++ b/src/Data/JLD/Expansion.hs @@ -39,7 +39,7 @@ import Data.Foldable.WithIndex (ifoldlM, iforM_) import Data.RDF (parseIRI) import Data.Set qualified as S (insert, member) import Data.Text qualified as T (elem, toLower) -import Data.Vector qualified as V (catMaybes, concat, cons, filter, fromList, mapMaybeM, maximum, modify, null, singleton, snoc, toList) +import Data.Vector qualified as V (catMaybes, concat, cons, filter, fromList, mapMaybeM, maximum, modify, null, snoc, toList) import Data.Vector.Algorithms.Merge qualified as V import Text.URI (URI) @@ -190,16 +190,16 @@ eo1314ExpandKeywordItem inputType key keyword value = do } case maybeExpandedStringValue of Just expandedStringValue - | jldeEnvFrameExpansion -> pure <. Just <. Array <. V.singleton <| String expandedStringValue + | jldeEnvFrameExpansion -> pure <. Just <. Array <. pure <| String expandedStringValue | otherwise -> pure <. Just <| String expandedStringValue Nothing -> pure <| Just Null -- Object (KM.null -> True) | jldeEnvFrameExpansion -> do - pure <. Just <. Array <. V.singleton <| Object mempty + pure <. Just <. Array <. pure <| Object mempty -- Array (allStrings -> Just arrayValue) | jldeEnvFrameExpansion && not (V.null arrayValue) -> do Just <. Array <. V.concat <. V.toList <$> forM arrayValue \item -> do - V.singleton <. maybe Null String <$> eo1314ExpandIriAC item \params -> + pure <. maybe Null String <$> eo1314ExpandIriAC item \params -> params { eiParamsDocumentRelative = True , eiParamsVocab = False @@ -233,7 +233,7 @@ eo1314ExpandKeywordItem inputType key keyword value = do -- 13.4.4.4. Array (allStrings -> Just arrayValue) -> Array <. V.concat <. V.toList <$> forM arrayValue \item -> do - V.singleton <. maybe Null String <$> eo1314ExpandIriTC item \params -> + pure <. maybe Null String <$> eo1314ExpandIriTC item \params -> params { eiParamsDocumentRelative = True , eiParamsVocab = True @@ -264,7 +264,7 @@ eo1314ExpandKeywordItem inputType key keyword value = do -- 13.4.6.4. gets <| eo1314StateResult .> KM.lookup (show KeywordIncluded) .> \case Just (Array includedValue) -> Just <. Array <| includedValue <> expandedValue - Just includedValue -> Just <. Array <| V.singleton includedValue <> expandedValue + Just includedValue -> Just <. Array <| pure includedValue <> expandedValue Nothing -> Just <| Array expandedValue -- 13.4.7. KeywordValue -> do @@ -277,9 +277,9 @@ eo1314ExpandKeywordItem inputType key keyword value = do -- 13.4.7.2. _ | value == Null || valueIsScalar value -> do if jldeEnvFrameExpansion - then pure <. Array <| V.singleton value + then pure <. Array <| pure value else pure value - Object (KM.null -> True) | jldeEnvFrameExpansion -> pure <. Array <| V.singleton value + Object (KM.null -> True) | jldeEnvFrameExpansion -> pure <. Array <| pure value Array (all valueIsString -> True) | jldeEnvFrameExpansion -> pure value -- _ -> throwError InvalidValueObjectValue @@ -291,7 +291,7 @@ eo1314ExpandKeywordItem inputType key keyword value = do -- 13.4.8. KeywordLanguage -> case value of String stringValue - | jldeEnvFrameExpansion -> pure <. Just <. Array <. V.singleton <. String <| T.toLower stringValue + | jldeEnvFrameExpansion -> pure <. Just <. Array <. pure <. String <| T.toLower stringValue | otherwise -> pure <. Just <. String <| T.toLower stringValue Object (KM.null -> True) | jldeEnvFrameExpansion -> pure <| Just value Array (all valueIsString -> True) | jldeEnvFrameExpansion -> pure <| Just value @@ -301,7 +301,7 @@ eo1314ExpandKeywordItem inputType key keyword value = do | JLD1_0 <- jldExpansionEnvProcessingMode -> pure Nothing | otherwise -> case value of String ((`elem` ["ltr", "rtl"]) -> True) - | jldeEnvFrameExpansion -> pure <. Just <. Array <| V.singleton value + | jldeEnvFrameExpansion -> pure <. Just <. Array <| pure value | otherwise -> pure <| Just value Object (KM.null -> True) | jldeEnvFrameExpansion -> pure <| Just value Array (all valueIsString -> True) | jldeEnvFrameExpansion -> pure <| Just value @@ -319,7 +319,7 @@ eo1314ExpandKeywordItem inputType key keyword value = do expandedValue <- eo1314ExpandAC jldeEnvActiveProperty value id case expandedValue of Array _ -> pure <| Just expandedValue - _ -> pure <. Just <. Array <| V.singleton expandedValue + _ -> pure <. Just <. Array <| pure expandedValue -- 13.4.12. KeywordSet -> Just <$> eo1314ExpandAC jldeEnvActiveProperty value id -- 13.4.13. @@ -491,7 +491,7 @@ eo1314ExpandNonKeywordItem key expandedProperty value = do let maybeExistingValues = expandedIndexKey >>= (`KM.lookup` item) indexPropertyValues = - V.singleton (Object reExpandedIndex) + pure (Object reExpandedIndex) |> case maybeExistingValues of Just (Array existingValues) -> (<> existingValues) Just existingValue -> (`V.snoc` existingValue) @@ -526,7 +526,7 @@ eo1314ExpandNonKeywordItem key expandedProperty value = do , expandedIndex /= show KeywordNone -> do let types = case KM.lookup (show KeywordType) item of Just existingType -> V.cons expandedIndex <| valueToArray existingType - Nothing -> V.singleton expandedIndex + Nothing -> pure expandedIndex pure <. KM.insert (show KeywordType) (Array types) <| item -- 13.8.3.7.6. | otherwise -> pure item @@ -755,7 +755,7 @@ expandObject maybePropertyContext value = do | Just resultType <- KM.lookup (show KeywordType) result -> eoNormalizeObject <| if valueIsNotArray resultType && resultType /= Null - then KM.insert (show KeywordType) (Array <| V.singleton resultType) result + then KM.insert (show KeywordType) (Array <| pure resultType) result else result -- 17. | KM.member (show KeywordList) result || KM.member (show KeywordSet) result -> do @@ -793,7 +793,7 @@ expandArrayItem item = do -- 5.2.3. Array a -> pure <| V.filter (/= Null) a Null -> pure mempty - _ -> pure <| V.singleton item'' + _ -> pure <| pure item'' -- diff --git a/src/Data/JLD/Expansion/Context.hs b/src/Data/JLD/Expansion/Context.hs index 99daba0..21350c8 100644 --- a/src/Data/JLD/Expansion/Context.hs +++ b/src/Data/JLD/Expansion/Context.hs @@ -96,8 +96,8 @@ bacBuildActiveContext context uri = do activeContext' <- buildActiveContext activeContext context (Just uri) params |> withEnvRES (const bacEnvGlobal) - |> withErrorRES Left - |> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global}) + .> withErrorRES Left + .> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global}) bacModifyActiveContext <| const activeContext' bacProcessItem :: Monad m => Maybe URI -> Value -> BACT e m () @@ -200,8 +200,8 @@ bacProcessItem baseUrl item = do (maybeVocabMapping, activeContext', _) <- expandIri activeContext value params |> withEnvRES (const bacEnvGlobal) - |> withErrorRES Left - |> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global}) + .> withErrorRES Left + .> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global}) bacModifyActiveContext <| const activeContext' case maybeVocabMapping of @@ -218,7 +218,7 @@ bacProcessItem baseUrl item = do -- 5.9.2. Just Null -> bacModifyActiveContext \ac -> ac{activeContextDefaultLanguage = Just NoLanguage} -- 5.9.3. - Just (String language) -> bacModifyActiveContext \ac -> ac{activeContextDefaultLanguage = Just <| Language language} + Just (String language) -> bacModifyActiveContext \ac -> ac{activeContextDefaultLanguage = Just <. Language <| T.toLower language} Just _ -> throwError <| Left InvalidDefaultLanguage -- Nothing -> pure () @@ -345,8 +345,8 @@ buildActiveContext activeContext localContext baseUrl paramsFn = do BACState{..} <- (buildActiveContext' localContext baseUrl >> get) |> withEnvRES env - |> withErrorRES' (either throwError (const get)) - |> withStateRES st (const bacStateGlobal) + .> withErrorRES' (either throwError (const get)) + .> withStateRES st (const bacStateGlobal) pure bacStateActiveContext where BACParams{..} = @@ -504,7 +504,7 @@ expandIri activeContext value paramsFn = do (value', EIState{..}) <- (expandIri' value >>= \v -> gets (v,)) |> withEnvRES env - |> withStateRES st (const eiStateGlobal) + .> withStateRES st (const eiStateGlobal) pure (value', eiStateActiveContext, eiStateDefined) where EIParams{..} = @@ -616,8 +616,8 @@ btdExpandIri value = do (expanded, activeContext', defined') <- expandIri activeContext value params |> withEnvRES (const btdEnvGlobal) - |> withErrorRES Left - |> withStateRES btdStateGlobal (\btd global -> btd{btdStateGlobal = global}) + .> withErrorRES Left + .> withStateRES btdStateGlobal (\btd global -> btd{btdStateGlobal = global}) modify \s -> s { btdStateActiveContext = activeContext' @@ -634,8 +634,8 @@ btdBuildTermDefinition term = do (activeContext', defined') <- buildTermDefinition activeContext btdEnvLocalContext term params |> withEnvRES (const btdEnvGlobal) - |> withErrorRES Left - |> withStateRES btdStateGlobal (\btd global -> btd{btdStateGlobal = global}) + .> withErrorRES Left + .> withStateRES btdStateGlobal (\btd global -> btd{btdStateGlobal = global}) modify \env -> env { btdStateActiveContext = activeContext' @@ -891,9 +891,9 @@ buildTermDefinition' term = do } buildActiveContext activeContext context btdEnvBaseUrl params |> withEnvRES (const btdEnvGlobal) - |> withStateRES btdStateGlobal (\btd global -> btd{btdStateGlobal = global}) - |> withErrorRES (const <| Left InvalidScopedContext) - |> void + .> withStateRES btdStateGlobal (\btd global -> btd{btdStateGlobal = global}) + .> withErrorRES (const <| Left InvalidScopedContext) + .> void -- 21.4. btdModifyTermDefinition \d -> @@ -909,7 +909,7 @@ buildTermDefinition' term = do -- 22. case KM.lookup (show KeywordLanguage) valueObject of Just Null -> btdModifyTermDefinition \d -> d{termDefinitionLanguageMapping = Just NoLanguage} - Just (String language) -> btdModifyTermDefinition \d -> d{termDefinitionLanguageMapping = Just <| Language language} + Just (String language) -> btdModifyTermDefinition \d -> d{termDefinitionLanguageMapping = Just <. Language <| T.toLower language} Just _ -> throwError <| Left InvalidLanguageMapping Nothing -> pure () @@ -985,8 +985,8 @@ buildTermDefinition activeContext localContext term paramsFn = do BTDState{..} <- (buildTermDefinition' term >> get) |> withEnvRES env - |> withErrorRES' (either throwError (const get)) - |> withStateRES st (const btdStateGlobal) + .> withErrorRES' (either throwError (const get)) + .> withStateRES st (const btdStateGlobal) pure (btdStateActiveContext, btdStateDefined) where BTDParams{..} = diff --git a/src/Data/JLD/Flattening/NodeMap.hs b/src/Data/JLD/Flattening/NodeMap.hs index 06af2d4..ef09757 100644 --- a/src/Data/JLD/Flattening/NodeMap.hs +++ b/src/Data/JLD/Flattening/NodeMap.hs @@ -18,7 +18,7 @@ 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_) import Data.Map.Strict qualified as M (insert, lookup) -import Data.Vector qualified as V (singleton, snoc, uniq) +import Data.Vector qualified as V (snoc, uniq) type BNMT e m = REST BNMEnv (Either (JLDError e) ()) BNMState m @@ -133,7 +133,7 @@ buildNodeMap' element = case element of N.insert bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty (Array <| V.snoc activePropertyValue element) nodeMap | otherwise -> nodeMap -- 4.2.2 - _ -> N.insert bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty (Array <| V.singleton element) nodeMap + _ -> N.insert bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty (Array <| pure element) nodeMap -- 4.2. Just list -> bnmModifyList <. const <. Just <| V.snoc list element -- 5. diff --git a/src/Data/JLD/Model/ActiveContext.hs b/src/Data/JLD/Model/ActiveContext.hs index 5423036..f2118c4 100644 --- a/src/Data/JLD/Model/ActiveContext.hs +++ b/src/Data/JLD/Model/ActiveContext.hs @@ -1,4 +1,4 @@ -module Data.JLD.Model.ActiveContext ( ActiveContext (..), newActiveContext, lookupTerm, containsProtectedTerm,) where +module Data.JLD.Model.ActiveContext (ActiveContext (..), newActiveContext, lookupTerm, containsProtectedTerm) where import Data.JLD.Prelude @@ -15,7 +15,7 @@ data ActiveContext = ActiveContext { activeContextTerms :: Map Text TermDefinition , activeContextBaseIri :: Maybe IRIRef , activeContextBaseUrl :: Maybe URI - , activeContextInverseContext :: InverseContext + , activeContextInverseContext :: Maybe InverseContext , activeContextPreviousContext :: Maybe ActiveContext , activeContextVocabularyMapping :: Maybe Text , activeContextDefaultLanguage :: Maybe Language @@ -30,7 +30,7 @@ newActiveContext fn = { activeContextTerms = mempty , activeContextBaseIri = Nothing , activeContextBaseUrl = Nothing - , activeContextInverseContext = mempty + , activeContextInverseContext = Nothing , activeContextPreviousContext = Nothing , activeContextVocabularyMapping = Nothing , activeContextDefaultLanguage = Nothing diff --git a/src/Data/JLD/Model/GraphObject.hs b/src/Data/JLD/Model/GraphObject.hs index 3db9e6b..4d7d3ad 100644 --- a/src/Data/JLD/Model/GraphObject.hs +++ b/src/Data/JLD/Model/GraphObject.hs @@ -1,4 +1,4 @@ -module Data.JLD.Model.GraphObject (isGraphObject, isNotGraphObject, toGraphObject) where +module Data.JLD.Model.GraphObject (isGraphObject, isGraphObject', isNotGraphObject, isNotGraphObject', toGraphObject) where import Data.JLD.Prelude @@ -6,17 +6,22 @@ import Data.JLD.Model.Keyword (Keyword (..), isKeyword) import Data.Aeson (Object, Value (..)) import Data.Aeson.Key qualified as K (toText) -import Data.Aeson.KeyMap qualified as KM (keys, singleton, member) -import Data.Vector qualified as V (singleton) +import Data.Aeson.KeyMap qualified as KM (keys, member, singleton) isGraphObject :: Value -> Bool -isGraphObject (Object o) - | KM.member (show KeywordGraph) o = - all (`isKeyword` [KeywordGraph, KeywordId, KeywordIndex, KeywordContext]) (K.toText <$> KM.keys o) +isGraphObject (Object o) = isGraphObject' o isGraphObject _ = False +isGraphObject' :: Object -> Bool +isGraphObject' o = + KM.member (show KeywordGraph) o + && all (`isKeyword` [KeywordGraph, KeywordId, KeywordIndex, KeywordContext]) (K.toText <$> KM.keys o) + isNotGraphObject :: Value -> Bool isNotGraphObject = isGraphObject .> not +isNotGraphObject' :: Object -> Bool +isNotGraphObject' = isGraphObject' .> not + toGraphObject :: Value -> Object -toGraphObject = V.singleton .> Array .> KM.singleton (show KeywordGraph) +toGraphObject = pure .> Array .> KM.singleton (show KeywordGraph) diff --git a/src/Data/JLD/Model/ListObject.hs b/src/Data/JLD/Model/ListObject.hs index 8dda349..6277d24 100644 --- a/src/Data/JLD/Model/ListObject.hs +++ b/src/Data/JLD/Model/ListObject.hs @@ -1,24 +1,26 @@ -module Data.JLD.Model.ListObject (isListObject, isNotListObject, toListObject) where +module Data.JLD.Model.ListObject (isListObject, isListObject', isNotListObject, toListObject) where import Data.JLD.Prelude import Data.JLD.Model.Keyword (Keyword (..)) -import Data.Aeson (Value (..)) -import Data.Aeson.KeyMap qualified as KM -import Data.Vector qualified as V +import Data.Aeson (Object, Value (..)) +import Data.Aeson.KeyMap qualified as KM (member, singleton, size) isListObject :: Value -> Bool -isListObject (Object o) = +isListObject (Object o) = isListObject' o +isListObject _ = False + +isListObject' :: Object -> Bool +isListObject' o = KM.member (show KeywordList) o && ( KM.size o == 1 || (KM.size o == 2 && KM.member (show KeywordIndex) o) ) -isListObject _ = False isNotListObject :: Value -> Bool isNotListObject = isListObject .> not toListObject :: Value -> Value toListObject value@(Array _) = Object <| KM.singleton (show KeywordList) value -toListObject value = Object <| KM.singleton (show KeywordList) (Array <| V.singleton value) +toListObject value = Object <| KM.singleton (show KeywordList) (Array <| pure value) diff --git a/src/Data/JLD/Util.hs b/src/Data/JLD/Util.hs index 26b2755..8d84778 100644 --- a/src/Data/JLD/Util.hs +++ b/src/Data/JLD/Util.hs @@ -25,7 +25,7 @@ import Data.Aeson.KeyMap qualified as KM (insert, lookup, member) import Data.Foldable qualified as F (Foldable (..), elem) import Data.Foldable.WithIndex (FoldableWithIndex (..), ifoldlM) import Data.Vector (Vector) -import Data.Vector qualified as V (filter, fromList, null, singleton, snoc, uncons) +import Data.Vector qualified as V (filter, fromList, null, snoc, uncons) valueContains :: Text -> Value -> Bool valueContains text = \case @@ -78,13 +78,13 @@ flattenSingletonArray = \case valueToArray :: Value -> Array valueToArray = \case Array a -> a - value -> V.singleton value + value -> pure value valueToNonNullArray :: Value -> Array valueToNonNullArray = \case Null -> mempty Array a -> V.filter (/= Null) a - value -> V.singleton value + value -> pure value allStrings :: Array -> Maybe (Vector Text) allStrings = foldl' go (Just mempty) @@ -106,7 +106,7 @@ mapAddValue key value True object = mapAddValue key value False <| KM.insert key where array = case KM.lookup key object of Just (Array a) -> a - Just original -> V.singleton original + Just original -> pure original Nothing -> mempty mapAddValue key (Array value) False object = foldl' (\o v -> mapAddValue key v False o) object value mapAddValue key value False object = case KM.lookup key object of -- cgit v1.2.3-70-g09d2