diff options
Diffstat (limited to 'src/Data/JLD/Expansion/Context.hs')
-rw-r--r-- | src/Data/JLD/Expansion/Context.hs | 80 |
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 | ||
55 | bacModifyContextCache :: Monad m => (ContextCache -> ContextCache) -> BACT e m () | 55 | bacModifyContextCache :: (Monad m) => (ContextCache -> ContextCache) -> BACT e m () |
56 | bacModifyContextCache = modifyContextCache .> withStateRES bacStateGlobal (\s g -> s{bacStateGlobal = g}) | 56 | bacModifyContextCache = modifyContextCache .> withStateRES bacStateGlobal (\s g -> s{bacStateGlobal = g}) |
57 | 57 | ||
58 | bacModifyDocumentCache :: Monad m => (DocumentCache -> DocumentCache) -> BACT e m () | 58 | bacModifyDocumentCache :: (Monad m) => (DocumentCache -> DocumentCache) -> BACT e m () |
59 | bacModifyDocumentCache = modifyDocumentCache .> withStateRES bacStateGlobal (\s g -> s{bacStateGlobal = g}) | 59 | bacModifyDocumentCache = modifyDocumentCache .> withStateRES bacStateGlobal (\s g -> s{bacStateGlobal = g}) |
60 | 60 | ||
61 | bacModifyActiveContext :: Monad m => (ActiveContext -> ActiveContext) -> BACT e m () | 61 | bacModifyActiveContext :: (Monad m) => (ActiveContext -> ActiveContext) -> BACT e m () |
62 | bacModifyActiveContext fn = modify \s -> s{bacStateActiveContext = fn (bacStateActiveContext s)} | 62 | bacModifyActiveContext fn = modify \s -> s{bacStateActiveContext = fn (bacStateActiveContext s)} |
63 | 63 | ||
64 | bacModifyRemoteContexts :: Monad m => (Set Text -> Set Text) -> BACT e m () | 64 | bacModifyRemoteContexts :: (Monad m) => (Set Text -> Set Text) -> BACT e m () |
65 | bacModifyRemoteContexts fn = modify \s -> s{bacStateRemoteContexts = fn (bacStateRemoteContexts s)} | 65 | bacModifyRemoteContexts fn = modify \s -> s{bacStateRemoteContexts = fn (bacStateRemoteContexts s)} |
66 | 66 | ||
67 | bacBuildTermDefinition :: Monad m => Object -> Maybe URI -> Text -> BACT e m () | 67 | bacBuildTermDefinition :: (Monad m) => Object -> Maybe URI -> Text -> BACT e m () |
68 | bacBuildTermDefinition contextDefinition baseUrl term = do | 68 | bacBuildTermDefinition 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 | ||
86 | bacBuildActiveContext :: Monad m => Value -> URI -> BACT e m () | 86 | bacBuildActiveContext :: (Monad m) => Value -> URI -> BACT e m () |
87 | bacBuildActiveContext context uri = do | 87 | bacBuildActiveContext 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 | ||
103 | bacProcessItem :: Monad m => Maybe URI -> Value -> BACT e m () | 103 | bacProcessItem :: (Monad m) => Maybe URI -> Value -> BACT e m () |
104 | bacProcessItem baseUrl item = do | 104 | bacProcessItem 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 | ||
266 | bacFetchRemoteContext :: Monad m => Text -> Maybe URI -> BACT e m () | 266 | bacFetchRemoteContext :: (Monad m) => Text -> Maybe URI -> BACT e m () |
267 | bacFetchRemoteContext url maybeBaseUrl | 267 | bacFetchRemoteContext 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 | ||
318 | buildActiveContext' :: Monad m => Value -> Maybe URI -> BACT e m () | 318 | buildActiveContext' :: (Monad m) => Value -> Maybe URI -> BACT e m () |
319 | buildActiveContext' localContext baseUrl = do | 319 | buildActiveContext' 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 | ||
343 | buildActiveContext :: Monad m => ActiveContext -> Value -> Maybe URI -> (BACParams -> BACParams) -> JLDExpansionT e m ActiveContext | 343 | buildActiveContext :: (Monad m) => ActiveContext -> Value -> Maybe URI -> (BACParams -> BACParams) -> JLDExpansionT e m ActiveContext |
344 | buildActiveContext activeContext localContext baseUrl paramsFn = do | 344 | buildActiveContext 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 | ||
403 | eiBuildTermDefinition :: Monad m => Text -> EIT e m () | 403 | eiBuildTermDefinition :: (Monad m) => Text -> EIT e m () |
404 | eiBuildTermDefinition value = do | 404 | eiBuildTermDefinition 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 | ||
420 | eiInitLocalContext :: Monad m => Text -> EIT e m () | 420 | eiInitLocalContext :: (Monad m) => Text -> EIT e m () |
421 | eiInitLocalContext value = | 421 | eiInitLocalContext 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 | ||
429 | eiInitPropertyContext :: Monad m => Text -> Text -> Text -> EIT e m Text | 429 | eiInitPropertyContext :: (Monad m) => Text -> Text -> Text -> EIT e m Text |
430 | eiInitPropertyContext prefix suffix value = do | 430 | eiInitPropertyContext 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 | ||
448 | eiExpandResult :: Monad m => Text -> EIT e m (Maybe Text) | 448 | eiExpandResult :: (Monad m) => Text -> EIT e m (Maybe Text) |
449 | eiExpandResult value = do | 449 | eiExpandResult 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 | ||
464 | expandIri' :: Monad m => Text -> EIT e m (Maybe Text) | 464 | expandIri' :: (Monad m) => Text -> EIT e m (Maybe Text) |
465 | expandIri' value | 465 | expandIri' 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 | ||
502 | expandIri :: Monad m => ActiveContext -> Text -> (EIParams -> EIParams) -> JLDExpansionT e m (Maybe Text, ActiveContext, Map Text Bool) | 502 | expandIri :: (Monad m) => ActiveContext -> Text -> (EIParams -> EIParams) -> JLDExpansionT e m (Maybe Text, ActiveContext, Map Text Bool) |
503 | expandIri activeContext value paramsFn = do | 503 | expandIri 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 | ||
566 | btdModifyActiveContext :: Monad m => (ActiveContext -> ActiveContext) -> BTDT e m () | 566 | btdModifyActiveContext :: (Monad m) => (ActiveContext -> ActiveContext) -> BTDT e m () |
567 | btdModifyActiveContext fn = modify \s -> s{btdStateActiveContext = fn (btdStateActiveContext s)} | 567 | btdModifyActiveContext fn = modify \s -> s{btdStateActiveContext = fn (btdStateActiveContext s)} |
568 | 568 | ||
569 | btdModifyTermDefinition :: Monad m => (TermDefinition -> TermDefinition) -> BTDT e m () | 569 | btdModifyTermDefinition :: (Monad m) => (TermDefinition -> TermDefinition) -> BTDT e m () |
570 | btdModifyTermDefinition fn = modify \s -> s{btdStateTermDefinition = fn (btdStateTermDefinition s)} | 570 | btdModifyTermDefinition fn = modify \s -> s{btdStateTermDefinition = fn (btdStateTermDefinition s)} |
571 | 571 | ||
572 | btdModifyDefined :: Monad m => (Map Text Bool -> Map Text Bool) -> BTDT e m () | 572 | btdModifyDefined :: (Monad m) => (Map Text Bool -> Map Text Bool) -> BTDT e m () |
573 | btdModifyDefined fn = modify \s -> s{btdStateDefined = fn (btdStateDefined s)} | 573 | btdModifyDefined fn = modify \s -> s{btdStateDefined = fn (btdStateDefined s)} |
574 | 574 | ||
575 | btdValidateContainer :: JLDExpansionEnv e m -> Value -> Bool | 575 | btdValidateContainer :: JLDExpansionEnv e m -> Value -> Bool |
@@ -602,7 +602,7 @@ btdValidateContainer JLDExpansionEnv{..} value | |||
602 | True | 602 | True |
603 | _ -> False | 603 | _ -> False |
604 | 604 | ||
605 | btdExpandIri :: Monad m => Text -> BTDT e m (Maybe Text) | 605 | btdExpandIri :: (Monad m) => Text -> BTDT e m (Maybe Text) |
606 | btdExpandIri value = do | 606 | btdExpandIri 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 | ||
628 | btdBuildTermDefinition :: Monad m => Text -> BTDT e m () | 628 | btdBuildTermDefinition :: (Monad m) => Text -> BTDT e m () |
629 | btdBuildTermDefinition term = do | 629 | btdBuildTermDefinition 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 | ||
645 | buildTermDefinition' :: Monad m => Text -> BTDT e m () | 645 | buildTermDefinition' :: (Monad m) => Text -> BTDT e m () |
646 | buildTermDefinition' "" = throwError <| Left InvalidTermDefinition -- 2. | 646 | buildTermDefinition' "" = throwError <| Left InvalidTermDefinition -- 2. |
647 | buildTermDefinition' term = do | 647 | buildTermDefinition' 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 | ||
983 | buildTermDefinition :: Monad m => ActiveContext -> Object -> Text -> (BTDParams -> BTDParams) -> JLDExpansionT e m (ActiveContext, Map Text Bool) | 979 | buildTermDefinition :: (Monad m) => ActiveContext -> Object -> Text -> (BTDParams -> BTDParams) -> JLDExpansionT e m (ActiveContext, Map Text Bool) |
984 | buildTermDefinition activeContext localContext term paramsFn = do | 980 | buildTermDefinition activeContext localContext term paramsFn = do |
985 | BTDState{..} <- | 981 | BTDState{..} <- |
986 | (buildTermDefinition' term >> get) | 982 | (buildTermDefinition' term >> get) |