WIP: IRI compaction

3 files changed, 121 insertions, 45 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)
 
-    --
-    pure Nothing
+    -- 4.18.
+    ciModifyPreferredValues <| V.cons (show KeywordAny)
 
-compactIri' :: Monad m => Text -> CIT e m (Text, InverseContext)
-compactIri' var = do
-    CIEnv{..} <- ask
+    -- 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)
 
-    -- 2. 3.
-    let inverseContext = case activeContextInverseContext ciEnvActiveContext of
-            Nothing -> buildInverseContext ciEnvActiveContext
-            Just ic -> ic
+    -- 4.21.
+    case maybeTerm of
+        Just term -> throwError <| Right term
+        Nothing -> pure ()
 
-    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)