aboutsummaryrefslogtreecommitdiffstats
path: root/src/Data/JLD
diff options
context:
space:
mode:
authorVolpeon <github@volpeon.ink>2023-05-26 07:40:13 +0200
committerVolpeon <github@volpeon.ink>2023-05-26 07:40:13 +0200
commit11d0fb47c292a0ca25a9c377499d2b221d97a5cb (patch)
treee729e2a4508763b3073b7eae9a56bc9c6a9ca0f7 /src/Data/JLD
downloadhs-jsonld-11d0fb47c292a0ca25a9c377499d2b221d97a5cb.tar.gz
hs-jsonld-11d0fb47c292a0ca25a9c377499d2b221d97a5cb.tar.bz2
hs-jsonld-11d0fb47c292a0ca25a9c377499d2b221d97a5cb.zip
Init
Diffstat (limited to 'src/Data/JLD')
-rw-r--r--src/Data/JLD/Context.hs1020
-rw-r--r--src/Data/JLD/Control/Monad/RES.hs35
-rw-r--r--src/Data/JLD/Error.hs81
-rw-r--r--src/Data/JLD/Expansion.hs942
-rw-r--r--src/Data/JLD/Mime.hs6
-rw-r--r--src/Data/JLD/Model/ActiveContext.hs44
-rw-r--r--src/Data/JLD/Model/Direction.hs13
-rw-r--r--src/Data/JLD/Model/GraphObject.hs22
-rw-r--r--src/Data/JLD/Model/IRI.hs46
-rw-r--r--src/Data/JLD/Model/InverseContext.hs5
-rw-r--r--src/Data/JLD/Model/Keyword.hs135
-rw-r--r--src/Data/JLD/Model/Language.hs6
-rw-r--r--src/Data/JLD/Model/ListObject.hs24
-rw-r--r--src/Data/JLD/Model/NodeObject.hs21
-rw-r--r--src/Data/JLD/Model/TermDefinition.hs43
-rw-r--r--src/Data/JLD/Model/URI.hs13
-rw-r--r--src/Data/JLD/Model/ValueObject.hs27
-rw-r--r--src/Data/JLD/Monad.hs86
-rw-r--r--src/Data/JLD/Options.hs34
-rw-r--r--src/Data/JLD/Prelude.hs4
-rw-r--r--src/Data/JLD/Util.hs118
21 files changed, 2725 insertions, 0 deletions
diff --git a/src/Data/JLD/Context.hs b/src/Data/JLD/Context.hs
new file mode 100644
index 0000000..a999395
--- /dev/null
+++ b/src/Data/JLD/Context.hs
@@ -0,0 +1,1020 @@
1module Data.JLD.Context (BTDParams (..), EIParams (..), BACParams (..), buildTermDefinition, expandIri, buildActiveContext) where
2
3import Data.JLD.Prelude
4
5import Data.JLD.Control.Monad.RES (REST, withEnvRES, withErrorRES, withErrorRES', withStateRES)
6import Data.JLD.Model.ActiveContext (ActiveContext (..), containsProtectedTerm, lookupTerm, newActiveContext)
7import Data.JLD.Model.Direction (Direction (..))
8import Data.JLD.Error (JLDError (..))
9import Data.JLD.Model.IRI (CompactIRI (..), endsWithGenericDelim, isBlankIri, parseCompactIri)
10import Data.JLD.Model.Keyword (Keyword (..), allKeywords, isKeyword, isKeywordLike, isNotKeyword, parseKeyword)
11import Data.JLD.Model.Language (Language (..))
12import Data.JLD.Monad (JLDEnv (..), JLDState (..), JLDT, hoistEnv, modifyContextCache, modifyDocumentCache)
13import Data.JLD.Options (ContextCache, Document (..), DocumentCache, DocumentLoader (..), JLDVersion (..))
14import Data.JLD.Model.TermDefinition (TermDefinition (..), newTermDefinition)
15import Data.JLD.Util (flattenSingletonArray, valueContains, valueContainsAny, valueIsTrue, valueToArray)
16import Data.JLD.Model.URI (parseUri, uriToIri)
17
18import Control.Monad.Except (MonadError (..))
19import Data.Aeson (Object, Value (..))
20import Data.Aeson.Key qualified as K (fromText, toText)
21import Data.Aeson.KeyMap qualified as KM (delete, keys, lookup, member, size)
22import Data.Map.Strict qualified as M (delete, insert, lookup)
23import Data.RDF (parseIRI, parseRelIRI, resolveIRI, serializeIRI, validateIRI)
24import Data.Set qualified as S (insert, member, notMember, size)
25import Data.Text qualified as T (drop, dropEnd, elem, findIndex, isPrefixOf, null, take, toLower)
26import Data.Vector qualified as V (length)
27import Text.URI (URI, isPathAbsolute, relativeTo)
28import Text.URI qualified as U (render)
29
30type BACT e m = REST (BACEnv e m) (Either (JLDError e) ()) BACState m
31
32data BACEnv e m = BACEnv
33 { bacEnvGlobal :: JLDEnv e m
34 , bacEnvOverrideProtected :: Bool
35 , bacEnvValidateScopedContext :: Bool
36 , bacEnvPropagate :: Bool
37 }
38 deriving (Show)
39
40data BACState = BACState
41 { bacStateGlobal :: JLDState
42 , bacStateActiveContext :: ActiveContext
43 , bacStateRemoteContexts :: Set Text
44 }
45 deriving (Show, Eq)
46
47data BACParams = BACParams
48 { bacParamsOverrideProtected :: Bool
49 , bacParamsPropagate :: Bool
50 , bacParamsValidateScopedContext :: Bool
51 , bacParamsRemoteContexts :: Set Text
52 }
53 deriving (Show, Eq)
54
55bacModifyContextCache :: Monad m => (ContextCache -> ContextCache) -> BACT e m ()
56bacModifyContextCache = modifyContextCache .> withStateRES bacStateGlobal (\s g -> s{bacStateGlobal = g})
57
58bacModifyDocumentCache :: Monad m => (DocumentCache -> DocumentCache) -> BACT e m ()
59bacModifyDocumentCache = modifyDocumentCache .> withStateRES bacStateGlobal (\s g -> s{bacStateGlobal = g})
60
61bacModifyActiveContext :: Monad m => (ActiveContext -> ActiveContext) -> BACT e m ()
62bacModifyActiveContext fn = modify \s -> s{bacStateActiveContext = fn (bacStateActiveContext s)}
63
64bacModifyRemoteContexts :: Monad m => (Set Text -> Set Text) -> BACT e m ()
65bacModifyRemoteContexts fn = modify \s -> s{bacStateRemoteContexts = fn (bacStateRemoteContexts s)}
66
67bacBuildTermDefinition :: Monad m => Object -> Maybe URI -> Text -> BACT e m ()
68bacBuildTermDefinition contextDefinition baseUrl term = do
69 BACEnv{..} <- ask
70 activeContext <- gets bacStateActiveContext
71 remoteContexts <- gets bacStateRemoteContexts
72 let params p =
73 p
74 { btdParamsBaseUrl = baseUrl
75 , btdParamsOverrideProtectedFlag = bacEnvOverrideProtected
76 , btdParamsProtectedFlag = contextDefinition |> KM.lookup (show KeywordProtected) .> maybe False valueIsTrue
77 , btdParamsRemoteContexts = remoteContexts
78 }
79 (activeContext', _) <-
80 buildTermDefinition activeContext contextDefinition term params
81 |> withEnvRES (const bacEnvGlobal)
82 |> withErrorRES Left
83 |> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global})
84 bacModifyActiveContext <| const activeContext'
85
86bacBuildActiveContext :: Monad m => Value -> URI -> BACT e m ()
87bacBuildActiveContext context uri = do
88 BACEnv{..} <- ask
89 activeContext <- gets bacStateActiveContext
90 remoteContexts <- gets bacStateRemoteContexts
91 let params p =
92 p
93 { bacParamsValidateScopedContext = bacEnvValidateScopedContext
94 , bacParamsRemoteContexts = remoteContexts
95 }
96 activeContext' <-
97 buildActiveContext activeContext context (Just uri) params
98 |> withEnvRES (const bacEnvGlobal)
99 |> withErrorRES Left
100 |> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global})
101 bacModifyActiveContext <| const activeContext'
102
103bacProcessItem :: Monad m => Maybe URI -> Value -> BACT e m ()
104bacProcessItem baseUrl item = do
105 BACEnv{..} <- ask
106 let JLDEnv{..} = hoistEnv (lift .> lift .> lift) bacEnvGlobal
107
108 result <- gets bacStateActiveContext
109
110 case item of
111 -- 5.1.
112 Null
113 -- 5.1.1.
114 | not bacEnvOverrideProtected && containsProtectedTerm result -> throwError <| Left InvalidContextNullification
115 -- 5.1.2.
116 | bacEnvPropagate ->
117 bacModifyActiveContext \ac -> newActiveContext \nac ->
118 nac
119 { activeContextBaseUrl = activeContextBaseUrl ac
120 , activeContextBaseIri = uriToIri =<< activeContextBaseUrl ac
121 }
122 | otherwise ->
123 bacModifyActiveContext \ac -> newActiveContext \nac ->
124 nac
125 { activeContextBaseUrl = activeContextBaseUrl ac
126 , activeContextBaseIri = uriToIri =<< activeContextBaseUrl ac
127 , activeContextPreviousContext = activeContextPreviousContext ac
128 }
129 -- 5.2.
130 String value -> bacFetchRemoteContext value baseUrl
131 -- 5.4.
132 Object contextDefinition -> do
133 -- 5.5. 5.5.1. 5.5.2.
134 case KM.lookup (show KeywordVersion) contextDefinition of
135 Just (String "1.1")
136 | JLD1_0 <- jldEnvProcessingMode -> throwError <| Left ProcessingModeConflict
137 | otherwise -> pure ()
138 Just (Number 1.1)
139 | JLD1_0 <- jldEnvProcessingMode -> throwError <| Left ProcessingModeConflict
140 | otherwise -> pure ()
141 Just value -> throwError <. Left <| InvalidKeywordValue KeywordVersion value
142 --
143 Nothing -> pure ()
144
145 -- 5.6.
146 contextDefinition' <- case KM.lookup (show KeywordImport) contextDefinition of
147 -- 5.6.1.
148 Just _ | JLD1_0 <- jldEnvProcessingMode -> throwError <| Left InvalidContextEntry
149 -- 5.6.3.
150 Just (String value)
151 | Just importUri <- parseUri value
152 , Just contextUri <- relativeTo importUri =<< baseUrl ->
153 runDocumentLoader jldEnvDocumentLoader contextUri >>= \case
154 Right (Object document) -> case KM.lookup (show KeywordContext) document of
155 Just (Object remoteContext)
156 -- 5.6.7.
157 | KM.member (show KeywordImport) remoteContext -> throwError <| Left InvalidContextEntry
158 -- 5.6.8.
159 | otherwise -> pure <| contextDefinition <> remoteContext
160 -- 5.6.6.
161 _ -> throwError <| Left InvalidRemoteContext
162 -- 5.6.6.
163 Right _ -> throwError <| Left InvalidRemoteContext
164 -- 5.6.5.
165 Left err -> throwError <. Left <| DocumentLoaderError err
166 -- 5.6.2.
167 Just value -> throwError <. Left <| InvalidKeywordValue KeywordImport value
168 --
169 Nothing -> pure contextDefinition
170
171 -- 5.7. 5.7.1.
172 case KM.lookup (show KeywordBase) contextDefinition' of
173 -- 5.7.2.
174 Just Null -> bacModifyActiveContext \ac -> ac{activeContextBaseIri = Nothing}
175 Just (String "") -> pure ()
176 Just (String value)
177 -- 5.7.3.
178 | Right iri <- parseIRI value -> bacModifyActiveContext \ac -> ac{activeContextBaseIri = Just iri}
179 -- 5.7.4.
180 | Just baseIri <- activeContextBaseIri result
181 , Right iri <- parseIRI =<< resolveIRI (serializeIRI baseIri) value ->
182 bacModifyActiveContext \ac -> ac{activeContextBaseIri = Just iri}
183 --
184 Just _ -> throwError <| Left InvalidBaseIri
185 --
186 Nothing -> pure ()
187
188 -- 5.8. 5.8.1.
189 case KM.lookup (show KeywordVocab) contextDefinition' of
190 -- 5.8.2.
191 Just Null -> bacModifyActiveContext \ac -> ac{activeContextVocabularyMapping = Nothing}
192 -- 5.8.3.
193 Just (String value) | T.null value || isBlankIri value || isRight (parseIRI value) || isRight (parseRelIRI value) -> do
194 activeContext <- gets bacStateActiveContext
195 let params p =
196 p
197 { eiParamsVocab = True
198 , eiParamsDocumentRelative = True
199 }
200 (maybeVocabMapping, activeContext', _) <-
201 expandIri activeContext value params
202 |> withEnvRES (const bacEnvGlobal)
203 |> withErrorRES Left
204 |> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global})
205 bacModifyActiveContext <| const activeContext'
206
207 case maybeVocabMapping of
208 Just vocabMapping | isBlankIri vocabMapping || isRight (parseIRI vocabMapping) ->
209 bacModifyActiveContext \ac -> ac{activeContextVocabularyMapping = Just vocabMapping}
210 _ ->
211 throwError <| Left InvalidVocabMapping
212 Just _ -> throwError <| Left InvalidVocabMapping
213 --
214 Nothing -> pure ()
215
216 -- 5.9. 5.9.1.
217 case KM.lookup (show KeywordLanguage) contextDefinition' of
218 -- 5.9.2.
219 Just Null -> bacModifyActiveContext \ac -> ac{activeContextDefaultLanguage = Just NoLanguage}
220 -- 5.9.3.
221 Just (String language) -> bacModifyActiveContext \ac -> ac{activeContextDefaultLanguage = Just <| Language language}
222 Just _ -> throwError <| Left InvalidDefaultLanguage
223 --
224 Nothing -> pure ()
225
226 -- 5.10. 5.10.2.
227 case KM.lookup (show KeywordDirection) contextDefinition' of
228 -- 5.10.1.
229 Just _ | JLD1_0 <- jldEnvProcessingMode -> throwError <| Left InvalidContextEntry
230 -- 5.10.3.
231 Just Null -> bacModifyActiveContext \ac -> ac{activeContextDefaultBaseDirection = Nothing}
232 --
233 Just (String (T.toLower -> "ltr")) -> bacModifyActiveContext \ac -> ac{activeContextDefaultBaseDirection = Just LTR}
234 Just (String (T.toLower -> "rtl")) -> bacModifyActiveContext \ac -> ac{activeContextDefaultBaseDirection = Just RTL}
235 Just _ -> throwError <| Left InvalidBaseDirection
236 --
237 Nothing -> pure ()
238
239 -- 5.11.
240 case KM.lookup (show KeywordPropagate) contextDefinition' of
241 -- 5.11.1.
242 Just _ | JLD1_0 <- jldEnvProcessingMode -> throwError <| Left InvalidContextEntry
243 Just (Bool _) -> pure ()
244 Just invalid -> throwError <. Left <| InvalidKeywordValue KeywordPropagate invalid
245 --
246 Nothing -> pure ()
247
248 -- 5.13.
249 KM.keys contextDefinition'
250 |> fmap K.toText
251 .> filter
252 ( `isNotKeyword`
253 [ KeywordBase
254 , KeywordDirection
255 , KeywordImport
256 , KeywordLanguage
257 , KeywordPropagate
258 , KeywordProtected
259 , KeywordVersion
260 , KeywordVocab
261 ]
262 )
263 .> mapM_ (bacBuildTermDefinition contextDefinition' baseUrl)
264 -- 5.3.
265 _ -> throwError <| Left InvalidLocalContext
266
267bacFetchRemoteContext :: Monad m => Text -> Maybe URI -> BACT e m ()
268bacFetchRemoteContext url maybeBaseUrl
269 | Just uri <- parseUri url
270 , Just contextUri <- relativeTo uri =<< maybeBaseUrl -- 5.2.1.
271 , isPathAbsolute contextUri
272 , contextKey <- U.render contextUri = do
273 BACEnv{..} <- ask
274 let JLDEnv{..} = hoistEnv (lift .> lift .> lift) bacEnvGlobal
275
276 remoteContexts <- gets bacStateRemoteContexts
277
278 -- 5.2.2.
279 when (not bacEnvValidateScopedContext && S.member contextKey remoteContexts) <| throwError (Right ())
280
281 -- 5.2.3.
282 when (S.size remoteContexts > jldEnvMaxRemoteContexts) <| throwError (Left ContextOverflow)
283
284 bacModifyRemoteContexts <| S.insert contextKey
285
286 -- 5.2.4.
287 gets (bacStateGlobal .> jldStateContextCache .> M.lookup contextKey) >>= \case
288 Just cachedContext -> do
289 bacBuildActiveContext cachedContext contextUri
290 throwError <| Right ()
291 --
292 Nothing -> pure ()
293
294 -- 5.2.5.
295 document <-
296 gets (bacStateGlobal .> jldStateDocumentCache .> M.lookup contextKey) >>= \case
297 Just document -> pure document
298 Nothing ->
299 runDocumentLoader jldEnvDocumentLoader contextUri >>= \case
300 Right (Object document) -> pure <| Document contextUri document
301 -- 5.2.5.2.
302 Right _ -> throwError <| Left InvalidRemoteContext
303 -- 5.2.5.1.
304 Left err -> throwError <. Left <| DocumentLoaderError err
305
306 -- 5.2.5.3.
307 importedContext <- case KM.lookup (show KeywordContext) (documentContent document) of
308 Just (Object context) -> pure <. Object <. KM.delete (show KeywordBase) <| context
309 Just context -> pure context
310 Nothing -> throwError <| Left InvalidRemoteContext
311
312 bacModifyDocumentCache <| M.insert contextKey document
313
314 -- 5.2.6.
315 bacBuildActiveContext importedContext (documentUri document)
316 bacModifyContextCache <| M.insert contextKey importedContext
317 | otherwise = throwError <| Left LoadingRemoteContextError
318
319buildActiveContext' :: Monad m => Value -> Maybe URI -> BACT e m ()
320buildActiveContext' localContext baseUrl = do
321 activeContext <- gets bacStateActiveContext
322
323 -- 1.
324 bacModifyActiveContext \ac -> ac{activeContextInverseContext = mempty}
325
326 -- 2.
327 propagate <- case localContext of
328 Object ctx | Just prop <- KM.lookup (show KeywordPropagate) ctx -> case prop of
329 Bool p -> pure p
330 _ -> throwError <. Left <| InvalidKeywordValue KeywordPropagate prop
331 _ -> asks bacEnvPropagate
332
333 -- 3.
334 previousContext <- gets <| activeContextPreviousContext <. bacStateActiveContext
335 when (not propagate && isNothing previousContext) do
336 bacModifyActiveContext \ac -> ac{activeContextPreviousContext = Just activeContext}
337
338 -- 4. 5.
339 forM_ (valueToArray localContext)
340 <| bacProcessItem baseUrl
341 .> withEnvRES (\env -> env{bacEnvPropagate = propagate})
342 .> withErrorRES' (either (Left .> throwError) pure)
343
344buildActiveContext :: Monad m => ActiveContext -> Value -> Maybe URI -> (BACParams -> BACParams) -> JLDT e m ActiveContext
345buildActiveContext activeContext localContext baseUrl paramsFn = do
346 BACState{..} <-
347 (buildActiveContext' localContext baseUrl >> get)
348 |> withEnvRES env
349 |> withErrorRES' (either throwError (const get))
350 |> withStateRES st (const bacStateGlobal)
351 pure bacStateActiveContext
352 where
353 BACParams{..} =
354 paramsFn
355 BACParams
356 { bacParamsOverrideProtected = False
357 , bacParamsPropagate = True
358 , bacParamsValidateScopedContext = True
359 , bacParamsRemoteContexts = mempty
360 }
361
362 env options =
363 BACEnv
364 { bacEnvGlobal = options
365 , bacEnvOverrideProtected = bacParamsOverrideProtected
366 , bacEnvValidateScopedContext = bacParamsValidateScopedContext
367 , bacEnvPropagate = bacParamsPropagate
368 }
369
370 st global =
371 BACState
372 { bacStateGlobal = global
373 , bacStateActiveContext = activeContext
374 , bacStateRemoteContexts = bacParamsRemoteContexts
375 }
376
377--
378
379type EIT e m = REST (EIEnv e m) (JLDError e) EIState m
380
381data EIEnv e m = EIEnv
382 { eiEnvGlobal :: JLDEnv e m
383 , eiEnvDocumentRelative :: Bool
384 , eiEnvVocab :: Bool
385 , eiEnvLocalContext :: Maybe Object
386 }
387 deriving (Show)
388
389data EIState = EIState
390 { eiStateGlobal :: JLDState
391 , eiStateDefined :: Map Text Bool
392 , eiStateActiveContext :: ActiveContext
393 }
394 deriving (Show, Eq)
395
396data EIParams = EIParams
397 { eiParamsDocumentRelative :: Bool
398 , eiParamsVocab :: Bool
399 , eiParamsLocalContext :: Maybe Object
400 , eiParamsDefined :: Map Text Bool
401 }
402 deriving (Show, Eq)
403
404eiBuildTermDefinition :: Monad m => Text -> EIT e m ()
405eiBuildTermDefinition value = do
406 EIEnv{..} <- ask
407 defined <- gets eiStateDefined
408 activeContext <- gets eiStateActiveContext
409 let params p = p{btdParamsDefined = defined}
410 localContext = fromMaybe mempty eiEnvLocalContext
411 (activeContext', defined') <-
412 buildTermDefinition activeContext localContext value params
413 |> withEnvRES (const eiEnvGlobal)
414 |> withStateRES eiStateGlobal (\ei global -> ei{eiStateGlobal = global})
415 modify \s ->
416 s
417 { eiStateActiveContext = activeContext'
418 , eiStateDefined = defined'
419 }
420
421eiInitLocalContext :: Monad m => Text -> EIT e m ()
422eiInitLocalContext value =
423 -- 3.
424 asks eiEnvLocalContext >>= \case
425 Just localContext | Just (String entry) <- KM.lookup (K.fromText value) localContext -> do
426 defined <- gets eiStateDefined
427 when (maybe True not (M.lookup entry defined)) <| eiBuildTermDefinition value
428 _ -> pure ()
429
430eiInitPropertyContext :: Monad m => Text -> Text -> Text -> EIT e m Text
431eiInitPropertyContext prefix suffix value = do
432 -- 6.3.
433 defined <- gets eiStateDefined
434 asks eiEnvLocalContext >>= \case
435 Just localContext
436 | KM.member (K.fromText prefix) localContext
437 , M.lookup prefix defined /= Just True ->
438 eiBuildTermDefinition prefix
439 _ -> pure ()
440
441 -- 6.4.
442 gets (eiStateActiveContext .> lookupTerm prefix) >>= \case
443 Just prefixDefiniton
444 | Just iriMapping <- termDefinitionIriMapping prefixDefiniton
445 , termDefinitionPrefixFlag prefixDefiniton ->
446 pure <| iriMapping <> suffix
447 _ -> pure value
448
449eiExpandResult :: Monad m => Text -> EIT e m (Maybe Text)
450eiExpandResult value = do
451 EIEnv{..} <- ask
452 activeContext <- gets eiStateActiveContext
453 case activeContextVocabularyMapping activeContext of
454 -- 7.
455 Just vocabMapping | eiEnvVocab -> pure <. Just <| vocabMapping <> value
456 -- 8.
457 _
458 | eiEnvDocumentRelative
459 , baseIri <- serializeIRI <$> activeContextBaseIri activeContext
460 , Right iri <- maybe (Right value) (`resolveIRI` value) baseIri ->
461 pure <| Just iri
462 -- 9.
463 _ -> pure <| Just value
464
465expandIri' :: Monad m => Text -> EIT e m (Maybe Text)
466expandIri' value
467 -- 1.
468 | Just _ <- parseKeyword value = pure <| Just value
469 -- 2.
470 | isKeywordLike value = pure Nothing
471 --
472 | otherwise = do
473 EIEnv{..} <- ask
474
475 -- 3.
476 eiInitLocalContext value
477
478 gets (eiStateActiveContext .> lookupTerm value) >>= \case
479 -- 4. 5.
480 Just definition
481 | Just iriMapping <- termDefinitionIriMapping definition
482 , Just _ <- parseKeyword iriMapping ->
483 pure <| Just iriMapping
484 | eiEnvVocab ->
485 pure <| termDefinitionIriMapping definition
486 -- 6. 6.1.
487 _
488 | Just idx <- (+ 1) <$> T.findIndex (== ':') (T.drop 1 value)
489 , prefix <- T.take idx value
490 , suffix <- T.drop (idx + 1) value ->
491 -- 6.2.
492 if "_" `T.isPrefixOf` prefix || "//" `T.isPrefixOf` suffix
493 then pure <| Just value
494 else do
495 value' <- eiInitPropertyContext prefix suffix value
496
497 if isBlankIri value' || isRight (validateIRI value')
498 then pure <| Just value'
499 else eiExpandResult value'
500 --
501 _ -> eiExpandResult value
502
503expandIri :: Monad m => ActiveContext -> Text -> (EIParams -> EIParams) -> JLDT e m (Maybe Text, ActiveContext, Map Text Bool)
504expandIri activeContext value paramsFn = do
505 (value', EIState{..}) <-
506 (expandIri' value >>= \v -> gets (v,))
507 |> withEnvRES env
508 |> withStateRES st (const eiStateGlobal)
509 pure (value', eiStateActiveContext, eiStateDefined)
510 where
511 EIParams{..} =
512 paramsFn
513 EIParams
514 { eiParamsDocumentRelative = False
515 , eiParamsVocab = False
516 , eiParamsLocalContext = Nothing
517 , eiParamsDefined = mempty
518 }
519
520 env options =
521 EIEnv
522 { eiEnvGlobal = options
523 , eiEnvDocumentRelative = eiParamsDocumentRelative
524 , eiEnvVocab = eiParamsVocab
525 , eiEnvLocalContext = eiParamsLocalContext
526 }
527
528 st global =
529 EIState
530 { eiStateGlobal = global
531 , eiStateDefined = eiParamsDefined
532 , eiStateActiveContext = activeContext
533 }
534
535--
536
537type BTDT e m = REST (BTDEnv e m) (Either (JLDError e) ()) BTDState m
538
539data BTDEnv e m = BTDEnv
540 { btdEnvGlobal :: JLDEnv e m
541 , btdEnvLocalContext :: Object
542 , btdEnvBaseUrl :: Maybe URI
543 , btdEnvProtectedFlag :: Bool
544 , btdEnvOverrideProtectedFlag :: Bool
545 , btdEnvRemoteContexts :: Set Text
546 }
547 deriving (Show)
548
549data BTDState = BTDState
550 { btdStateGlobal :: JLDState
551 , btdStateDefined :: Map Text Bool
552 , btdStateTermDefinition :: TermDefinition
553 , btdStateActiveContext :: ActiveContext
554 }
555 deriving (Show, Eq)
556
557data BTDParams = BTDParams
558 { btdParamsBaseUrl :: Maybe URI
559 , btdParamsProtectedFlag :: Bool
560 , btdParamsOverrideProtectedFlag :: Bool
561 , btdParamsRemoteContexts :: Set Text
562 , btdParamsDefined :: Map Text Bool
563 , btdParamsTermDefinition :: TermDefinition
564 }
565 deriving (Show, Eq)
566
567btdModifyActiveContext :: Monad m => (ActiveContext -> ActiveContext) -> BTDT e m ()
568btdModifyActiveContext fn = modify \s -> s{btdStateActiveContext = fn (btdStateActiveContext s)}
569
570btdModifyTermDefinition :: Monad m => (TermDefinition -> TermDefinition) -> BTDT e m ()
571btdModifyTermDefinition fn = modify \s -> s{btdStateTermDefinition = fn (btdStateTermDefinition s)}
572
573btdModifyDefined :: Monad m => (Map Text Bool -> Map Text Bool) -> BTDT e m ()
574btdModifyDefined fn = modify \s -> s{btdStateDefined = fn (btdStateDefined s)}
575
576btdValidateContainer :: JLDEnv e m -> Value -> Bool
577btdValidateContainer _ Null = False
578btdValidateContainer JLDEnv{..} value
579 | JLD1_0 <- jldEnvProcessingMode = case value of
580 String value' -> isNotKeyword value' [KeywordGraph, KeywordId, KeywordType]
581 _ -> False
582 | otherwise = case flattenSingletonArray value of
583 String container' ->
584 isKeyword
585 container'
586 [ KeywordGraph
587 , KeywordId
588 , KeywordIndex
589 , KeywordLanguage
590 , KeywordList
591 , KeywordSet
592 , KeywordType
593 ]
594 container@(Array (V.length -> len))
595 | len > 3 ->
596 False
597 | valueContains (show KeywordGraph) container
598 , valueContainsAny (show <$> [KeywordId, KeywordIndex]) container ->
599 len == 2 || valueContains (show KeywordSet) container
600 | len == 2
601 , valueContains (show KeywordSet) container
602 , valueContainsAny (show <$> [KeywordGraph, KeywordId, KeywordIndex, KeywordLanguage, KeywordType]) container ->
603 True
604 _ -> False
605
606btdExpandIri :: Monad m => Text -> BTDT e m (Maybe Text)
607btdExpandIri value = do
608 BTDEnv{..} <- ask
609 defined <- gets btdStateDefined
610 activeContext <- gets btdStateActiveContext
611 let params p =
612 p
613 { eiParamsLocalContext = Just btdEnvLocalContext
614 , eiParamsVocab = True
615 , eiParamsDefined = defined
616 }
617 (expanded, activeContext', defined') <-
618 expandIri activeContext value params
619 |> withEnvRES (const btdEnvGlobal)
620 |> withErrorRES Left
621 |> withStateRES btdStateGlobal (\btd global -> btd{btdStateGlobal = global})
622 modify \s ->
623 s
624 { btdStateActiveContext = activeContext'
625 , btdStateDefined = defined'
626 }
627 pure expanded
628
629btdBuildTermDefinition :: Monad m => Text -> BTDT e m ()
630btdBuildTermDefinition term = do
631 BTDEnv{..} <- ask
632 defined <- gets btdStateDefined
633 activeContext <- gets btdStateActiveContext
634 let params p = p{btdParamsDefined = defined}
635 (activeContext', defined') <-
636 buildTermDefinition activeContext btdEnvLocalContext term params
637 |> withEnvRES (const btdEnvGlobal)
638 |> withErrorRES Left
639 |> withStateRES btdStateGlobal (\btd global -> btd{btdStateGlobal = global})
640 modify \env ->
641 env
642 { btdStateActiveContext = activeContext'
643 , btdStateDefined = defined'
644 }
645
646buildTermDefinition' :: Monad m => Text -> BTDT e m ()
647buildTermDefinition' "" = throwError <| Left InvalidTermDefinition -- 2.
648buildTermDefinition' term = do
649 BTDEnv{..} <- ask
650 let JLDEnv{..} = btdEnvGlobal
651
652 -- 1.
653 gets (btdStateDefined .> M.lookup term) >>= \case
654 Just True -> throwError <| Right ()
655 Just False -> throwError <| Left CyclicIriMapping
656 Nothing -> pure ()
657
658 -- 2.
659 btdModifyDefined <| M.insert term False
660
661 -- 3.
662 let value = btdEnvLocalContext |> KM.lookup (K.fromText term) .> fromMaybe Null
663
664 -- 4.
665 case term of
666 ((`isKeyword` [KeywordType]) -> True)
667 | JLD1_0 <- jldEnvProcessingMode -> throwError <| Left KeywordRedefinition
668 | Object map' <- value ->
669 if
670 | KM.size map' == 1
671 , Just container <- KM.lookup (show KeywordContainer) map' ->
672 when (container /= String (show KeywordSet)) <| throwError (Left KeywordRedefinition)
673 | KM.size map' == 2
674 , Just container <- KM.lookup (show KeywordContainer) map'
675 , KM.member (show KeywordProtected) map' ->
676 unless (valueContains (show KeywordSet) container) <| throwError (Left KeywordRedefinition)
677 | KM.size map' /= 1 || not (KM.member (show KeywordProtected) map') ->
678 throwError <| Left KeywordRedefinition
679 | otherwise -> pure ()
680 | otherwise -> throwError <| Left KeywordRedefinition
681 -- 5.
682 (parseKeyword -> Just _) -> throwError <| Left KeywordRedefinition
683 (isKeywordLike -> True) -> throwError <| Right ()
684 _ -> pure ()
685
686 -- 6.
687 maybePreviousDefinition <- gets (btdStateActiveContext .> lookupTerm term)
688 btdModifyActiveContext \ac -> ac{activeContextTerms = M.delete term (activeContextTerms ac)}
689
690 -- 7. 8. 9.
691 (valueObject, idValue, simpleTerm) <- case value of
692 Null -> pure (mempty, Just Null, False)
693 (String s) -> pure (mempty, Just (String s), True)
694 (Object o) -> pure (o, KM.lookup (show KeywordId) o, False)
695 _ -> throwError <| Left InvalidTermDefinition
696
697 -- 10.
698 btdModifyTermDefinition <| const (newTermDefinition btdEnvProtectedFlag id)
699
700 -- 11.
701 case KM.lookup (show KeywordProtected) valueObject of
702 Just _ | JLD1_0 <- jldEnvProcessingMode -> throwError <| Left InvalidTermDefinition
703 Just (Bool protected) -> btdModifyTermDefinition \d -> d{termDefinitionProtectedFlag = protected}
704 Just invalid -> throwError <. Left <| InvalidKeywordValue KeywordProtected invalid
705 Nothing -> pure ()
706
707 -- 12.
708 case KM.lookup (show KeywordType) valueObject of
709 -- 12.2.
710 Just (String type') ->
711 btdExpandIri type' >>= \case
712 Nothing -> throwError <| Left InvalidTypeMapping
713 Just expandedType
714 -- 12.3.
715 | isKeyword expandedType [KeywordJson, KeywordNone]
716 , JLD1_0 <- jldEnvProcessingMode ->
717 throwError <| Left InvalidTypeMapping
718 -- 12.4.
719 | isNotKeyword expandedType [KeywordId, KeywordJson, KeywordNone, KeywordVocab]
720 , Left _ <- validateIRI expandedType ->
721 throwError <| Left InvalidTypeMapping
722 -- 12.5.
723 | otherwise ->
724 btdModifyTermDefinition \d -> d{termDefinitionTypeMapping = Just expandedType}
725 -- 12.1.
726 Just _ -> throwError <| Left InvalidTypeMapping
727 --
728 Nothing -> pure ()
729
730 -- 13.
731 case KM.lookup (show KeywordReverse) valueObject of
732 -- 13.1.
733 Just _ | KM.member (show KeywordId) valueObject || KM.member (show KeywordNest) valueObject -> throwError <| Left InvalidReverseProperty
734 Just (String (isKeywordLike -> True)) -> throwError <| Right ()
735 -- 13.3.
736 Just (String reverse') -> do
737 -- 13.4.
738 btdExpandIri reverse' >>= \case
739 Just (validateIRI -> Right expandedReverse) ->
740 btdModifyTermDefinition \d -> d{termDefinitionIriMapping = Just expandedReverse}
741 _ -> throwError <| Left InvalidIriMapping
742
743 -- 13.5.
744 case KM.lookup (show KeywordContainer) valueObject of
745 Just (String container) | isKeyword container [KeywordSet, KeywordIndex] -> do
746 btdModifyTermDefinition \d ->
747 d
748 { termDefinitionContainerMapping = S.insert container <| termDefinitionContainerMapping d
749 }
750 Just Null -> pure ()
751 Just _ -> throwError <| Left InvalidReverseProperty
752 Nothing -> pure ()
753
754 -- 13.6.
755 btdModifyTermDefinition \d -> d{termDefinitionReversePropertyFlag = True}
756
757 -- 13.7.
758 definition <- gets btdStateTermDefinition
759 btdModifyActiveContext \ac -> ac{activeContextTerms = activeContextTerms ac |> M.insert term definition}
760 btdModifyDefined <| M.insert term True
761
762 throwError <| Right ()
763 -- 13.2.
764 Just _ -> throwError <| Left InvalidIriMapping
765 --
766 Nothing -> pure ()
767
768 -- 14. 15. 16. 17. 18.
769 maybeVocabMapping <- gets (btdStateActiveContext .> activeContextVocabularyMapping)
770 if
771 -- 14. 14.1.
772 | Just idValue' <- idValue
773 , idValue' /= String term -> case idValue' of
774 Null -> pure ()
775 String id'
776 -- 14.2.2.
777 | isNothing (parseKeyword id') && isKeywordLike id' -> throwError <| Right ()
778 | otherwise -> do
779 -- 14.2.3.
780 iriMapping <-
781 btdExpandIri id' >>= \case
782 Nothing -> throwError <| Left InvalidIriMapping
783 Just expandedId
784 | isKeyword expandedId [KeywordContext] ->
785 throwError <| Left InvalidKeywordAlias
786 | Nothing <- parseKeyword expandedId
787 , Left _ <- validateIRI expandedId
788 , isBlankIri expandedId ->
789 throwError <| Left InvalidIriMapping
790 | otherwise ->
791 expandedId <$ btdModifyTermDefinition \d -> d{termDefinitionIriMapping = Just expandedId}
792
793 -- 14.2.4.
794 when (T.elem ':' (T.dropEnd 1 <. T.drop 1 <| term) || T.elem '/' term) do
795 -- 14.2.4.1
796 btdModifyDefined <| M.insert term True
797
798 -- 14.2.4.2.
799 expandedTerm <- btdExpandIri term
800 when (expandedTerm /= Just iriMapping) <| throwError (Left InvalidIriMapping)
801
802 -- 14.2.5.
803 definition <- gets btdStateTermDefinition
804 when (not <| termDefinitionPrefixFlag definition) do
805 let validIri = isRight <. validateIRI <. T.dropEnd 1 <| iriMapping
806 let prefix =
807 not (T.elem ':' term || T.elem '/' term)
808 && simpleTerm
809 && ((endsWithGenericDelim iriMapping && validIri) || isBlankIri iriMapping)
810 btdModifyTermDefinition \d -> d{termDefinitionPrefixFlag = prefix}
811 -- 14.2.1.
812 _ -> throwError <| Left InvalidIriMapping
813 -- 15.
814 | T.elem ':' (T.drop 1 term) -> do
815 let maybeCompactIri = parseCompactIri term
816
817 -- 15.1.
818 case maybeCompactIri of
819 Just (CompactIRI prefix _) | KM.member (K.fromText prefix) btdEnvLocalContext -> do
820 btdBuildTermDefinition prefix
821 _ -> pure ()
822
823 -- 15.2.
824 activeContextTerms <- gets (btdStateActiveContext .> activeContextTerms)
825 case maybeCompactIri of
826 Just (CompactIRI prefix suffix)
827 | Just term' <- M.lookup prefix activeContextTerms
828 , iriMapping <- (<> suffix) <$> termDefinitionIriMapping term' ->
829 btdModifyTermDefinition \d -> d{termDefinitionIriMapping = iriMapping}
830 -- 15.3.
831 _
832 | isRight (validateIRI term) || isBlankIri term ->
833 btdModifyTermDefinition \d -> d{termDefinitionIriMapping = Just term}
834 _ -> pure ()
835 -- 16.
836 | T.elem '/' term ->
837 btdExpandIri term >>= \case
838 Just expandedTerm -> btdModifyTermDefinition \d -> d{termDefinitionIriMapping = Just expandedTerm}
839 Nothing -> throwError <| Left InvalidIriMapping
840 -- 17.
841 | isKeyword term [KeywordType] -> btdModifyTermDefinition \d -> d{termDefinitionIriMapping = Just term}
842 -- 18.
843 | Just vocabMapping <- maybeVocabMapping -> btdModifyTermDefinition \d -> d{termDefinitionIriMapping = Just (vocabMapping <> term)}
844 --
845 | otherwise -> throwError <| Left InvalidIriMapping
846
847 -- 19.
848 case KM.lookup (show KeywordContainer) valueObject of
849 Just container -> do
850 when (not <| btdValidateContainer btdEnvGlobal container) <| throwError (Left InvalidContainerMapping)
851
852 forM_ (valueToArray container) \case
853 String item -> btdModifyTermDefinition \d -> d{termDefinitionContainerMapping = termDefinitionContainerMapping d |> S.insert item}
854 _ -> pure ()
855
856 definition <- gets btdStateTermDefinition
857 when (S.member (show KeywordType) <| termDefinitionContainerMapping definition) do
858 let typeMapping = termDefinitionTypeMapping definition |> fromMaybe (show KeywordId)
859 btdModifyTermDefinition \d -> d{termDefinitionTypeMapping = Just typeMapping}
860 when (isNotKeyword typeMapping [KeywordId, KeywordVocab]) do
861 throwError <| Left InvalidTypeMapping
862 --
863 Nothing -> pure ()
864
865 -- 20.
866 containerMapping <- gets (btdStateTermDefinition .> termDefinitionContainerMapping)
867 case KM.lookup (show KeywordIndex) valueObject of
868 -- 20.1.
869 Just _ | jldEnvProcessingMode == JLD1_0 || S.notMember (show KeywordIndex) containerMapping -> throwError <| Left InvalidTermDefinition
870 -- 20.2.
871 Just (String index) ->
872 btdExpandIri index >>= \case
873 Just (validateIRI -> Right _) -> btdModifyTermDefinition \d -> d{termDefinitionIndexMapping = Just index}
874 _ -> throwError <| Left InvalidTermDefinition
875 Just _ -> throwError <| Left InvalidTermDefinition
876 --
877 Nothing -> pure ()
878
879 -- 21.
880 case KM.lookup (show KeywordContext) valueObject of
881 -- 21.1.
882 Just _ | JLD1_0 <- jldEnvProcessingMode -> throwError <| Left InvalidTermDefinition
883 -- 21.2.
884 Just context -> do
885 -- 21.3.
886 activeContext <- gets btdStateActiveContext
887 let params p =
888 p
889 { bacParamsOverrideProtected = True
890 , bacParamsRemoteContexts = btdEnvRemoteContexts
891 , bacParamsValidateScopedContext = False
892 }
893 buildActiveContext activeContext context btdEnvBaseUrl params
894 |> withEnvRES (const btdEnvGlobal)
895 |> withStateRES btdStateGlobal (\btd global -> btd{btdStateGlobal = global})
896 |> withErrorRES (const <| Left InvalidScopedContext)
897 |> void
898
899 -- 21.4.
900 btdModifyTermDefinition \d ->
901 d
902 { termDefinitionLocalContext = Just context
903 , termDefinitionBaseUrl = btdEnvBaseUrl
904 }
905 --
906 Nothing -> pure ()
907
908 -- 22. 23.
909 unless (KM.member (show KeywordType) valueObject) do
910 -- 22.
911 case KM.lookup (show KeywordLanguage) valueObject of
912 Just Null -> btdModifyTermDefinition \d -> d{termDefinitionLanguageMapping = Just NoLanguage}
913 Just (String language) -> btdModifyTermDefinition \d -> d{termDefinitionLanguageMapping = Just <| Language language}
914 Just _ -> throwError <| Left InvalidLanguageMapping
915 Nothing -> pure ()
916
917 -- 23.
918 case KM.lookup (show KeywordDirection) valueObject of
919 Just Null -> btdModifyTermDefinition \d -> d{termDefinitionDirectionMapping = Just NoDirection}
920 Just (String "ltr") -> btdModifyTermDefinition \d -> d{termDefinitionDirectionMapping = Just LTR}
921 Just (String "rtl") -> btdModifyTermDefinition \d -> d{termDefinitionDirectionMapping = Just RTL}
922 Just _ -> throwError <| Left InvalidBaseDirection
923 Nothing -> pure ()
924
925 -- 24.
926 case KM.lookup (show KeywordNest) valueObject of
927 -- 24.1.
928 Just _ | JLD1_0 <- jldEnvProcessingMode -> throwError <| Left InvalidTermDefinition
929 Just (String nest)
930 | parseKeyword nest /= Just KeywordNest -> throwError <. Left <| InvalidKeywordValue KeywordNest (String nest)
931 | otherwise -> btdModifyTermDefinition \d -> d{termDefinitionNestValue = Just nest}
932 Just invalid -> throwError <. Left <| InvalidKeywordValue KeywordNest invalid
933 Nothing -> pure ()
934
935 -- 25.
936 maybeIriMapping <- gets (btdStateTermDefinition .> termDefinitionIriMapping)
937 case KM.lookup (show KeywordPrefix) valueObject of
938 -- 25.1.
939 Just _
940 | jldEnvProcessingMode == JLD1_0 || T.elem ':' term || T.elem '/' term ->
941 throwError <| Left InvalidTermDefinition
942 Just (Bool prefix)
943 | prefix, Just _ <- parseKeyword =<< maybeIriMapping -> throwError <| Left InvalidTermDefinition
944 | otherwise -> btdModifyTermDefinition \d -> d{termDefinitionPrefixFlag = prefix}
945 Just invalid -> throwError <. Left <| InvalidKeywordValue KeywordPrefix invalid
946 Nothing -> pure ()
947
948 -- 26.
949 unless
950 ( allKeywords
951 (KM.keys valueObject <&> K.toText)
952 [ KeywordId
953 , KeywordReverse
954 , KeywordContainer
955 , KeywordContext
956 , KeywordDirection
957 , KeywordIndex
958 , KeywordLanguage
959 , KeywordNest
960 , KeywordPrefix
961 , KeywordProtected
962 , KeywordType
963 ]
964 )
965 do throwError <| Left InvalidTermDefinition
966
967 -- 27.
968 definition <- gets btdStateTermDefinition
969
970 case maybePreviousDefinition of
971 Just previousDefinition | not btdEnvOverrideProtectedFlag && termDefinitionProtectedFlag previousDefinition -> do
972 -- 27.1.
973 when (definition{termDefinitionProtectedFlag = True} /= previousDefinition) do
974 throwError <| Left ProtectedTermRedefinition
975
976 -- 27.2.
977 btdModifyActiveContext \ac -> ac{activeContextTerms = activeContextTerms ac |> M.insert term previousDefinition}
978 --
979 _ ->
980 btdModifyActiveContext \ac -> ac{activeContextTerms = activeContextTerms ac |> M.insert term definition}
981
982 btdModifyDefined <| M.insert term True
983
984buildTermDefinition :: Monad m => ActiveContext -> Object -> Text -> (BTDParams -> BTDParams) -> JLDT e m (ActiveContext, Map Text Bool)
985buildTermDefinition activeContext localContext term paramsFn = do
986 BTDState{..} <-
987 (buildTermDefinition' term >> get)
988 |> withEnvRES env
989 |> withErrorRES' (either throwError (const get))
990 |> withStateRES st (const btdStateGlobal)
991 pure (btdStateActiveContext, btdStateDefined)
992 where
993 BTDParams{..} =
994 paramsFn
995 BTDParams
996 { btdParamsBaseUrl = Nothing
997 , btdParamsProtectedFlag = False
998 , btdParamsOverrideProtectedFlag = False
999 , btdParamsRemoteContexts = mempty
1000 , btdParamsDefined = mempty
1001 , btdParamsTermDefinition = newTermDefinition False id
1002 }
1003
1004 env options =
1005 BTDEnv
1006 { btdEnvGlobal = options
1007 , btdEnvLocalContext = localContext
1008 , btdEnvBaseUrl = btdParamsBaseUrl
1009 , btdEnvProtectedFlag = btdParamsProtectedFlag
1010 , btdEnvOverrideProtectedFlag = btdParamsOverrideProtectedFlag
1011 , btdEnvRemoteContexts = btdParamsRemoteContexts
1012 }
1013
1014 st global =
1015 BTDState
1016 { btdStateGlobal = global
1017 , btdStateDefined = btdParamsDefined
1018 , btdStateTermDefinition = btdParamsTermDefinition
1019 , btdStateActiveContext = activeContext
1020 }
diff --git a/src/Data/JLD/Control/Monad/RES.hs b/src/Data/JLD/Control/Monad/RES.hs
new file mode 100644
index 0000000..1c96d46
--- /dev/null
+++ b/src/Data/JLD/Control/Monad/RES.hs
@@ -0,0 +1,35 @@
1module Data.JLD.Control.Monad.RES (
2 REST,
3 runREST,
4 evalREST,
5 withEnvRES,
6 withErrorRES,
7 withErrorRES',
8 withStateRES,
9) where
10
11import Data.JLD.Prelude
12
13import Control.Monad.Except (mapExceptT)
14
15type REST r e s m = ReaderT r (ExceptT e (StateT s m))
16
17runREST :: r -> s -> REST r e s m a -> m (Either e a, s)
18runREST env st = flip runReaderT env .> runExceptT .> flip runStateT st
19
20evalREST :: Monad m => r -> s -> REST r e s m a -> m (Either e a)
21evalREST env st = flip runReaderT env .> runExceptT .> flip evalStateT st
22
23withEnvRES :: (r -> r') -> REST r' e s m a -> REST r e s m a
24withEnvRES fn (ReaderT m) = ReaderT <| fn .> m
25
26withErrorRES :: Functor m => (e' -> e) -> REST r e' s m a -> REST r e s m a
27withErrorRES fn (ReaderT m) = ReaderT <| m .> mapExceptT (fmap <| first fn)
28
29withErrorRES' :: Monad m => (e' -> REST r e s m a) -> REST r e' s m a -> REST r e s m a
30withErrorRES' fn (ReaderT m) =
31 ReaderT <| \r -> m r |> mapExceptT \m' -> m' >>= either (fn .> flip runReaderT r .> runExceptT) (Right .> pure)
32
33withStateRES :: Monad m => (s -> s') -> (s -> s' -> s) -> REST r e s' m a -> REST r e s m a
34withStateRES fin fout (ReaderT m) =
35 ReaderT \env -> m env |> mapExceptT \st -> StateT \s -> second (fout s) <$> runStateT st (fin s)
diff --git a/src/Data/JLD/Error.hs b/src/Data/JLD/Error.hs
new file mode 100644
index 0000000..91c2a0b
--- /dev/null
+++ b/src/Data/JLD/Error.hs
@@ -0,0 +1,81 @@
1module Data.JLD.Error (JLDError (..), toJldErrorCode) where
2
3import Data.JLD.Prelude
4
5import Data.JLD.Model.Keyword (Keyword (KeywordType))
6
7import Data.Aeson (Value)
8
9data JLDError e
10 = InvalidKeywordValue Keyword Value
11 | ProcessingModeConflict
12 | InvalidContextEntry
13 | InvalidContextNullification
14 | InvalidLocalContext
15 | InvalidRemoteContext
16 | InvalidBaseIri
17 | InvalidVocabMapping
18 | InvalidDefaultLanguage
19 | InvalidBaseDirection
20 | LoadingRemoteContextError
21 | DocumentLoaderError e
22 | ContextOverflow
23 | InvalidTermDefinition
24 | CyclicIriMapping
25 | KeywordRedefinition
26 | InvalidTypeMapping
27 | InvalidReverseProperty
28 | InvalidIriMapping
29 | InvalidKeywordAlias
30 | InvalidContainerMapping
31 | InvalidLanguageMapping
32 | ProtectedTermRedefinition
33 | InvalidReversePropertyMap
34 | CollidingKeywords Text Keyword
35 | InvalidValueObjectValue
36 | InvalidLanguageTaggedString
37 | InvalidReversePropertyValue
38 | InvalidLanguageMapValue
39 | InvalidValueObject
40 | InvalidLanguageTaggedValue
41 | InvalidTypedValue
42 | InvalidSetOrListObject
43 | InvalidScopedContext
44 deriving (Eq, Show)
45
46toJldErrorCode :: JLDError e -> Text
47toJldErrorCode (InvalidKeywordValue KeywordType _) = "invalid type value"
48toJldErrorCode (InvalidKeywordValue keyword _) = "invalid " <> show keyword <> " value"
49toJldErrorCode ProcessingModeConflict = "processing mode conflict"
50toJldErrorCode InvalidContextEntry = "invalid context entry"
51toJldErrorCode InvalidContextNullification = "invalid context nullification"
52toJldErrorCode InvalidLocalContext = "invalid local context"
53toJldErrorCode InvalidRemoteContext = "invalid remote context"
54toJldErrorCode InvalidBaseIri = "invalid base IRI"
55toJldErrorCode InvalidVocabMapping = "invalid vocab mapping"
56toJldErrorCode InvalidDefaultLanguage = "invalid default language"
57toJldErrorCode InvalidBaseDirection = "invalid base direction"
58toJldErrorCode LoadingRemoteContextError = "loading remote context failed"
59toJldErrorCode (DocumentLoaderError _) = "loading document failed"
60toJldErrorCode ContextOverflow = "context overflow"
61toJldErrorCode InvalidTermDefinition = "invalid term definition"
62toJldErrorCode CyclicIriMapping = "cyclic IRI mapping"
63toJldErrorCode KeywordRedefinition = "keyword redefinition"
64toJldErrorCode InvalidTypeMapping = "invalid type mapping"
65toJldErrorCode InvalidReverseProperty = "invalid reverse property"
66toJldErrorCode InvalidIriMapping = "invalid IRI mapping"
67toJldErrorCode InvalidKeywordAlias = "invalid keyword alias"
68toJldErrorCode InvalidContainerMapping = "invalid container mapping"
69toJldErrorCode InvalidLanguageMapping = "invalid language mapping"
70toJldErrorCode ProtectedTermRedefinition = "protected term redefinition"
71toJldErrorCode InvalidReversePropertyMap = "invalid reverse property map"
72toJldErrorCode (CollidingKeywords _ _) = "colliding keywords"
73toJldErrorCode InvalidValueObjectValue = "invalid value object value"
74toJldErrorCode InvalidLanguageTaggedString = "invalid language-tagged string"
75toJldErrorCode InvalidReversePropertyValue = "invalid reverse property value"
76toJldErrorCode InvalidLanguageMapValue = "invalid language map value"
77toJldErrorCode InvalidValueObject = "invalid value object"
78toJldErrorCode InvalidLanguageTaggedValue = "invalid language-tagged value"
79toJldErrorCode InvalidTypedValue = "invalid typed value"
80toJldErrorCode InvalidSetOrListObject = "invalid set or list object"
81toJldErrorCode InvalidScopedContext = "invalid scoped context"
diff --git a/src/Data/JLD/Expansion.hs b/src/Data/JLD/Expansion.hs
new file mode 100644
index 0000000..18d7fc6
--- /dev/null
+++ b/src/Data/JLD/Expansion.hs
@@ -0,0 +1,942 @@
1module Data.JLD.Expansion (JLDEParams (..), expand) where
2
3import Data.JLD.Prelude
4
5import Data.JLD.Control.Monad.RES (REST, withEnvRES, withStateRES)
6import Data.JLD.Context (BACParams (..), EIParams (..), buildActiveContext, expandIri)
7import Data.JLD.Model.ActiveContext (ActiveContext (..), lookupTerm)
8import Data.JLD.Model.Direction (Direction (..))
9import Data.JLD.Error (JLDError (..))
10import Data.JLD.Model.GraphObject (isNotGraphObject, toGraphObject)
11import Data.JLD.Model.Keyword (Keyword (..), isKeyword, isNotKeyword, parseKeyword)
12import Data.JLD.Model.Language (Language (..))
13import Data.JLD.Model.ListObject (isListObject, isNotListObject, toListObject)
14import Data.JLD.Monad (JLDEEnv (..), JLDEState (..), JLDET, JLDEnv (..), JLDT, modifyActiveContext)
15import Data.JLD.Model.NodeObject (isNotNodeObject)
16import Data.JLD.Options (JLDVersion (..))
17import Data.JLD.Model.TermDefinition (TermDefinition (..))
18import Data.JLD.Model.ValueObject (isNotValueObject', isValueObject, isValueObject')
19import Data.JLD.Util (
20 allStrings,
21 getMapDefault,
22 ifindM,
23 mapAddValue,
24 valueContains,
25 valueIsEmptyArray,
26 valueIsNotArray,
27 valueIsNotNull,
28 valueIsNotString,
29 valueIsScalar,
30 valueIsString,
31 valueToArray,
32 valueToString,
33 )
34
35import Control.Monad.Except (MonadError (..))
36import Data.Aeson (Array, Key, KeyValue (..), Object, Value (..), object)
37import Data.Aeson.Key qualified as K (fromText, toText)
38import Data.Aeson.KeyMap qualified as KM (delete, fromList, insert, keys, lookup, member, null, singleton, size, toList)
39import Data.Foldable.WithIndex (ifoldlM, iforM_)
40import Data.RDF (parseIRI)
41import Data.Set qualified as S (insert, member)
42import Data.Text qualified as T (elem, toLower)
43import Data.Vector qualified as V (catMaybes, concat, cons, filter, fromList, mapMaybeM, maximum, modify, null, singleton, snoc, toList)
44import Data.Vector.Algorithms.Merge qualified as V
45import Text.URI (URI)
46
47type EO1314T e m = REST (JLDEEnv e m) (JLDError e) EO1314State m
48
49data EO1314State = EO1314State
50 { eo1314StateJlde :: JLDEState
51 , eo1314StateNest :: Set Key
52 , eo1314StateResult :: Object
53 , eo1314StateTypeContext :: ActiveContext
54 }
55 deriving (Show, Eq)
56
57eo1314ModifyActiveContext :: Monad m => (ActiveContext -> ActiveContext) -> EO1314T e m ()
58eo1314ModifyActiveContext = modifyActiveContext .> withStateRES eo1314StateJlde (\s g -> s{eo1314StateJlde = g})
59
60eo1314ModifyTypeContext :: Monad m => (ActiveContext -> ActiveContext) -> EO1314T e m ()
61eo1314ModifyTypeContext fn = modify \st -> st{eo1314StateTypeContext = fn (eo1314StateTypeContext st)}
62
63eo1314ModifyNest :: Monad m => (Set Key -> Set Key) -> EO1314T e m ()
64eo1314ModifyNest fn = modify \s -> s{eo1314StateNest = fn (eo1314StateNest s)}
65
66eo1314ModifyResult :: Monad m => (Object -> Object) -> EO1314T e m ()
67eo1314ModifyResult fn = modify \s -> s{eo1314StateResult = fn (eo1314StateResult s)}
68
69eo1314BuildActiveContext :: Monad m => ActiveContext -> Value -> Maybe URI -> (BACParams -> BACParams) -> EO1314T e m ActiveContext
70eo1314BuildActiveContext activeContext context baseUrl paramsFn = do
71 buildActiveContext activeContext context baseUrl paramsFn
72 |> withEnvRES jldeEnvGlobal
73 |> withStateRES
74 (eo1314StateJlde .> jldeStateGlobal)
75 (\eo1314 jld -> eo1314{eo1314StateJlde = (eo1314StateJlde eo1314){jldeStateGlobal = jld}})
76
77eo1314ExpandAC :: Monad m => Maybe Text -> Value -> (JLDEParams -> JLDEParams) -> EO1314T e m Value
78eo1314ExpandAC activeProperty value fn = do
79 activeContext <- gets <| jldeStateActiveContext <. eo1314StateJlde
80 baseUrl <- asks jldeEnvBaseUrl
81 frameExpansion <- asks jldeEnvFrameExpansion
82 let params p = fn p{jldeParamsFrameExpansion = frameExpansion, jldeParamsActiveProperty = activeProperty}
83 expand activeContext value baseUrl params
84 |> withEnvRES jldeEnvGlobal
85 |> withStateRES
86 (eo1314StateJlde .> jldeStateGlobal)
87 (\eo1314 jld -> eo1314{eo1314StateJlde = (eo1314StateJlde eo1314){jldeStateGlobal = jld}})
88
89eo1314ExpandTC :: Monad m => Maybe Text -> Value -> (JLDEParams -> JLDEParams) -> EO1314T e m Value
90eo1314ExpandTC activeProperty value fn = do
91 typeContext <- gets <| eo1314StateTypeContext
92 baseUrl <- asks jldeEnvBaseUrl
93 frameExpansion <- asks jldeEnvFrameExpansion
94 let params p = fn p{jldeParamsFrameExpansion = frameExpansion, jldeParamsActiveProperty = activeProperty}
95 expand typeContext value baseUrl params
96 |> withEnvRES jldeEnvGlobal
97 |> withStateRES
98 (eo1314StateJlde .> jldeStateGlobal)
99 (\eo1314 jld -> eo1314{eo1314StateJlde = (eo1314StateJlde eo1314){jldeStateGlobal = jld}})
100
101eo1314Expand' :: Monad m => ActiveContext -> Maybe Text -> Value -> (JLDEParams -> JLDEParams) -> EO1314T e m Value
102eo1314Expand' activeContext activeProperty value fn = do
103 baseUrl <- asks <| jldeEnvBaseUrl
104 frameExpansion <- asks <| jldeEnvFrameExpansion
105 let params p = fn p{jldeParamsFrameExpansion = frameExpansion, jldeParamsActiveProperty = activeProperty}
106 expand activeContext value baseUrl params
107 |> withEnvRES jldeEnvGlobal
108 |> withStateRES
109 (eo1314StateJlde .> jldeStateGlobal)
110 (\eo1314 jld -> eo1314{eo1314StateJlde = (eo1314StateJlde eo1314){jldeStateGlobal = jld}})
111
112eo1314ExpandIriAC :: Monad m => Text -> (EIParams -> EIParams) -> EO1314T e m (Maybe Text)
113eo1314ExpandIriAC value fn = do
114 activeContext <- gets <| jldeStateActiveContext <. eo1314StateJlde
115 (value', activeContext', _) <-
116 expandIri activeContext value fn
117 |> withEnvRES jldeEnvGlobal
118 |> withStateRES
119 (eo1314StateJlde .> jldeStateGlobal)
120 (\eo1314 jld -> eo1314{eo1314StateJlde = (eo1314StateJlde eo1314){jldeStateGlobal = jld}})
121 eo1314ModifyActiveContext <| const activeContext'
122 pure value'
123
124eo1314ExpandIriTC :: Monad m => Text -> (EIParams -> EIParams) -> EO1314T e m (Maybe Text)
125eo1314ExpandIriTC value fn = do
126 typeContext <- gets <| eo1314StateTypeContext
127 (value', typeContext', _) <-
128 expandIri typeContext value fn
129 |> withEnvRES jldeEnvGlobal
130 |> withStateRES
131 (eo1314StateJlde .> jldeStateGlobal)
132 (\eo1314 jld -> eo1314{eo1314StateJlde = (eo1314StateJlde eo1314){jldeStateGlobal = jld}})
133 eo1314ModifyTypeContext <| const typeContext'
134 pure value'
135
136eo1314ExpandValue :: Monad m => Text -> Value -> EO1314T e m Object
137eo1314ExpandValue activeProperty value = do
138 expandValue activeProperty value
139 |> withStateRES eo1314StateJlde (\eo1314 jld -> eo1314{eo1314StateJlde = jld})
140
141eo1314ExpandKeywordItem :: Monad m => Maybe Text -> Key -> Keyword -> Value -> EO1314T e m ()
142eo1314ExpandKeywordItem inputType key keyword value = do
143 JLDEEnv{..} <- ask
144 let JLDEnv{..} = jldeEnvGlobal
145
146 -- 13.4.1.
147 when (jldeEnvActiveProperty == Just (show KeywordReverse)) <| throwError InvalidReversePropertyMap
148
149 -- 13.4.2.
150 containsProp <- gets (eo1314StateResult .> KM.member (show keyword))
151 when (containsProp && keyword /= KeywordIncluded && keyword /= KeywordType) <| throwError (CollidingKeywords (K.toText key) keyword)
152
153 maybeExpandedValue <- case keyword of
154 -- 13.4.3.
155 KeywordId -> case value of
156 String stringValue -> do
157 maybeExpandedStringValue <- eo1314ExpandIriAC stringValue \params ->
158 params
159 { eiParamsDocumentRelative = True
160 , eiParamsVocab = False
161 }
162 case maybeExpandedStringValue of
163 Just expandedStringValue
164 | jldeEnvFrameExpansion -> pure <. Just <. Array <. V.singleton <| String expandedStringValue
165 | otherwise -> pure <. Just <| String expandedStringValue
166 Nothing -> pure <| Just Null
167 --
168 Object (KM.null -> True) | jldeEnvFrameExpansion -> do
169 pure <. Just <. Array <. V.singleton <| Object mempty
170 --
171 Array (allStrings -> Just arrayValue) | jldeEnvFrameExpansion && not (V.null arrayValue) -> do
172 Just <. Array <. V.concat <. V.toList <$> forM arrayValue \item -> do
173 V.singleton <. maybe Null String <$> eo1314ExpandIriAC item \params ->
174 params
175 { eiParamsDocumentRelative = True
176 , eiParamsVocab = False
177 }
178 --
179 _ -> throwError <| InvalidKeywordValue keyword value
180 -- 13.4.4.
181 KeywordType -> do
182 expandedValue <- case value of
183 -- 13.4.4.4.
184 String stringValue -> do
185 maybe Null String <$> eo1314ExpandIriTC stringValue \params ->
186 params
187 { eiParamsDocumentRelative = True
188 , eiParamsVocab = True
189 }
190 -- 13.4.4.2. 13.4.4.3.
191 Object objectValue
192 -- 13.4.4.2.
193 | jldeEnvFrameExpansion && KM.null objectValue ->
194 pure value
195 -- 13.4.4.3.
196 | jldeEnvFrameExpansion
197 , Just (String defaultValue) <- KM.lookup (show KeywordDefault) objectValue
198 , Right _ <- parseIRI defaultValue -> do
199 Object <. KM.singleton (show KeywordDefault) <. maybe Null String <$> eo1314ExpandIriTC defaultValue \params ->
200 params
201 { eiParamsDocumentRelative = True
202 , eiParamsVocab = True
203 }
204 -- 13.4.4.4.
205 Array (allStrings -> Just arrayValue) ->
206 Array <. V.concat <. V.toList <$> forM arrayValue \item -> do
207 V.singleton <. maybe Null String <$> eo1314ExpandIriTC item \params ->
208 params
209 { eiParamsDocumentRelative = True
210 , eiParamsVocab = True
211 }
212 -- 13.4.4.1.
213 _ -> throwError <| InvalidKeywordValue keyword value
214
215 -- 13.4.4.5.
216 gets <| eo1314StateResult .> KM.lookup (show KeywordType) .> \case
217 Just (Array typeValue) -> Just <. Array <| V.snoc typeValue expandedValue
218 Just typeValue -> Just <. Array <| V.fromList [typeValue, expandedValue]
219 Nothing -> Just expandedValue
220 -- 13.4.5.
221 KeywordGraph -> Just <. Array <. valueToArray <$> eo1314ExpandTC (Just <| show KeywordGraph) value id
222 -- 13.4.6.
223 KeywordIncluded
224 -- 13.4.6.1.
225 | JLD1_0 <- jldEnvProcessingMode -> pure Nothing
226 -- 13.4.6.2.
227 | otherwise -> do
228 expandedValue <- valueToArray <$> eo1314ExpandAC Nothing value id
229
230 when (V.null expandedValue) <| throwError (InvalidKeywordValue keyword value)
231
232 -- 13.4.6.3.
233 when (any isNotNodeObject expandedValue) <| throwError (InvalidKeywordValue keyword value)
234
235 -- 13.4.6.4.
236 gets <| eo1314StateResult .> KM.lookup (show KeywordIncluded) .> \case
237 Just (Array includedValue) -> Just <. Array <| includedValue <> expandedValue
238 Just includedValue -> Just <. Array <| V.singleton includedValue <> expandedValue
239 Nothing -> Just <| Array expandedValue
240 -- 13.4.7.
241 KeywordValue -> do
242 expandedValue <- case value of
243 -- 13.4.7.1.
244 _ | inputType == Just (show KeywordJson) -> do
245 if jldEnvProcessingMode == JLD1_0
246 then throwError InvalidValueObjectValue
247 else pure value
248 -- 13.4.7.2.
249 _ | value == Null || valueIsScalar value -> do
250 if jldeEnvFrameExpansion
251 then pure <. Array <| V.singleton value
252 else pure value
253 Object (KM.null -> True) | jldeEnvFrameExpansion -> pure <. Array <| V.singleton value
254 Array (all valueIsString -> True) | jldeEnvFrameExpansion -> pure value
255 --
256 _ -> throwError InvalidValueObjectValue
257
258 -- 13.4.7.4.
259 case expandedValue of
260 Null -> Nothing <$ eo1314ModifyResult (KM.insert (show KeywordValue) Null)
261 _ -> pure <| Just expandedValue
262 -- 13.4.8.
263 KeywordLanguage -> case value of
264 String stringValue
265 | jldeEnvFrameExpansion -> pure <. Just <. Array <. V.singleton <. String <| T.toLower stringValue
266 | otherwise -> pure <. Just <. String <| T.toLower stringValue
267 Object (KM.null -> True) | jldeEnvFrameExpansion -> pure <| Just value
268 Array (all valueIsString -> True) | jldeEnvFrameExpansion -> pure <| Just value
269 _ -> throwError InvalidLanguageTaggedString
270 -- 13.4.9.
271 KeywordDirection
272 | JLD1_0 <- jldEnvProcessingMode -> pure Nothing
273 | otherwise -> case value of
274 String ((`elem` ["ltr", "rtl"]) -> True)
275 | jldeEnvFrameExpansion -> pure <. Just <. Array <| V.singleton value
276 | otherwise -> pure <| Just value
277 Object (KM.null -> True) | jldeEnvFrameExpansion -> pure <| Just value
278 Array (all valueIsString -> True) | jldeEnvFrameExpansion -> pure <| Just value
279 _ -> throwError InvalidBaseDirection
280 -- 13.4.10.
281 KeywordIndex
282 | String _ <- value -> pure <| Just value
283 | otherwise -> throwError <| InvalidKeywordValue keyword value
284 -- 13.4.11.
285 KeywordList
286 -- 13.4.11.1.
287 | maybe True (== show KeywordGraph) jldeEnvActiveProperty -> pure Nothing
288 -- 13.4.11.2.
289 | otherwise -> do
290 expandedValue <- eo1314ExpandAC jldeEnvActiveProperty value id
291 case expandedValue of
292 Array _ -> pure <| Just expandedValue
293 _ -> pure <. Just <. Array <| V.singleton expandedValue
294 -- 13.4.12.
295 KeywordSet -> Just <$> eo1314ExpandAC jldeEnvActiveProperty value id
296 -- 13.4.13.
297 KeywordReverse
298 -- 13.4.13.2.
299 | Object _ <- value ->
300 eo1314ExpandAC (Just <| show KeywordReverse) value id >>= \case
301 Object expandedObjectValue -> do
302 -- 13.4.13.3.
303 case KM.lookup (show KeywordReverse) expandedObjectValue of
304 Just (Object rev) -> iforM_ rev \key' item -> eo1314ModifyResult <| mapAddValue key' item True
305 _ -> pure ()
306
307 -- 13.4.13.4.
308 unless (KM.size expandedObjectValue == 1 && KM.member (show KeywordReverse) expandedObjectValue) do
309 reverseMap <- gets <| getMapDefault (show KeywordReverse) <. eo1314StateResult
310 reverseMap' <-
311 (\fn -> ifoldlM fn reverseMap expandedObjectValue) <| \key' rm -> \case
312 Array item | key' /= show KeywordReverse -> do
313 (\fn -> foldlM fn rm item) <| \rm' i ->
314 if isListObject i || isValueObject i
315 then throwError <| InvalidReversePropertyValue
316 else pure <| mapAddValue key' i True rm'
317 _ -> pure rm
318
319 if KM.null reverseMap'
320 then eo1314ModifyResult <| KM.delete (show KeywordReverse)
321 else eo1314ModifyResult <| KM.insert (show KeywordReverse) (Object reverseMap')
322
323 -- 13.4.13.5.
324 pure Nothing
325 --
326 _ -> pure <| Just Null
327 -- 13.4.13.1.
328 | otherwise -> throwError <| InvalidKeywordValue keyword value
329 -- 13.4.14.
330 KeywordNest -> Nothing <$ eo1314ModifyNest (S.insert key)
331 --
332 _ -> pure Nothing
333
334 case maybeExpandedValue of
335 Just expandedValue -> do
336 -- 13.4.15.
337 expandedValue' <-
338 if jldeEnvFrameExpansion && keyword `elem` [KeywordDefault, KeywordEmbed, KeywordExplicit, KeywordOmitDefault, KeywordRequireAll]
339 then eo1314ExpandAC (Just <| show keyword) expandedValue id
340 else pure expandedValue
341
342 -- 13.4.16.
343 unless (expandedValue' == Null && keyword == KeywordValue && inputType /= Just (show KeywordJson))
344 <| eo1314ModifyResult (KM.insert (show keyword) expandedValue')
345 --
346 Nothing -> pure ()
347
348eo1314ExpandNonKeywordItem :: Monad m => Key -> Text -> Value -> EO1314T e m ()
349eo1314ExpandNonKeywordItem key expandedProperty value = do
350 -- 13.5.
351 keyTermDefinition <- gets <| lookupTerm (K.toText key) <. jldeStateActiveContext <. eo1314StateJlde
352 defaultBaseDirection <- gets <| activeContextDefaultBaseDirection <. jldeStateActiveContext <. eo1314StateJlde
353
354 let containerMapping = maybe mempty termDefinitionContainerMapping keyTermDefinition
355 -- 13.7.2.
356 direction = (keyTermDefinition >>= termDefinitionDirectionMapping) <|> defaultBaseDirection
357 -- 13.8.2.
358 indexKey = fromMaybe (show KeywordIndex) (keyTermDefinition >>= termDefinitionIndexMapping)
359
360 expandedValue <- case value of
361 -- 13.6.
362 _ | (keyTermDefinition >>= termDefinitionTypeMapping) == Just (show KeywordJson) -> do
363 pure
364 <| object
365 [ show KeywordValue .= value
366 , show KeywordType .= String (show KeywordJson)
367 ]
368 -- 13.7.
369 Object objectValue
370 | S.member (show KeywordLanguage) containerMapping ->
371 -- 13.7.4.
372 Array <. V.concat <$> forM (KM.toList objectValue) \(langCode, langValue) ->
373 -- 13.7.4.1. 13.7.4.2.
374 flip V.mapMaybeM (valueToArray langValue) \case
375 -- 13.7.4.2.1.
376 Null -> pure Nothing
377 --
378 String item -> do
379 -- 13.7.4.2.3.
380 let langMap = KM.singleton (show KeywordValue) (String item)
381
382 -- 13.7.4.2.4.
383 langMap' <-
384 if langCode /= show KeywordNone
385 then do
386 expandedLangCode <- maybe Null String <$> eo1314ExpandIriAC (K.toText langCode) \params -> params{eiParamsVocab = True}
387 if expandedLangCode /= show KeywordNone
388 then pure <| KM.insert (show KeywordLanguage) (String <. T.toLower <| K.toText langCode) langMap
389 else pure langMap
390 else pure langMap
391
392 -- 13.7.4.2.5.
393 let langMap'' = case direction of
394 Nothing -> langMap'
395 Just NoDirection -> langMap'
396 Just dir -> KM.insert (show KeywordDirection) (String <| show dir) langMap'
397
398 -- 13.7.4.2.6.
399 pure <. Just <| Object langMap''
400 -- 13.7.4.2.2.
401 _ -> throwError <| InvalidLanguageMapValue
402 -- 13.8.
403 | S.member (show KeywordIndex) containerMapping
404 || S.member (show KeywordType) containerMapping
405 || S.member (show KeywordId) containerMapping ->
406 Array <. fmap Object <. V.concat <$> forM (KM.toList objectValue) \(index, indexValue) -> do
407 -- 13.8.3.1.
408 mapContext <- gets <| jldeStateActiveContext <. eo1314StateJlde
409
410 let mapContext' = case activeContextPreviousContext mapContext of
411 Just previousContext
412 | S.member (show KeywordId) containerMapping || S.member (show KeywordType) containerMapping ->
413 previousContext
414 _ -> mapContext
415
416 mapContext'' <- case lookupTerm (K.toText index) mapContext' of
417 -- 13.8.3.2.
418 Just termDefinition
419 | Just localContext <- termDefinitionLocalContext termDefinition
420 , S.member (show KeywordType) containerMapping ->
421 eo1314BuildActiveContext mapContext' localContext (termDefinitionBaseUrl termDefinition) id
422 -- 13.8.3.3.
423 _ -> pure mapContext'
424
425 -- 13.8.3.4.
426 expandedIndex <-
427 maybe Null String <$> eo1314ExpandIriAC (K.toText index) \params ->
428 params
429 { eiParamsVocab = True
430 }
431
432 -- 13.8.3.6.
433 indexValue' <-
434 eo1314Expand' mapContext'' (Just <| K.toText key) (Array <| valueToArray indexValue) \params ->
435 params
436 { jldeParamsFromMap = True
437 }
438
439 -- 13.8.3.7.
440 -- 13.8.3.7.1.
441 let ensureGraphObject item =
442 if S.member (show KeywordGraph) containerMapping && isNotGraphObject item
443 then Object <| toGraphObject item
444 else item
445
446 forM (valueToArray indexValue') <| ensureGraphObject .> \case
447 Object item
448 -- 13.8.3.7.2.
449 | S.member (show KeywordIndex) containerMapping
450 , indexKey /= show KeywordIndex
451 , expandedIndex /= show KeywordNone -> do
452 -- 13.8.3.7.2.1.
453 reExpandedIndex <- eo1314ExpandValue indexKey (String <| K.toText index)
454
455 -- 13.8.3.7.2.2.
456 expandedIndexKey <-
457 fmap K.fromText <$> eo1314ExpandIriAC indexKey \params ->
458 params
459 { eiParamsVocab = True
460 }
461
462 -- 13.8.3.7.2.3.
463 let maybeExistingValues = expandedIndexKey >>= (`KM.lookup` item)
464
465 indexPropertyValues =
466 V.singleton (Object reExpandedIndex)
467 |> case maybeExistingValues of
468 Just (Array existingValues) -> (<> existingValues)
469 Just existingValue -> (`V.snoc` existingValue)
470 Nothing -> id
471
472 -- 13.8.3.7.2.4.
473 let item' = case expandedIndexKey of
474 Just eiKey -> item |> KM.insert eiKey (Array indexPropertyValues)
475 Nothing -> item
476
477 -- 13.8.3.7.2.5.
478 when (isValueObject' item' && KM.size item' > 1) <| throwError InvalidValueObject
479
480 pure item'
481 -- 13.8.3.7.3.
482 | S.member (show KeywordIndex) containerMapping
483 , not (KM.member (show KeywordIndex) item)
484 , expandedIndex /= show KeywordNone ->
485 pure <. KM.insert (show KeywordIndex) (String <| K.toText index) <| item
486 -- 13.8.3.7.4.
487 | S.member (show KeywordId) containerMapping
488 , not (KM.member (show KeywordId) item)
489 , expandedIndex /= show KeywordNone -> do
490 expandedIndex' <- eo1314ExpandIriAC (K.toText index) \params ->
491 params
492 { eiParamsVocab = False
493 , eiParamsDocumentRelative = True
494 }
495 pure <| KM.insert (show KeywordId) (maybe Null String expandedIndex') item
496 -- 13.8.3.7.5.
497 | S.member (show KeywordType) containerMapping
498 , expandedIndex /= show KeywordNone -> do
499 let types = case KM.lookup (show KeywordType) item of
500 Just existingType -> V.cons expandedIndex <| valueToArray existingType
501 Nothing -> V.singleton expandedIndex
502 pure <. KM.insert (show KeywordType) (Array types) <| item
503 -- 13.8.3.7.6.
504 | otherwise -> pure item
505 --
506 _ -> pure mempty
507 -- 13.9.
508 _ -> eo1314ExpandAC (Just <| K.toText key) value id
509
510 -- 13.10.
511 when (expandedValue /= Null) do
512 -- 13.11.
513 let expandedValue' =
514 if S.member (show KeywordList) containerMapping && isNotListObject expandedValue
515 then toListObject expandedValue
516 else expandedValue
517
518 -- 13.12.
519 let expandedValue'' =
520 if S.member (show KeywordGraph) containerMapping
521 && not (S.member (show KeywordId) containerMapping)
522 && not (S.member (show KeywordIndex) containerMapping)
523 then Array <| Object <. toGraphObject <$> valueToArray expandedValue'
524 else expandedValue'
525
526 -- 13.13.
527 if maybe False termDefinitionReversePropertyFlag keyTermDefinition
528 then do
529 reverseMap <- gets <| getMapDefault (show KeywordReverse) <. eo1314StateResult
530
531 -- 13.13.3. 13.13.4.
532 reverseMap' <-
533 (\fn -> foldlM fn reverseMap (valueToArray expandedValue'')) <| \rm item ->
534 if isListObject item || isValueObject item
535 then -- 13.13.4.1.
536 throwError InvalidReversePropertyValue
537 else -- 13.13.4.3.
538 pure <| mapAddValue (K.fromText expandedProperty) item True rm
539
540 eo1314ModifyResult <| KM.insert (show KeywordReverse) (Object reverseMap')
541 else -- 13.14.
542 eo1314ModifyResult <| mapAddValue (K.fromText expandedProperty) expandedValue'' True
543
544eo1314ExpandItem :: Monad m => Maybe Text -> Key -> Value -> EO1314T e m ()
545eo1314ExpandItem _ ((== K.fromText (show KeywordContext)) -> True) _ = pure () -- 13.1.
546eo1314ExpandItem inputType key value = do
547 -- 13.2. 13.3.
548 maybeExpandedProperty <- eo1314ExpandIriAC (K.toText key) \params ->
549 params
550 { eiParamsDocumentRelative = False
551 , eiParamsVocab = True
552 }
553
554 case maybeExpandedProperty of
555 Just expandedProperty
556 -- 13.4.
557 | Just keyword <- parseKeyword expandedProperty -> eo1314ExpandKeywordItem inputType key keyword value
558 -- 13.5.
559 | ':' `T.elem` expandedProperty -> eo1314ExpandNonKeywordItem key expandedProperty value
560 --
561 _ -> pure ()
562
563eo1314Recurse :: Monad m => Text -> Maybe Text -> Object -> EO1314T e m ()
564eo1314Recurse activeProperty inputType value = do
565 -- 3. 8.
566 activeContext <- gets <| jldeStateActiveContext <. eo1314StateJlde
567 case lookupTerm activeProperty activeContext of
568 Just propertyDefinition | Just propertyContext <- termDefinitionLocalContext propertyDefinition -> do
569 activeContext' <- eo1314BuildActiveContext activeContext propertyContext (termDefinitionBaseUrl propertyDefinition) \params ->
570 params
571 { bacParamsOverrideProtected = True
572 }
573 eo1314ModifyActiveContext <| const activeContext'
574 _ -> pure ()
575
576 expandObject1314' inputType value
577
578expandObject1314' :: Monad m => Maybe Text -> Object -> EO1314T e m ()
579expandObject1314' inputType value = do
580 -- 13.
581 iforM_ value <| eo1314ExpandItem inputType
582
583 -- 14.
584 gets eo1314StateNest >>= mapM_ \nestedKey ->
585 KM.lookup nestedKey value |> fmap valueToArray .> fromMaybe mempty .> mapM_ \case
586 Object nestValue -> do
587 forM_ (KM.keys nestValue) \nestedValueKey -> do
588 -- 14.2.1.
589 expandedNestedValueKey <- eo1314ExpandIriTC (K.toText nestedValueKey) \params -> params{eiParamsVocab = True}
590 when (expandedNestedValueKey == Just (show KeywordValue)) <| throwError (InvalidKeywordValue KeywordNest (Object nestValue))
591 -- 14.2.2.
592 eo1314ModifyNest <| const mempty
593 eo1314Recurse (K.toText nestedKey) inputType nestValue
594 -- 14.2.1.
595 invalid -> throwError <| InvalidKeywordValue KeywordNest invalid
596
597--
598
599eoExpandObject1314 :: Monad m => ActiveContext -> Maybe Text -> Object -> JLDET e m Object
600eoExpandObject1314 typeContext inputType value = do
601 EO1314State{..} <-
602 (expandObject1314' inputType value >> get)
603 |> withStateRES
604 ( \jld ->
605 EO1314State
606 { eo1314StateJlde = jld
607 , eo1314StateNest = mempty
608 , eo1314StateResult = mempty
609 , eo1314StateTypeContext = typeContext
610 }
611 )
612 (const eo1314StateJlde)
613 pure eo1314StateResult
614
615eoNormalizeObject :: Monad m => Object -> JLDET e m Value
616eoNormalizeObject result
617 -- 18.
618 | KM.size result == 1 && KM.member (show KeywordLanguage) result = pure Null
619 --
620 | otherwise = do
621 JLDEEnv{..} <- ask
622
623 if
624 -- 19.1.
625 | maybe True (== show KeywordGraph) jldeEnvActiveProperty
626 , not jldeEnvFrameExpansion
627 , KM.null result || KM.member (show KeywordValue) result || KM.member (show KeywordList) result ->
628 pure Null
629 -- 19.2.
630 | maybe True (== show KeywordGraph) jldeEnvActiveProperty
631 , not jldeEnvFrameExpansion
632 , KM.size result == 1
633 , KM.member (show KeywordId) result ->
634 pure Null
635 --
636 | otherwise ->
637 pure <| Object result
638
639expandObject :: Monad m => Maybe Value -> Object -> JLDET e m Value
640expandObject maybePropertyContext value = do
641 JLDEEnv{..} <- ask
642
643 -- 7.
644 gets (jldeStateActiveContext .> activeContextPreviousContext) >>= \case
645 Just previousContext | not jldeEnvFromMap -> do
646 noRevert <- flip anyM (KM.keys value) \k -> do
647 expanded <- exExpandIri <| K.toText k
648 pure <| expanded == Just (show KeywordValue) || (expanded == Just (show KeywordId) && KM.size value == 1)
649 unless noRevert <| exModifyActiveContext (const previousContext)
650 --
651 _ -> pure ()
652
653 -- 8.
654 case (jldeEnvActiveProperty, maybePropertyContext) of
655 (Just activeProperty, Just propertyContext) -> do
656 baseUrl' <- gets (jldeStateActiveContext .> lookupTerm activeProperty >=> termDefinitionBaseUrl)
657 exBuildActiveContext baseUrl' propertyContext \params -> params{bacParamsOverrideProtected = True}
658 --
659 _ -> pure ()
660
661 -- 9.
662 case KM.lookup (show KeywordContext) value of
663 Just context -> exBuildActiveContext (Just jldeEnvBaseUrl) context id
664 --
665 _ -> pure ()
666
667 -- 10.
668 typeContext <- gets jldeStateActiveContext
669
670 -- 11.
671 inputType <- do
672 maybeType <-
673 value |> ifindM \key item -> do
674 -- 11.2.
675 isType <- (Just (show KeywordType) ==) <$> exExpandIri (K.toText key)
676
677 when isType do
678 valueToArray item |> fmap valueToString .> V.catMaybes .> V.modify V.sort .> mapM_ \term ->
679 case lookupTerm term typeContext >>= termDefinitionLocalContext of
680 Just localContext -> do
681 valueBaseUrl <- gets <| termDefinitionBaseUrl <=< lookupTerm term <. jldeStateActiveContext
682 exBuildActiveContext valueBaseUrl localContext \params ->
683 params
684 { bacParamsPropagate = False
685 }
686 _ -> pure ()
687
688 pure isType
689
690 case maybeType of
691 Just (Array type') | not (V.null type') -> exExpandIri <. V.maximum <. V.catMaybes <| valueToString <$> type'
692 Just (String type') -> exExpandIri type'
693 --
694 _ -> pure Nothing
695
696 -- 13. 14.
697 result <- eoExpandObject1314 typeContext inputType value
698
699 if
700 -- 15.
701 | Just resultValue <- KM.lookup (show KeywordValue) result -> do
702 -- 15.1.
703 when (isNotValueObject' result) <| throwError InvalidValueObject
704 when
705 ( KM.member (show KeywordType) result
706 && (KM.member (show KeywordDirection) result || KM.member (show KeywordLanguage) result)
707 )
708 <| throwError InvalidValueObject
709
710 case KM.lookup (show KeywordType) result of
711 -- 15.2.
712 Just type' | valueContains (show KeywordJson) type' -> do
713 eoNormalizeObject result
714 _
715 -- 15.3.
716 | resultValue == Null || valueIsEmptyArray resultValue ->
717 pure Null
718 -- 15.4.
719 | not jldeEnvFrameExpansion
720 , valueIsNotString resultValue
721 , KM.member (show KeywordLanguage) result ->
722 throwError InvalidLanguageTaggedValue
723 -- 15.5.
724 Just (String (parseIRI -> Left _)) | not jldeEnvFrameExpansion -> do
725 throwError InvalidTypedValue
726 Just (valueIsNotString -> True) | not jldeEnvFrameExpansion -> do
727 throwError InvalidTypedValue
728 --
729 _ -> eoNormalizeObject result
730 -- 16.
731 | Just resultType <- KM.lookup (show KeywordType) result ->
732 eoNormalizeObject
733 <| if valueIsNotArray resultType && valueIsNotNull resultType
734 then KM.insert (show KeywordType) (Array <| V.singleton resultType) result
735 else result
736 -- 17.
737 | KM.member (show KeywordList) result || KM.member (show KeywordSet) result -> do
738 -- 17.1.
739 when (KM.size result > 2 || (KM.size result == 2 && not (KM.member (show KeywordIndex) result)))
740 <| throwError InvalidSetOrListObject
741 -- 17.2.
742 if
743 | Just (Object set) <- KM.lookup (show KeywordSet) result -> eoNormalizeObject set
744 | Just set <- KM.lookup (show KeywordSet) result -> pure set
745 | otherwise -> eoNormalizeObject result
746 --
747 | otherwise -> eoNormalizeObject result
748
749--
750
751expandArrayItem :: Monad m => Value -> JLDET e m Array
752expandArrayItem item = do
753 JLDEEnv{..} <- ask
754
755 -- 5.2.1.
756 item' <- exExpand item id
757
758 -- 5.2.2.
759 activeContext <- gets jldeStateActiveContext
760 let item'' = case item' of
761 Array a
762 | Just activeProperty <- jldeEnvActiveProperty
763 , Just term <- lookupTerm activeProperty activeContext
764 , S.member (show KeywordList) (termDefinitionContainerMapping term) ->
765 toListObject <| Array a
766 _ -> item'
767
768 case item'' of
769 -- 5.2.3.
770 Array a -> pure <| V.filter valueIsNotNull a
771 Null -> pure mempty
772 _ -> pure <| V.singleton item''
773
774--
775
776expandValue :: Monad m => Text -> Value -> JLDET e m Object
777expandValue activeProperty value = do
778 definition <- gets <| lookupTerm activeProperty <. jldeStateActiveContext
779
780 case definition >>= termDefinitionTypeMapping of
781 -- 1. 2.
782 Just typeMapping
783 | String stringValue <- value
784 , typeMapping `isKeyword` [KeywordId, KeywordVocab] ->
785 KM.singleton (show KeywordId) <. maybe Null String <$> evExpandIri stringValue \params ->
786 params
787 { eiParamsDocumentRelative = True
788 , eiParamsVocab = typeMapping == show KeywordVocab
789 }
790 -- 3. 4.
791 | typeMapping `isNotKeyword` [KeywordId, KeywordVocab, KeywordNone] ->
792 pure <| KM.fromList [(show KeywordType, String typeMapping), (show KeywordValue, value)]
793 -- 5.
794 _ | String _ <- value -> do
795 defaultLanguage <- gets <| activeContextDefaultLanguage <. jldeStateActiveContext
796 defaultDirection <- gets <| activeContextDefaultBaseDirection <. jldeStateActiveContext
797
798 -- 5.1. 5.2. 5.3. 5.4.
799 KM.singleton (show KeywordValue) value
800 |> case definition >>= termDefinitionLanguageMapping of
801 Nothing
802 | Just (Language def) <- defaultLanguage -> KM.insert (show KeywordLanguage) (String def)
803 | otherwise -> id
804 Just NoLanguage -> id
805 Just (Language lang) -> KM.insert (show KeywordLanguage) (String lang)
806 |> case definition >>= termDefinitionDirectionMapping of
807 Nothing
808 | Just def <- defaultDirection -> KM.insert (show KeywordDirection) (show def)
809 | otherwise -> id
810 Just NoDirection -> id
811 Just dir -> KM.insert (show KeywordDirection) (show dir)
812 |> pure
813 -- 6.
814 _ -> pure <| KM.singleton (show KeywordValue) value
815
816--
817
818data JLDEParams = JLDEParams
819 { jldeParamsFrameExpansion :: Bool
820 , jldeParamsFromMap :: Bool
821 , jldeParamsBaseUrl :: URI
822 , jldeParamsActiveProperty :: Maybe Text
823 }
824 deriving (Show, Eq)
825
826exModifyActiveContext :: Monad m => (ActiveContext -> ActiveContext) -> JLDET e m ()
827exModifyActiveContext fn = modify \st -> st{jldeStateActiveContext = fn (jldeStateActiveContext st)}
828
829evExpandIri :: Monad m => Text -> (EIParams -> EIParams) -> JLDET e m (Maybe Text)
830evExpandIri value fn = do
831 JLDEEnv{..} <- ask
832 activeContext <- gets jldeStateActiveContext
833 (value', activeContext', _) <-
834 expandIri activeContext value fn
835 |> withEnvRES (const jldeEnvGlobal)
836 |> withStateRES jldeStateGlobal (\s jlde -> s{jldeStateGlobal = jlde})
837 exModifyActiveContext <| const activeContext'
838 pure value'
839
840exExpandIri :: Monad m => Text -> JLDET e m (Maybe Text)
841exExpandIri value = do
842 JLDEEnv{..} <- ask
843 activeContext <- gets jldeStateActiveContext
844 let params p = p{eiParamsVocab = True}
845 (value', activeContext', _) <-
846 expandIri activeContext value params
847 |> withEnvRES (const jldeEnvGlobal)
848 |> withStateRES jldeStateGlobal (\s jlde -> s{jldeStateGlobal = jlde})
849 exModifyActiveContext <| const activeContext'
850 pure value'
851
852exBuildActiveContext :: Monad m => Maybe URI -> Value -> (BACParams -> BACParams) -> JLDET e m ()
853exBuildActiveContext baseUrl localContext fn = do
854 JLDEEnv{..} <- ask
855 activeContext <- gets jldeStateActiveContext
856 activeContext' <-
857 buildActiveContext activeContext localContext baseUrl fn
858 |> withEnvRES (const jldeEnvGlobal)
859 |> withStateRES jldeStateGlobal (\s jlde -> s{jldeStateGlobal = jlde})
860 exModifyActiveContext (const activeContext')
861
862exExpand :: Monad m => Value -> (JLDEParams -> JLDEParams) -> JLDET e m Value
863exExpand value fn = do
864 JLDEEnv{..} <- ask
865 activeContext <- gets jldeStateActiveContext
866 let params p = fn p{jldeParamsActiveProperty = jldeEnvActiveProperty}
867 expand activeContext value jldeEnvBaseUrl params
868 |> withEnvRES (const jldeEnvGlobal)
869 |> withStateRES jldeStateGlobal (\s jlde -> s{jldeStateGlobal = jlde})
870
871expand' :: Monad m => Value -> JLDET e m Value
872expand' = \case
873 -- 1.
874 Null -> pure Null
875 -- 5.
876 Array value -> Array <. V.concat <. V.toList <$> forM value expandArrayItem
877 -- 6.
878 Object value -> do
879 JLDEEnv{..} <- ask
880
881 -- 3.
882 maybePropertyContext <- case jldeEnvActiveProperty of
883 Just activeProperty -> gets (jldeStateActiveContext .> lookupTerm activeProperty >=> termDefinitionLocalContext)
884 Nothing -> pure Nothing
885
886 -- 6.
887 expandObject maybePropertyContext value
888 |> withEnvRES \env ->
889 env{jldeEnvFrameExpansion = jldeEnvFrameExpansion && maybePropertyContext /= Just (show KeywordDefault)}
890
891 -- 4.
892 value -> do
893 JLDEEnv{..} <- ask
894
895 maybePropertyTerm <- case jldeEnvActiveProperty of
896 Just activeProperty -> gets <| lookupTerm activeProperty <. jldeStateActiveContext
897 Nothing -> pure Nothing
898
899 case jldeEnvActiveProperty of
900 -- 4.1.
901 Nothing -> pure Null
902 --
903 Just activeProperty
904 -- 4.1.
905 | activeProperty == show KeywordGraph -> pure Null
906 -- 4.2.
907 | Just propertyTerm <- maybePropertyTerm
908 , Just propertyContext <- termDefinitionLocalContext propertyTerm -> do
909 exBuildActiveContext (termDefinitionBaseUrl propertyTerm) propertyContext id
910 Object <$> expandValue activeProperty value
911 -- 4.3.
912 | otherwise -> Object <$> expandValue activeProperty value
913
914expand :: Monad m => ActiveContext -> Value -> URI -> (JLDEParams -> JLDEParams) -> JLDT e m Value
915expand activeContext value baseUrl paramsFn =
916 expand' value
917 |> withEnvRES env
918 |> withStateRES st (const jldeStateGlobal)
919 where
920 JLDEParams{..} =
921 paramsFn
922 JLDEParams
923 { jldeParamsFrameExpansion = False
924 , jldeParamsFromMap = False
925 , jldeParamsBaseUrl = baseUrl
926 , jldeParamsActiveProperty = Nothing
927 }
928
929 env global =
930 JLDEEnv
931 { jldeEnvGlobal = global
932 , jldeEnvFrameExpansion = jldeParamsFrameExpansion
933 , jldeEnvFromMap = jldeParamsFromMap
934 , jldeEnvBaseUrl = jldeParamsBaseUrl
935 , jldeEnvActiveProperty = jldeParamsActiveProperty
936 }
937
938 st global =
939 JLDEState
940 { jldeStateGlobal = global
941 , jldeStateActiveContext = activeContext
942 }
diff --git a/src/Data/JLD/Mime.hs b/src/Data/JLD/Mime.hs
new file mode 100644
index 0000000..64158e8
--- /dev/null
+++ b/src/Data/JLD/Mime.hs
@@ -0,0 +1,6 @@
1module Data.JLD.Mime (mimeType) where
2
3import Data.JLD.Prelude
4
5mimeType :: ByteString
6mimeType = "application/ld+json"
diff --git a/src/Data/JLD/Model/ActiveContext.hs b/src/Data/JLD/Model/ActiveContext.hs
new file mode 100644
index 0000000..5423036
--- /dev/null
+++ b/src/Data/JLD/Model/ActiveContext.hs
@@ -0,0 +1,44 @@
1module Data.JLD.Model.ActiveContext ( ActiveContext (..), newActiveContext, lookupTerm, containsProtectedTerm,) where
2
3import Data.JLD.Prelude
4
5import Data.JLD.Model.Direction (Direction)
6import Data.JLD.Model.InverseContext (InverseContext)
7import Data.JLD.Model.Language (Language)
8import Data.JLD.Model.TermDefinition (TermDefinition (..))
9
10import Data.Map.Strict qualified as M (lookup)
11import Data.RDF (IRIRef)
12import Text.URI (URI)
13
14data ActiveContext = ActiveContext
15 { activeContextTerms :: Map Text TermDefinition
16 , activeContextBaseIri :: Maybe IRIRef
17 , activeContextBaseUrl :: Maybe URI
18 , activeContextInverseContext :: InverseContext
19 , activeContextPreviousContext :: Maybe ActiveContext
20 , activeContextVocabularyMapping :: Maybe Text
21 , activeContextDefaultLanguage :: Maybe Language
22 , activeContextDefaultBaseDirection :: Maybe Direction
23 }
24 deriving (Eq, Show)
25
26newActiveContext :: (ActiveContext -> ActiveContext) -> ActiveContext
27newActiveContext fn =
28 fn
29 ActiveContext
30 { activeContextTerms = mempty
31 , activeContextBaseIri = Nothing
32 , activeContextBaseUrl = Nothing
33 , activeContextInverseContext = mempty
34 , activeContextPreviousContext = Nothing
35 , activeContextVocabularyMapping = Nothing
36 , activeContextDefaultLanguage = Nothing
37 , activeContextDefaultBaseDirection = Nothing
38 }
39
40lookupTerm :: Text -> ActiveContext -> Maybe TermDefinition
41lookupTerm key ActiveContext{..} = M.lookup key activeContextTerms
42
43containsProtectedTerm :: ActiveContext -> Bool
44containsProtectedTerm = activeContextTerms .> any termDefinitionProtectedFlag
diff --git a/src/Data/JLD/Model/Direction.hs b/src/Data/JLD/Model/Direction.hs
new file mode 100644
index 0000000..2ed8e87
--- /dev/null
+++ b/src/Data/JLD/Model/Direction.hs
@@ -0,0 +1,13 @@
1module Data.JLD.Model.Direction (Direction (..)) where
2
3import Data.JLD.Prelude
4
5import Text.Show (Show (..))
6
7data Direction = LTR | RTL | NoDirection
8 deriving (Eq, Ord)
9
10instance Show Direction where
11 show LTR = "ltr"
12 show RTL = "rtl"
13 show NoDirection = "none"
diff --git a/src/Data/JLD/Model/GraphObject.hs b/src/Data/JLD/Model/GraphObject.hs
new file mode 100644
index 0000000..3db9e6b
--- /dev/null
+++ b/src/Data/JLD/Model/GraphObject.hs
@@ -0,0 +1,22 @@
1module Data.JLD.Model.GraphObject (isGraphObject, isNotGraphObject, toGraphObject) where
2
3import Data.JLD.Prelude
4
5import Data.JLD.Model.Keyword (Keyword (..), isKeyword)
6
7import Data.Aeson (Object, Value (..))
8import Data.Aeson.Key qualified as K (toText)
9import Data.Aeson.KeyMap qualified as KM (keys, singleton, member)
10import Data.Vector qualified as V (singleton)
11
12isGraphObject :: Value -> Bool
13isGraphObject (Object o)
14 | KM.member (show KeywordGraph) o =
15 all (`isKeyword` [KeywordGraph, KeywordId, KeywordIndex, KeywordContext]) (K.toText <$> KM.keys o)
16isGraphObject _ = False
17
18isNotGraphObject :: Value -> Bool
19isNotGraphObject = isGraphObject .> not
20
21toGraphObject :: Value -> Object
22toGraphObject = V.singleton .> Array .> KM.singleton (show KeywordGraph)
diff --git a/src/Data/JLD/Model/IRI.hs b/src/Data/JLD/Model/IRI.hs
new file mode 100644
index 0000000..7c054eb
--- /dev/null
+++ b/src/Data/JLD/Model/IRI.hs
@@ -0,0 +1,46 @@
1module Data.JLD.Model.IRI (
2 CompactIRI (..),
3 compactIriPrefix,
4 compactIriSuffix,
5 isBlankIri,
6 endsWithGenericDelim,
7 parseCompactIri,
8 renderCompactIri,
9) where
10
11import Data.JLD.Prelude
12
13import Data.Char (isAlphaNum)
14import Data.Text qualified as T (drop, findIndex, isPrefixOf, take, uncons, unsnoc)
15
16data CompactIRI = CompactIRI Text Text | BlankIRI Text
17 deriving (Show, Eq)
18
19compactIriPrefix :: CompactIRI -> Text
20compactIriPrefix (CompactIRI prefix _) = prefix
21compactIriPrefix (BlankIRI _) = "_"
22
23compactIriSuffix :: CompactIRI -> Text
24compactIriSuffix (CompactIRI _ suffix) = suffix
25compactIriSuffix (BlankIRI suffix) = suffix
26
27renderCompactIri :: CompactIRI -> Text
28renderCompactIri iri = compactIriPrefix iri <> ":" <> compactIriSuffix iri
29
30parseCompactIri :: Text -> Maybe CompactIRI
31parseCompactIri value
32 | Just idx <- (+ 1) <$> T.findIndex (== ':') (T.drop 1 value)
33 , prefix <- T.take idx value
34 , suffix <- T.drop (idx + 1) value
35 , not ("/" `T.isPrefixOf` suffix)
36 , Just (prefixFirst, _) <- T.uncons prefix
37 , prefixFirst == '_' || isAlphaNum prefixFirst =
38 Just <| if prefix == "_" then BlankIRI suffix else CompactIRI prefix suffix
39 | otherwise = Nothing
40
41isBlankIri :: Text -> Bool
42isBlankIri = T.isPrefixOf "_:"
43
44endsWithGenericDelim :: Text -> Bool
45endsWithGenericDelim (T.unsnoc -> Just (_, c)) = c `elem` (":/?#[]@" :: String)
46endsWithGenericDelim _ = False
diff --git a/src/Data/JLD/Model/InverseContext.hs b/src/Data/JLD/Model/InverseContext.hs
new file mode 100644
index 0000000..fe4b516
--- /dev/null
+++ b/src/Data/JLD/Model/InverseContext.hs
@@ -0,0 +1,5 @@
1module Data.JLD.Model.InverseContext (InverseContext) where
2
3import Data.JLD.Prelude
4
5type InverseContext = Map (Text, Text, Text, Text) Text
diff --git a/src/Data/JLD/Model/Keyword.hs b/src/Data/JLD/Model/Keyword.hs
new file mode 100644
index 0000000..10835a9
--- /dev/null
+++ b/src/Data/JLD/Model/Keyword.hs
@@ -0,0 +1,135 @@
1module Data.JLD.Model.Keyword (
2 Keyword (..),
3 parseKeyword,
4 isKeyword,
5 isNotKeyword,
6 allKeywords,
7 isKeywordLike,
8) where
9
10import Data.JLD.Prelude hiding (show)
11
12import Data.Char (isAlpha)
13import Data.Foldable qualified as F
14import Data.Text qualified as T (all, null, uncons)
15import Text.Show (Show (..))
16
17data Keyword
18 = KeywordAny
19 | KeywordBase
20 | KeywordContainer
21 | KeywordContext
22 | KeywordDefault
23 | KeywordDirection
24 | KeywordEmbed
25 | KeywordExplicit
26 | KeywordFirst
27 | KeywordGraph
28 | KeywordId
29 | KeywordImport
30 | KeywordIncluded
31 | KeywordIndex
32 | KeywordJson
33 | KeywordLanguage
34 | KeywordList
35 | KeywordNest
36 | KeywordNone
37 | KeywordNull
38 | KeywordOmitDefault
39 | KeywordPrefix
40 | KeywordPreserve
41 | KeywordPropagate
42 | KeywordProtected
43 | KeywordRequireAll
44 | KeywordReverse
45 | KeywordSet
46 | KeywordType
47 | KeywordValue
48 | KeywordVersion
49 | KeywordVocab
50 deriving (Eq, Ord)
51
52instance Show Keyword where
53 show = \case
54 KeywordAny -> "@any"
55 KeywordBase -> "@base"
56 KeywordContainer -> "@container"
57 KeywordContext -> "@context"
58 KeywordDefault -> "@default"
59 KeywordDirection -> "@direction"
60 KeywordEmbed -> "@embed"
61 KeywordExplicit -> "@explicit"
62 KeywordFirst -> "@first"
63 KeywordGraph -> "@graph"
64 KeywordId -> "@id"
65 KeywordImport -> "@import"
66 KeywordIncluded -> "@included"
67 KeywordIndex -> "@index"
68 KeywordJson -> "@json"
69 KeywordLanguage -> "@language"
70 KeywordList -> "@list"
71 KeywordNest -> "@nest"
72 KeywordNone -> "@none"
73 KeywordNull -> "@null"
74 KeywordOmitDefault -> "@omitDefault"
75 KeywordPrefix -> "@prefix"
76 KeywordPreserve -> "@preserve"
77 KeywordPropagate -> "@propagate"
78 KeywordProtected -> "@protected"
79 KeywordRequireAll -> "@requireAll"
80 KeywordReverse -> "@reverse"
81 KeywordSet -> "@set"
82 KeywordType -> "@type"
83 KeywordValue -> "@value"
84 KeywordVersion -> "@version"
85 KeywordVocab -> "@vocab"
86
87parseKeyword :: Text -> Maybe Keyword
88parseKeyword = \case
89 "@any" -> Just KeywordAny
90 "@base" -> Just KeywordBase
91 "@container" -> Just KeywordContainer
92 "@context" -> Just KeywordContext
93 "@default" -> Just KeywordDefault
94 "@direction" -> Just KeywordDirection
95 "@embed" -> Just KeywordEmbed
96 "@explicit" -> Just KeywordExplicit
97 "@first" -> Just KeywordFirst
98 "@graph" -> Just KeywordGraph
99 "@id" -> Just KeywordId
100 "@import" -> Just KeywordImport
101 "@included" -> Just KeywordIncluded
102 "@index" -> Just KeywordIndex
103 "@json" -> Just KeywordJson
104 "@language" -> Just KeywordLanguage
105 "@list" -> Just KeywordList
106 "@nest" -> Just KeywordNest
107 "@none" -> Just KeywordNone
108 "@null" -> Just KeywordNull
109 "@omitDefault" -> Just KeywordOmitDefault
110 "@prefix" -> Just KeywordPrefix
111 "@preserve" -> Just KeywordPreserve
112 "@propagate" -> Just KeywordPropagate
113 "@protected" -> Just KeywordProtected
114 "@requireAll" -> Just KeywordRequireAll
115 "@reverse" -> Just KeywordReverse
116 "@set" -> Just KeywordSet
117 "@type" -> Just KeywordType
118 "@value" -> Just KeywordValue
119 "@version" -> Just KeywordVersion
120 "@vocab" -> Just KeywordVocab
121 _ -> Nothing
122
123isKeyword :: Foldable f => Text -> f Keyword -> Bool
124isKeyword (parseKeyword -> Just keyword) (F.elem keyword -> True) = True
125isKeyword _ _ = False
126
127isNotKeyword :: Foldable f => Text -> f Keyword -> Bool
128isNotKeyword s = isKeyword s .> not
129
130allKeywords :: Foldable f => f Text -> f Keyword -> Bool
131allKeywords values keywords = all (`isKeyword` keywords) values
132
133isKeywordLike :: Text -> Bool
134isKeywordLike (T.uncons -> Just ('@', res)) = not (T.null res) && T.all isAlpha res
135isKeywordLike _ = False
diff --git a/src/Data/JLD/Model/Language.hs b/src/Data/JLD/Model/Language.hs
new file mode 100644
index 0000000..c24994e
--- /dev/null
+++ b/src/Data/JLD/Model/Language.hs
@@ -0,0 +1,6 @@
1module Data.JLD.Model.Language (Language (..)) where
2
3import Data.JLD.Prelude
4
5data Language = Language Text | NoLanguage
6 deriving (Show, Eq)
diff --git a/src/Data/JLD/Model/ListObject.hs b/src/Data/JLD/Model/ListObject.hs
new file mode 100644
index 0000000..8dda349
--- /dev/null
+++ b/src/Data/JLD/Model/ListObject.hs
@@ -0,0 +1,24 @@
1module Data.JLD.Model.ListObject (isListObject, isNotListObject, toListObject) where
2
3import Data.JLD.Prelude
4
5import Data.JLD.Model.Keyword (Keyword (..))
6
7import Data.Aeson (Value (..))
8import Data.Aeson.KeyMap qualified as KM
9import Data.Vector qualified as V
10
11isListObject :: Value -> Bool
12isListObject (Object o) =
13 KM.member (show KeywordList) o
14 && ( KM.size o == 1
15 || (KM.size o == 2 && KM.member (show KeywordIndex) o)
16 )
17isListObject _ = False
18
19isNotListObject :: Value -> Bool
20isNotListObject = isListObject .> not
21
22toListObject :: Value -> Value
23toListObject value@(Array _) = Object <| KM.singleton (show KeywordList) value
24toListObject value = Object <| KM.singleton (show KeywordList) (Array <| V.singleton value)
diff --git a/src/Data/JLD/Model/NodeObject.hs b/src/Data/JLD/Model/NodeObject.hs
new file mode 100644
index 0000000..d0bb4c5
--- /dev/null
+++ b/src/Data/JLD/Model/NodeObject.hs
@@ -0,0 +1,21 @@
1module Data.JLD.Model.NodeObject (isNodeObject, isNotNodeObject) where
2
3import Data.JLD.Prelude
4
5import Data.JLD.Model.Keyword (Keyword (..))
6
7import Data.Aeson (Value (..))
8import Data.Aeson.Key qualified as K
9import Data.Aeson.KeyMap qualified as KM
10
11isNodeObject :: Value -> Bool
12isNodeObject (Object o) =
13 ( not (KM.member (show KeywordValue) o)
14 && not (KM.member (show KeywordList) o)
15 && not (KM.member (show KeywordSet) o)
16 )
17 || (KM.keys o == ([KeywordContext, KeywordGraph] <&> show .> K.fromText))
18isNodeObject _ = False
19
20isNotNodeObject :: Value -> Bool
21isNotNodeObject = isNodeObject .> not
diff --git a/src/Data/JLD/Model/TermDefinition.hs b/src/Data/JLD/Model/TermDefinition.hs
new file mode 100644
index 0000000..5f39eee
--- /dev/null
+++ b/src/Data/JLD/Model/TermDefinition.hs
@@ -0,0 +1,43 @@
1module Data.JLD.Model.TermDefinition (TermDefinition (..), newTermDefinition) where
2
3import Data.JLD.Prelude
4
5import Data.JLD.Model.Direction (Direction)
6import Data.JLD.Model.Language (Language)
7
8import Data.Aeson (Value)
9import Text.URI (URI)
10
11data TermDefinition = TermDefinition
12 { termDefinitionIriMapping :: Maybe Text
13 , termDefinitionPrefixFlag :: Bool
14 , termDefinitionProtectedFlag :: Bool
15 , termDefinitionReversePropertyFlag :: Bool
16 , termDefinitionBaseUrl :: Maybe URI
17 , termDefinitionLocalContext :: Maybe Value
18 , termDefinitionContainerMapping :: Set Text
19 , termDefinitionIndexMapping :: Maybe Text
20 , termDefinitionNestValue :: Maybe Text
21 , termDefinitionTypeMapping :: Maybe Text
22 , termDefinitionDirectionMapping :: Maybe Direction
23 , termDefinitionLanguageMapping :: Maybe Language
24 }
25 deriving (Show, Eq)
26
27newTermDefinition :: Bool -> (TermDefinition -> TermDefinition) -> TermDefinition
28newTermDefinition protectedFlag fn =
29 fn
30 TermDefinition
31 { termDefinitionIriMapping = Nothing
32 , termDefinitionPrefixFlag = False
33 , termDefinitionProtectedFlag = protectedFlag
34 , termDefinitionReversePropertyFlag = False
35 , termDefinitionBaseUrl = Nothing
36 , termDefinitionLocalContext = Nothing
37 , termDefinitionContainerMapping = mempty
38 , termDefinitionIndexMapping = Nothing
39 , termDefinitionNestValue = Nothing
40 , termDefinitionTypeMapping = Nothing
41 , termDefinitionDirectionMapping = Nothing
42 , termDefinitionLanguageMapping = Nothing
43 }
diff --git a/src/Data/JLD/Model/URI.hs b/src/Data/JLD/Model/URI.hs
new file mode 100644
index 0000000..07cf8a9
--- /dev/null
+++ b/src/Data/JLD/Model/URI.hs
@@ -0,0 +1,13 @@
1module Data.JLD.Model.URI (parseUri, uriToIri) where
2
3import Data.JLD.Prelude
4
5import Data.RDF (IRIRef, parseIRI)
6import Text.Megaparsec (MonadParsec (..), Parsec, runParser)
7import Text.URI (URI, parser, render)
8
9parseUri :: Text -> Maybe URI
10parseUri = runParser (parser <* eof :: Parsec Void Text URI) "" .> either (const Nothing) Just
11
12uriToIri :: URI -> Maybe IRIRef
13uriToIri = render .> parseIRI .> either (const Nothing) Just
diff --git a/src/Data/JLD/Model/ValueObject.hs b/src/Data/JLD/Model/ValueObject.hs
new file mode 100644
index 0000000..79bd94f
--- /dev/null
+++ b/src/Data/JLD/Model/ValueObject.hs
@@ -0,0 +1,27 @@
1module Data.JLD.Model.ValueObject (isValueObject, isValueObject', isNotValueObject, isNotValueObject', valueObjectValue) where
2
3import Data.JLD.Prelude
4
5import Data.JLD.Model.Keyword (Keyword (..), isNotKeyword)
6
7import Data.Aeson (Object, Value (..))
8import Data.Aeson.Key qualified as K
9import Data.Aeson.KeyMap qualified as KM
10
11isValueObject :: Value -> Bool
12isValueObject (Object o) = isValueObject' o
13isValueObject _ = False
14
15isValueObject' :: Object -> Bool
16isValueObject' = KM.member (show KeywordValue)
17
18isNotValueObject :: Value -> Bool
19isNotValueObject (Object o) = isNotValueObject' o
20isNotValueObject _ = False
21
22isNotValueObject' :: Object -> Bool
23isNotValueObject' = KM.keys .> fmap K.toText .> any (`isNotKeyword` [KeywordType, KeywordValue, KeywordDirection, KeywordLanguage, KeywordIndex])
24
25valueObjectValue :: Value -> Maybe Value
26valueObjectValue (Object o) = KM.lookup (show KeywordValue) o
27valueObjectValue _ = Nothing
diff --git a/src/Data/JLD/Monad.hs b/src/Data/JLD/Monad.hs
new file mode 100644
index 0000000..3ae929d
--- /dev/null
+++ b/src/Data/JLD/Monad.hs
@@ -0,0 +1,86 @@
1module Data.JLD.Monad (
2 JLDT,
3 JLDEnv (..),
4 JLDState (..),
5 newEnv,
6 newState,
7 hoistEnv,
8 modifyContextCache,
9 modifyDocumentCache,
10 JLDET,
11 JLDEEnv (..),
12 JLDEState (..),
13 modifyActiveContext,
14) where
15
16import Data.JLD.Prelude
17
18import Data.JLD.Control.Monad.RES (REST)
19import Data.JLD.Error (JLDError)
20import Data.JLD.Model.ActiveContext (ActiveContext)
21import Data.JLD.Options (ContextCache, DocumentCache, DocumentLoader (..), JLDVersion (..), hoistDocumentLoader)
22
23import Text.URI (URI)
24
25type JLDT e m = REST (JLDEnv e m) (JLDError e) JLDState m
26
27data JLDEnv e m = JLDEnv
28 { jldEnvDocumentLoader :: DocumentLoader e m
29 , jldEnvProcessingMode :: JLDVersion
30 , jldEnvMaxRemoteContexts :: Int
31 }
32 deriving (Show)
33
34data JLDState = JLDState
35 { jldStateContextCache :: ContextCache
36 , jldStateDocumentCache :: DocumentCache
37 }
38 deriving (Show, Eq)
39
40newEnv :: Applicative m => (JLDEnv () m -> JLDEnv e m) -> JLDEnv e m
41newEnv fn =
42 fn
43 JLDEnv
44 { jldEnvDocumentLoader = DocumentLoader (const <. pure <| Left ())
45 , jldEnvProcessingMode = JLD1_1
46 , jldEnvMaxRemoteContexts = 20
47 }
48
49newState :: (JLDState -> JLDState) -> JLDState
50newState fn =
51 fn
52 JLDState
53 { jldStateContextCache = mempty
54 , jldStateDocumentCache = mempty
55 }
56
57hoistEnv :: (forall a. m a -> n a) -> JLDEnv e m -> JLDEnv e n
58hoistEnv map' options = options{jldEnvDocumentLoader = options |> jldEnvDocumentLoader .> hoistDocumentLoader map'}
59
60modifyContextCache :: MonadState JLDState m => (ContextCache -> ContextCache) -> m ()
61modifyContextCache fn = modify \s -> s{jldStateContextCache = fn (jldStateContextCache s)}
62
63modifyDocumentCache :: MonadState JLDState m => (DocumentCache -> DocumentCache) -> m ()
64modifyDocumentCache fn = modify \s -> s{jldStateDocumentCache = fn (jldStateDocumentCache s)}
65
66--
67
68type JLDET e m = REST (JLDEEnv e m) (JLDError e) JLDEState m
69
70data JLDEEnv e m = JLDEEnv
71 { jldeEnvGlobal :: JLDEnv e m
72 , jldeEnvFrameExpansion :: Bool
73 , jldeEnvFromMap :: Bool
74 , jldeEnvBaseUrl :: URI
75 , jldeEnvActiveProperty :: Maybe Text
76 }
77 deriving (Show)
78
79data JLDEState = JLDEState
80 { jldeStateGlobal :: JLDState
81 , jldeStateActiveContext :: ActiveContext
82 }
83 deriving (Show, Eq)
84
85modifyActiveContext :: MonadState JLDEState m => (ActiveContext -> ActiveContext) -> m ()
86modifyActiveContext fn = modify \s -> s{jldeStateActiveContext = fn (jldeStateActiveContext s)}
diff --git a/src/Data/JLD/Options.hs b/src/Data/JLD/Options.hs
new file mode 100644
index 0000000..d6ec51d
--- /dev/null
+++ b/src/Data/JLD/Options.hs
@@ -0,0 +1,34 @@
1module Data.JLD.Options (
2 Document (..),
3 ContextCache,
4 DocumentCache,
5 JLDVersion (..),
6 DocumentLoader (..),
7 hoistDocumentLoader,
8) where
9
10import Data.JLD.Prelude
11
12import Data.Aeson (Object, Value)
13import Text.Show (Show (..))
14import Text.URI (URI)
15
16data Document = Document
17 { documentUri :: URI
18 , documentContent :: Object
19 }
20 deriving (Show, Eq)
21
22type ContextCache = Map Text Value
23
24type DocumentCache = Map Text Document
25
26newtype DocumentLoader e m = DocumentLoader {runDocumentLoader :: URI -> m (Either e Value)}
27
28instance Show (DocumentLoader e m) where
29 show _ = "DocumentLoader"
30
31data JLDVersion = JLD1_0 | JLD1_1 deriving (Show, Eq)
32
33hoistDocumentLoader :: (forall a. m a -> n a) -> DocumentLoader e m -> DocumentLoader e n
34hoistDocumentLoader map' (DocumentLoader loader) = DocumentLoader <| loader .> map'
diff --git a/src/Data/JLD/Prelude.hs b/src/Data/JLD/Prelude.hs
new file mode 100644
index 0000000..5be118b
--- /dev/null
+++ b/src/Data/JLD/Prelude.hs
@@ -0,0 +1,4 @@
1module Data.JLD.Prelude (module Flow, module Relude) where
2
3import Flow
4import Relude
diff --git a/src/Data/JLD/Util.hs b/src/Data/JLD/Util.hs
new file mode 100644
index 0000000..82cbdee
--- /dev/null
+++ b/src/Data/JLD/Util.hs
@@ -0,0 +1,118 @@
1module Data.JLD.Util (
2 valueContains,
3 valueContainsAny,
4 valueIsTrue,
5 valueIsString,
6 valueIsArray,
7 valueIsNotArray,
8 valueIsEmptyArray,
9 valueIsScalar,
10 valueToString,
11 valueIsNotString,
12 valueIsNotNull,
13 flattenSingletonArray,
14 valueToArray,
15 allStrings,
16 ifindM,
17 getMapDefault,
18 mapAddValue,
19) where
20
21import Data.JLD.Prelude
22
23import Data.Aeson (Array, Key, Object, Value (..))
24import Data.Aeson.Key qualified as K (fromText)
25import Data.Aeson.KeyMap qualified as KM (insert, lookup, member)
26import Data.Foldable qualified as F (Foldable (..), elem)
27import Data.Foldable.WithIndex (FoldableWithIndex (..), ifoldlM)
28import Data.Vector (Vector)
29import Data.Vector qualified as V (fromList, null, singleton, snoc, uncons)
30
31valueContains :: Text -> Value -> Bool
32valueContains text = \case
33 String s -> s == text
34 Array a -> elem (String text) a
35 Object o -> KM.member (K.fromText text) o
36 _ -> False
37
38valueContainsAny :: (Foldable f, Functor f) => f Text -> Value -> Bool
39valueContainsAny texts = \case
40 String s -> s `F.elem` texts
41 Array a -> any (`elem` a) <| String <$> texts
42 Object o -> any (\text -> KM.member (K.fromText text) o) texts
43 _ -> False
44
45valueIsTrue :: Value -> Bool
46valueIsTrue (Bool True) = True
47valueIsTrue _ = False
48
49valueIsString :: Value -> Bool
50valueIsString (String _) = True
51valueIsString _ = False
52
53valueIsNotString :: Value -> Bool
54valueIsNotString = valueIsString .> not
55
56valueIsArray :: Value -> Bool
57valueIsArray (Array _) = True
58valueIsArray _ = False
59
60valueIsNotArray :: Value -> Bool
61valueIsNotArray = valueIsArray .> not
62
63valueIsEmptyArray :: Value -> Bool
64valueIsEmptyArray (Array a) = V.null a
65valueIsEmptyArray _ = False
66
67valueIsScalar :: Value -> Bool
68valueIsScalar = \case
69 String _ -> True
70 Number _ -> True
71 Bool _ -> True
72 _ -> False
73
74valueToString :: Value -> Maybe Text
75valueToString (String s) = Just s
76valueToString _ = Nothing
77
78valueIsNotNull :: Value -> Bool
79valueIsNotNull Null = False
80valueIsNotNull _ = True
81
82flattenSingletonArray :: Value -> Value
83flattenSingletonArray = \case
84 Array (V.uncons -> Just (value, V.null -> True)) -> value
85 value -> value
86
87valueToArray :: Value -> Array
88valueToArray = \case
89 Array a -> a
90 value -> V.singleton value
91
92allStrings :: Array -> Maybe (Vector Text)
93allStrings = foldl' go (Just mempty)
94 where
95 go :: Maybe (Vector Text) -> Value -> Maybe (Vector Text)
96 go (Just a) (String s) = Just <| V.snoc a s
97 go _ _ = Nothing
98
99ifindM :: (FoldableWithIndex i f, Monad m) => (i -> a -> m Bool) -> f a -> m (Maybe a)
100ifindM p = ifoldlM (\i r x -> p i x <&> bool r (Just x)) Nothing
101
102getMapDefault :: Key -> Object -> Object
103getMapDefault key obj = case KM.lookup key obj of
104 Just (Object o) -> o
105 _ -> mempty
106
107mapAddValue :: Key -> Value -> Bool -> Object -> Object
108mapAddValue key value True object = mapAddValue key value False <| KM.insert key (Array array) object
109 where
110 array = case KM.lookup key object of
111 Just (Array a) -> a
112 Just original -> V.singleton original
113 Nothing -> mempty
114mapAddValue key (Array value) False object = foldl' (\o v -> mapAddValue key v False o) object value
115mapAddValue key value False object = case KM.lookup key object of
116 Just (Array a) -> KM.insert key (Array <| V.snoc a value) object
117 Just original -> KM.insert key (Array <| V.fromList [original, value]) object
118 Nothing -> KM.insert key value object
generated by cgit v1.2.3-70-g09d2 (git 2.47.0) at 2024-11-22 02:26:33 +0000