aboutsummaryrefslogtreecommitdiffstats
path: root/src/Data/JLD/Compaction/IRI.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Data/JLD/Compaction/IRI.hs')
-rw-r--r--src/Data/JLD/Compaction/IRI.hs342
1 files changed, 342 insertions, 0 deletions
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 @@
1module Data.JLD.Compaction.IRI (compactIri) where
2
3import Data.JLD.Prelude
4
5import Data.JLD (JLDError (InvalidKeywordValue), JLDVersion (JLD1_0))
6import Data.JLD.Compaction.Global (JLDCompactionEnv (jldCompactionEnvProcessingMode), JLDCompactionT)
7import Data.JLD.Compaction.InverseContext (buildInverseContext)
8import Data.JLD.Control.Monad.RES (REST, evalREST, runREST, withEnvRES, withStateRES)
9import Data.JLD.Model.ActiveContext (ActiveContext (..))
10import Data.JLD.Model.InverseContext (InverseContext)
11
12import Control.Monad.Except (MonadError (..))
13import Data.Aeson (Value (..))
14import Data.Aeson.KeyMap qualified as KM (lookup, member, size)
15import Data.JLD.Model.Direction (Direction (..))
16import Data.JLD.Model.GraphObject (isGraphObject', isNotGraphObject, isNotGraphObject')
17import Data.JLD.Model.Keyword (Keyword (..))
18import Data.JLD.Model.Language (Language (..))
19import Data.JLD.Model.ListObject (isListObject')
20import Data.JLD.Model.ValueObject (isValueObject')
21import Data.JLD.Util (valueToArray)
22import Data.Set qualified as S
23import Data.Text (toLower)
24import Data.Text qualified as T (drop, findIndex, isPrefixOf, take)
25import Data.Vector (Vector, (!?))
26import Data.Vector qualified as V (cons, snoc)
27
28type CIT e m = REST CIEnv (JLDError e) CIState m
29
30data CIEnv = CIEnv
31 { ciEnvGlobal :: JLDCompactionEnv
32 , ciEnvActiveContext :: ActiveContext
33 , ciEnvValue :: Maybe Value
34 , ciEnvVocab :: Bool
35 , ciEnvReverse :: Bool
36 }
37 deriving (Show)
38
39data CIState = CIState
40 { ciStateContainers :: Set Text
41 , ciStateTypeLanguage :: Keyword
42 , ciStateTypeLanguageValue :: Text
43 , ciStatePreferredValues :: Vector Text
44 }
45 deriving (Show, Eq)
46
47data CIParams = CIParams
48 { ciParamsActiveContext :: ActiveContext
49 , ciParamsValue :: Maybe Value
50 , ciParamsVocab :: Bool
51 , ciParamsReverse :: Bool
52 }
53 deriving (Show, Eq)
54
55ciModifyContainers :: Monad m => (Set Text -> Set Text) -> CIT e m ()
56ciModifyContainers fn = modify \s -> s{ciStateContainers = fn (ciStateContainers s)}
57
58ciModifyPreferredValues :: Monad m => (Vector Text -> Vector Text) -> CIT e m ()
59ciModifyPreferredValues fn = modify \s -> s{ciStatePreferredValues = fn (ciStatePreferredValues s)}
60
61ciPutTypeLanguage :: Monad m => Keyword -> CIT e m ()
62ciPutTypeLanguage v = modify \s -> s{ciStateTypeLanguage = v}
63
64ciPutTypeLanguageValue :: Monad m => Text -> CIT e m ()
65ciPutTypeLanguageValue v = modify \s -> s{ciStateTypeLanguageValue = v}
66
67compactIri4 :: Monad m => InverseContext -> Text -> CIT e m (Maybe Text)
68compactIri4 inverseContext var = do
69 CIEnv{..} <- ask
70 let ActiveContext{..} = ciEnvActiveContext
71
72 -- 4.1.
73 let defaultLanguage = case (activeContextDefaultLanguage, activeContextDefaultBaseDirection) of
74 (Just (Language language), Just dir) -> language <> show dir
75 (Nothing, Just dir) -> "_" <> show dir
76 _ -> show KeywordNone
77
78 -- 4.2.
79 value = case ciEnvValue of
80 Just v@(Object o) -> case KM.lookup (show KeywordPreserve) o of
81 Just Null -> Just v
82 Just preserve -> valueToArray preserve !? 0
83 _ -> Just v
84 _ -> Nothing
85
86 -- 4.5.
87 case value of
88 Just (Object o)
89 | KM.member (show KeywordIndex) o && isNotGraphObject' o ->
90 ciModifyContainers
91 <| S.insert (show KeywordIndex)
92 .> S.insert (show KeywordIndex <> show KeywordSet)
93 _ -> pure ()
94
95 case value of
96 -- 4.6.
97 _ | ciEnvReverse -> do
98 ciPutTypeLanguage KeywordType
99 ciPutTypeLanguageValue <| show KeywordReverse
100 --
101 Just (Object o)
102 -- 4.7.
103 | isListObject' o
104 , Just (Array list) <- KM.lookup (show KeywordList) o -> do
105 -- 4.7.1.
106 unless (KM.member (show KeywordIndex) o) <| ciModifyContainers (S.insert (show KeywordList))
107
108 -- 4.7.4.
109 let go (commonType, commonLanguage) item
110 -- 4.7.4.8.
111 | commonLanguage == Just (show KeywordNone)
112 , commonType == Just (show KeywordNone) =
113 (commonType, commonLanguage)
114 --
115 | otherwise = (Just commonType', Just commonLanguage')
116 where
117 (itemLanguage, itemType) = case item of
118 Object objectItem
119 | KM.member (show KeywordValue) objectItem ->
120 if
121 -- 4.7.4.2.1.
122 | Just (String dir) <- KM.lookup (show KeywordDirection) objectItem
123 , Just (String lang) <- KM.lookup (show KeywordLanguage) objectItem ->
124 (toLower lang <> "_" <> toLower dir, show KeywordId)
125 | Just (String dir) <- KM.lookup (show KeywordDirection) objectItem ->
126 ("_" <> toLower dir, show KeywordId)
127 -- 4.7.4.2.2.
128 | Just (String lang) <- KM.lookup (show KeywordLanguage) objectItem ->
129 (toLower lang, show KeywordId)
130 -- 4.7.4.2.3.
131 | Just (String type') <- KM.lookup (show KeywordType) objectItem ->
132 (show KeywordNone, type')
133 -- 4.7.4.2.4.
134 | otherwise ->
135 (show KeywordNone, show KeywordId)
136 -- 4.7.4.2.4.
137 _ -> (show KeywordNone, show KeywordId)
138
139 commonLanguage' = case commonLanguage of
140 -- 4.7.4.4.
141 Nothing -> itemLanguage
142 -- 4.7.4.5.
143 Just lang
144 | itemLanguage /= lang
145 , Object itemObject <- item
146 , KM.member (show KeywordValue) itemObject ->
147 show KeywordNone
148 | otherwise -> lang
149
150 commonType' = case commonType of
151 Nothing -> itemType
152 Just it
153 | itemType /= it -> show KeywordNone
154 | otherwise -> it
155
156 -- 4.7.3. 4.7.5. 4.7.6.
157 (commonType'', commonLanguage'') =
158 list
159 |> foldl' go (Nothing, if null list then Just defaultLanguage else Nothing)
160 .> bimap (fromMaybe (show KeywordNone)) (fromMaybe (show KeywordNone))
161
162 -- 4.7.7.
163 if commonType'' /= show KeywordNone
164 then do
165 ciPutTypeLanguage KeywordType
166 ciPutTypeLanguageValue (show commonType'')
167 else -- 4.7.8.
168 ciPutTypeLanguageValue (show commonLanguage'')
169 -- 4.8.
170 | isGraphObject' o -> do
171 -- 4.8.1.
172 when (KM.member (show KeywordIndex) o) do
173 ciModifyContainers
174 <| S.insert (show KeywordGraph <> show KeywordIndex)
175 .> S.insert (show KeywordGraph <> show KeywordIndex <> show KeywordSet)
176 -- 4.8.2.
177 when (KM.member (show KeywordId) o) do
178 ciModifyContainers
179 <| S.insert (show KeywordGraph <> show KeywordId)
180 .> S.insert (show KeywordGraph <> show KeywordId <> show KeywordSet)
181 -- 4.8.3.
182 ciModifyContainers
183 <| S.insert (show KeywordGraph)
184 .> S.insert (show KeywordGraph <> show KeywordSet)
185 .> S.insert (show KeywordSet)
186 -- 4.8.4.
187 unless (KM.member (show KeywordIndex) o) do
188 ciModifyContainers
189 <| S.insert (show KeywordGraph <> show KeywordIndex)
190 .> S.insert (show KeywordGraph <> show KeywordIndex <> show KeywordSet)
191 -- 4.8.5.
192 unless (KM.member (show KeywordId) o) do
193 ciModifyContainers
194 <| S.insert (show KeywordGraph <> show KeywordId)
195 .> S.insert (show KeywordGraph <> show KeywordId <> show KeywordSet)
196 -- 4.8.6.
197 ciModifyContainers
198 <| S.insert (show KeywordIndex)
199 .> S.insert (show KeywordIndex <> show KeywordSet)
200 -- 4.8.7.
201 ciPutTypeLanguage KeywordType
202 ciPutTypeLanguageValue (show KeywordId)
203 -- 4.9. 4.9.1.
204 | isValueObject' o -> do
205 if
206 -- 4.9.1.1.
207 | Just (String dir) <- KM.lookup (show KeywordDirection) o
208 , Just (String lang) <- KM.lookup (show KeywordLanguage) o
209 , not (KM.member (show KeywordIndex) o) -> do
210 ciPutTypeLanguageValue (toLower lang <> "_" <> toLower dir)
211 ciModifyContainers
212 <| S.insert (show KeywordLanguage)
213 .> S.insert (show KeywordLanguage <> show KeywordSet)
214 | Just (String dir) <- KM.lookup (show KeywordDirection) o
215 , not (KM.member (show KeywordIndex) o) -> do
216 ciPutTypeLanguageValue ("_" <> toLower dir)
217 ciModifyContainers
218 <| S.insert (show KeywordLanguage)
219 .> S.insert (show KeywordLanguage <> show KeywordSet)
220 -- 4.9.1.2.
221 | Just (String lang) <- KM.lookup (show KeywordLanguage) o
222 , not (KM.member (show KeywordIndex) o) -> do
223 ciPutTypeLanguageValue (toLower lang)
224 ciModifyContainers
225 <| S.insert (show KeywordLanguage)
226 .> S.insert (show KeywordLanguage <> show KeywordSet)
227 -- 4.9.1.3.
228 | Just (String type') <- KM.lookup (show KeywordType) o -> do
229 ciPutTypeLanguage KeywordType
230 ciPutTypeLanguageValue type'
231 --
232 | otherwise -> pure ()
233 -- 4.9.3.
234 ciModifyContainers <| S.insert (show KeywordSet)
235 -- 4.9.2.
236 _ -> do
237 ciPutTypeLanguage KeywordType
238 ciPutTypeLanguageValue (show KeywordId)
239 -- 4.9.3.
240 ciModifyContainers
241 <| S.insert (show KeywordId)
242 .> S.insert (show KeywordId <> show KeywordSet)
243 .> S.insert (show KeywordType)
244 .> S.insert (show KeywordSet <> show KeywordType)
245 .> S.insert (show KeywordSet)
246
247 -- 4.10.
248 ciModifyContainers <| S.insert (show KeywordNone)
249
250 -- 4.11.
251 case value of
252 Just (Object o)
253 | jldCompactionEnvProcessingMode ciEnvGlobal /= JLD1_0
254 , not (KM.member (show KeywordIndex) o) ->
255 ciModifyContainers
256 <| S.insert (show KeywordIndex)
257 .> S.insert (show KeywordIndex <> show KeywordSet)
258 _
259 | jldCompactionEnvProcessingMode ciEnvGlobal /= JLD1_0 ->
260 ciModifyContainers
261 <| S.insert (show KeywordIndex)
262 .> S.insert (show KeywordIndex <> show KeywordSet)
263 --
264 | otherwise -> pure ()
265
266 -- 4.12.
267 case value of
268 Just (Object o)
269 | jldCompactionEnvProcessingMode ciEnvGlobal /= JLD1_0
270 , KM.member (show KeywordIndex) o
271 , KM.size o == 1 ->
272 ciModifyContainers
273 <| S.insert (show KeywordLanguage)
274 .> S.insert (show KeywordLanguage <> show KeywordSet)
275 --
276 _ -> pure ()
277
278 -- 4.15.
279 typeLanguageValue <- gets ciStateTypeLanguageValue
280 when (typeLanguageValue == show KeywordReverse) <| ciModifyPreferredValues (V.cons (show KeywordReverse))
281
282 -- 4.16.
283 case value of
284 Just (Object o)
285 | typeLanguageValue == show KeywordReverse || typeLanguageValue == show KeywordId
286 , Just idValue <- KM.lookup (show KeywordId) o -> case idValue of
287 String idValue' -> pure ()
288 _ -> throwError <| InvalidKeywordValue KeywordId idValue
289 --
290 _ -> pure ()
291
292 --
293 pure Nothing
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
308compactIri :: Monad m => ActiveContext -> Text -> (CIParams -> CIParams) -> JLDCompactionT e m (Text, InverseContext)
309compactIri activeContext var paramsFn = do
310 envGlobal <- ask
311 result <-
312 compactIri' var
313 |> evalREST (env envGlobal) st
314 case result of
315 Left err -> throwError err
316 Right res -> pure res
317 where
318 CIParams{..} =
319 paramsFn
320 CIParams
321 { ciParamsActiveContext = activeContext
322 , ciParamsValue = Nothing
323 , ciParamsVocab = False
324 , ciParamsReverse = False
325 }
326
327 env global =
328 CIEnv
329 { ciEnvGlobal = global
330 , ciEnvActiveContext = ciParamsActiveContext
331 , ciEnvValue = ciParamsValue
332 , ciEnvVocab = ciParamsVocab
333 , ciEnvReverse = ciParamsReverse
334 }
335
336 st =
337 CIState
338 { ciStateContainers = mempty
339 , ciStateTypeLanguage = KeywordLanguage
340 , ciStateTypeLanguageValue = show KeywordNull
341 , ciStatePreferredValues = mempty
342 }
generated by cgit v1.2.3-54-g00ecf (git 2.44.0) at 2024-05-19 01:33:23 +0000