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/Compaction/Global.hs | 13 ++ src/Data/JLD/Compaction/IRI.hs | 342 ++++++++++++++++++++++++++++++ src/Data/JLD/Compaction/InverseContext.hs | 54 +++++ 3 files changed, 409 insertions(+) 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/Data/JLD/Compaction') 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 -- cgit v1.2.3-54-g00ecf