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/Context.hs | 1020 ----------------------------------------------- 1 file changed, 1020 deletions(-) delete mode 100644 src/Data/JLD/Context.hs (limited to 'src/Data/JLD/Context.hs') diff --git a/src/Data/JLD/Context.hs b/src/Data/JLD/Context.hs deleted file mode 100644 index a999395..0000000 --- a/src/Data/JLD/Context.hs +++ /dev/null @@ -1,1020 +0,0 @@ -module Data.JLD.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.Model.ActiveContext (ActiveContext (..), containsProtectedTerm, lookupTerm, newActiveContext) -import Data.JLD.Model.Direction (Direction (..)) -import Data.JLD.Error (JLDError (..)) -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.Monad (JLDEnv (..), JLDState (..), JLDT, hoistEnv, modifyContextCache, modifyDocumentCache) -import Data.JLD.Options (ContextCache, Document (..), DocumentCache, DocumentLoader (..), JLDVersion (..)) -import Data.JLD.Model.TermDefinition (TermDefinition (..), newTermDefinition) -import Data.JLD.Util (flattenSingletonArray, valueContains, valueContainsAny, valueIsTrue, valueToArray) -import Data.JLD.Model.URI (parseUri, uriToIri) - -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 :: JLDEnv e m - , bacEnvOverrideProtected :: Bool - , bacEnvValidateScopedContext :: Bool - , bacEnvPropagate :: Bool - } - deriving (Show) - -data BACState = BACState - { bacStateGlobal :: JLDState - , 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 JLDEnv{..} = 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 <- jldEnvProcessingMode -> throwError <| Left ProcessingModeConflict - | otherwise -> pure () - Just (Number 1.1) - | JLD1_0 <- jldEnvProcessingMode -> 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 <- jldEnvProcessingMode -> throwError <| Left InvalidContextEntry - -- 5.6.3. - Just (String value) - | Just importUri <- parseUri value - , Just contextUri <- relativeTo importUri =<< baseUrl -> - runDocumentLoader jldEnvDocumentLoader 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 <- jldEnvProcessingMode -> 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 <- jldEnvProcessingMode -> 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 JLDEnv{..} = 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 > jldEnvMaxRemoteContexts) <| throwError (Left ContextOverflow) - - bacModifyRemoteContexts <| S.insert contextKey - - -- 5.2.4. - gets (bacStateGlobal .> jldStateContextCache .> M.lookup contextKey) >>= \case - Just cachedContext -> do - bacBuildActiveContext cachedContext contextUri - throwError <| Right () - -- - Nothing -> pure () - - -- 5.2.5. - document <- - gets (bacStateGlobal .> jldStateDocumentCache .> M.lookup contextKey) >>= \case - Just document -> pure document - Nothing -> - runDocumentLoader jldEnvDocumentLoader 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) -> JLDT 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 :: JLDEnv e m - , eiEnvDocumentRelative :: Bool - , eiEnvVocab :: Bool - , eiEnvLocalContext :: Maybe Object - } - deriving (Show) - -data EIState = EIState - { eiStateGlobal :: JLDState - , 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) -> JLDT 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 :: JLDEnv e m - , btdEnvLocalContext :: Object - , btdEnvBaseUrl :: Maybe URI - , btdEnvProtectedFlag :: Bool - , btdEnvOverrideProtectedFlag :: Bool - , btdEnvRemoteContexts :: Set Text - } - deriving (Show) - -data BTDState = BTDState - { btdStateGlobal :: JLDState - , 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 :: JLDEnv e m -> Value -> Bool -btdValidateContainer _ Null = False -btdValidateContainer JLDEnv{..} value - | JLD1_0 <- jldEnvProcessingMode = 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 JLDEnv{..} = 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 <- jldEnvProcessingMode -> 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 <- jldEnvProcessingMode -> 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 <- jldEnvProcessingMode -> - 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 _ | jldEnvProcessingMode == 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 <- jldEnvProcessingMode -> 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 <- jldEnvProcessingMode -> 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 _ - | jldEnvProcessingMode == 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) -> JLDT 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 - } -- cgit v1.2.3-54-g00ecf