aboutsummaryrefslogtreecommitdiffstats
path: root/src/Data/JLD/Expansion
diff options
context:
space:
mode:
authorVolpeon <github@volpeon.ink>2024-01-04 11:33:13 +0100
committerVolpeon <github@volpeon.ink>2024-01-04 11:33:13 +0100
commit9d15bdb3fcd81f76050ac172e0d9fa6296876e54 (patch)
tree787651d22022e1d03532a3aa1ce425890f8086f1 /src/Data/JLD/Expansion
parentRemove Stack (diff)
downloadhs-jsonld-9d15bdb3fcd81f76050ac172e0d9fa6296876e54.tar.gz
hs-jsonld-9d15bdb3fcd81f76050ac172e0d9fa6296876e54.tar.bz2
hs-jsonld-9d15bdb3fcd81f76050ac172e0d9fa6296876e54.zip
Fix https://github.com/w3c/json-ld-api/issues/565HEADmaster
Diffstat (limited to 'src/Data/JLD/Expansion')
-rw-r--r--src/Data/JLD/Expansion/Context.hs80
1 files changed, 38 insertions, 42 deletions
diff --git a/src/Data/JLD/Expansion/Context.hs b/src/Data/JLD/Expansion/Context.hs
index 21350c8..570628f 100644
--- a/src/Data/JLD/Expansion/Context.hs
+++ b/src/Data/JLD/Expansion/Context.hs
@@ -52,19 +52,19 @@ data BACParams = BACParams
52 } 52 }
53 deriving (Show, Eq) 53 deriving (Show, Eq)
54 54
55bacModifyContextCache :: Monad m => (ContextCache -> ContextCache) -> BACT e m () 55bacModifyContextCache :: (Monad m) => (ContextCache -> ContextCache) -> BACT e m ()
56bacModifyContextCache = modifyContextCache .> withStateRES bacStateGlobal (\s g -> s{bacStateGlobal = g}) 56bacModifyContextCache = modifyContextCache .> withStateRES bacStateGlobal (\s g -> s{bacStateGlobal = g})
57 57
58bacModifyDocumentCache :: Monad m => (DocumentCache -> DocumentCache) -> BACT e m () 58bacModifyDocumentCache :: (Monad m) => (DocumentCache -> DocumentCache) -> BACT e m ()
59bacModifyDocumentCache = modifyDocumentCache .> withStateRES bacStateGlobal (\s g -> s{bacStateGlobal = g}) 59bacModifyDocumentCache = modifyDocumentCache .> withStateRES bacStateGlobal (\s g -> s{bacStateGlobal = g})
60 60
61bacModifyActiveContext :: Monad m => (ActiveContext -> ActiveContext) -> BACT e m () 61bacModifyActiveContext :: (Monad m) => (ActiveContext -> ActiveContext) -> BACT e m ()
62bacModifyActiveContext fn = modify \s -> s{bacStateActiveContext = fn (bacStateActiveContext s)} 62bacModifyActiveContext fn = modify \s -> s{bacStateActiveContext = fn (bacStateActiveContext s)}
63 63
64bacModifyRemoteContexts :: Monad m => (Set Text -> Set Text) -> BACT e m () 64bacModifyRemoteContexts :: (Monad m) => (Set Text -> Set Text) -> BACT e m ()
65bacModifyRemoteContexts fn = modify \s -> s{bacStateRemoteContexts = fn (bacStateRemoteContexts s)} 65bacModifyRemoteContexts fn = modify \s -> s{bacStateRemoteContexts = fn (bacStateRemoteContexts s)}
66 66
67bacBuildTermDefinition :: Monad m => Object -> Maybe URI -> Text -> BACT e m () 67bacBuildTermDefinition :: (Monad m) => Object -> Maybe URI -> Text -> BACT e m ()
68bacBuildTermDefinition contextDefinition baseUrl term = do 68bacBuildTermDefinition contextDefinition baseUrl term = do
69 BACEnv{..} <- ask 69 BACEnv{..} <- ask
70 activeContext <- gets bacStateActiveContext 70 activeContext <- gets bacStateActiveContext
@@ -83,7 +83,7 @@ bacBuildTermDefinition contextDefinition baseUrl term = do
83 |> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global}) 83 |> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global})
84 bacModifyActiveContext <| const activeContext' 84 bacModifyActiveContext <| const activeContext'
85 85
86bacBuildActiveContext :: Monad m => Value -> URI -> BACT e m () 86bacBuildActiveContext :: (Monad m) => Value -> URI -> BACT e m ()
87bacBuildActiveContext context uri = do 87bacBuildActiveContext context uri = do
88 BACEnv{..} <- ask 88 BACEnv{..} <- ask
89 activeContext <- gets bacStateActiveContext 89 activeContext <- gets bacStateActiveContext
@@ -100,7 +100,7 @@ bacBuildActiveContext context uri = do
100 .> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global}) 100 .> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global})
101 bacModifyActiveContext <| const activeContext' 101 bacModifyActiveContext <| const activeContext'
102 102
103bacProcessItem :: Monad m => Maybe URI -> Value -> BACT e m () 103bacProcessItem :: (Monad m) => Maybe URI -> Value -> BACT e m ()
104bacProcessItem baseUrl item = do 104bacProcessItem baseUrl item = do
105 BACEnv{..} <- ask 105 BACEnv{..} <- ask
106 let JLDExpansionEnv{..} = hoistEnv (lift .> lift .> lift) bacEnvGlobal 106 let JLDExpansionEnv{..} = hoistEnv (lift .> lift .> lift) bacEnvGlobal
@@ -263,7 +263,7 @@ bacProcessItem baseUrl item = do
263 -- 5.3. 263 -- 5.3.
264 _ -> throwError <| Left InvalidLocalContext 264 _ -> throwError <| Left InvalidLocalContext
265 265
266bacFetchRemoteContext :: Monad m => Text -> Maybe URI -> BACT e m () 266bacFetchRemoteContext :: (Monad m) => Text -> Maybe URI -> BACT e m ()
267bacFetchRemoteContext url maybeBaseUrl 267bacFetchRemoteContext url maybeBaseUrl
268 | Just uri <- parseUri url 268 | Just uri <- parseUri url
269 , Just contextUri <- relativeTo uri =<< maybeBaseUrl -- 5.2.1. 269 , Just contextUri <- relativeTo uri =<< maybeBaseUrl -- 5.2.1.
@@ -315,7 +315,7 @@ bacFetchRemoteContext url maybeBaseUrl
315 bacModifyContextCache <| M.insert contextKey importedContext 315 bacModifyContextCache <| M.insert contextKey importedContext
316 | otherwise = throwError <| Left LoadingRemoteContextError 316 | otherwise = throwError <| Left LoadingRemoteContextError
317 317
318buildActiveContext' :: Monad m => Value -> Maybe URI -> BACT e m () 318buildActiveContext' :: (Monad m) => Value -> Maybe URI -> BACT e m ()
319buildActiveContext' localContext baseUrl = do 319buildActiveContext' localContext baseUrl = do
320 activeContext <- gets bacStateActiveContext 320 activeContext <- gets bacStateActiveContext
321 321
@@ -340,7 +340,7 @@ buildActiveContext' localContext baseUrl = do
340 .> withEnvRES (\env -> env{bacEnvPropagate = propagate}) 340 .> withEnvRES (\env -> env{bacEnvPropagate = propagate})
341 .> withErrorRES' (either (Left .> throwError) pure) 341 .> withErrorRES' (either (Left .> throwError) pure)
342 342
343buildActiveContext :: Monad m => ActiveContext -> Value -> Maybe URI -> (BACParams -> BACParams) -> JLDExpansionT e m ActiveContext 343buildActiveContext :: (Monad m) => ActiveContext -> Value -> Maybe URI -> (BACParams -> BACParams) -> JLDExpansionT e m ActiveContext
344buildActiveContext activeContext localContext baseUrl paramsFn = do 344buildActiveContext activeContext localContext baseUrl paramsFn = do
345 BACState{..} <- 345 BACState{..} <-
346 (buildActiveContext' localContext baseUrl >> get) 346 (buildActiveContext' localContext baseUrl >> get)
@@ -400,7 +400,7 @@ data EIParams = EIParams
400 } 400 }
401 deriving (Show, Eq) 401 deriving (Show, Eq)
402 402
403eiBuildTermDefinition :: Monad m => Text -> EIT e m () 403eiBuildTermDefinition :: (Monad m) => Text -> EIT e m ()
404eiBuildTermDefinition value = do 404eiBuildTermDefinition value = do
405 EIEnv{..} <- ask 405 EIEnv{..} <- ask
406 defined <- gets eiStateDefined 406 defined <- gets eiStateDefined
@@ -417,7 +417,7 @@ eiBuildTermDefinition value = do
417 , eiStateDefined = defined' 417 , eiStateDefined = defined'
418 } 418 }
419 419
420eiInitLocalContext :: Monad m => Text -> EIT e m () 420eiInitLocalContext :: (Monad m) => Text -> EIT e m ()
421eiInitLocalContext value = 421eiInitLocalContext value =
422 -- 3. 422 -- 3.
423 asks eiEnvLocalContext >>= \case 423 asks eiEnvLocalContext >>= \case
@@ -426,7 +426,7 @@ eiInitLocalContext value =
426 when (maybe True not (M.lookup entry defined)) <| eiBuildTermDefinition value 426 when (maybe True not (M.lookup entry defined)) <| eiBuildTermDefinition value
427 _ -> pure () 427 _ -> pure ()
428 428
429eiInitPropertyContext :: Monad m => Text -> Text -> Text -> EIT e m Text 429eiInitPropertyContext :: (Monad m) => Text -> Text -> Text -> EIT e m Text
430eiInitPropertyContext prefix suffix value = do 430eiInitPropertyContext prefix suffix value = do
431 -- 6.3. 431 -- 6.3.
432 defined <- gets eiStateDefined 432 defined <- gets eiStateDefined
@@ -445,7 +445,7 @@ eiInitPropertyContext prefix suffix value = do
445 pure <| iriMapping <> suffix 445 pure <| iriMapping <> suffix
446 _ -> pure value 446 _ -> pure value
447 447
448eiExpandResult :: Monad m => Text -> EIT e m (Maybe Text) 448eiExpandResult :: (Monad m) => Text -> EIT e m (Maybe Text)
449eiExpandResult value = do 449eiExpandResult value = do
450 EIEnv{..} <- ask 450 EIEnv{..} <- ask
451 activeContext <- gets eiStateActiveContext 451 activeContext <- gets eiStateActiveContext
@@ -461,7 +461,7 @@ eiExpandResult value = do
461 -- 9. 461 -- 9.
462 _ -> pure <| Just value 462 _ -> pure <| Just value
463 463
464expandIri' :: Monad m => Text -> EIT e m (Maybe Text) 464expandIri' :: (Monad m) => Text -> EIT e m (Maybe Text)
465expandIri' value 465expandIri' value
466 -- 1. 466 -- 1.
467 | Just _ <- parseKeyword value = pure <| Just value 467 | Just _ <- parseKeyword value = pure <| Just value
@@ -499,7 +499,7 @@ expandIri' value
499 -- 499 --
500 _ -> eiExpandResult value 500 _ -> eiExpandResult value
501 501
502expandIri :: Monad m => ActiveContext -> Text -> (EIParams -> EIParams) -> JLDExpansionT e m (Maybe Text, ActiveContext, Map Text Bool) 502expandIri :: (Monad m) => ActiveContext -> Text -> (EIParams -> EIParams) -> JLDExpansionT e m (Maybe Text, ActiveContext, Map Text Bool)
503expandIri activeContext value paramsFn = do 503expandIri activeContext value paramsFn = do
504 (value', EIState{..}) <- 504 (value', EIState{..}) <-
505 (expandIri' value >>= \v -> gets (v,)) 505 (expandIri' value >>= \v -> gets (v,))
@@ -563,13 +563,13 @@ data BTDParams = BTDParams
563 } 563 }
564 deriving (Show, Eq) 564 deriving (Show, Eq)
565 565
566btdModifyActiveContext :: Monad m => (ActiveContext -> ActiveContext) -> BTDT e m () 566btdModifyActiveContext :: (Monad m) => (ActiveContext -> ActiveContext) -> BTDT e m ()
567btdModifyActiveContext fn = modify \s -> s{btdStateActiveContext = fn (btdStateActiveContext s)} 567btdModifyActiveContext fn = modify \s -> s{btdStateActiveContext = fn (btdStateActiveContext s)}
568 568
569btdModifyTermDefinition :: Monad m => (TermDefinition -> TermDefinition) -> BTDT e m () 569btdModifyTermDefinition :: (Monad m) => (TermDefinition -> TermDefinition) -> BTDT e m ()
570btdModifyTermDefinition fn = modify \s -> s{btdStateTermDefinition = fn (btdStateTermDefinition s)} 570btdModifyTermDefinition fn = modify \s -> s{btdStateTermDefinition = fn (btdStateTermDefinition s)}
571 571
572btdModifyDefined :: Monad m => (Map Text Bool -> Map Text Bool) -> BTDT e m () 572btdModifyDefined :: (Monad m) => (Map Text Bool -> Map Text Bool) -> BTDT e m ()
573btdModifyDefined fn = modify \s -> s{btdStateDefined = fn (btdStateDefined s)} 573btdModifyDefined fn = modify \s -> s{btdStateDefined = fn (btdStateDefined s)}
574 574
575btdValidateContainer :: JLDExpansionEnv e m -> Value -> Bool 575btdValidateContainer :: JLDExpansionEnv e m -> Value -> Bool
@@ -602,7 +602,7 @@ btdValidateContainer JLDExpansionEnv{..} value
602 True 602 True
603 _ -> False 603 _ -> False
604 604
605btdExpandIri :: Monad m => Text -> BTDT e m (Maybe Text) 605btdExpandIri :: (Monad m) => Text -> BTDT e m (Maybe Text)
606btdExpandIri value = do 606btdExpandIri value = do
607 BTDEnv{..} <- ask 607 BTDEnv{..} <- ask
608 defined <- gets btdStateDefined 608 defined <- gets btdStateDefined
@@ -625,7 +625,7 @@ btdExpandIri value = do
625 } 625 }
626 pure expanded 626 pure expanded
627 627
628btdBuildTermDefinition :: Monad m => Text -> BTDT e m () 628btdBuildTermDefinition :: (Monad m) => Text -> BTDT e m ()
629btdBuildTermDefinition term = do 629btdBuildTermDefinition term = do
630 BTDEnv{..} <- ask 630 BTDEnv{..} <- ask
631 defined <- gets btdStateDefined 631 defined <- gets btdStateDefined
@@ -642,7 +642,7 @@ btdBuildTermDefinition term = do
642 , btdStateDefined = defined' 642 , btdStateDefined = defined'
643 } 643 }
644 644
645buildTermDefinition' :: Monad m => Text -> BTDT e m () 645buildTermDefinition' :: (Monad m) => Text -> BTDT e m ()
646buildTermDefinition' "" = throwError <| Left InvalidTermDefinition -- 2. 646buildTermDefinition' "" = throwError <| Left InvalidTermDefinition -- 2.
647buildTermDefinition' term = do 647buildTermDefinition' term = do
648 BTDEnv{..} <- ask 648 BTDEnv{..} <- ask
@@ -666,16 +666,16 @@ buildTermDefinition' term = do
666 | JLD1_0 <- jldExpansionEnvProcessingMode -> throwError <| Left KeywordRedefinition 666 | JLD1_0 <- jldExpansionEnvProcessingMode -> throwError <| Left KeywordRedefinition
667 | Object map' <- value -> 667 | Object map' <- value ->
668 if 668 if
669 | KM.size map' == 1 669 | KM.size map' == 1
670 , Just container <- KM.lookup (show KeywordContainer) map' -> 670 , Just container <- KM.lookup (show KeywordContainer) map' ->
671 when (container /= String (show KeywordSet)) <| throwError (Left KeywordRedefinition) 671 when (container /= String (show KeywordSet)) <| throwError (Left KeywordRedefinition)
672 | KM.size map' == 2 672 | KM.size map' == 2
673 , Just container <- KM.lookup (show KeywordContainer) map' 673 , Just container <- KM.lookup (show KeywordContainer) map'
674 , KM.member (show KeywordProtected) map' -> 674 , KM.member (show KeywordProtected) map' ->
675 unless (valueContains (show KeywordSet) container) <| throwError (Left KeywordRedefinition) 675 unless (valueContains (show KeywordSet) container) <| throwError (Left KeywordRedefinition)
676 | KM.size map' /= 1 || not (KM.member (show KeywordProtected) map') -> 676 | KM.size map' /= 1 || not (KM.member (show KeywordProtected) map') ->
677 throwError <| Left KeywordRedefinition 677 throwError <| Left KeywordRedefinition
678 | otherwise -> pure () 678 | otherwise -> pure ()
679 | otherwise -> throwError <| Left KeywordRedefinition 679 | otherwise -> throwError <| Left KeywordRedefinition
680 -- 5. 680 -- 5.
681 (parseKeyword -> Just _) -> throwError <| Left KeywordRedefinition 681 (parseKeyword -> Just _) -> throwError <| Left KeywordRedefinition
@@ -726,6 +726,9 @@ buildTermDefinition' term = do
726 -- 726 --
727 Nothing -> pure () 727 Nothing -> pure ()
728 728
729 -- 14. 15. 16. 17. 18.
730 maybeVocabMapping <- gets (btdStateActiveContext .> activeContextVocabularyMapping)
731
729 -- 13. 732 -- 13.
730 case KM.lookup (show KeywordReverse) valueObject of 733 case KM.lookup (show KeywordReverse) valueObject of
731 -- 13.1. 734 -- 13.1.
@@ -757,17 +760,10 @@ buildTermDefinition' term = do
757 definition <- gets btdStateTermDefinition 760 definition <- gets btdStateTermDefinition
758 btdModifyActiveContext \ac -> ac{activeContextTerms = activeContextTerms ac |> M.insert term definition} 761 btdModifyActiveContext \ac -> ac{activeContextTerms = activeContextTerms ac |> M.insert term definition}
759 btdModifyDefined <| M.insert term True 762 btdModifyDefined <| M.insert term True
760
761 throwError <| Right ()
762 -- 13.2. 763 -- 13.2.
763 Just _ -> throwError <| Left InvalidIriMapping 764 Just _ -> throwError <| Left InvalidIriMapping
764 -- 765 -- 14. 14.1.
765 Nothing -> pure () 766 Nothing
766
767 -- 14. 15. 16. 17. 18.
768 maybeVocabMapping <- gets (btdStateActiveContext .> activeContextVocabularyMapping)
769 if
770 -- 14. 14.1.
771 | Just idValue' <- idValue 767 | Just idValue' <- idValue
772 , idValue' /= String term -> case idValue' of 768 , idValue' /= String term -> case idValue' of
773 Null -> pure () 769 Null -> pure ()
@@ -980,7 +976,7 @@ buildTermDefinition' term = do
980 976
981 btdModifyDefined <| M.insert term True 977 btdModifyDefined <| M.insert term True
982 978
983buildTermDefinition :: Monad m => ActiveContext -> Object -> Text -> (BTDParams -> BTDParams) -> JLDExpansionT e m (ActiveContext, Map Text Bool) 979buildTermDefinition :: (Monad m) => ActiveContext -> Object -> Text -> (BTDParams -> BTDParams) -> JLDExpansionT e m (ActiveContext, Map Text Bool)
984buildTermDefinition activeContext localContext term paramsFn = do 980buildTermDefinition activeContext localContext term paramsFn = do
985 BTDState{..} <- 981 BTDState{..} <-
986 (buildTermDefinition' term >> get) 982 (buildTermDefinition' term >> get)