From 9d15bdb3fcd81f76050ac172e0d9fa6296876e54 Mon Sep 17 00:00:00 2001 From: Volpeon Date: Thu, 4 Jan 2024 11:33:13 +0100 Subject: Fix https://github.com/w3c/json-ld-api/issues/565 --- README.md | 4 +- src/Data/JLD/Expansion/Context.hs | 80 +++++++++++++++++++-------------------- 2 files changed, 40 insertions(+), 44 deletions(-) diff --git a/README.md b/README.md index b4e5b77..c047aee 100644 --- a/README.md +++ b/README.md @@ -8,6 +8,6 @@ Tests are generated from the [official test suite](https://github.com/w3c/json-l | Feature | Tests | Pass | Status | | ---------- | ----- | ---- | ------ | -| Expansion | 371 | 371 | 100% | -| Flattening | 55 | 54 | 98% | +| Expansion | 382 | 382 | 100% | +| Flattening | 58 | 57 | 98% | | 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 } deriving (Show, Eq) -bacModifyContextCache :: Monad m => (ContextCache -> ContextCache) -> BACT e m () +bacModifyContextCache :: (Monad m) => (ContextCache -> ContextCache) -> BACT e m () bacModifyContextCache = modifyContextCache .> withStateRES bacStateGlobal (\s g -> s{bacStateGlobal = g}) -bacModifyDocumentCache :: Monad m => (DocumentCache -> DocumentCache) -> BACT e m () +bacModifyDocumentCache :: (Monad m) => (DocumentCache -> DocumentCache) -> BACT e m () bacModifyDocumentCache = modifyDocumentCache .> withStateRES bacStateGlobal (\s g -> s{bacStateGlobal = g}) -bacModifyActiveContext :: Monad m => (ActiveContext -> ActiveContext) -> BACT e m () +bacModifyActiveContext :: (Monad m) => (ActiveContext -> ActiveContext) -> BACT e m () bacModifyActiveContext fn = modify \s -> s{bacStateActiveContext = fn (bacStateActiveContext s)} -bacModifyRemoteContexts :: Monad m => (Set Text -> Set Text) -> BACT e m () +bacModifyRemoteContexts :: (Monad m) => (Set Text -> Set Text) -> BACT e m () bacModifyRemoteContexts fn = modify \s -> s{bacStateRemoteContexts = fn (bacStateRemoteContexts s)} -bacBuildTermDefinition :: Monad m => Object -> Maybe URI -> Text -> BACT e m () +bacBuildTermDefinition :: (Monad m) => Object -> Maybe URI -> Text -> BACT e m () bacBuildTermDefinition contextDefinition baseUrl term = do BACEnv{..} <- ask activeContext <- gets bacStateActiveContext @@ -83,7 +83,7 @@ bacBuildTermDefinition contextDefinition baseUrl term = do |> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global}) bacModifyActiveContext <| const activeContext' -bacBuildActiveContext :: Monad m => Value -> URI -> BACT e m () +bacBuildActiveContext :: (Monad m) => Value -> URI -> BACT e m () bacBuildActiveContext context uri = do BACEnv{..} <- ask activeContext <- gets bacStateActiveContext @@ -100,7 +100,7 @@ bacBuildActiveContext context uri = do .> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global}) bacModifyActiveContext <| const activeContext' -bacProcessItem :: Monad m => Maybe URI -> Value -> BACT e m () +bacProcessItem :: (Monad m) => Maybe URI -> Value -> BACT e m () bacProcessItem baseUrl item = do BACEnv{..} <- ask let JLDExpansionEnv{..} = hoistEnv (lift .> lift .> lift) bacEnvGlobal @@ -263,7 +263,7 @@ bacProcessItem baseUrl item = do -- 5.3. _ -> throwError <| Left InvalidLocalContext -bacFetchRemoteContext :: Monad m => Text -> Maybe URI -> BACT e m () +bacFetchRemoteContext :: (Monad m) => Text -> Maybe URI -> BACT e m () bacFetchRemoteContext url maybeBaseUrl | Just uri <- parseUri url , Just contextUri <- relativeTo uri =<< maybeBaseUrl -- 5.2.1. @@ -315,7 +315,7 @@ bacFetchRemoteContext url maybeBaseUrl bacModifyContextCache <| M.insert contextKey importedContext | otherwise = throwError <| Left LoadingRemoteContextError -buildActiveContext' :: Monad m => Value -> Maybe URI -> BACT e m () +buildActiveContext' :: (Monad m) => Value -> Maybe URI -> BACT e m () buildActiveContext' localContext baseUrl = do activeContext <- gets bacStateActiveContext @@ -340,7 +340,7 @@ buildActiveContext' localContext baseUrl = do .> withEnvRES (\env -> env{bacEnvPropagate = propagate}) .> withErrorRES' (either (Left .> throwError) pure) -buildActiveContext :: Monad m => ActiveContext -> Value -> Maybe URI -> (BACParams -> BACParams) -> JLDExpansionT e m ActiveContext +buildActiveContext :: (Monad m) => ActiveContext -> Value -> Maybe URI -> (BACParams -> BACParams) -> JLDExpansionT e m ActiveContext buildActiveContext activeContext localContext baseUrl paramsFn = do BACState{..} <- (buildActiveContext' localContext baseUrl >> get) @@ -400,7 +400,7 @@ data EIParams = EIParams } deriving (Show, Eq) -eiBuildTermDefinition :: Monad m => Text -> EIT e m () +eiBuildTermDefinition :: (Monad m) => Text -> EIT e m () eiBuildTermDefinition value = do EIEnv{..} <- ask defined <- gets eiStateDefined @@ -417,7 +417,7 @@ eiBuildTermDefinition value = do , eiStateDefined = defined' } -eiInitLocalContext :: Monad m => Text -> EIT e m () +eiInitLocalContext :: (Monad m) => Text -> EIT e m () eiInitLocalContext value = -- 3. asks eiEnvLocalContext >>= \case @@ -426,7 +426,7 @@ eiInitLocalContext value = when (maybe True not (M.lookup entry defined)) <| eiBuildTermDefinition value _ -> pure () -eiInitPropertyContext :: Monad m => Text -> Text -> Text -> EIT e m Text +eiInitPropertyContext :: (Monad m) => Text -> Text -> Text -> EIT e m Text eiInitPropertyContext prefix suffix value = do -- 6.3. defined <- gets eiStateDefined @@ -445,7 +445,7 @@ eiInitPropertyContext prefix suffix value = do pure <| iriMapping <> suffix _ -> pure value -eiExpandResult :: Monad m => Text -> EIT e m (Maybe Text) +eiExpandResult :: (Monad m) => Text -> EIT e m (Maybe Text) eiExpandResult value = do EIEnv{..} <- ask activeContext <- gets eiStateActiveContext @@ -461,7 +461,7 @@ eiExpandResult value = do -- 9. _ -> pure <| Just value -expandIri' :: Monad m => Text -> EIT e m (Maybe Text) +expandIri' :: (Monad m) => Text -> EIT e m (Maybe Text) expandIri' value -- 1. | Just _ <- parseKeyword value = pure <| Just value @@ -499,7 +499,7 @@ expandIri' value -- _ -> eiExpandResult value -expandIri :: Monad m => ActiveContext -> Text -> (EIParams -> EIParams) -> JLDExpansionT e m (Maybe Text, ActiveContext, Map Text Bool) +expandIri :: (Monad m) => ActiveContext -> Text -> (EIParams -> EIParams) -> JLDExpansionT e m (Maybe Text, ActiveContext, Map Text Bool) expandIri activeContext value paramsFn = do (value', EIState{..}) <- (expandIri' value >>= \v -> gets (v,)) @@ -563,13 +563,13 @@ data BTDParams = BTDParams } deriving (Show, Eq) -btdModifyActiveContext :: Monad m => (ActiveContext -> ActiveContext) -> BTDT e m () +btdModifyActiveContext :: (Monad m) => (ActiveContext -> ActiveContext) -> BTDT e m () btdModifyActiveContext fn = modify \s -> s{btdStateActiveContext = fn (btdStateActiveContext s)} -btdModifyTermDefinition :: Monad m => (TermDefinition -> TermDefinition) -> BTDT e m () +btdModifyTermDefinition :: (Monad m) => (TermDefinition -> TermDefinition) -> BTDT e m () btdModifyTermDefinition fn = modify \s -> s{btdStateTermDefinition = fn (btdStateTermDefinition s)} -btdModifyDefined :: Monad m => (Map Text Bool -> Map Text Bool) -> BTDT e m () +btdModifyDefined :: (Monad m) => (Map Text Bool -> Map Text Bool) -> BTDT e m () btdModifyDefined fn = modify \s -> s{btdStateDefined = fn (btdStateDefined s)} btdValidateContainer :: JLDExpansionEnv e m -> Value -> Bool @@ -602,7 +602,7 @@ btdValidateContainer JLDExpansionEnv{..} value True _ -> False -btdExpandIri :: Monad m => Text -> BTDT e m (Maybe Text) +btdExpandIri :: (Monad m) => Text -> BTDT e m (Maybe Text) btdExpandIri value = do BTDEnv{..} <- ask defined <- gets btdStateDefined @@ -625,7 +625,7 @@ btdExpandIri value = do } pure expanded -btdBuildTermDefinition :: Monad m => Text -> BTDT e m () +btdBuildTermDefinition :: (Monad m) => Text -> BTDT e m () btdBuildTermDefinition term = do BTDEnv{..} <- ask defined <- gets btdStateDefined @@ -642,7 +642,7 @@ btdBuildTermDefinition term = do , btdStateDefined = defined' } -buildTermDefinition' :: Monad m => Text -> BTDT e m () +buildTermDefinition' :: (Monad m) => Text -> BTDT e m () buildTermDefinition' "" = throwError <| Left InvalidTermDefinition -- 2. buildTermDefinition' term = do BTDEnv{..} <- ask @@ -666,16 +666,16 @@ buildTermDefinition' term = do | JLD1_0 <- jldExpansionEnvProcessingMode -> throwError <| Left KeywordRedefinition | Object map' <- value -> if - | KM.size map' == 1 - , Just container <- KM.lookup (show KeywordContainer) map' -> - when (container /= String (show KeywordSet)) <| throwError (Left KeywordRedefinition) - | KM.size map' == 2 - , Just container <- KM.lookup (show KeywordContainer) map' - , KM.member (show KeywordProtected) map' -> - unless (valueContains (show KeywordSet) container) <| throwError (Left KeywordRedefinition) - | KM.size map' /= 1 || not (KM.member (show KeywordProtected) map') -> - throwError <| Left KeywordRedefinition - | otherwise -> pure () + | KM.size map' == 1 + , Just container <- KM.lookup (show KeywordContainer) map' -> + when (container /= String (show KeywordSet)) <| throwError (Left KeywordRedefinition) + | KM.size map' == 2 + , Just container <- KM.lookup (show KeywordContainer) map' + , KM.member (show KeywordProtected) map' -> + unless (valueContains (show KeywordSet) container) <| throwError (Left KeywordRedefinition) + | KM.size map' /= 1 || not (KM.member (show KeywordProtected) map') -> + throwError <| Left KeywordRedefinition + | otherwise -> pure () | otherwise -> throwError <| Left KeywordRedefinition -- 5. (parseKeyword -> Just _) -> throwError <| Left KeywordRedefinition @@ -726,6 +726,9 @@ buildTermDefinition' term = do -- Nothing -> pure () + -- 14. 15. 16. 17. 18. + maybeVocabMapping <- gets (btdStateActiveContext .> activeContextVocabularyMapping) + -- 13. case KM.lookup (show KeywordReverse) valueObject of -- 13.1. @@ -757,17 +760,10 @@ buildTermDefinition' term = do definition <- gets btdStateTermDefinition btdModifyActiveContext \ac -> ac{activeContextTerms = activeContextTerms ac |> M.insert term definition} btdModifyDefined <| M.insert term True - - throwError <| Right () -- 13.2. Just _ -> throwError <| Left InvalidIriMapping - -- - Nothing -> pure () - - -- 14. 15. 16. 17. 18. - maybeVocabMapping <- gets (btdStateActiveContext .> activeContextVocabularyMapping) - if - -- 14. 14.1. + -- 14. 14.1. + Nothing | Just idValue' <- idValue , idValue' /= String term -> case idValue' of Null -> pure () @@ -980,7 +976,7 @@ buildTermDefinition' term = do btdModifyDefined <| M.insert term True -buildTermDefinition :: Monad m => ActiveContext -> Object -> Text -> (BTDParams -> BTDParams) -> JLDExpansionT e m (ActiveContext, Map Text Bool) +buildTermDefinition :: (Monad m) => ActiveContext -> Object -> Text -> (BTDParams -> BTDParams) -> JLDExpansionT e m (ActiveContext, Map Text Bool) buildTermDefinition activeContext localContext term paramsFn = do BTDState{..} <- (buildTermDefinition' term >> get) -- cgit v1.2.3-70-g09d2