From 2479f89067408b8b9dc79abf09bbe6b1d3c0647d Mon Sep 17 00:00:00 2001 From: Volpeon Date: Sat, 24 Jun 2023 10:32:18 +0200 Subject: WIP: IRI compaction --- src/Data/JLD/Compaction/IRI.hs | 118 +++++++++++++++++++++--------- src/Data/JLD/Compaction/InverseContext.hs | 22 +++--- src/Data/JLD/Model/InverseContext.hs | 30 +++++++- 3 files changed, 123 insertions(+), 47 deletions(-) diff --git a/src/Data/JLD/Compaction/IRI.hs b/src/Data/JLD/Compaction/IRI.hs index 34379d2..208643f 100644 --- a/src/Data/JLD/Compaction/IRI.hs +++ b/src/Data/JLD/Compaction/IRI.hs @@ -5,31 +5,33 @@ 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.Control.Monad.RES (REST, evalREST, withEnvRES, withErrorRES, withErrorRES') import Data.JLD.Model.ActiveContext (ActiveContext (..)) -import Data.JLD.Model.InverseContext (InverseContext) +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.JLD.Model.Direction (Direction (..)) -import Data.JLD.Model.GraphObject (isGraphObject', isNotGraphObject, isNotGraphObject') +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.ValueObject (isValueObject') import Data.JLD.Util (valueToArray) -import Data.Set qualified as S +import Data.Map qualified as M (lookup) +import Data.Set qualified as S (insert) import Data.Text (toLower) -import Data.Text qualified as T (drop, findIndex, isPrefixOf, take) +import Data.Text qualified as T (drop, findIndex) import Data.Vector (Vector, (!?)) -import Data.Vector qualified as V (cons, snoc) +import Data.Vector qualified as V (cons) -type CIT e m = REST CIEnv (JLDError e) CIState m +type CIT e m = REST CIEnv (Either (JLDError e) Text) CIState m data CIEnv = CIEnv { ciEnvGlobal :: JLDCompactionEnv , ciEnvActiveContext :: ActiveContext + , ciEnvInverseContext :: InverseContext , ciEnvValue :: Maybe Value , ciEnvVocab :: Bool , ciEnvReverse :: Bool @@ -45,7 +47,7 @@ data CIState = CIState deriving (Show, Eq) data CIParams = CIParams - { ciParamsActiveContext :: ActiveContext + { ciParamsInverseContext :: Maybe InverseContext , ciParamsValue :: Maybe Value , ciParamsVocab :: Bool , ciParamsReverse :: Bool @@ -64,8 +66,22 @@ 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 +ciCompactIri :: Monad m => Text -> CIT e m Text +ciCompactIri var = do + CIEnv{..} <- ask + let params p = + p + { ciParamsInverseContext = Just ciEnvInverseContext + , ciParamsVocab = True + } + (var', _) <- + compactIri ciEnvActiveContext var params + |> withEnvRES (const ciEnvGlobal) + .> withErrorRES Left + pure var' + +compactIri' :: Monad m => Text -> CIT e m Text +compactIri' var = do CIEnv{..} <- ask let ActiveContext{..} = ciEnvActiveContext @@ -284,41 +300,74 @@ compactIri4 inverseContext var = do 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 () + -- 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) + + -- 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 () -- - 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) + pure var compactIri :: Monad m => ActiveContext -> Text -> (CIParams -> CIParams) -> JLDCompactionT e m (Text, InverseContext) compactIri activeContext var paramsFn = do - envGlobal <- ask + env' <- asks env result <- compactIri' var - |> evalREST (env envGlobal) st + |> withErrorRES' (either throwError pure) + .> evalREST env' st case result of Left err -> throwError err - Right res -> pure res + Right res -> pure (res, ciEnvInverseContext env') where CIParams{..} = paramsFn CIParams - { ciParamsActiveContext = activeContext + { ciParamsInverseContext = Nothing , ciParamsValue = Nothing , ciParamsVocab = False , ciParamsReverse = False @@ -327,7 +376,8 @@ compactIri activeContext var paramsFn = do env global = CIEnv { ciEnvGlobal = global - , ciEnvActiveContext = ciParamsActiveContext + , ciEnvActiveContext = activeContext + , ciEnvInverseContext = fromMaybe (buildInverseContext activeContext) ciParamsInverseContext , ciEnvValue = ciParamsValue , ciEnvVocab = ciParamsVocab , ciEnvReverse = ciParamsReverse diff --git a/src/Data/JLD/Compaction/InverseContext.hs b/src/Data/JLD/Compaction/InverseContext.hs index b351e34..03a45f2 100644 --- a/src/Data/JLD/Compaction/InverseContext.hs +++ b/src/Data/JLD/Compaction/InverseContext.hs @@ -4,32 +4,32 @@ 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.InverseContext (InverseContext, insert) 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 +import Data.Map qualified as M (foldlWithKey) processTerm :: Text -> InverseContext -> Text -> TermDefinition -> InverseContext processTerm defaultLangDir out termName TermDefinition{..} | Just variableName <- termDefinitionIriMapping = out - |> M.insert (variableName, container, show KeywordAny, show KeywordNone) termName + |> insert variableName container KeywordAny (show KeywordNone) termName .> if | termDefinitionReversePropertyFlag -> - M.insert (variableName, container, show KeywordType, show KeywordReverse) termName + insert variableName container 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 + insert variableName container KeywordLanguage (show KeywordAny) termName + .> insert variableName container KeywordType (show KeywordAny) termName | Just typeMapping <- termDefinitionTypeMapping -> - M.insert (variableName, container, show KeywordType, typeMapping) termName + insert variableName container KeywordType typeMapping termName | Just langDir <- maybeLangDir -> - M.insert (variableName, container, show KeywordLanguage, langDir) termName + insert variableName container 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 + insert variableName container KeywordLanguage defaultLangDir termName + .> insert variableName container KeywordLanguage (show KeywordNone) termName + .> insert variableName container KeywordType (show KeywordNone) termName | otherwise = out where container = if null termDefinitionContainerMapping then show KeywordNone else fold termDefinitionContainerMapping diff --git a/src/Data/JLD/Model/InverseContext.hs b/src/Data/JLD/Model/InverseContext.hs index fe4b516..ee85ce9 100644 --- a/src/Data/JLD/Model/InverseContext.hs +++ b/src/Data/JLD/Model/InverseContext.hs @@ -1,5 +1,31 @@ -module Data.JLD.Model.InverseContext (InverseContext) where +module Data.JLD.Model.InverseContext (InverseContext, hasKey3, insert, selectTerm) where import Data.JLD.Prelude -type InverseContext = Map (Text, Text, Text, Text) Text +import Data.JLD.Model.Keyword (Keyword) +import Data.Map qualified as M +import Data.Set qualified as S +import Data.Vector (Vector, (!?)) +import Data.Vector qualified as V (catMaybes) + +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 + +lookup4 :: Text -> Text -> Keyword -> Text -> InverseContext -> Maybe Text +lookup4 var container type' typeMapping inverseContext = + M.lookup var inverseContext >>= M.lookup container >>= M.lookup type' >>= M.lookup typeMapping + +insert :: Text -> Text -> Keyword -> Text -> Text -> InverseContext -> InverseContext +insert var container type' typeMapping value = + M.alter (Just <. M.alter (Just <. M.alter (Just <. M.insert typeMapping value <. fromMaybe mempty) type' <. fromMaybe mempty) container <. fromMaybe mempty) var + +selectTerm :: Text -> Set Text -> Keyword -> Vector Text -> InverseContext -> Maybe Text +selectTerm var containers typeLanguage preferredValues inverseContext = + containers + |> S.filter (\container -> hasKey3 var container typeLanguage inverseContext) + .> foldMap' (\container -> preferredValues <&> \item -> lookup4 var container typeLanguage item inverseContext) + .> V.catMaybes + .> (!? 0) -- cgit v1.2.3-70-g09d2