aboutsummaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
authorVolpeon <github@volpeon.ink>2023-06-24 10:32:18 +0200
committerVolpeon <github@volpeon.ink>2023-06-24 10:32:18 +0200
commit2479f89067408b8b9dc79abf09bbe6b1d3c0647d (patch)
tree6ca1262fe02bc89ac522b228565021e773e29b87 /src
parentWIP: Compaction (diff)
downloadhs-jsonld-2479f89067408b8b9dc79abf09bbe6b1d3c0647d.tar.gz
hs-jsonld-2479f89067408b8b9dc79abf09bbe6b1d3c0647d.tar.bz2
hs-jsonld-2479f89067408b8b9dc79abf09bbe6b1d3c0647d.zip
WIP: IRI compaction
Diffstat (limited to 'src')
-rw-r--r--src/Data/JLD/Compaction/IRI.hs118
-rw-r--r--src/Data/JLD/Compaction/InverseContext.hs22
-rw-r--r--src/Data/JLD/Model/InverseContext.hs30
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
5import Data.JLD (JLDError (InvalidKeywordValue), JLDVersion (JLD1_0)) 5import Data.JLD (JLDError (InvalidKeywordValue), JLDVersion (JLD1_0))
6import Data.JLD.Compaction.Global (JLDCompactionEnv (jldCompactionEnvProcessingMode), JLDCompactionT) 6import Data.JLD.Compaction.Global (JLDCompactionEnv (jldCompactionEnvProcessingMode), JLDCompactionT)
7import Data.JLD.Compaction.InverseContext (buildInverseContext) 7import Data.JLD.Compaction.InverseContext (buildInverseContext)
8import Data.JLD.Control.Monad.RES (REST, evalREST, runREST, withEnvRES, withStateRES) 8import Data.JLD.Control.Monad.RES (REST, evalREST, withEnvRES, withErrorRES, withErrorRES')
9import Data.JLD.Model.ActiveContext (ActiveContext (..)) 9import Data.JLD.Model.ActiveContext (ActiveContext (..))
10import Data.JLD.Model.InverseContext (InverseContext) 10import Data.JLD.Model.InverseContext (InverseContext, selectTerm)
11 11
12import Control.Monad.Except (MonadError (..)) 12import Control.Monad.Except (MonadError (..))
13import Data.Aeson (Value (..)) 13import Data.Aeson (Value (..))
14import Data.Aeson.KeyMap qualified as KM (lookup, member, size) 14import Data.Aeson.KeyMap qualified as KM (lookup, member, size)
15import Data.JLD.Model.Direction (Direction (..)) 15import Data.JLD.Model.GraphObject (isGraphObject', isNotGraphObject')
16import Data.JLD.Model.GraphObject (isGraphObject', isNotGraphObject, isNotGraphObject')
17import Data.JLD.Model.Keyword (Keyword (..)) 16import Data.JLD.Model.Keyword (Keyword (..))
18import Data.JLD.Model.Language (Language (..)) 17import Data.JLD.Model.Language (Language (..))
19import Data.JLD.Model.ListObject (isListObject') 18import Data.JLD.Model.ListObject (isListObject')
19import Data.JLD.Model.TermDefinition (TermDefinition (termDefinitionIriMapping))
20import Data.JLD.Model.ValueObject (isValueObject') 20import Data.JLD.Model.ValueObject (isValueObject')
21import Data.JLD.Util (valueToArray) 21import Data.JLD.Util (valueToArray)
22import Data.Set qualified as S 22import Data.Map qualified as M (lookup)
23import Data.Set qualified as S (insert)
23import Data.Text (toLower) 24import Data.Text (toLower)
24import Data.Text qualified as T (drop, findIndex, isPrefixOf, take) 25import Data.Text qualified as T (drop, findIndex)
25import Data.Vector (Vector, (!?)) 26import Data.Vector (Vector, (!?))
26import Data.Vector qualified as V (cons, snoc) 27import Data.Vector qualified as V (cons)
27 28
28type CIT e m = REST CIEnv (JLDError e) CIState m 29type CIT e m = REST CIEnv (Either (JLDError e) Text) CIState m
29 30
30data CIEnv = CIEnv 31data CIEnv = CIEnv
31 { ciEnvGlobal :: JLDCompactionEnv 32 { ciEnvGlobal :: JLDCompactionEnv
32 , ciEnvActiveContext :: ActiveContext 33 , ciEnvActiveContext :: ActiveContext
34 , ciEnvInverseContext :: InverseContext
33 , ciEnvValue :: Maybe Value 35 , ciEnvValue :: Maybe Value
34 , ciEnvVocab :: Bool 36 , ciEnvVocab :: Bool
35 , ciEnvReverse :: Bool 37 , ciEnvReverse :: Bool
@@ -45,7 +47,7 @@ data CIState = CIState
45 deriving (Show, Eq) 47 deriving (Show, Eq)
46 48
47data CIParams = CIParams 49data CIParams = CIParams
48 { ciParamsActiveContext :: ActiveContext 50 { ciParamsInverseContext :: Maybe InverseContext
49 , ciParamsValue :: Maybe Value 51 , ciParamsValue :: Maybe Value
50 , ciParamsVocab :: Bool 52 , ciParamsVocab :: Bool
51 , ciParamsReverse :: Bool 53 , ciParamsReverse :: Bool
@@ -64,8 +66,22 @@ ciPutTypeLanguage v = modify \s -> s{ciStateTypeLanguage = v}
64ciPutTypeLanguageValue :: Monad m => Text -> CIT e m () 66ciPutTypeLanguageValue :: Monad m => Text -> CIT e m ()
65ciPutTypeLanguageValue v = modify \s -> s{ciStateTypeLanguageValue = v} 67ciPutTypeLanguageValue v = modify \s -> s{ciStateTypeLanguageValue = v}
66 68
67compactIri4 :: Monad m => InverseContext -> Text -> CIT e m (Maybe Text) 69ciCompactIri :: Monad m => Text -> CIT e m Text
68compactIri4 inverseContext var = do 70ciCompactIri var = do
71 CIEnv{..} <- ask
72 let params p =
73 p
74 { ciParamsInverseContext = Just ciEnvInverseContext
75 , ciParamsVocab = True
76 }
77 (var', _) <-
78 compactIri ciEnvActiveContext var params
79 |> withEnvRES (const ciEnvGlobal)
80 .> withErrorRES Left
81 pure var'
82
83compactIri' :: Monad m => Text -> CIT e m Text
84compactIri' var = do
69 CIEnv{..} <- ask 85 CIEnv{..} <- ask
70 let ActiveContext{..} = ciEnvActiveContext 86 let ActiveContext{..} = ciEnvActiveContext
71 87
@@ -284,41 +300,74 @@ compactIri4 inverseContext var = do
284 Just (Object o) 300 Just (Object o)
285 | typeLanguageValue == show KeywordReverse || typeLanguageValue == show KeywordId 301 | typeLanguageValue == show KeywordReverse || typeLanguageValue == show KeywordId
286 , Just idValue <- KM.lookup (show KeywordId) o -> case idValue of 302 , Just idValue <- KM.lookup (show KeywordId) o -> case idValue of
287 String idValue' -> pure () 303 -- 4.16.1.
288 _ -> throwError <| InvalidKeywordValue KeywordId idValue 304 String idValue' -> do
289 -- 305 compactedIdValue <- ciCompactIri idValue'
290 _ -> pure () 306 case M.lookup compactedIdValue activeContextTerms of
307 Just term
308 | termDefinitionIriMapping term == Just idValue' ->
309 ciModifyPreferredValues
310 <| V.cons (show KeywordVocab)
311 .> V.cons (show KeywordId)
312 -- 4.16.2.
313 _ ->
314 ciModifyPreferredValues
315 <| V.cons (show KeywordId)
316 .> V.cons (show KeywordVocab)
317 ciModifyPreferredValues <| V.cons (show KeywordNone)
318 --
319 _ -> throwError <. Left <| InvalidKeywordValue KeywordId idValue
320 -- 4.17.
321 | Just (Array a) <- KM.lookup (show KeywordList) o
322 , null a -> do
323 ciModifyPreferredValues
324 <| V.cons typeLanguageValue
325 .> V.cons (show KeywordNone)
326 ciPutTypeLanguage KeywordAny
327 _ -> do
328 ciModifyPreferredValues
329 <| V.cons typeLanguageValue
330 .> V.cons (show KeywordNone)
331
332 -- 4.18.
333 ciModifyPreferredValues <| V.cons (show KeywordAny)
334
335 -- 4.19.
336 gets ciStatePreferredValues >>= mapM_ \preferredValue -> case T.findIndex (== ':') preferredValue of
337 Just idx -> ciModifyPreferredValues <| V.cons (T.drop idx preferredValue)
338 Nothing -> pure ()
339
340 -- 4.20.
341 maybeTerm <-
342 liftA3
343 (\containers typeLanguage preferredValues -> selectTerm var containers typeLanguage preferredValues ciEnvInverseContext)
344 (gets ciStateContainers)
345 (gets ciStateTypeLanguage)
346 (gets ciStatePreferredValues)
347
348 -- 4.21.
349 case maybeTerm of
350 Just term -> throwError <| Right term
351 Nothing -> pure ()
291 352
292 -- 353 --
293 pure Nothing 354 pure var
294
295compactIri' :: Monad m => Text -> CIT e m (Text, InverseContext)
296compactIri' var = do
297 CIEnv{..} <- ask
298
299 -- 2. 3.
300 let inverseContext = case activeContextInverseContext ciEnvActiveContext of
301 Nothing -> buildInverseContext ciEnvActiveContext
302 Just ic -> ic
303
304 compactIri4 inverseContext var >>= \case
305 Just var' -> pure (var', inverseContext)
306 Nothing -> pure (var, inverseContext)
307 355
308compactIri :: Monad m => ActiveContext -> Text -> (CIParams -> CIParams) -> JLDCompactionT e m (Text, InverseContext) 356compactIri :: Monad m => ActiveContext -> Text -> (CIParams -> CIParams) -> JLDCompactionT e m (Text, InverseContext)
309compactIri activeContext var paramsFn = do 357compactIri activeContext var paramsFn = do
310 envGlobal <- ask 358 env' <- asks env
311 result <- 359 result <-
312 compactIri' var 360 compactIri' var
313 |> evalREST (env envGlobal) st 361 |> withErrorRES' (either throwError pure)
362 .> evalREST env' st
314 case result of 363 case result of
315 Left err -> throwError err 364 Left err -> throwError err
316 Right res -> pure res 365 Right res -> pure (res, ciEnvInverseContext env')
317 where 366 where
318 CIParams{..} = 367 CIParams{..} =
319 paramsFn 368 paramsFn
320 CIParams 369 CIParams
321 { ciParamsActiveContext = activeContext 370 { ciParamsInverseContext = Nothing
322 , ciParamsValue = Nothing 371 , ciParamsValue = Nothing
323 , ciParamsVocab = False 372 , ciParamsVocab = False
324 , ciParamsReverse = False 373 , ciParamsReverse = False
@@ -327,7 +376,8 @@ compactIri activeContext var paramsFn = do
327 env global = 376 env global =
328 CIEnv 377 CIEnv
329 { ciEnvGlobal = global 378 { ciEnvGlobal = global
330 , ciEnvActiveContext = ciParamsActiveContext 379 , ciEnvActiveContext = activeContext
380 , ciEnvInverseContext = fromMaybe (buildInverseContext activeContext) ciParamsInverseContext
331 , ciEnvValue = ciParamsValue 381 , ciEnvValue = ciParamsValue
332 , ciEnvVocab = ciParamsVocab 382 , ciEnvVocab = ciParamsVocab
333 , ciEnvReverse = ciParamsReverse 383 , 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
4 4
5import Data.JLD.Model.ActiveContext (ActiveContext (..)) 5import Data.JLD.Model.ActiveContext (ActiveContext (..))
6import Data.JLD.Model.Direction (Direction (..)) 6import Data.JLD.Model.Direction (Direction (..))
7import Data.JLD.Model.InverseContext (InverseContext) 7import Data.JLD.Model.InverseContext (InverseContext, insert)
8import Data.JLD.Model.Keyword (Keyword (..)) 8import Data.JLD.Model.Keyword (Keyword (..))
9import Data.JLD.Model.Language (Language (Language)) 9import Data.JLD.Model.Language (Language (Language))
10import Data.JLD.Model.TermDefinition (TermDefinition (..)) 10import Data.JLD.Model.TermDefinition (TermDefinition (..))
11 11
12import Data.Map qualified as M 12import Data.Map qualified as M (foldlWithKey)
13 13
14processTerm :: Text -> InverseContext -> Text -> TermDefinition -> InverseContext 14processTerm :: Text -> InverseContext -> Text -> TermDefinition -> InverseContext
15processTerm defaultLangDir out termName TermDefinition{..} 15processTerm defaultLangDir out termName TermDefinition{..}
16 | Just variableName <- termDefinitionIriMapping = 16 | Just variableName <- termDefinitionIriMapping =
17 out 17 out
18 |> M.insert (variableName, container, show KeywordAny, show KeywordNone) termName 18 |> insert variableName container KeywordAny (show KeywordNone) termName
19 .> if 19 .> if
20 | termDefinitionReversePropertyFlag -> 20 | termDefinitionReversePropertyFlag ->
21 M.insert (variableName, container, show KeywordType, show KeywordReverse) termName 21 insert variableName container KeywordType (show KeywordReverse) termName
22 | termDefinitionTypeMapping == Just (show KeywordNone) -> 22 | termDefinitionTypeMapping == Just (show KeywordNone) ->
23 M.insert (variableName, container, show KeywordLanguage, show KeywordAny) termName 23 insert variableName container KeywordLanguage (show KeywordAny) termName
24 .> M.insert (variableName, container, show KeywordType, show KeywordAny) termName 24 .> insert variableName container KeywordType (show KeywordAny) termName
25 | Just typeMapping <- termDefinitionTypeMapping -> 25 | Just typeMapping <- termDefinitionTypeMapping ->
26 M.insert (variableName, container, show KeywordType, typeMapping) termName 26 insert variableName container KeywordType typeMapping termName
27 | Just langDir <- maybeLangDir -> 27 | Just langDir <- maybeLangDir ->
28 M.insert (variableName, container, show KeywordLanguage, langDir) termName 28 insert variableName container KeywordLanguage langDir termName
29 | otherwise -> 29 | otherwise ->
30 M.insert (variableName, container, show KeywordLanguage, defaultLangDir) termName 30 insert variableName container KeywordLanguage defaultLangDir termName
31 .> M.insert (variableName, container, show KeywordLanguage, show KeywordNone) termName 31 .> insert variableName container KeywordLanguage (show KeywordNone) termName
32 .> M.insert (variableName, container, show KeywordType, show KeywordNone) termName 32 .> insert variableName container KeywordType (show KeywordNone) termName
33 | otherwise = out 33 | otherwise = out
34 where 34 where
35 container = if null termDefinitionContainerMapping then show KeywordNone else fold termDefinitionContainerMapping 35 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 @@
1module Data.JLD.Model.InverseContext (InverseContext) where 1module Data.JLD.Model.InverseContext (InverseContext, hasKey3, insert, selectTerm) where
2 2
3import Data.JLD.Prelude 3import Data.JLD.Prelude
4 4
5type InverseContext = Map (Text, Text, Text, Text) Text 5import Data.JLD.Model.Keyword (Keyword)
6import Data.Map qualified as M
7import Data.Set qualified as S
8import Data.Vector (Vector, (!?))
9import Data.Vector qualified as V (catMaybes)
10
11type InverseContext = Map Text (Map Text (Map Keyword (Map Text Text)))
12
13hasKey3 :: Text -> Text -> Keyword -> InverseContext -> Bool
14hasKey3 var container type' inverseContext =
15 M.lookup var inverseContext >>= M.lookup container >>= M.lookup type' |> isJust
16
17lookup4 :: Text -> Text -> Keyword -> Text -> InverseContext -> Maybe Text
18lookup4 var container type' typeMapping inverseContext =
19 M.lookup var inverseContext >>= M.lookup container >>= M.lookup type' >>= M.lookup typeMapping
20
21insert :: Text -> Text -> Keyword -> Text -> Text -> InverseContext -> InverseContext
22insert var container type' typeMapping value =
23 M.alter (Just <. M.alter (Just <. M.alter (Just <. M.insert typeMapping value <. fromMaybe mempty) type' <. fromMaybe mempty) container <. fromMaybe mempty) var
24
25selectTerm :: Text -> Set Text -> Keyword -> Vector Text -> InverseContext -> Maybe Text
26selectTerm var containers typeLanguage preferredValues inverseContext =
27 containers
28 |> S.filter (\container -> hasKey3 var container typeLanguage inverseContext)
29 .> foldMap' (\container -> preferredValues <&> \item -> lookup4 var container typeLanguage item inverseContext)
30 .> V.catMaybes
31 .> (!? 0)