WIP: Compaction

3 files changed, 409 insertions, 0 deletions

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