From 1bb6f74645e39bb45e33a7413771ea7f971628c9 Mon Sep 17 00:00:00 2001 From: Volpeon Date: Sat, 27 May 2023 12:10:51 +0200 Subject: Structural improvements --- jsonld.cabal | 7 +- src/Data/JLD.hs | 53 +- src/Data/JLD/Context.hs | 1020 ------------------------------------- src/Data/JLD/Control/Monad/RES.hs | 4 + src/Data/JLD/Expansion.hs | 56 +- src/Data/JLD/Expansion/Context.hs | 1020 +++++++++++++++++++++++++++++++++++++ src/Data/JLD/Expansion/Global.hs | 38 ++ src/Data/JLD/Monad.hs | 86 ---- src/Data/JLD/NodeMap.hs | 88 ++++ test/Test/Expansion.hs | 25 +- 10 files changed, 1238 insertions(+), 1159 deletions(-) delete mode 100644 src/Data/JLD/Context.hs create mode 100644 src/Data/JLD/Expansion/Context.hs create mode 100644 src/Data/JLD/Expansion/Global.hs delete mode 100644 src/Data/JLD/Monad.hs create mode 100644 src/Data/JLD/NodeMap.hs diff --git a/jsonld.cabal b/jsonld.cabal index 6f36afa..1308318 100644 --- a/jsonld.cabal +++ b/jsonld.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.1. +-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack @@ -24,10 +24,11 @@ source-repository head library exposed-modules: Data.JLD - Data.JLD.Context Data.JLD.Control.Monad.RES Data.JLD.Error Data.JLD.Expansion + Data.JLD.Expansion.Context + Data.JLD.Expansion.Global Data.JLD.Mime Data.JLD.Model.ActiveContext Data.JLD.Model.Direction @@ -41,7 +42,7 @@ library Data.JLD.Model.TermDefinition Data.JLD.Model.URI Data.JLD.Model.ValueObject - Data.JLD.Monad + Data.JLD.NodeMap Data.JLD.Options Data.JLD.Prelude Data.JLD.Util diff --git a/src/Data/JLD.hs b/src/Data/JLD.hs index d60e5a1..1f894bb 100644 --- a/src/Data/JLD.hs +++ b/src/Data/JLD.hs @@ -2,22 +2,22 @@ module Data.JLD ( module Data.JLD.Mime, module Data.JLD.Error, module Data.JLD.Options, - JLDExpandParams (..), + JLDExpansionParams (..), expand, ) where import Data.JLD.Prelude -import Data.JLD.Context (buildActiveContext) import Data.JLD.Control.Monad.RES (evalREST, runREST) import Data.JLD.Error import Data.JLD.Expansion (JLDEParams (..)) import Data.JLD.Expansion qualified as E (expand) +import Data.JLD.Expansion.Context (buildActiveContext) +import Data.JLD.Expansion.Global (JLDExpansionEnv (..), JLDExpansionState (..)) import Data.JLD.Mime import Data.JLD.Model.ActiveContext (ActiveContext (..), newActiveContext) import Data.JLD.Model.Keyword (Keyword (..)) import Data.JLD.Model.URI (uriToIri) -import Data.JLD.Monad (JLDEnv, JLDState, newEnv, newState) import Data.JLD.Options import Data.JLD.Util (flattenSingletonArray, valueToArray) @@ -26,31 +26,46 @@ import Data.Aeson.KeyMap qualified as KM import Data.Vector qualified as V (singleton) import Text.URI (URI) -data JLDExpandParams e m = JLDExpandParams - { jldExpandParamsExpandContext :: Maybe Value - , jldExpandParamsFrameExpansion :: Bool - , jldExpandParamsEnv :: JLDEnv e m - , jldExpandParamsState :: JLDState +data JLDExpansionParams e m = JLDExpansionParams + { jldExpansionParamsDocumentLoader :: DocumentLoader e m + , jldExpansionParamsProcessingMode :: JLDVersion + , jldExpansionParamsMaxRemoteContexts :: Int + , jldExpansionParamsExpandContext :: Maybe Value + , jldExpansionParamsFrameExpansion :: Bool + , jldExpansionParamsState :: JLDExpansionState } deriving (Show) -expand :: Monad m => Value -> URI -> (JLDExpandParams () m -> JLDExpandParams e m) -> m (Either (JLDError e) Value, JLDState) +expand :: Monad m => Value -> URI -> (JLDExpansionParams () m -> JLDExpansionParams e m) -> m (Either (JLDError e) Value, JLDExpansionState) expand document baseUrl paramsFn = do - let JLDExpandParams{..} = + let JLDExpansionParams{..} = paramsFn - JLDExpandParams - { jldExpandParamsExpandContext = Nothing - , jldExpandParamsFrameExpansion = False - , jldExpandParamsEnv = newEnv id - , jldExpandParamsState = newState id + JLDExpansionParams + { jldExpansionParamsDocumentLoader = DocumentLoader <. const <. pure <| Left () + , jldExpansionParamsProcessingMode = JLD1_1 + , jldExpansionParamsMaxRemoteContexts = 20 + , jldExpansionParamsExpandContext = Nothing + , jldExpansionParamsFrameExpansion = False + , jldExpansionParamsState = + JLDExpansionState + { jldExpansionStateContextCache = mempty + , jldExpansionStateDocumentCache = mempty + } } + env = + JLDExpansionEnv + { jldExpansionEnvDocumentLoader = jldExpansionParamsDocumentLoader + , jldExpansionEnvProcessingMode = jldExpansionParamsProcessingMode + , jldExpansionEnvMaxRemoteContexts = jldExpansionParamsMaxRemoteContexts + } + activeContext = newActiveContext \ac -> ac{activeContextBaseUrl = Just baseUrl, activeContextBaseIri = uriToIri baseUrl} - expansionParams p = p{jldeParamsFrameExpansion = jldExpandParamsFrameExpansion} + expansionParams p = p{jldeParamsFrameExpansion = jldExpansionParamsFrameExpansion} -- 6. let maybeExpandContext = - jldExpandParamsExpandContext <&> flattenSingletonArray .> \case + jldExpansionParamsExpandContext <&> flattenSingletonArray .> \case Array expandedContext -> Array expandedContext (Object expandedContext) | Just ctx <- KM.lookup (show KeywordContext) expandedContext -> ctx expandedContext -> Array <| V.singleton expandedContext @@ -58,14 +73,14 @@ expand document baseUrl paramsFn = do activeContext' <- case maybeExpandContext of Just expandContext -> buildActiveContext activeContext expandContext (Just baseUrl) id - |> evalREST jldExpandParamsEnv jldExpandParamsState + |> evalREST env jldExpansionParamsState |> fmap (fromRight activeContext) Nothing -> pure activeContext -- 8. (result, state') <- E.expand activeContext' document baseUrl expansionParams - |> runREST jldExpandParamsEnv jldExpandParamsState + |> runREST env jldExpansionParamsState let result' = case result of -- 8.1. 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 - } diff --git a/src/Data/JLD/Control/Monad/RES.hs b/src/Data/JLD/Control/Monad/RES.hs index 1c96d46..b9f8f22 100644 --- a/src/Data/JLD/Control/Monad/RES.hs +++ b/src/Data/JLD/Control/Monad/RES.hs @@ -2,6 +2,7 @@ module Data.JLD.Control.Monad.RES ( REST, runREST, evalREST, + execREST, withEnvRES, withErrorRES, withErrorRES', @@ -20,6 +21,9 @@ runREST env st = flip runReaderT env .> runExceptT .> flip runStateT st evalREST :: Monad m => r -> s -> REST r e s m a -> m (Either e a) evalREST env st = flip runReaderT env .> runExceptT .> flip evalStateT st +execREST :: Monad m => r -> s -> REST r e s m a -> m s +execREST env st = flip runReaderT env .> runExceptT .> flip execStateT st + withEnvRES :: (r -> r') -> REST r' e s m a -> REST r e s m a withEnvRES fn (ReaderT m) = ReaderT <| fn .> m diff --git a/src/Data/JLD/Expansion.hs b/src/Data/JLD/Expansion.hs index 18d7fc6..ff2d9c3 100644 --- a/src/Data/JLD/Expansion.hs +++ b/src/Data/JLD/Expansion.hs @@ -3,19 +3,19 @@ module Data.JLD.Expansion (JLDEParams (..), expand) where import Data.JLD.Prelude import Data.JLD.Control.Monad.RES (REST, withEnvRES, withStateRES) -import Data.JLD.Context (BACParams (..), EIParams (..), buildActiveContext, expandIri) +import Data.JLD.Error (JLDError (..)) +import Data.JLD.Expansion.Context (BACParams (..), EIParams (..), buildActiveContext, expandIri) +import Data.JLD.Expansion.Global (JLDExpansionEnv (..), JLDExpansionState, JLDExpansionT) import Data.JLD.Model.ActiveContext (ActiveContext (..), lookupTerm) import Data.JLD.Model.Direction (Direction (..)) -import Data.JLD.Error (JLDError (..)) import Data.JLD.Model.GraphObject (isNotGraphObject, toGraphObject) import Data.JLD.Model.Keyword (Keyword (..), isKeyword, isNotKeyword, parseKeyword) import Data.JLD.Model.Language (Language (..)) import Data.JLD.Model.ListObject (isListObject, isNotListObject, toListObject) -import Data.JLD.Monad (JLDEEnv (..), JLDEState (..), JLDET, JLDEnv (..), JLDT, modifyActiveContext) import Data.JLD.Model.NodeObject (isNotNodeObject) -import Data.JLD.Options (JLDVersion (..)) import Data.JLD.Model.TermDefinition (TermDefinition (..)) import Data.JLD.Model.ValueObject (isNotValueObject', isValueObject, isValueObject') +import Data.JLD.Options (JLDVersion (..)) import Data.JLD.Util ( allStrings, getMapDefault, @@ -44,6 +44,36 @@ import Data.Vector qualified as V (catMaybes, concat, cons, filter, fromList, ma import Data.Vector.Algorithms.Merge qualified as V import Text.URI (URI) +type JLDET e m = REST (JLDEEnv e m) (JLDError e) JLDEState m + +data JLDEEnv e m = JLDEEnv + { jldeEnvGlobal :: JLDExpansionEnv e m + , jldeEnvFrameExpansion :: Bool + , jldeEnvFromMap :: Bool + , jldeEnvBaseUrl :: URI + , jldeEnvActiveProperty :: Maybe Text + } + deriving (Show) + +data JLDEState = JLDEState + { jldeStateGlobal :: JLDExpansionState + , jldeStateActiveContext :: ActiveContext + } + deriving (Show, Eq) + +data JLDEParams = JLDEParams + { jldeParamsFrameExpansion :: Bool + , jldeParamsFromMap :: Bool + , jldeParamsBaseUrl :: URI + , jldeParamsActiveProperty :: Maybe Text + } + deriving (Show, Eq) + +modifyActiveContext :: MonadState JLDEState m => (ActiveContext -> ActiveContext) -> m () +modifyActiveContext fn = modify \s -> s{jldeStateActiveContext = fn (jldeStateActiveContext s)} + +-- + type EO1314T e m = REST (JLDEEnv e m) (JLDError e) EO1314State m data EO1314State = EO1314State @@ -141,7 +171,7 @@ eo1314ExpandValue activeProperty value = do eo1314ExpandKeywordItem :: Monad m => Maybe Text -> Key -> Keyword -> Value -> EO1314T e m () eo1314ExpandKeywordItem inputType key keyword value = do JLDEEnv{..} <- ask - let JLDEnv{..} = jldeEnvGlobal + let JLDExpansionEnv{..} = jldeEnvGlobal -- 13.4.1. when (jldeEnvActiveProperty == Just (show KeywordReverse)) <| throwError InvalidReversePropertyMap @@ -222,7 +252,7 @@ eo1314ExpandKeywordItem inputType key keyword value = do -- 13.4.6. KeywordIncluded -- 13.4.6.1. - | JLD1_0 <- jldEnvProcessingMode -> pure Nothing + | JLD1_0 <- jldExpansionEnvProcessingMode -> pure Nothing -- 13.4.6.2. | otherwise -> do expandedValue <- valueToArray <$> eo1314ExpandAC Nothing value id @@ -242,7 +272,7 @@ eo1314ExpandKeywordItem inputType key keyword value = do expandedValue <- case value of -- 13.4.7.1. _ | inputType == Just (show KeywordJson) -> do - if jldEnvProcessingMode == JLD1_0 + if jldExpansionEnvProcessingMode == JLD1_0 then throwError InvalidValueObjectValue else pure value -- 13.4.7.2. @@ -269,7 +299,7 @@ eo1314ExpandKeywordItem inputType key keyword value = do _ -> throwError InvalidLanguageTaggedString -- 13.4.9. KeywordDirection - | JLD1_0 <- jldEnvProcessingMode -> pure Nothing + | JLD1_0 <- jldExpansionEnvProcessingMode -> pure Nothing | otherwise -> case value of String ((`elem` ["ltr", "rtl"]) -> True) | jldeEnvFrameExpansion -> pure <. Just <. Array <| V.singleton value @@ -815,14 +845,6 @@ expandValue activeProperty value = do -- -data JLDEParams = JLDEParams - { jldeParamsFrameExpansion :: Bool - , jldeParamsFromMap :: Bool - , jldeParamsBaseUrl :: URI - , jldeParamsActiveProperty :: Maybe Text - } - deriving (Show, Eq) - exModifyActiveContext :: Monad m => (ActiveContext -> ActiveContext) -> JLDET e m () exModifyActiveContext fn = modify \st -> st{jldeStateActiveContext = fn (jldeStateActiveContext st)} @@ -911,7 +933,7 @@ expand' = \case -- 4.3. | otherwise -> Object <$> expandValue activeProperty value -expand :: Monad m => ActiveContext -> Value -> URI -> (JLDEParams -> JLDEParams) -> JLDT e m Value +expand :: Monad m => ActiveContext -> Value -> URI -> (JLDEParams -> JLDEParams) -> JLDExpansionT e m Value expand activeContext value baseUrl paramsFn = expand' value |> withEnvRES env 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)} diff --git a/src/Data/JLD/Monad.hs b/src/Data/JLD/Monad.hs deleted file mode 100644 index 3ae929d..0000000 --- a/src/Data/JLD/Monad.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Data.JLD.Monad ( - JLDT, - JLDEnv (..), - JLDState (..), - newEnv, - newState, - hoistEnv, - modifyContextCache, - modifyDocumentCache, - JLDET, - JLDEEnv (..), - JLDEState (..), - modifyActiveContext, -) where - -import Data.JLD.Prelude - -import Data.JLD.Control.Monad.RES (REST) -import Data.JLD.Error (JLDError) -import Data.JLD.Model.ActiveContext (ActiveContext) -import Data.JLD.Options (ContextCache, DocumentCache, DocumentLoader (..), JLDVersion (..), hoistDocumentLoader) - -import Text.URI (URI) - -type JLDT e m = REST (JLDEnv e m) (JLDError e) JLDState m - -data JLDEnv e m = JLDEnv - { jldEnvDocumentLoader :: DocumentLoader e m - , jldEnvProcessingMode :: JLDVersion - , jldEnvMaxRemoteContexts :: Int - } - deriving (Show) - -data JLDState = JLDState - { jldStateContextCache :: ContextCache - , jldStateDocumentCache :: DocumentCache - } - deriving (Show, Eq) - -newEnv :: Applicative m => (JLDEnv () m -> JLDEnv e m) -> JLDEnv e m -newEnv fn = - fn - JLDEnv - { jldEnvDocumentLoader = DocumentLoader (const <. pure <| Left ()) - , jldEnvProcessingMode = JLD1_1 - , jldEnvMaxRemoteContexts = 20 - } - -newState :: (JLDState -> JLDState) -> JLDState -newState fn = - fn - JLDState - { jldStateContextCache = mempty - , jldStateDocumentCache = mempty - } - -hoistEnv :: (forall a. m a -> n a) -> JLDEnv e m -> JLDEnv e n -hoistEnv map' options = options{jldEnvDocumentLoader = options |> jldEnvDocumentLoader .> hoistDocumentLoader map'} - -modifyContextCache :: MonadState JLDState m => (ContextCache -> ContextCache) -> m () -modifyContextCache fn = modify \s -> s{jldStateContextCache = fn (jldStateContextCache s)} - -modifyDocumentCache :: MonadState JLDState m => (DocumentCache -> DocumentCache) -> m () -modifyDocumentCache fn = modify \s -> s{jldStateDocumentCache = fn (jldStateDocumentCache s)} - --- - -type JLDET e m = REST (JLDEEnv e m) (JLDError e) JLDEState m - -data JLDEEnv e m = JLDEEnv - { jldeEnvGlobal :: JLDEnv e m - , jldeEnvFrameExpansion :: Bool - , jldeEnvFromMap :: Bool - , jldeEnvBaseUrl :: URI - , jldeEnvActiveProperty :: Maybe Text - } - deriving (Show) - -data JLDEState = JLDEState - { jldeStateGlobal :: JLDState - , jldeStateActiveContext :: ActiveContext - } - deriving (Show, Eq) - -modifyActiveContext :: MonadState JLDEState m => (ActiveContext -> ActiveContext) -> m () -modifyActiveContext fn = modify \s -> s{jldeStateActiveContext = fn (jldeStateActiveContext s)} diff --git a/src/Data/JLD/NodeMap.hs b/src/Data/JLD/NodeMap.hs new file mode 100644 index 0000000..0c40c9a --- /dev/null +++ b/src/Data/JLD/NodeMap.hs @@ -0,0 +1,88 @@ +module Data.JLD.NodeMap (NodeMap, BNMParams (..)) where + +import Data.JLD.Prelude + +import Data.JLD.Control.Monad.RES (REST, execREST, runREST, withEnvRES, withErrorRES, withErrorRES', withStateRES) +import Data.JLD.Error (JLDError (..)) +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 NodeMap = Map (Text, Text, Text) Value + +type BNMT e m = REST BNMEnv (JLDError e) BNMState m + +data BNMEnv = BNMEnv + { bnmEnvDocument :: Value + , bnmEnvActiveGraph :: Text + , bnmEnvActiveSubject :: Maybe Text + , bnmEnvActiveProperty :: Maybe Text + } + deriving (Show) + +newtype BNMState = BNMState + { bnmStateNodeMap :: NodeMap + } + deriving (Show, Eq) + +data BNMParams = BNMParams + { bnmParamsNodeMap :: NodeMap + , bnmParamsActiveGraph :: Text + , bnmParamsActiveSubject :: Maybe Text + , bnmParamsActiveProperty :: Maybe Text + , bnmParamsList :: Map Text Value + } + deriving (Show, Eq) + +bnmModifyNodeMap :: Monad m => (NodeMap -> NodeMap) -> BNMT e m () +bnmModifyNodeMap fn = modify \s -> s{bnmStateNodeMap = fn (bnmStateNodeMap s)} + +buildNodeMap' :: Monad m => BNMT e m () +buildNodeMap' = do + pure () + +buildNodeMap :: Monad m => Value -> (BNMParams -> BNMParams) -> m NodeMap +buildNodeMap document paramsFn = do + BNMState{..} <- buildNodeMap' |> execREST env st + pure bnmStateNodeMap + where + BNMParams{..} = + paramsFn + BNMParams + { bnmParamsNodeMap = mempty + , bnmParamsActiveGraph = show KeywordDefault + , bnmParamsActiveSubject = Nothing + , bnmParamsActiveProperty = Nothing + , bnmParamsList = mempty + } + + env = + BNMEnv + { bnmEnvDocument = document + , bnmEnvActiveGraph = bnmParamsActiveGraph + , bnmEnvActiveSubject = bnmParamsActiveSubject + , bnmEnvActiveProperty = bnmParamsActiveProperty + } + + st = + BNMState + { bnmStateNodeMap = bnmParamsNodeMap + } diff --git a/test/Test/Expansion.hs b/test/Test/Expansion.hs index 33397f4..89024c6 100644 --- a/test/Test/Expansion.hs +++ b/test/Test/Expansion.hs @@ -2,9 +2,8 @@ module Test.Expansion (W3CExpansionTestList, expansionTests) where import Data.JLD.Prelude -import Data.JLD (DocumentLoader (..), JLDExpandParams (..), JLDVersion (..), expand, mimeType, toJldErrorCode) +import Data.JLD (DocumentLoader (..), JLDExpansionParams (..), JLDVersion (..), expand, mimeType, toJldErrorCode) import Data.JLD.Model.URI (parseUri) -import Data.JLD.Monad (JLDEnv (..), newEnv) import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) @@ -31,7 +30,7 @@ instance FromJSON W3CExpansionTestOption where <*> (v .:? "processingMode") <*> (v .:? "base") <*> (v .:? "expandContext") - parseJSON invalid = prependFailure "parsing Coord failed, " (typeMismatch "Object" invalid) + parseJSON invalid = prependFailure "parsing W3CExpansionTestOption failed, " (typeMismatch "Object" invalid) data W3CExpansionTest = W3CExpansionTest { w3cExpansionTestName :: Text @@ -50,7 +49,7 @@ instance FromJSON W3CExpansionTest where <*> (v .:? "expect") <*> (v .:? "expectErrorCode") <*> (v .:? "option") - parseJSON invalid = prependFailure "parsing Coord failed, " (typeMismatch "Object" invalid) + parseJSON invalid = prependFailure "parsing W3CExpansionTest failed, " (typeMismatch "Object" invalid) newtype W3CExpansionTestList = W3CExpansionTestList { w3cExpansionSequence :: [W3CExpansionTest] @@ -59,7 +58,7 @@ newtype W3CExpansionTestList = W3CExpansionTestList instance FromJSON W3CExpansionTestList where parseJSON (Object v) = W3CExpansionTestList <$> (v .: "sequence") - parseJSON invalid = prependFailure "parsing Coord failed, " (typeMismatch "Object" invalid) + parseJSON invalid = prependFailure "parsing W3CExpansionTestList failed, " (typeMismatch "Object" invalid) documentLoader :: MonadIO m => DocumentLoader Text m documentLoader = DocumentLoader \uri -> @@ -75,7 +74,7 @@ fetchTest url = do res <- req GET reqUrl NoReqBody jsonResponse (reqOptions <> header "Accept" mimeType) pure <| responseBody res -parseOptions :: URI -> URI -> Maybe W3CExpansionTestOption -> IO (URI, JLDExpandParams () IO -> JLDExpandParams Text IO) +parseOptions :: URI -> URI -> Maybe W3CExpansionTestOption -> IO (URI, JLDExpansionParams () IO -> JLDExpansionParams Text IO) parseOptions baseUrl inputUrl maybeOptions = do expandContext <- case maybeOptions >>= w3cExpansionTestOptionExpandContext of Just rawUrl -> do @@ -85,20 +84,18 @@ parseOptions baseUrl inputUrl maybeOptions = do let params p = p - { jldExpandParamsEnv = env' - , jldExpandParamsExpandContext = expandContext <|> jldExpandParamsExpandContext p + { jldExpansionParamsDocumentLoader = documentLoader + , jldExpansionParamsProcessingMode = case maybeOptions >>= w3cExpansionTestOptionProcessingMode of + Just "json-ld-1.0" -> JLD1_0 + Just "json-ld-1.1" -> JLD1_1 + _ -> jldExpansionParamsProcessingMode p + , jldExpansionParamsExpandContext = expandContext <|> jldExpansionParamsExpandContext p } pure (expandBaseUrl, params) where expandBaseUrl = fromMaybe inputUrl (parseUri =<< w3cExpansionTestOptionBase =<< maybeOptions) - env = newEnv \e -> e{jldEnvDocumentLoader = documentLoader} - env' = case maybeOptions >>= w3cExpansionTestOptionProcessingMode of - Just "json-ld-1.0" -> env{jldEnvProcessingMode = JLD1_0} - Just "json-ld-1.1" -> env{jldEnvProcessingMode = JLD1_1} - _ -> env - expansionTests :: W3CExpansionTestList -> TestTree expansionTests testList = testGroup "Expansion" <| uncurry expansionTest <$> (take 999 <. drop 0 <| zip (w3cExpansionSequence testList) [1 ..]) -- cgit v1.2.3-70-g09d2