From 1bb6f74645e39bb45e33a7413771ea7f971628c9 Mon Sep 17 00:00:00 2001 From: Volpeon Date: Sat, 27 May 2023 12:10:51 +0200 Subject: Structural improvements --- src/Data/JLD/Expansion/Context.hs | 1020 +++++++++++++++++++++++++++++++++++++ src/Data/JLD/Expansion/Global.hs | 38 ++ 2 files changed, 1058 insertions(+) create mode 100644 src/Data/JLD/Expansion/Context.hs create mode 100644 src/Data/JLD/Expansion/Global.hs (limited to 'src/Data/JLD/Expansion') diff --git a/src/Data/JLD/Expansion/Context.hs b/src/Data/JLD/Expansion/Context.hs new file mode 100644 index 0000000..ce61644 --- /dev/null +++ b/src/Data/JLD/Expansion/Context.hs @@ -0,0 +1,1020 @@ +module Data.JLD.Expansion.Context (BTDParams (..), EIParams (..), BACParams (..), buildTermDefinition, expandIri, buildActiveContext) where + +import Data.JLD.Prelude + +import Data.JLD.Control.Monad.RES (REST, withEnvRES, withErrorRES, withErrorRES', withStateRES) +import Data.JLD.Error (JLDError (..)) +import Data.JLD.Expansion.Global (JLDExpansionEnv (..), JLDExpansionState (..), JLDExpansionT, hoistEnv, modifyContextCache, modifyDocumentCache) +import Data.JLD.Model.ActiveContext (ActiveContext (..), containsProtectedTerm, lookupTerm, newActiveContext) +import Data.JLD.Model.Direction (Direction (..)) +import Data.JLD.Model.IRI (CompactIRI (..), endsWithGenericDelim, isBlankIri, parseCompactIri) +import Data.JLD.Model.Keyword (Keyword (..), allKeywords, isKeyword, isKeywordLike, isNotKeyword, parseKeyword) +import Data.JLD.Model.Language (Language (..)) +import Data.JLD.Model.TermDefinition (TermDefinition (..), newTermDefinition) +import Data.JLD.Model.URI (parseUri, uriToIri) +import Data.JLD.Options (ContextCache, Document (..), DocumentCache, DocumentLoader (..), JLDVersion (..)) +import Data.JLD.Util (flattenSingletonArray, valueContains, valueContainsAny, valueIsTrue, valueToArray) + +import Control.Monad.Except (MonadError (..)) +import Data.Aeson (Object, Value (..)) +import Data.Aeson.Key qualified as K (fromText, toText) +import Data.Aeson.KeyMap qualified as KM (delete, keys, lookup, member, size) +import Data.Map.Strict qualified as M (delete, insert, lookup) +import Data.RDF (parseIRI, parseRelIRI, resolveIRI, serializeIRI, validateIRI) +import Data.Set qualified as S (insert, member, notMember, size) +import Data.Text qualified as T (drop, dropEnd, elem, findIndex, isPrefixOf, null, take, toLower) +import Data.Vector qualified as V (length) +import Text.URI (URI, isPathAbsolute, relativeTo) +import Text.URI qualified as U (render) + +type BACT e m = REST (BACEnv e m) (Either (JLDError e) ()) BACState m + +data BACEnv e m = BACEnv + { bacEnvGlobal :: JLDExpansionEnv e m + , bacEnvOverrideProtected :: Bool + , bacEnvValidateScopedContext :: Bool + , bacEnvPropagate :: Bool + } + deriving (Show) + +data BACState = BACState + { bacStateGlobal :: JLDExpansionState + , bacStateActiveContext :: ActiveContext + , bacStateRemoteContexts :: Set Text + } + deriving (Show, Eq) + +data BACParams = BACParams + { bacParamsOverrideProtected :: Bool + , bacParamsPropagate :: Bool + , bacParamsValidateScopedContext :: Bool + , bacParamsRemoteContexts :: Set Text + } + deriving (Show, Eq) + +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 = modifyDocumentCache .> withStateRES bacStateGlobal (\s g -> s{bacStateGlobal = g}) + +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 fn = modify \s -> s{bacStateRemoteContexts = fn (bacStateRemoteContexts s)} + +bacBuildTermDefinition :: Monad m => Object -> Maybe URI -> Text -> BACT e m () +bacBuildTermDefinition contextDefinition baseUrl term = do + BACEnv{..} <- ask + activeContext <- gets bacStateActiveContext + remoteContexts <- gets bacStateRemoteContexts + let params p = + p + { btdParamsBaseUrl = baseUrl + , btdParamsOverrideProtectedFlag = bacEnvOverrideProtected + , btdParamsProtectedFlag = contextDefinition |> KM.lookup (show KeywordProtected) .> maybe False valueIsTrue + , btdParamsRemoteContexts = remoteContexts + } + (activeContext', _) <- + buildTermDefinition activeContext contextDefinition term params + |> withEnvRES (const bacEnvGlobal) + |> withErrorRES Left + |> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global}) + bacModifyActiveContext <| const activeContext' + +bacBuildActiveContext :: Monad m => Value -> URI -> BACT e m () +bacBuildActiveContext context uri = do + BACEnv{..} <- ask + activeContext <- gets bacStateActiveContext + remoteContexts <- gets bacStateRemoteContexts + let params p = + p + { bacParamsValidateScopedContext = bacEnvValidateScopedContext + , bacParamsRemoteContexts = remoteContexts + } + activeContext' <- + buildActiveContext activeContext context (Just uri) params + |> withEnvRES (const bacEnvGlobal) + |> withErrorRES Left + |> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global}) + bacModifyActiveContext <| const activeContext' + +bacProcessItem :: Monad m => Maybe URI -> Value -> BACT e m () +bacProcessItem baseUrl item = do + BACEnv{..} <- ask + let JLDExpansionEnv{..} = hoistEnv (lift .> lift .> lift) bacEnvGlobal + + result <- gets bacStateActiveContext + + case item of + -- 5.1. + Null + -- 5.1.1. + | not bacEnvOverrideProtected && containsProtectedTerm result -> throwError <| Left InvalidContextNullification + -- 5.1.2. + | bacEnvPropagate -> + bacModifyActiveContext \ac -> newActiveContext \nac -> + nac + { activeContextBaseUrl = activeContextBaseUrl ac + , activeContextBaseIri = uriToIri =<< activeContextBaseUrl ac + } + | otherwise -> + bacModifyActiveContext \ac -> newActiveContext \nac -> + nac + { activeContextBaseUrl = activeContextBaseUrl ac + , activeContextBaseIri = uriToIri =<< activeContextBaseUrl ac + , activeContextPreviousContext = activeContextPreviousContext ac + } + -- 5.2. + String value -> bacFetchRemoteContext value baseUrl + -- 5.4. + Object contextDefinition -> do + -- 5.5. 5.5.1. 5.5.2. + case KM.lookup (show KeywordVersion) contextDefinition of + Just (String "1.1") + | JLD1_0 <- jldExpansionEnvProcessingMode -> throwError <| Left ProcessingModeConflict + | otherwise -> pure () + Just (Number 1.1) + | JLD1_0 <- jldExpansionEnvProcessingMode -> throwError <| Left ProcessingModeConflict + | otherwise -> pure () + Just value -> throwError <. Left <| InvalidKeywordValue KeywordVersion value + -- + Nothing -> pure () + + -- 5.6. + contextDefinition' <- case KM.lookup (show KeywordImport) contextDefinition of + -- 5.6.1. + Just _ | JLD1_0 <- jldExpansionEnvProcessingMode -> throwError <| Left InvalidContextEntry + -- 5.6.3. + Just (String value) + | Just importUri <- parseUri value + , Just contextUri <- relativeTo importUri =<< baseUrl -> + runDocumentLoader jldExpansionEnvDocumentLoader contextUri >>= \case + Right (Object document) -> case KM.lookup (show KeywordContext) document of + Just (Object remoteContext) + -- 5.6.7. + | KM.member (show KeywordImport) remoteContext -> throwError <| Left InvalidContextEntry + -- 5.6.8. + | otherwise -> pure <| contextDefinition <> remoteContext + -- 5.6.6. + _ -> throwError <| Left InvalidRemoteContext + -- 5.6.6. + Right _ -> throwError <| Left InvalidRemoteContext + -- 5.6.5. + Left err -> throwError <. Left <| DocumentLoaderError err + -- 5.6.2. + Just value -> throwError <. Left <| InvalidKeywordValue KeywordImport value + -- + Nothing -> pure contextDefinition + + -- 5.7. 5.7.1. + case KM.lookup (show KeywordBase) contextDefinition' of + -- 5.7.2. + Just Null -> bacModifyActiveContext \ac -> ac{activeContextBaseIri = Nothing} + Just (String "") -> pure () + Just (String value) + -- 5.7.3. + | Right iri <- parseIRI value -> bacModifyActiveContext \ac -> ac{activeContextBaseIri = Just iri} + -- 5.7.4. + | Just baseIri <- activeContextBaseIri result + , Right iri <- parseIRI =<< resolveIRI (serializeIRI baseIri) value -> + bacModifyActiveContext \ac -> ac{activeContextBaseIri = Just iri} + -- + Just _ -> throwError <| Left InvalidBaseIri + -- + Nothing -> pure () + + -- 5.8. 5.8.1. + case KM.lookup (show KeywordVocab) contextDefinition' of + -- 5.8.2. + Just Null -> bacModifyActiveContext \ac -> ac{activeContextVocabularyMapping = Nothing} + -- 5.8.3. + Just (String value) | T.null value || isBlankIri value || isRight (parseIRI value) || isRight (parseRelIRI value) -> do + activeContext <- gets bacStateActiveContext + let params p = + p + { eiParamsVocab = True + , eiParamsDocumentRelative = True + } + (maybeVocabMapping, activeContext', _) <- + expandIri activeContext value params + |> withEnvRES (const bacEnvGlobal) + |> withErrorRES Left + |> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global}) + bacModifyActiveContext <| const activeContext' + + case maybeVocabMapping of + Just vocabMapping | isBlankIri vocabMapping || isRight (parseIRI vocabMapping) -> + bacModifyActiveContext \ac -> ac{activeContextVocabularyMapping = Just vocabMapping} + _ -> + throwError <| Left InvalidVocabMapping + Just _ -> throwError <| Left InvalidVocabMapping + -- + Nothing -> pure () + + -- 5.9. 5.9.1. + case KM.lookup (show KeywordLanguage) contextDefinition' of + -- 5.9.2. + Just Null -> bacModifyActiveContext \ac -> ac{activeContextDefaultLanguage = Just NoLanguage} + -- 5.9.3. + Just (String language) -> bacModifyActiveContext \ac -> ac{activeContextDefaultLanguage = Just <| Language language} + Just _ -> throwError <| Left InvalidDefaultLanguage + -- + Nothing -> pure () + + -- 5.10. 5.10.2. + case KM.lookup (show KeywordDirection) contextDefinition' of + -- 5.10.1. + Just _ | JLD1_0 <- jldExpansionEnvProcessingMode -> throwError <| Left InvalidContextEntry + -- 5.10.3. + Just Null -> bacModifyActiveContext \ac -> ac{activeContextDefaultBaseDirection = Nothing} + -- + Just (String (T.toLower -> "ltr")) -> bacModifyActiveContext \ac -> ac{activeContextDefaultBaseDirection = Just LTR} + Just (String (T.toLower -> "rtl")) -> bacModifyActiveContext \ac -> ac{activeContextDefaultBaseDirection = Just RTL} + Just _ -> throwError <| Left InvalidBaseDirection + -- + Nothing -> pure () + + -- 5.11. + case KM.lookup (show KeywordPropagate) contextDefinition' of + -- 5.11.1. + Just _ | JLD1_0 <- jldExpansionEnvProcessingMode -> throwError <| Left InvalidContextEntry + Just (Bool _) -> pure () + Just invalid -> throwError <. Left <| InvalidKeywordValue KeywordPropagate invalid + -- + Nothing -> pure () + + -- 5.13. + KM.keys contextDefinition' + |> fmap K.toText + .> filter + ( `isNotKeyword` + [ KeywordBase + , KeywordDirection + , KeywordImport + , KeywordLanguage + , KeywordPropagate + , KeywordProtected + , KeywordVersion + , KeywordVocab + ] + ) + .> mapM_ (bacBuildTermDefinition contextDefinition' baseUrl) + -- 5.3. + _ -> throwError <| Left InvalidLocalContext + +bacFetchRemoteContext :: Monad m => Text -> Maybe URI -> BACT e m () +bacFetchRemoteContext url maybeBaseUrl + | Just uri <- parseUri url + , Just contextUri <- relativeTo uri =<< maybeBaseUrl -- 5.2.1. + , isPathAbsolute contextUri + , contextKey <- U.render contextUri = do + BACEnv{..} <- ask + let JLDExpansionEnv{..} = hoistEnv (lift .> lift .> lift) bacEnvGlobal + + remoteContexts <- gets bacStateRemoteContexts + + -- 5.2.2. + when (not bacEnvValidateScopedContext && S.member contextKey remoteContexts) <| throwError (Right ()) + + -- 5.2.3. + when (S.size remoteContexts > jldExpansionEnvMaxRemoteContexts) <| throwError (Left ContextOverflow) + + bacModifyRemoteContexts <| S.insert contextKey + + -- 5.2.4. + gets (bacStateGlobal .> jldExpansionStateContextCache .> M.lookup contextKey) >>= \case + Just cachedContext -> do + bacBuildActiveContext cachedContext contextUri + throwError <| Right () + -- + Nothing -> pure () + + -- 5.2.5. + document <- + gets (bacStateGlobal .> jldExpansionStateDocumentCache .> M.lookup contextKey) >>= \case + Just document -> pure document + Nothing -> + runDocumentLoader jldExpansionEnvDocumentLoader contextUri >>= \case + Right (Object document) -> pure <| Document contextUri document + -- 5.2.5.2. + Right _ -> throwError <| Left InvalidRemoteContext + -- 5.2.5.1. + Left err -> throwError <. Left <| DocumentLoaderError err + + -- 5.2.5.3. + importedContext <- case KM.lookup (show KeywordContext) (documentContent document) of + Just (Object context) -> pure <. Object <. KM.delete (show KeywordBase) <| context + Just context -> pure context + Nothing -> throwError <| Left InvalidRemoteContext + + bacModifyDocumentCache <| M.insert contextKey document + + -- 5.2.6. + bacBuildActiveContext importedContext (documentUri document) + bacModifyContextCache <| M.insert contextKey importedContext + | otherwise = throwError <| Left LoadingRemoteContextError + +buildActiveContext' :: Monad m => Value -> Maybe URI -> BACT e m () +buildActiveContext' localContext baseUrl = do + activeContext <- gets bacStateActiveContext + + -- 1. + bacModifyActiveContext \ac -> ac{activeContextInverseContext = mempty} + + -- 2. + propagate <- case localContext of + Object ctx | Just prop <- KM.lookup (show KeywordPropagate) ctx -> case prop of + Bool p -> pure p + _ -> throwError <. Left <| InvalidKeywordValue KeywordPropagate prop + _ -> asks bacEnvPropagate + + -- 3. + previousContext <- gets <| activeContextPreviousContext <. bacStateActiveContext + when (not propagate && isNothing previousContext) do + bacModifyActiveContext \ac -> ac{activeContextPreviousContext = Just activeContext} + + -- 4. 5. + forM_ (valueToArray localContext) + <| bacProcessItem baseUrl + .> withEnvRES (\env -> env{bacEnvPropagate = propagate}) + .> withErrorRES' (either (Left .> throwError) pure) + +buildActiveContext :: Monad m => ActiveContext -> Value -> Maybe URI -> (BACParams -> BACParams) -> JLDExpansionT e m ActiveContext +buildActiveContext activeContext localContext baseUrl paramsFn = do + BACState{..} <- + (buildActiveContext' localContext baseUrl >> get) + |> withEnvRES env + |> withErrorRES' (either throwError (const get)) + |> withStateRES st (const bacStateGlobal) + pure bacStateActiveContext + where + BACParams{..} = + paramsFn + BACParams + { bacParamsOverrideProtected = False + , bacParamsPropagate = True + , bacParamsValidateScopedContext = True + , bacParamsRemoteContexts = mempty + } + + env options = + BACEnv + { bacEnvGlobal = options + , bacEnvOverrideProtected = bacParamsOverrideProtected + , bacEnvValidateScopedContext = bacParamsValidateScopedContext + , bacEnvPropagate = bacParamsPropagate + } + + st global = + BACState + { bacStateGlobal = global + , bacStateActiveContext = activeContext + , bacStateRemoteContexts = bacParamsRemoteContexts + } + +-- + +type EIT e m = REST (EIEnv e m) (JLDError e) EIState m + +data EIEnv e m = EIEnv + { eiEnvGlobal :: JLDExpansionEnv e m + , eiEnvDocumentRelative :: Bool + , eiEnvVocab :: Bool + , eiEnvLocalContext :: Maybe Object + } + deriving (Show) + +data EIState = EIState + { eiStateGlobal :: JLDExpansionState + , eiStateDefined :: Map Text Bool + , eiStateActiveContext :: ActiveContext + } + deriving (Show, Eq) + +data EIParams = EIParams + { eiParamsDocumentRelative :: Bool + , eiParamsVocab :: Bool + , eiParamsLocalContext :: Maybe Object + , eiParamsDefined :: Map Text Bool + } + deriving (Show, Eq) + +eiBuildTermDefinition :: Monad m => Text -> EIT e m () +eiBuildTermDefinition value = do + EIEnv{..} <- ask + defined <- gets eiStateDefined + activeContext <- gets eiStateActiveContext + let params p = p{btdParamsDefined = defined} + localContext = fromMaybe mempty eiEnvLocalContext + (activeContext', defined') <- + buildTermDefinition activeContext localContext value params + |> withEnvRES (const eiEnvGlobal) + |> withStateRES eiStateGlobal (\ei global -> ei{eiStateGlobal = global}) + modify \s -> + s + { eiStateActiveContext = activeContext' + , eiStateDefined = defined' + } + +eiInitLocalContext :: Monad m => Text -> EIT e m () +eiInitLocalContext value = + -- 3. + asks eiEnvLocalContext >>= \case + Just localContext | Just (String entry) <- KM.lookup (K.fromText value) localContext -> do + defined <- gets eiStateDefined + when (maybe True not (M.lookup entry defined)) <| eiBuildTermDefinition value + _ -> pure () + +eiInitPropertyContext :: Monad m => Text -> Text -> Text -> EIT e m Text +eiInitPropertyContext prefix suffix value = do + -- 6.3. + defined <- gets eiStateDefined + asks eiEnvLocalContext >>= \case + Just localContext + | KM.member (K.fromText prefix) localContext + , M.lookup prefix defined /= Just True -> + eiBuildTermDefinition prefix + _ -> pure () + + -- 6.4. + gets (eiStateActiveContext .> lookupTerm prefix) >>= \case + Just prefixDefiniton + | Just iriMapping <- termDefinitionIriMapping prefixDefiniton + , termDefinitionPrefixFlag prefixDefiniton -> + pure <| iriMapping <> suffix + _ -> pure value + +eiExpandResult :: Monad m => Text -> EIT e m (Maybe Text) +eiExpandResult value = do + EIEnv{..} <- ask + activeContext <- gets eiStateActiveContext + case activeContextVocabularyMapping activeContext of + -- 7. + Just vocabMapping | eiEnvVocab -> pure <. Just <| vocabMapping <> value + -- 8. + _ + | eiEnvDocumentRelative + , baseIri <- serializeIRI <$> activeContextBaseIri activeContext + , Right iri <- maybe (Right value) (`resolveIRI` value) baseIri -> + pure <| Just iri + -- 9. + _ -> pure <| Just value + +expandIri' :: Monad m => Text -> EIT e m (Maybe Text) +expandIri' value + -- 1. + | Just _ <- parseKeyword value = pure <| Just value + -- 2. + | isKeywordLike value = pure Nothing + -- + | otherwise = do + EIEnv{..} <- ask + + -- 3. + eiInitLocalContext value + + gets (eiStateActiveContext .> lookupTerm value) >>= \case + -- 4. 5. + Just definition + | Just iriMapping <- termDefinitionIriMapping definition + , Just _ <- parseKeyword iriMapping -> + pure <| Just iriMapping + | eiEnvVocab -> + pure <| termDefinitionIriMapping definition + -- 6. 6.1. + _ + | Just idx <- (+ 1) <$> T.findIndex (== ':') (T.drop 1 value) + , prefix <- T.take idx value + , suffix <- T.drop (idx + 1) value -> + -- 6.2. + if "_" `T.isPrefixOf` prefix || "//" `T.isPrefixOf` suffix + then pure <| Just value + else do + value' <- eiInitPropertyContext prefix suffix value + + if isBlankIri value' || isRight (validateIRI value') + then pure <| Just value' + else eiExpandResult value' + -- + _ -> eiExpandResult value + +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,)) + |> withEnvRES env + |> withStateRES st (const eiStateGlobal) + pure (value', eiStateActiveContext, eiStateDefined) + where + EIParams{..} = + paramsFn + EIParams + { eiParamsDocumentRelative = False + , eiParamsVocab = False + , eiParamsLocalContext = Nothing + , eiParamsDefined = mempty + } + + env options = + EIEnv + { eiEnvGlobal = options + , eiEnvDocumentRelative = eiParamsDocumentRelative + , eiEnvVocab = eiParamsVocab + , eiEnvLocalContext = eiParamsLocalContext + } + + st global = + EIState + { eiStateGlobal = global + , eiStateDefined = eiParamsDefined + , eiStateActiveContext = activeContext + } + +-- + +type BTDT e m = REST (BTDEnv e m) (Either (JLDError e) ()) BTDState m + +data BTDEnv e m = BTDEnv + { btdEnvGlobal :: JLDExpansionEnv e m + , btdEnvLocalContext :: Object + , btdEnvBaseUrl :: Maybe URI + , btdEnvProtectedFlag :: Bool + , btdEnvOverrideProtectedFlag :: Bool + , btdEnvRemoteContexts :: Set Text + } + deriving (Show) + +data BTDState = BTDState + { btdStateGlobal :: JLDExpansionState + , btdStateDefined :: Map Text Bool + , btdStateTermDefinition :: TermDefinition + , btdStateActiveContext :: ActiveContext + } + deriving (Show, Eq) + +data BTDParams = BTDParams + { btdParamsBaseUrl :: Maybe URI + , btdParamsProtectedFlag :: Bool + , btdParamsOverrideProtectedFlag :: Bool + , btdParamsRemoteContexts :: Set Text + , btdParamsDefined :: Map Text Bool + , btdParamsTermDefinition :: TermDefinition + } + deriving (Show, Eq) + +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 fn = modify \s -> s{btdStateTermDefinition = fn (btdStateTermDefinition s)} + +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 +btdValidateContainer _ Null = False +btdValidateContainer JLDExpansionEnv{..} value + | JLD1_0 <- jldExpansionEnvProcessingMode = case value of + String value' -> isNotKeyword value' [KeywordGraph, KeywordId, KeywordType] + _ -> False + | otherwise = case flattenSingletonArray value of + String container' -> + isKeyword + container' + [ KeywordGraph + , KeywordId + , KeywordIndex + , KeywordLanguage + , KeywordList + , KeywordSet + , KeywordType + ] + container@(Array (V.length -> len)) + | len > 3 -> + False + | valueContains (show KeywordGraph) container + , valueContainsAny (show <$> [KeywordId, KeywordIndex]) container -> + len == 2 || valueContains (show KeywordSet) container + | len == 2 + , valueContains (show KeywordSet) container + , valueContainsAny (show <$> [KeywordGraph, KeywordId, KeywordIndex, KeywordLanguage, KeywordType]) container -> + True + _ -> False + +btdExpandIri :: Monad m => Text -> BTDT e m (Maybe Text) +btdExpandIri value = do + BTDEnv{..} <- ask + defined <- gets btdStateDefined + activeContext <- gets btdStateActiveContext + let params p = + p + { eiParamsLocalContext = Just btdEnvLocalContext + , eiParamsVocab = True + , eiParamsDefined = defined + } + (expanded, activeContext', defined') <- + expandIri activeContext value params + |> withEnvRES (const btdEnvGlobal) + |> withErrorRES Left + |> withStateRES btdStateGlobal (\btd global -> btd{btdStateGlobal = global}) + modify \s -> + s + { btdStateActiveContext = activeContext' + , btdStateDefined = defined' + } + pure expanded + +btdBuildTermDefinition :: Monad m => Text -> BTDT e m () +btdBuildTermDefinition term = do + BTDEnv{..} <- ask + defined <- gets btdStateDefined + activeContext <- gets btdStateActiveContext + let params p = p{btdParamsDefined = defined} + (activeContext', defined') <- + buildTermDefinition activeContext btdEnvLocalContext term params + |> withEnvRES (const btdEnvGlobal) + |> withErrorRES Left + |> withStateRES btdStateGlobal (\btd global -> btd{btdStateGlobal = global}) + modify \env -> + env + { btdStateActiveContext = activeContext' + , btdStateDefined = defined' + } + +buildTermDefinition' :: Monad m => Text -> BTDT e m () +buildTermDefinition' "" = throwError <| Left InvalidTermDefinition -- 2. +buildTermDefinition' term = do + BTDEnv{..} <- ask + let JLDExpansionEnv{..} = btdEnvGlobal + + -- 1. + gets (btdStateDefined .> M.lookup term) >>= \case + Just True -> throwError <| Right () + Just False -> throwError <| Left CyclicIriMapping + Nothing -> pure () + + -- 2. + btdModifyDefined <| M.insert term False + + -- 3. + let value = btdEnvLocalContext |> KM.lookup (K.fromText term) .> fromMaybe Null + + -- 4. + case term of + ((`isKeyword` [KeywordType]) -> True) + | 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 () + | otherwise -> throwError <| Left KeywordRedefinition + -- 5. + (parseKeyword -> Just _) -> throwError <| Left KeywordRedefinition + (isKeywordLike -> True) -> throwError <| Right () + _ -> pure () + + -- 6. + maybePreviousDefinition <- gets (btdStateActiveContext .> lookupTerm term) + btdModifyActiveContext \ac -> ac{activeContextTerms = M.delete term (activeContextTerms ac)} + + -- 7. 8. 9. + (valueObject, idValue, simpleTerm) <- case value of + Null -> pure (mempty, Just Null, False) + (String s) -> pure (mempty, Just (String s), True) + (Object o) -> pure (o, KM.lookup (show KeywordId) o, False) + _ -> throwError <| Left InvalidTermDefinition + + -- 10. + btdModifyTermDefinition <| const (newTermDefinition btdEnvProtectedFlag id) + + -- 11. + case KM.lookup (show KeywordProtected) valueObject of + Just _ | JLD1_0 <- jldExpansionEnvProcessingMode -> throwError <| Left InvalidTermDefinition + Just (Bool protected) -> btdModifyTermDefinition \d -> d{termDefinitionProtectedFlag = protected} + Just invalid -> throwError <. Left <| InvalidKeywordValue KeywordProtected invalid + Nothing -> pure () + + -- 12. + case KM.lookup (show KeywordType) valueObject of + -- 12.2. + Just (String type') -> + btdExpandIri type' >>= \case + Nothing -> throwError <| Left InvalidTypeMapping + Just expandedType + -- 12.3. + | isKeyword expandedType [KeywordJson, KeywordNone] + , JLD1_0 <- jldExpansionEnvProcessingMode -> + throwError <| Left InvalidTypeMapping + -- 12.4. + | isNotKeyword expandedType [KeywordId, KeywordJson, KeywordNone, KeywordVocab] + , Left _ <- validateIRI expandedType -> + throwError <| Left InvalidTypeMapping + -- 12.5. + | otherwise -> + btdModifyTermDefinition \d -> d{termDefinitionTypeMapping = Just expandedType} + -- 12.1. + Just _ -> throwError <| Left InvalidTypeMapping + -- + Nothing -> pure () + + -- 13. + case KM.lookup (show KeywordReverse) valueObject of + -- 13.1. + Just _ | KM.member (show KeywordId) valueObject || KM.member (show KeywordNest) valueObject -> throwError <| Left InvalidReverseProperty + Just (String (isKeywordLike -> True)) -> throwError <| Right () + -- 13.3. + Just (String reverse') -> do + -- 13.4. + btdExpandIri reverse' >>= \case + Just (validateIRI -> Right expandedReverse) -> + btdModifyTermDefinition \d -> d{termDefinitionIriMapping = Just expandedReverse} + _ -> throwError <| Left InvalidIriMapping + + -- 13.5. + case KM.lookup (show KeywordContainer) valueObject of + Just (String container) | isKeyword container [KeywordSet, KeywordIndex] -> do + btdModifyTermDefinition \d -> + d + { termDefinitionContainerMapping = S.insert container <| termDefinitionContainerMapping d + } + Just Null -> pure () + Just _ -> throwError <| Left InvalidReverseProperty + Nothing -> pure () + + -- 13.6. + btdModifyTermDefinition \d -> d{termDefinitionReversePropertyFlag = True} + + -- 13.7. + 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. + | Just idValue' <- idValue + , idValue' /= String term -> case idValue' of + Null -> pure () + String id' + -- 14.2.2. + | isNothing (parseKeyword id') && isKeywordLike id' -> throwError <| Right () + | otherwise -> do + -- 14.2.3. + iriMapping <- + btdExpandIri id' >>= \case + Nothing -> throwError <| Left InvalidIriMapping + Just expandedId + | isKeyword expandedId [KeywordContext] -> + throwError <| Left InvalidKeywordAlias + | Nothing <- parseKeyword expandedId + , Left _ <- validateIRI expandedId + , isBlankIri expandedId -> + throwError <| Left InvalidIriMapping + | otherwise -> + expandedId <$ btdModifyTermDefinition \d -> d{termDefinitionIriMapping = Just expandedId} + + -- 14.2.4. + when (T.elem ':' (T.dropEnd 1 <. T.drop 1 <| term) || T.elem '/' term) do + -- 14.2.4.1 + btdModifyDefined <| M.insert term True + + -- 14.2.4.2. + expandedTerm <- btdExpandIri term + when (expandedTerm /= Just iriMapping) <| throwError (Left InvalidIriMapping) + + -- 14.2.5. + definition <- gets btdStateTermDefinition + when (not <| termDefinitionPrefixFlag definition) do + let validIri = isRight <. validateIRI <. T.dropEnd 1 <| iriMapping + let prefix = + not (T.elem ':' term || T.elem '/' term) + && simpleTerm + && ((endsWithGenericDelim iriMapping && validIri) || isBlankIri iriMapping) + btdModifyTermDefinition \d -> d{termDefinitionPrefixFlag = prefix} + -- 14.2.1. + _ -> throwError <| Left InvalidIriMapping + -- 15. + | T.elem ':' (T.drop 1 term) -> do + let maybeCompactIri = parseCompactIri term + + -- 15.1. + case maybeCompactIri of + Just (CompactIRI prefix _) | KM.member (K.fromText prefix) btdEnvLocalContext -> do + btdBuildTermDefinition prefix + _ -> pure () + + -- 15.2. + activeContextTerms <- gets (btdStateActiveContext .> activeContextTerms) + case maybeCompactIri of + Just (CompactIRI prefix suffix) + | Just term' <- M.lookup prefix activeContextTerms + , iriMapping <- (<> suffix) <$> termDefinitionIriMapping term' -> + btdModifyTermDefinition \d -> d{termDefinitionIriMapping = iriMapping} + -- 15.3. + _ + | isRight (validateIRI term) || isBlankIri term -> + btdModifyTermDefinition \d -> d{termDefinitionIriMapping = Just term} + _ -> pure () + -- 16. + | T.elem '/' term -> + btdExpandIri term >>= \case + Just expandedTerm -> btdModifyTermDefinition \d -> d{termDefinitionIriMapping = Just expandedTerm} + Nothing -> throwError <| Left InvalidIriMapping + -- 17. + | isKeyword term [KeywordType] -> btdModifyTermDefinition \d -> d{termDefinitionIriMapping = Just term} + -- 18. + | Just vocabMapping <- maybeVocabMapping -> btdModifyTermDefinition \d -> d{termDefinitionIriMapping = Just (vocabMapping <> term)} + -- + | otherwise -> throwError <| Left InvalidIriMapping + + -- 19. + case KM.lookup (show KeywordContainer) valueObject of + Just container -> do + when (not <| btdValidateContainer btdEnvGlobal container) <| throwError (Left InvalidContainerMapping) + + forM_ (valueToArray container) \case + String item -> btdModifyTermDefinition \d -> d{termDefinitionContainerMapping = termDefinitionContainerMapping d |> S.insert item} + _ -> pure () + + definition <- gets btdStateTermDefinition + when (S.member (show KeywordType) <| termDefinitionContainerMapping definition) do + let typeMapping = termDefinitionTypeMapping definition |> fromMaybe (show KeywordId) + btdModifyTermDefinition \d -> d{termDefinitionTypeMapping = Just typeMapping} + when (isNotKeyword typeMapping [KeywordId, KeywordVocab]) do + throwError <| Left InvalidTypeMapping + -- + Nothing -> pure () + + -- 20. + containerMapping <- gets (btdStateTermDefinition .> termDefinitionContainerMapping) + case KM.lookup (show KeywordIndex) valueObject of + -- 20.1. + Just _ | jldExpansionEnvProcessingMode == JLD1_0 || S.notMember (show KeywordIndex) containerMapping -> throwError <| Left InvalidTermDefinition + -- 20.2. + Just (String index) -> + btdExpandIri index >>= \case + Just (validateIRI -> Right _) -> btdModifyTermDefinition \d -> d{termDefinitionIndexMapping = Just index} + _ -> throwError <| Left InvalidTermDefinition + Just _ -> throwError <| Left InvalidTermDefinition + -- + Nothing -> pure () + + -- 21. + case KM.lookup (show KeywordContext) valueObject of + -- 21.1. + Just _ | JLD1_0 <- jldExpansionEnvProcessingMode -> throwError <| Left InvalidTermDefinition + -- 21.2. + Just context -> do + -- 21.3. + activeContext <- gets btdStateActiveContext + let params p = + p + { bacParamsOverrideProtected = True + , bacParamsRemoteContexts = btdEnvRemoteContexts + , bacParamsValidateScopedContext = False + } + buildActiveContext activeContext context btdEnvBaseUrl params + |> withEnvRES (const btdEnvGlobal) + |> withStateRES btdStateGlobal (\btd global -> btd{btdStateGlobal = global}) + |> withErrorRES (const <| Left InvalidScopedContext) + |> void + + -- 21.4. + btdModifyTermDefinition \d -> + d + { termDefinitionLocalContext = Just context + , termDefinitionBaseUrl = btdEnvBaseUrl + } + -- + Nothing -> pure () + + -- 22. 23. + unless (KM.member (show KeywordType) valueObject) do + -- 22. + case KM.lookup (show KeywordLanguage) valueObject of + Just Null -> btdModifyTermDefinition \d -> d{termDefinitionLanguageMapping = Just NoLanguage} + Just (String language) -> btdModifyTermDefinition \d -> d{termDefinitionLanguageMapping = Just <| Language language} + Just _ -> throwError <| Left InvalidLanguageMapping + Nothing -> pure () + + -- 23. + case KM.lookup (show KeywordDirection) valueObject of + Just Null -> btdModifyTermDefinition \d -> d{termDefinitionDirectionMapping = Just NoDirection} + Just (String "ltr") -> btdModifyTermDefinition \d -> d{termDefinitionDirectionMapping = Just LTR} + Just (String "rtl") -> btdModifyTermDefinition \d -> d{termDefinitionDirectionMapping = Just RTL} + Just _ -> throwError <| Left InvalidBaseDirection + Nothing -> pure () + + -- 24. + case KM.lookup (show KeywordNest) valueObject of + -- 24.1. + Just _ | JLD1_0 <- jldExpansionEnvProcessingMode -> throwError <| Left InvalidTermDefinition + Just (String nest) + | parseKeyword nest /= Just KeywordNest -> throwError <. Left <| InvalidKeywordValue KeywordNest (String nest) + | otherwise -> btdModifyTermDefinition \d -> d{termDefinitionNestValue = Just nest} + Just invalid -> throwError <. Left <| InvalidKeywordValue KeywordNest invalid + Nothing -> pure () + + -- 25. + maybeIriMapping <- gets (btdStateTermDefinition .> termDefinitionIriMapping) + case KM.lookup (show KeywordPrefix) valueObject of + -- 25.1. + Just _ + | jldExpansionEnvProcessingMode == JLD1_0 || T.elem ':' term || T.elem '/' term -> + throwError <| Left InvalidTermDefinition + Just (Bool prefix) + | prefix, Just _ <- parseKeyword =<< maybeIriMapping -> throwError <| Left InvalidTermDefinition + | otherwise -> btdModifyTermDefinition \d -> d{termDefinitionPrefixFlag = prefix} + Just invalid -> throwError <. Left <| InvalidKeywordValue KeywordPrefix invalid + Nothing -> pure () + + -- 26. + unless + ( allKeywords + (KM.keys valueObject <&> K.toText) + [ KeywordId + , KeywordReverse + , KeywordContainer + , KeywordContext + , KeywordDirection + , KeywordIndex + , KeywordLanguage + , KeywordNest + , KeywordPrefix + , KeywordProtected + , KeywordType + ] + ) + do throwError <| Left InvalidTermDefinition + + -- 27. + definition <- gets btdStateTermDefinition + + case maybePreviousDefinition of + Just previousDefinition | not btdEnvOverrideProtectedFlag && termDefinitionProtectedFlag previousDefinition -> do + -- 27.1. + when (definition{termDefinitionProtectedFlag = True} /= previousDefinition) do + throwError <| Left ProtectedTermRedefinition + + -- 27.2. + btdModifyActiveContext \ac -> ac{activeContextTerms = activeContextTerms ac |> M.insert term previousDefinition} + -- + _ -> + btdModifyActiveContext \ac -> ac{activeContextTerms = activeContextTerms ac |> M.insert term definition} + + btdModifyDefined <| M.insert term True + +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) + |> withEnvRES env + |> withErrorRES' (either throwError (const get)) + |> withStateRES st (const btdStateGlobal) + pure (btdStateActiveContext, btdStateDefined) + where + BTDParams{..} = + paramsFn + BTDParams + { btdParamsBaseUrl = Nothing + , btdParamsProtectedFlag = False + , btdParamsOverrideProtectedFlag = False + , btdParamsRemoteContexts = mempty + , btdParamsDefined = mempty + , btdParamsTermDefinition = newTermDefinition False id + } + + env options = + BTDEnv + { btdEnvGlobal = options + , btdEnvLocalContext = localContext + , btdEnvBaseUrl = btdParamsBaseUrl + , btdEnvProtectedFlag = btdParamsProtectedFlag + , btdEnvOverrideProtectedFlag = btdParamsOverrideProtectedFlag + , btdEnvRemoteContexts = btdParamsRemoteContexts + } + + st global = + BTDState + { btdStateGlobal = global + , btdStateDefined = btdParamsDefined + , btdStateTermDefinition = btdParamsTermDefinition + , btdStateActiveContext = activeContext + } diff --git a/src/Data/JLD/Expansion/Global.hs b/src/Data/JLD/Expansion/Global.hs new file mode 100644 index 0000000..b92b4af --- /dev/null +++ b/src/Data/JLD/Expansion/Global.hs @@ -0,0 +1,38 @@ +module Data.JLD.Expansion.Global ( + JLDExpansionT, + JLDExpansionEnv (..), + JLDExpansionState (..), + hoistEnv, + modifyContextCache, + modifyDocumentCache, +) where + +import Data.JLD.Prelude + +import Data.JLD.Control.Monad.RES (REST) +import Data.JLD.Error (JLDError) +import Data.JLD.Options (ContextCache, DocumentCache, DocumentLoader (..), JLDVersion (..), hoistDocumentLoader) + +type JLDExpansionT e m = REST (JLDExpansionEnv e m) (JLDError e) JLDExpansionState m + +data JLDExpansionEnv e m = JLDExpansionEnv + { jldExpansionEnvDocumentLoader :: DocumentLoader e m + , jldExpansionEnvProcessingMode :: JLDVersion + , jldExpansionEnvMaxRemoteContexts :: Int + } + deriving (Show) + +data JLDExpansionState = JLDExpansionState + { jldExpansionStateContextCache :: ContextCache + , jldExpansionStateDocumentCache :: DocumentCache + } + deriving (Show, Eq) + +hoistEnv :: (forall a. m a -> n a) -> JLDExpansionEnv e m -> JLDExpansionEnv e n +hoistEnv map' options = options{jldExpansionEnvDocumentLoader = options |> jldExpansionEnvDocumentLoader .> hoistDocumentLoader map'} + +modifyContextCache :: MonadState JLDExpansionState m => (ContextCache -> ContextCache) -> m () +modifyContextCache fn = modify \s -> s{jldExpansionStateContextCache = fn (jldExpansionStateContextCache s)} + +modifyDocumentCache :: MonadState JLDExpansionState m => (DocumentCache -> DocumentCache) -> m () +modifyDocumentCache fn = modify \s -> s{jldExpansionStateDocumentCache = fn (jldExpansionStateDocumentCache s)} -- cgit v1.2.3-54-g00ecf