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, 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 (== Bool True) , 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 <| T.toLower 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. let filteredKeywords = [ KeywordBase , KeywordDirection , KeywordImport , KeywordLanguage , KeywordPropagate , KeywordProtected , KeywordVersion , KeywordVocab ] KM.keys contextDefinition' |> fmap K.toText .> filter (`isNotKeyword` filteredKeywords) .> 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 () -- 14. 15. 16. 17. 18. maybeVocabMapping <- gets (btdStateActiveContext .> activeContextVocabularyMapping) -- 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 -- 13.2. Just _ -> throwError <| Left InvalidIriMapping -- 14. 14.1. Nothing | 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 <| T.toLower 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 }