diff options
| -rw-r--r-- | README.md | 4 | ||||
| -rw-r--r-- | src/Data/JLD/Expansion/Context.hs | 80 | 
2 files changed, 40 insertions, 44 deletions
| @@ -8,6 +8,6 @@ Tests are generated from the [official test suite](https://github.com/w3c/json-l | |||
| 8 | 8 | ||
| 9 | | Feature | Tests | Pass | Status | | 9 | | Feature | Tests | Pass | Status | | 
| 10 | | ---------- | ----- | ---- | ------ | | 10 | | ---------- | ----- | ---- | ------ | | 
| 11 | | Expansion | 371 | 371 | 100% | | 11 | | Expansion | 382 | 382 | 100% | | 
| 12 | | Flattening | 55 | 54 | 98% | | 12 | | Flattening | 58 | 57 | 98% | | 
| 13 | | Compaction | ? | 0 | 0% | | 13 | | Compaction | ? | 0 | 0% | | 
| 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) | 
