aboutsummaryrefslogtreecommitdiffstats
path: root/src/Data/JLD/Expansion
diff options
context:
space:
mode:
Diffstat (limited to 'src/Data/JLD/Expansion')
-rw-r--r--src/Data/JLD/Expansion/Context.hs1020
-rw-r--r--src/Data/JLD/Expansion/Global.hs38
2 files changed, 1058 insertions, 0 deletions
diff --git a/src/Data/JLD/Expansion/Context.hs b/src/Data/JLD/Expansion/Context.hs
new file mode 100644
index 0000000..ce61644
--- /dev/null
+++ b/src/Data/JLD/Expansion/Context.hs
@@ -0,0 +1,1020 @@
1module Data.JLD.Expansion.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.Error (JLDError (..))
7import Data.JLD.Expansion.Global (JLDExpansionEnv (..), JLDExpansionState (..), JLDExpansionT, hoistEnv, modifyContextCache, modifyDocumentCache)
8import Data.JLD.Model.ActiveContext (ActiveContext (..), containsProtectedTerm, lookupTerm, newActiveContext)
9import Data.JLD.Model.Direction (Direction (..))
10import Data.JLD.Model.IRI (CompactIRI (..), endsWithGenericDelim, isBlankIri, parseCompactIri)
11import Data.JLD.Model.Keyword (Keyword (..), allKeywords, isKeyword, isKeywordLike, isNotKeyword, parseKeyword)
12import Data.JLD.Model.Language (Language (..))
13import Data.JLD.Model.TermDefinition (TermDefinition (..), newTermDefinition)
14import Data.JLD.Model.URI (parseUri, uriToIri)
15import Data.JLD.Options (ContextCache, Document (..), DocumentCache, DocumentLoader (..), JLDVersion (..))
16import Data.JLD.Util (flattenSingletonArray, valueContains, valueContainsAny, valueIsTrue, valueToArray)
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 :: JLDExpansionEnv e m
34 , bacEnvOverrideProtected :: Bool
35 , bacEnvValidateScopedContext :: Bool
36 , bacEnvPropagate :: Bool
37 }
38 deriving (Show)
39
40data BACState = BACState
41 { bacStateGlobal :: JLDExpansionState
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 JLDExpansionEnv{..} = 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 <- jldExpansionEnvProcessingMode -> throwError <| Left ProcessingModeConflict
137 | otherwise -> pure ()
138 Just (Number 1.1)
139 | JLD1_0 <- jldExpansionEnvProcessingMode -> 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 <- jldExpansionEnvProcessingMode -> throwError <| Left InvalidContextEntry
149 -- 5.6.3.
150 Just (String value)
151 | Just importUri <- parseUri value
152 , Just contextUri <- relativeTo importUri =<< baseUrl ->
153 runDocumentLoader jldExpansionEnvDocumentLoader 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 <- jldExpansionEnvProcessingMode -> 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 <- jldExpansionEnvProcessingMode -> 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 JLDExpansionEnv{..} = 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 > jldExpansionEnvMaxRemoteContexts) <| throwError (Left ContextOverflow)
283
284 bacModifyRemoteContexts <| S.insert contextKey
285
286 -- 5.2.4.
287 gets (bacStateGlobal .> jldExpansionStateContextCache .> 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 .> jldExpansionStateDocumentCache .> M.lookup contextKey) >>= \case
297 Just document -> pure document
298 Nothing ->
299 runDocumentLoader jldExpansionEnvDocumentLoader 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) -> JLDExpansionT 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 :: JLDExpansionEnv e m
383 , eiEnvDocumentRelative :: Bool
384 , eiEnvVocab :: Bool
385 , eiEnvLocalContext :: Maybe Object
386 }
387 deriving (Show)
388
389data EIState = EIState
390 { eiStateGlobal :: JLDExpansionState
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) -> JLDExpansionT 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 :: JLDExpansionEnv 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 :: JLDExpansionState
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 :: JLDExpansionEnv e m -> Value -> Bool
577btdValidateContainer _ Null = False
578btdValidateContainer JLDExpansionEnv{..} value
579 | JLD1_0 <- jldExpansionEnvProcessingMode = 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 JLDExpansionEnv{..} = 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 <- jldExpansionEnvProcessingMode -> 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 <- jldExpansionEnvProcessingMode -> 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 <- jldExpansionEnvProcessingMode ->
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 _ | jldExpansionEnvProcessingMode == 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 <- jldExpansionEnvProcessingMode -> 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 <- jldExpansionEnvProcessingMode -> 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 | jldExpansionEnvProcessingMode == 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) -> JLDExpansionT 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/Expansion/Global.hs b/src/Data/JLD/Expansion/Global.hs
new file mode 100644
index 0000000..b92b4af
--- /dev/null
+++ b/src/Data/JLD/Expansion/Global.hs
@@ -0,0 +1,38 @@
1module Data.JLD.Expansion.Global (
2 JLDExpansionT,
3 JLDExpansionEnv (..),
4 JLDExpansionState (..),
5 hoistEnv,
6 modifyContextCache,
7 modifyDocumentCache,
8) where
9
10import Data.JLD.Prelude
11
12import Data.JLD.Control.Monad.RES (REST)
13import Data.JLD.Error (JLDError)
14import Data.JLD.Options (ContextCache, DocumentCache, DocumentLoader (..), JLDVersion (..), hoistDocumentLoader)
15
16type JLDExpansionT e m = REST (JLDExpansionEnv e m) (JLDError e) JLDExpansionState m
17
18data JLDExpansionEnv e m = JLDExpansionEnv
19 { jldExpansionEnvDocumentLoader :: DocumentLoader e m
20 , jldExpansionEnvProcessingMode :: JLDVersion
21 , jldExpansionEnvMaxRemoteContexts :: Int
22 }
23 deriving (Show)
24
25data JLDExpansionState = JLDExpansionState
26 { jldExpansionStateContextCache :: ContextCache
27 , jldExpansionStateDocumentCache :: DocumentCache
28 }
29 deriving (Show, Eq)
30
31hoistEnv :: (forall a. m a -> n a) -> JLDExpansionEnv e m -> JLDExpansionEnv e n
32hoistEnv map' options = options{jldExpansionEnvDocumentLoader = options |> jldExpansionEnvDocumentLoader .> hoistDocumentLoader map'}
33
34modifyContextCache :: MonadState JLDExpansionState m => (ContextCache -> ContextCache) -> m ()
35modifyContextCache fn = modify \s -> s{jldExpansionStateContextCache = fn (jldExpansionStateContextCache s)}
36
37modifyDocumentCache :: MonadState JLDExpansionState m => (DocumentCache -> DocumentCache) -> m ()
38modifyDocumentCache fn = modify \s -> s{jldExpansionStateDocumentCache = fn (jldExpansionStateDocumentCache s)}
generated by cgit v1.2.3-70-g09d2 (git 2.47.0) at 2024-11-22 10:35:18 +0000