diff options
Diffstat (limited to 'src/Data/JLD')
| -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) |
