From 11d0fb47c292a0ca25a9c377499d2b221d97a5cb Mon Sep 17 00:00:00 2001 From: Volpeon Date: Fri, 26 May 2023 07:40:13 +0200 Subject: Init --- src/Data/JLD/Context.hs | 1020 ++++++++++++++++++++++++++++++++++ src/Data/JLD/Control/Monad/RES.hs | 35 ++ src/Data/JLD/Error.hs | 81 +++ src/Data/JLD/Expansion.hs | 942 +++++++++++++++++++++++++++++++ src/Data/JLD/Mime.hs | 6 + src/Data/JLD/Model/ActiveContext.hs | 44 ++ src/Data/JLD/Model/Direction.hs | 13 + src/Data/JLD/Model/GraphObject.hs | 22 + src/Data/JLD/Model/IRI.hs | 46 ++ src/Data/JLD/Model/InverseContext.hs | 5 + src/Data/JLD/Model/Keyword.hs | 135 +++++ src/Data/JLD/Model/Language.hs | 6 + src/Data/JLD/Model/ListObject.hs | 24 + src/Data/JLD/Model/NodeObject.hs | 21 + src/Data/JLD/Model/TermDefinition.hs | 43 ++ src/Data/JLD/Model/URI.hs | 13 + src/Data/JLD/Model/ValueObject.hs | 27 + src/Data/JLD/Monad.hs | 86 +++ src/Data/JLD/Options.hs | 34 ++ src/Data/JLD/Prelude.hs | 4 + src/Data/JLD/Util.hs | 118 ++++ 21 files changed, 2725 insertions(+) create mode 100644 src/Data/JLD/Context.hs create mode 100644 src/Data/JLD/Control/Monad/RES.hs create mode 100644 src/Data/JLD/Error.hs create mode 100644 src/Data/JLD/Expansion.hs create mode 100644 src/Data/JLD/Mime.hs create mode 100644 src/Data/JLD/Model/ActiveContext.hs create mode 100644 src/Data/JLD/Model/Direction.hs create mode 100644 src/Data/JLD/Model/GraphObject.hs create mode 100644 src/Data/JLD/Model/IRI.hs create mode 100644 src/Data/JLD/Model/InverseContext.hs create mode 100644 src/Data/JLD/Model/Keyword.hs create mode 100644 src/Data/JLD/Model/Language.hs create mode 100644 src/Data/JLD/Model/ListObject.hs create mode 100644 src/Data/JLD/Model/NodeObject.hs create mode 100644 src/Data/JLD/Model/TermDefinition.hs create mode 100644 src/Data/JLD/Model/URI.hs create mode 100644 src/Data/JLD/Model/ValueObject.hs create mode 100644 src/Data/JLD/Monad.hs create mode 100644 src/Data/JLD/Options.hs create mode 100644 src/Data/JLD/Prelude.hs create mode 100644 src/Data/JLD/Util.hs (limited to 'src/Data/JLD') diff --git a/src/Data/JLD/Context.hs b/src/Data/JLD/Context.hs new file mode 100644 index 0000000..a999395 --- /dev/null +++ b/src/Data/JLD/Context.hs @@ -0,0 +1,1020 @@ +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 new file mode 100644 index 0000000..1c96d46 --- /dev/null +++ b/src/Data/JLD/Control/Monad/RES.hs @@ -0,0 +1,35 @@ +module Data.JLD.Control.Monad.RES ( + REST, + runREST, + evalREST, + withEnvRES, + withErrorRES, + withErrorRES', + withStateRES, +) where + +import Data.JLD.Prelude + +import Control.Monad.Except (mapExceptT) + +type REST r e s m = ReaderT r (ExceptT e (StateT s m)) + +runREST :: r -> s -> REST r e s m a -> m (Either e a, s) +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 + +withEnvRES :: (r -> r') -> REST r' e s m a -> REST r e s m a +withEnvRES fn (ReaderT m) = ReaderT <| fn .> m + +withErrorRES :: Functor m => (e' -> e) -> REST r e' s m a -> REST r e s m a +withErrorRES fn (ReaderT m) = ReaderT <| m .> mapExceptT (fmap <| first fn) + +withErrorRES' :: Monad m => (e' -> REST r e s m a) -> REST r e' s m a -> REST r e s m a +withErrorRES' fn (ReaderT m) = + ReaderT <| \r -> m r |> mapExceptT \m' -> m' >>= either (fn .> flip runReaderT r .> runExceptT) (Right .> pure) + +withStateRES :: Monad m => (s -> s') -> (s -> s' -> s) -> REST r e s' m a -> REST r e s m a +withStateRES fin fout (ReaderT m) = + ReaderT \env -> m env |> mapExceptT \st -> StateT \s -> second (fout s) <$> runStateT st (fin s) diff --git a/src/Data/JLD/Error.hs b/src/Data/JLD/Error.hs new file mode 100644 index 0000000..91c2a0b --- /dev/null +++ b/src/Data/JLD/Error.hs @@ -0,0 +1,81 @@ +module Data.JLD.Error (JLDError (..), toJldErrorCode) where + +import Data.JLD.Prelude + +import Data.JLD.Model.Keyword (Keyword (KeywordType)) + +import Data.Aeson (Value) + +data JLDError e + = InvalidKeywordValue Keyword Value + | ProcessingModeConflict + | InvalidContextEntry + | InvalidContextNullification + | InvalidLocalContext + | InvalidRemoteContext + | InvalidBaseIri + | InvalidVocabMapping + | InvalidDefaultLanguage + | InvalidBaseDirection + | LoadingRemoteContextError + | DocumentLoaderError e + | ContextOverflow + | InvalidTermDefinition + | CyclicIriMapping + | KeywordRedefinition + | InvalidTypeMapping + | InvalidReverseProperty + | InvalidIriMapping + | InvalidKeywordAlias + | InvalidContainerMapping + | InvalidLanguageMapping + | ProtectedTermRedefinition + | InvalidReversePropertyMap + | CollidingKeywords Text Keyword + | InvalidValueObjectValue + | InvalidLanguageTaggedString + | InvalidReversePropertyValue + | InvalidLanguageMapValue + | InvalidValueObject + | InvalidLanguageTaggedValue + | InvalidTypedValue + | InvalidSetOrListObject + | InvalidScopedContext + deriving (Eq, Show) + +toJldErrorCode :: JLDError e -> Text +toJldErrorCode (InvalidKeywordValue KeywordType _) = "invalid type value" +toJldErrorCode (InvalidKeywordValue keyword _) = "invalid " <> show keyword <> " value" +toJldErrorCode ProcessingModeConflict = "processing mode conflict" +toJldErrorCode InvalidContextEntry = "invalid context entry" +toJldErrorCode InvalidContextNullification = "invalid context nullification" +toJldErrorCode InvalidLocalContext = "invalid local context" +toJldErrorCode InvalidRemoteContext = "invalid remote context" +toJldErrorCode InvalidBaseIri = "invalid base IRI" +toJldErrorCode InvalidVocabMapping = "invalid vocab mapping" +toJldErrorCode InvalidDefaultLanguage = "invalid default language" +toJldErrorCode InvalidBaseDirection = "invalid base direction" +toJldErrorCode LoadingRemoteContextError = "loading remote context failed" +toJldErrorCode (DocumentLoaderError _) = "loading document failed" +toJldErrorCode ContextOverflow = "context overflow" +toJldErrorCode InvalidTermDefinition = "invalid term definition" +toJldErrorCode CyclicIriMapping = "cyclic IRI mapping" +toJldErrorCode KeywordRedefinition = "keyword redefinition" +toJldErrorCode InvalidTypeMapping = "invalid type mapping" +toJldErrorCode InvalidReverseProperty = "invalid reverse property" +toJldErrorCode InvalidIriMapping = "invalid IRI mapping" +toJldErrorCode InvalidKeywordAlias = "invalid keyword alias" +toJldErrorCode InvalidContainerMapping = "invalid container mapping" +toJldErrorCode InvalidLanguageMapping = "invalid language mapping" +toJldErrorCode ProtectedTermRedefinition = "protected term redefinition" +toJldErrorCode InvalidReversePropertyMap = "invalid reverse property map" +toJldErrorCode (CollidingKeywords _ _) = "colliding keywords" +toJldErrorCode InvalidValueObjectValue = "invalid value object value" +toJldErrorCode InvalidLanguageTaggedString = "invalid language-tagged string" +toJldErrorCode InvalidReversePropertyValue = "invalid reverse property value" +toJldErrorCode InvalidLanguageMapValue = "invalid language map value" +toJldErrorCode InvalidValueObject = "invalid value object" +toJldErrorCode InvalidLanguageTaggedValue = "invalid language-tagged value" +toJldErrorCode InvalidTypedValue = "invalid typed value" +toJldErrorCode InvalidSetOrListObject = "invalid set or list object" +toJldErrorCode InvalidScopedContext = "invalid scoped context" diff --git a/src/Data/JLD/Expansion.hs b/src/Data/JLD/Expansion.hs new file mode 100644 index 0000000..18d7fc6 --- /dev/null +++ b/src/Data/JLD/Expansion.hs @@ -0,0 +1,942 @@ +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.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.Util ( + allStrings, + getMapDefault, + ifindM, + mapAddValue, + valueContains, + valueIsEmptyArray, + valueIsNotArray, + valueIsNotNull, + valueIsNotString, + valueIsScalar, + valueIsString, + valueToArray, + valueToString, + ) + +import Control.Monad.Except (MonadError (..)) +import Data.Aeson (Array, Key, KeyValue (..), Object, Value (..), object) +import Data.Aeson.Key qualified as K (fromText, toText) +import Data.Aeson.KeyMap qualified as KM (delete, fromList, insert, keys, lookup, member, null, singleton, size, toList) +import Data.Foldable.WithIndex (ifoldlM, iforM_) +import Data.RDF (parseIRI) +import Data.Set qualified as S (insert, member) +import Data.Text qualified as T (elem, toLower) +import Data.Vector qualified as V (catMaybes, concat, cons, filter, fromList, mapMaybeM, maximum, modify, null, singleton, snoc, toList) +import Data.Vector.Algorithms.Merge qualified as V +import Text.URI (URI) + +type EO1314T e m = REST (JLDEEnv e m) (JLDError e) EO1314State m + +data EO1314State = EO1314State + { eo1314StateJlde :: JLDEState + , eo1314StateNest :: Set Key + , eo1314StateResult :: Object + , eo1314StateTypeContext :: ActiveContext + } + deriving (Show, Eq) + +eo1314ModifyActiveContext :: Monad m => (ActiveContext -> ActiveContext) -> EO1314T e m () +eo1314ModifyActiveContext = modifyActiveContext .> withStateRES eo1314StateJlde (\s g -> s{eo1314StateJlde = g}) + +eo1314ModifyTypeContext :: Monad m => (ActiveContext -> ActiveContext) -> EO1314T e m () +eo1314ModifyTypeContext fn = modify \st -> st{eo1314StateTypeContext = fn (eo1314StateTypeContext st)} + +eo1314ModifyNest :: Monad m => (Set Key -> Set Key) -> EO1314T e m () +eo1314ModifyNest fn = modify \s -> s{eo1314StateNest = fn (eo1314StateNest s)} + +eo1314ModifyResult :: Monad m => (Object -> Object) -> EO1314T e m () +eo1314ModifyResult fn = modify \s -> s{eo1314StateResult = fn (eo1314StateResult s)} + +eo1314BuildActiveContext :: Monad m => ActiveContext -> Value -> Maybe URI -> (BACParams -> BACParams) -> EO1314T e m ActiveContext +eo1314BuildActiveContext activeContext context baseUrl paramsFn = do + buildActiveContext activeContext context baseUrl paramsFn + |> withEnvRES jldeEnvGlobal + |> withStateRES + (eo1314StateJlde .> jldeStateGlobal) + (\eo1314 jld -> eo1314{eo1314StateJlde = (eo1314StateJlde eo1314){jldeStateGlobal = jld}}) + +eo1314ExpandAC :: Monad m => Maybe Text -> Value -> (JLDEParams -> JLDEParams) -> EO1314T e m Value +eo1314ExpandAC activeProperty value fn = do + activeContext <- gets <| jldeStateActiveContext <. eo1314StateJlde + baseUrl <- asks jldeEnvBaseUrl + frameExpansion <- asks jldeEnvFrameExpansion + let params p = fn p{jldeParamsFrameExpansion = frameExpansion, jldeParamsActiveProperty = activeProperty} + expand activeContext value baseUrl params + |> withEnvRES jldeEnvGlobal + |> withStateRES + (eo1314StateJlde .> jldeStateGlobal) + (\eo1314 jld -> eo1314{eo1314StateJlde = (eo1314StateJlde eo1314){jldeStateGlobal = jld}}) + +eo1314ExpandTC :: Monad m => Maybe Text -> Value -> (JLDEParams -> JLDEParams) -> EO1314T e m Value +eo1314ExpandTC activeProperty value fn = do + typeContext <- gets <| eo1314StateTypeContext + baseUrl <- asks jldeEnvBaseUrl + frameExpansion <- asks jldeEnvFrameExpansion + let params p = fn p{jldeParamsFrameExpansion = frameExpansion, jldeParamsActiveProperty = activeProperty} + expand typeContext value baseUrl params + |> withEnvRES jldeEnvGlobal + |> withStateRES + (eo1314StateJlde .> jldeStateGlobal) + (\eo1314 jld -> eo1314{eo1314StateJlde = (eo1314StateJlde eo1314){jldeStateGlobal = jld}}) + +eo1314Expand' :: Monad m => ActiveContext -> Maybe Text -> Value -> (JLDEParams -> JLDEParams) -> EO1314T e m Value +eo1314Expand' activeContext activeProperty value fn = do + baseUrl <- asks <| jldeEnvBaseUrl + frameExpansion <- asks <| jldeEnvFrameExpansion + let params p = fn p{jldeParamsFrameExpansion = frameExpansion, jldeParamsActiveProperty = activeProperty} + expand activeContext value baseUrl params + |> withEnvRES jldeEnvGlobal + |> withStateRES + (eo1314StateJlde .> jldeStateGlobal) + (\eo1314 jld -> eo1314{eo1314StateJlde = (eo1314StateJlde eo1314){jldeStateGlobal = jld}}) + +eo1314ExpandIriAC :: Monad m => Text -> (EIParams -> EIParams) -> EO1314T e m (Maybe Text) +eo1314ExpandIriAC value fn = do + activeContext <- gets <| jldeStateActiveContext <. eo1314StateJlde + (value', activeContext', _) <- + expandIri activeContext value fn + |> withEnvRES jldeEnvGlobal + |> withStateRES + (eo1314StateJlde .> jldeStateGlobal) + (\eo1314 jld -> eo1314{eo1314StateJlde = (eo1314StateJlde eo1314){jldeStateGlobal = jld}}) + eo1314ModifyActiveContext <| const activeContext' + pure value' + +eo1314ExpandIriTC :: Monad m => Text -> (EIParams -> EIParams) -> EO1314T e m (Maybe Text) +eo1314ExpandIriTC value fn = do + typeContext <- gets <| eo1314StateTypeContext + (value', typeContext', _) <- + expandIri typeContext value fn + |> withEnvRES jldeEnvGlobal + |> withStateRES + (eo1314StateJlde .> jldeStateGlobal) + (\eo1314 jld -> eo1314{eo1314StateJlde = (eo1314StateJlde eo1314){jldeStateGlobal = jld}}) + eo1314ModifyTypeContext <| const typeContext' + pure value' + +eo1314ExpandValue :: Monad m => Text -> Value -> EO1314T e m Object +eo1314ExpandValue activeProperty value = do + expandValue activeProperty value + |> withStateRES eo1314StateJlde (\eo1314 jld -> eo1314{eo1314StateJlde = jld}) + +eo1314ExpandKeywordItem :: Monad m => Maybe Text -> Key -> Keyword -> Value -> EO1314T e m () +eo1314ExpandKeywordItem inputType key keyword value = do + JLDEEnv{..} <- ask + let JLDEnv{..} = jldeEnvGlobal + + -- 13.4.1. + when (jldeEnvActiveProperty == Just (show KeywordReverse)) <| throwError InvalidReversePropertyMap + + -- 13.4.2. + containsProp <- gets (eo1314StateResult .> KM.member (show keyword)) + when (containsProp && keyword /= KeywordIncluded && keyword /= KeywordType) <| throwError (CollidingKeywords (K.toText key) keyword) + + maybeExpandedValue <- case keyword of + -- 13.4.3. + KeywordId -> case value of + String stringValue -> do + maybeExpandedStringValue <- eo1314ExpandIriAC stringValue \params -> + params + { eiParamsDocumentRelative = True + , eiParamsVocab = False + } + case maybeExpandedStringValue of + Just expandedStringValue + | jldeEnvFrameExpansion -> pure <. Just <. Array <. V.singleton <| String expandedStringValue + | otherwise -> pure <. Just <| String expandedStringValue + Nothing -> pure <| Just Null + -- + Object (KM.null -> True) | jldeEnvFrameExpansion -> do + pure <. Just <. Array <. V.singleton <| Object mempty + -- + Array (allStrings -> Just arrayValue) | jldeEnvFrameExpansion && not (V.null arrayValue) -> do + Just <. Array <. V.concat <. V.toList <$> forM arrayValue \item -> do + V.singleton <. maybe Null String <$> eo1314ExpandIriAC item \params -> + params + { eiParamsDocumentRelative = True + , eiParamsVocab = False + } + -- + _ -> throwError <| InvalidKeywordValue keyword value + -- 13.4.4. + KeywordType -> do + expandedValue <- case value of + -- 13.4.4.4. + String stringValue -> do + maybe Null String <$> eo1314ExpandIriTC stringValue \params -> + params + { eiParamsDocumentRelative = True + , eiParamsVocab = True + } + -- 13.4.4.2. 13.4.4.3. + Object objectValue + -- 13.4.4.2. + | jldeEnvFrameExpansion && KM.null objectValue -> + pure value + -- 13.4.4.3. + | jldeEnvFrameExpansion + , Just (String defaultValue) <- KM.lookup (show KeywordDefault) objectValue + , Right _ <- parseIRI defaultValue -> do + Object <. KM.singleton (show KeywordDefault) <. maybe Null String <$> eo1314ExpandIriTC defaultValue \params -> + params + { eiParamsDocumentRelative = True + , eiParamsVocab = True + } + -- 13.4.4.4. + Array (allStrings -> Just arrayValue) -> + Array <. V.concat <. V.toList <$> forM arrayValue \item -> do + V.singleton <. maybe Null String <$> eo1314ExpandIriTC item \params -> + params + { eiParamsDocumentRelative = True + , eiParamsVocab = True + } + -- 13.4.4.1. + _ -> throwError <| InvalidKeywordValue keyword value + + -- 13.4.4.5. + gets <| eo1314StateResult .> KM.lookup (show KeywordType) .> \case + Just (Array typeValue) -> Just <. Array <| V.snoc typeValue expandedValue + Just typeValue -> Just <. Array <| V.fromList [typeValue, expandedValue] + Nothing -> Just expandedValue + -- 13.4.5. + KeywordGraph -> Just <. Array <. valueToArray <$> eo1314ExpandTC (Just <| show KeywordGraph) value id + -- 13.4.6. + KeywordIncluded + -- 13.4.6.1. + | JLD1_0 <- jldEnvProcessingMode -> pure Nothing + -- 13.4.6.2. + | otherwise -> do + expandedValue <- valueToArray <$> eo1314ExpandAC Nothing value id + + when (V.null expandedValue) <| throwError (InvalidKeywordValue keyword value) + + -- 13.4.6.3. + when (any isNotNodeObject expandedValue) <| throwError (InvalidKeywordValue keyword value) + + -- 13.4.6.4. + gets <| eo1314StateResult .> KM.lookup (show KeywordIncluded) .> \case + Just (Array includedValue) -> Just <. Array <| includedValue <> expandedValue + Just includedValue -> Just <. Array <| V.singleton includedValue <> expandedValue + Nothing -> Just <| Array expandedValue + -- 13.4.7. + KeywordValue -> do + expandedValue <- case value of + -- 13.4.7.1. + _ | inputType == Just (show KeywordJson) -> do + if jldEnvProcessingMode == JLD1_0 + then throwError InvalidValueObjectValue + else pure value + -- 13.4.7.2. + _ | value == Null || valueIsScalar value -> do + if jldeEnvFrameExpansion + then pure <. Array <| V.singleton value + else pure value + Object (KM.null -> True) | jldeEnvFrameExpansion -> pure <. Array <| V.singleton value + Array (all valueIsString -> True) | jldeEnvFrameExpansion -> pure value + -- + _ -> throwError InvalidValueObjectValue + + -- 13.4.7.4. + case expandedValue of + Null -> Nothing <$ eo1314ModifyResult (KM.insert (show KeywordValue) Null) + _ -> pure <| Just expandedValue + -- 13.4.8. + KeywordLanguage -> case value of + String stringValue + | jldeEnvFrameExpansion -> pure <. Just <. Array <. V.singleton <. String <| T.toLower stringValue + | otherwise -> pure <. Just <. String <| T.toLower stringValue + Object (KM.null -> True) | jldeEnvFrameExpansion -> pure <| Just value + Array (all valueIsString -> True) | jldeEnvFrameExpansion -> pure <| Just value + _ -> throwError InvalidLanguageTaggedString + -- 13.4.9. + KeywordDirection + | JLD1_0 <- jldEnvProcessingMode -> pure Nothing + | otherwise -> case value of + String ((`elem` ["ltr", "rtl"]) -> True) + | jldeEnvFrameExpansion -> pure <. Just <. Array <| V.singleton value + | otherwise -> pure <| Just value + Object (KM.null -> True) | jldeEnvFrameExpansion -> pure <| Just value + Array (all valueIsString -> True) | jldeEnvFrameExpansion -> pure <| Just value + _ -> throwError InvalidBaseDirection + -- 13.4.10. + KeywordIndex + | String _ <- value -> pure <| Just value + | otherwise -> throwError <| InvalidKeywordValue keyword value + -- 13.4.11. + KeywordList + -- 13.4.11.1. + | maybe True (== show KeywordGraph) jldeEnvActiveProperty -> pure Nothing + -- 13.4.11.2. + | otherwise -> do + expandedValue <- eo1314ExpandAC jldeEnvActiveProperty value id + case expandedValue of + Array _ -> pure <| Just expandedValue + _ -> pure <. Just <. Array <| V.singleton expandedValue + -- 13.4.12. + KeywordSet -> Just <$> eo1314ExpandAC jldeEnvActiveProperty value id + -- 13.4.13. + KeywordReverse + -- 13.4.13.2. + | Object _ <- value -> + eo1314ExpandAC (Just <| show KeywordReverse) value id >>= \case + Object expandedObjectValue -> do + -- 13.4.13.3. + case KM.lookup (show KeywordReverse) expandedObjectValue of + Just (Object rev) -> iforM_ rev \key' item -> eo1314ModifyResult <| mapAddValue key' item True + _ -> pure () + + -- 13.4.13.4. + unless (KM.size expandedObjectValue == 1 && KM.member (show KeywordReverse) expandedObjectValue) do + reverseMap <- gets <| getMapDefault (show KeywordReverse) <. eo1314StateResult + reverseMap' <- + (\fn -> ifoldlM fn reverseMap expandedObjectValue) <| \key' rm -> \case + Array item | key' /= show KeywordReverse -> do + (\fn -> foldlM fn rm item) <| \rm' i -> + if isListObject i || isValueObject i + then throwError <| InvalidReversePropertyValue + else pure <| mapAddValue key' i True rm' + _ -> pure rm + + if KM.null reverseMap' + then eo1314ModifyResult <| KM.delete (show KeywordReverse) + else eo1314ModifyResult <| KM.insert (show KeywordReverse) (Object reverseMap') + + -- 13.4.13.5. + pure Nothing + -- + _ -> pure <| Just Null + -- 13.4.13.1. + | otherwise -> throwError <| InvalidKeywordValue keyword value + -- 13.4.14. + KeywordNest -> Nothing <$ eo1314ModifyNest (S.insert key) + -- + _ -> pure Nothing + + case maybeExpandedValue of + Just expandedValue -> do + -- 13.4.15. + expandedValue' <- + if jldeEnvFrameExpansion && keyword `elem` [KeywordDefault, KeywordEmbed, KeywordExplicit, KeywordOmitDefault, KeywordRequireAll] + then eo1314ExpandAC (Just <| show keyword) expandedValue id + else pure expandedValue + + -- 13.4.16. + unless (expandedValue' == Null && keyword == KeywordValue && inputType /= Just (show KeywordJson)) + <| eo1314ModifyResult (KM.insert (show keyword) expandedValue') + -- + Nothing -> pure () + +eo1314ExpandNonKeywordItem :: Monad m => Key -> Text -> Value -> EO1314T e m () +eo1314ExpandNonKeywordItem key expandedProperty value = do + -- 13.5. + keyTermDefinition <- gets <| lookupTerm (K.toText key) <. jldeStateActiveContext <. eo1314StateJlde + defaultBaseDirection <- gets <| activeContextDefaultBaseDirection <. jldeStateActiveContext <. eo1314StateJlde + + let containerMapping = maybe mempty termDefinitionContainerMapping keyTermDefinition + -- 13.7.2. + direction = (keyTermDefinition >>= termDefinitionDirectionMapping) <|> defaultBaseDirection + -- 13.8.2. + indexKey = fromMaybe (show KeywordIndex) (keyTermDefinition >>= termDefinitionIndexMapping) + + expandedValue <- case value of + -- 13.6. + _ | (keyTermDefinition >>= termDefinitionTypeMapping) == Just (show KeywordJson) -> do + pure + <| object + [ show KeywordValue .= value + , show KeywordType .= String (show KeywordJson) + ] + -- 13.7. + Object objectValue + | S.member (show KeywordLanguage) containerMapping -> + -- 13.7.4. + Array <. V.concat <$> forM (KM.toList objectValue) \(langCode, langValue) -> + -- 13.7.4.1. 13.7.4.2. + flip V.mapMaybeM (valueToArray langValue) \case + -- 13.7.4.2.1. + Null -> pure Nothing + -- + String item -> do + -- 13.7.4.2.3. + let langMap = KM.singleton (show KeywordValue) (String item) + + -- 13.7.4.2.4. + langMap' <- + if langCode /= show KeywordNone + then do + expandedLangCode <- maybe Null String <$> eo1314ExpandIriAC (K.toText langCode) \params -> params{eiParamsVocab = True} + if expandedLangCode /= show KeywordNone + then pure <| KM.insert (show KeywordLanguage) (String <. T.toLower <| K.toText langCode) langMap + else pure langMap + else pure langMap + + -- 13.7.4.2.5. + let langMap'' = case direction of + Nothing -> langMap' + Just NoDirection -> langMap' + Just dir -> KM.insert (show KeywordDirection) (String <| show dir) langMap' + + -- 13.7.4.2.6. + pure <. Just <| Object langMap'' + -- 13.7.4.2.2. + _ -> throwError <| InvalidLanguageMapValue + -- 13.8. + | S.member (show KeywordIndex) containerMapping + || S.member (show KeywordType) containerMapping + || S.member (show KeywordId) containerMapping -> + Array <. fmap Object <. V.concat <$> forM (KM.toList objectValue) \(index, indexValue) -> do + -- 13.8.3.1. + mapContext <- gets <| jldeStateActiveContext <. eo1314StateJlde + + let mapContext' = case activeContextPreviousContext mapContext of + Just previousContext + | S.member (show KeywordId) containerMapping || S.member (show KeywordType) containerMapping -> + previousContext + _ -> mapContext + + mapContext'' <- case lookupTerm (K.toText index) mapContext' of + -- 13.8.3.2. + Just termDefinition + | Just localContext <- termDefinitionLocalContext termDefinition + , S.member (show KeywordType) containerMapping -> + eo1314BuildActiveContext mapContext' localContext (termDefinitionBaseUrl termDefinition) id + -- 13.8.3.3. + _ -> pure mapContext' + + -- 13.8.3.4. + expandedIndex <- + maybe Null String <$> eo1314ExpandIriAC (K.toText index) \params -> + params + { eiParamsVocab = True + } + + -- 13.8.3.6. + indexValue' <- + eo1314Expand' mapContext'' (Just <| K.toText key) (Array <| valueToArray indexValue) \params -> + params + { jldeParamsFromMap = True + } + + -- 13.8.3.7. + -- 13.8.3.7.1. + let ensureGraphObject item = + if S.member (show KeywordGraph) containerMapping && isNotGraphObject item + then Object <| toGraphObject item + else item + + forM (valueToArray indexValue') <| ensureGraphObject .> \case + Object item + -- 13.8.3.7.2. + | S.member (show KeywordIndex) containerMapping + , indexKey /= show KeywordIndex + , expandedIndex /= show KeywordNone -> do + -- 13.8.3.7.2.1. + reExpandedIndex <- eo1314ExpandValue indexKey (String <| K.toText index) + + -- 13.8.3.7.2.2. + expandedIndexKey <- + fmap K.fromText <$> eo1314ExpandIriAC indexKey \params -> + params + { eiParamsVocab = True + } + + -- 13.8.3.7.2.3. + let maybeExistingValues = expandedIndexKey >>= (`KM.lookup` item) + + indexPropertyValues = + V.singleton (Object reExpandedIndex) + |> case maybeExistingValues of + Just (Array existingValues) -> (<> existingValues) + Just existingValue -> (`V.snoc` existingValue) + Nothing -> id + + -- 13.8.3.7.2.4. + let item' = case expandedIndexKey of + Just eiKey -> item |> KM.insert eiKey (Array indexPropertyValues) + Nothing -> item + + -- 13.8.3.7.2.5. + when (isValueObject' item' && KM.size item' > 1) <| throwError InvalidValueObject + + pure item' + -- 13.8.3.7.3. + | S.member (show KeywordIndex) containerMapping + , not (KM.member (show KeywordIndex) item) + , expandedIndex /= show KeywordNone -> + pure <. KM.insert (show KeywordIndex) (String <| K.toText index) <| item + -- 13.8.3.7.4. + | S.member (show KeywordId) containerMapping + , not (KM.member (show KeywordId) item) + , expandedIndex /= show KeywordNone -> do + expandedIndex' <- eo1314ExpandIriAC (K.toText index) \params -> + params + { eiParamsVocab = False + , eiParamsDocumentRelative = True + } + pure <| KM.insert (show KeywordId) (maybe Null String expandedIndex') item + -- 13.8.3.7.5. + | S.member (show KeywordType) containerMapping + , expandedIndex /= show KeywordNone -> do + let types = case KM.lookup (show KeywordType) item of + Just existingType -> V.cons expandedIndex <| valueToArray existingType + Nothing -> V.singleton expandedIndex + pure <. KM.insert (show KeywordType) (Array types) <| item + -- 13.8.3.7.6. + | otherwise -> pure item + -- + _ -> pure mempty + -- 13.9. + _ -> eo1314ExpandAC (Just <| K.toText key) value id + + -- 13.10. + when (expandedValue /= Null) do + -- 13.11. + let expandedValue' = + if S.member (show KeywordList) containerMapping && isNotListObject expandedValue + then toListObject expandedValue + else expandedValue + + -- 13.12. + let expandedValue'' = + if S.member (show KeywordGraph) containerMapping + && not (S.member (show KeywordId) containerMapping) + && not (S.member (show KeywordIndex) containerMapping) + then Array <| Object <. toGraphObject <$> valueToArray expandedValue' + else expandedValue' + + -- 13.13. + if maybe False termDefinitionReversePropertyFlag keyTermDefinition + then do + reverseMap <- gets <| getMapDefault (show KeywordReverse) <. eo1314StateResult + + -- 13.13.3. 13.13.4. + reverseMap' <- + (\fn -> foldlM fn reverseMap (valueToArray expandedValue'')) <| \rm item -> + if isListObject item || isValueObject item + then -- 13.13.4.1. + throwError InvalidReversePropertyValue + else -- 13.13.4.3. + pure <| mapAddValue (K.fromText expandedProperty) item True rm + + eo1314ModifyResult <| KM.insert (show KeywordReverse) (Object reverseMap') + else -- 13.14. + eo1314ModifyResult <| mapAddValue (K.fromText expandedProperty) expandedValue'' True + +eo1314ExpandItem :: Monad m => Maybe Text -> Key -> Value -> EO1314T e m () +eo1314ExpandItem _ ((== K.fromText (show KeywordContext)) -> True) _ = pure () -- 13.1. +eo1314ExpandItem inputType key value = do + -- 13.2. 13.3. + maybeExpandedProperty <- eo1314ExpandIriAC (K.toText key) \params -> + params + { eiParamsDocumentRelative = False + , eiParamsVocab = True + } + + case maybeExpandedProperty of + Just expandedProperty + -- 13.4. + | Just keyword <- parseKeyword expandedProperty -> eo1314ExpandKeywordItem inputType key keyword value + -- 13.5. + | ':' `T.elem` expandedProperty -> eo1314ExpandNonKeywordItem key expandedProperty value + -- + _ -> pure () + +eo1314Recurse :: Monad m => Text -> Maybe Text -> Object -> EO1314T e m () +eo1314Recurse activeProperty inputType value = do + -- 3. 8. + activeContext <- gets <| jldeStateActiveContext <. eo1314StateJlde + case lookupTerm activeProperty activeContext of + Just propertyDefinition | Just propertyContext <- termDefinitionLocalContext propertyDefinition -> do + activeContext' <- eo1314BuildActiveContext activeContext propertyContext (termDefinitionBaseUrl propertyDefinition) \params -> + params + { bacParamsOverrideProtected = True + } + eo1314ModifyActiveContext <| const activeContext' + _ -> pure () + + expandObject1314' inputType value + +expandObject1314' :: Monad m => Maybe Text -> Object -> EO1314T e m () +expandObject1314' inputType value = do + -- 13. + iforM_ value <| eo1314ExpandItem inputType + + -- 14. + gets eo1314StateNest >>= mapM_ \nestedKey -> + KM.lookup nestedKey value |> fmap valueToArray .> fromMaybe mempty .> mapM_ \case + Object nestValue -> do + forM_ (KM.keys nestValue) \nestedValueKey -> do + -- 14.2.1. + expandedNestedValueKey <- eo1314ExpandIriTC (K.toText nestedValueKey) \params -> params{eiParamsVocab = True} + when (expandedNestedValueKey == Just (show KeywordValue)) <| throwError (InvalidKeywordValue KeywordNest (Object nestValue)) + -- 14.2.2. + eo1314ModifyNest <| const mempty + eo1314Recurse (K.toText nestedKey) inputType nestValue + -- 14.2.1. + invalid -> throwError <| InvalidKeywordValue KeywordNest invalid + +-- + +eoExpandObject1314 :: Monad m => ActiveContext -> Maybe Text -> Object -> JLDET e m Object +eoExpandObject1314 typeContext inputType value = do + EO1314State{..} <- + (expandObject1314' inputType value >> get) + |> withStateRES + ( \jld -> + EO1314State + { eo1314StateJlde = jld + , eo1314StateNest = mempty + , eo1314StateResult = mempty + , eo1314StateTypeContext = typeContext + } + ) + (const eo1314StateJlde) + pure eo1314StateResult + +eoNormalizeObject :: Monad m => Object -> JLDET e m Value +eoNormalizeObject result + -- 18. + | KM.size result == 1 && KM.member (show KeywordLanguage) result = pure Null + -- + | otherwise = do + JLDEEnv{..} <- ask + + if + -- 19.1. + | maybe True (== show KeywordGraph) jldeEnvActiveProperty + , not jldeEnvFrameExpansion + , KM.null result || KM.member (show KeywordValue) result || KM.member (show KeywordList) result -> + pure Null + -- 19.2. + | maybe True (== show KeywordGraph) jldeEnvActiveProperty + , not jldeEnvFrameExpansion + , KM.size result == 1 + , KM.member (show KeywordId) result -> + pure Null + -- + | otherwise -> + pure <| Object result + +expandObject :: Monad m => Maybe Value -> Object -> JLDET e m Value +expandObject maybePropertyContext value = do + JLDEEnv{..} <- ask + + -- 7. + gets (jldeStateActiveContext .> activeContextPreviousContext) >>= \case + Just previousContext | not jldeEnvFromMap -> do + noRevert <- flip anyM (KM.keys value) \k -> do + expanded <- exExpandIri <| K.toText k + pure <| expanded == Just (show KeywordValue) || (expanded == Just (show KeywordId) && KM.size value == 1) + unless noRevert <| exModifyActiveContext (const previousContext) + -- + _ -> pure () + + -- 8. + case (jldeEnvActiveProperty, maybePropertyContext) of + (Just activeProperty, Just propertyContext) -> do + baseUrl' <- gets (jldeStateActiveContext .> lookupTerm activeProperty >=> termDefinitionBaseUrl) + exBuildActiveContext baseUrl' propertyContext \params -> params{bacParamsOverrideProtected = True} + -- + _ -> pure () + + -- 9. + case KM.lookup (show KeywordContext) value of + Just context -> exBuildActiveContext (Just jldeEnvBaseUrl) context id + -- + _ -> pure () + + -- 10. + typeContext <- gets jldeStateActiveContext + + -- 11. + inputType <- do + maybeType <- + value |> ifindM \key item -> do + -- 11.2. + isType <- (Just (show KeywordType) ==) <$> exExpandIri (K.toText key) + + when isType do + valueToArray item |> fmap valueToString .> V.catMaybes .> V.modify V.sort .> mapM_ \term -> + case lookupTerm term typeContext >>= termDefinitionLocalContext of + Just localContext -> do + valueBaseUrl <- gets <| termDefinitionBaseUrl <=< lookupTerm term <. jldeStateActiveContext + exBuildActiveContext valueBaseUrl localContext \params -> + params + { bacParamsPropagate = False + } + _ -> pure () + + pure isType + + case maybeType of + Just (Array type') | not (V.null type') -> exExpandIri <. V.maximum <. V.catMaybes <| valueToString <$> type' + Just (String type') -> exExpandIri type' + -- + _ -> pure Nothing + + -- 13. 14. + result <- eoExpandObject1314 typeContext inputType value + + if + -- 15. + | Just resultValue <- KM.lookup (show KeywordValue) result -> do + -- 15.1. + when (isNotValueObject' result) <| throwError InvalidValueObject + when + ( KM.member (show KeywordType) result + && (KM.member (show KeywordDirection) result || KM.member (show KeywordLanguage) result) + ) + <| throwError InvalidValueObject + + case KM.lookup (show KeywordType) result of + -- 15.2. + Just type' | valueContains (show KeywordJson) type' -> do + eoNormalizeObject result + _ + -- 15.3. + | resultValue == Null || valueIsEmptyArray resultValue -> + pure Null + -- 15.4. + | not jldeEnvFrameExpansion + , valueIsNotString resultValue + , KM.member (show KeywordLanguage) result -> + throwError InvalidLanguageTaggedValue + -- 15.5. + Just (String (parseIRI -> Left _)) | not jldeEnvFrameExpansion -> do + throwError InvalidTypedValue + Just (valueIsNotString -> True) | not jldeEnvFrameExpansion -> do + throwError InvalidTypedValue + -- + _ -> eoNormalizeObject result + -- 16. + | Just resultType <- KM.lookup (show KeywordType) result -> + eoNormalizeObject + <| if valueIsNotArray resultType && valueIsNotNull resultType + then KM.insert (show KeywordType) (Array <| V.singleton resultType) result + else result + -- 17. + | KM.member (show KeywordList) result || KM.member (show KeywordSet) result -> do + -- 17.1. + when (KM.size result > 2 || (KM.size result == 2 && not (KM.member (show KeywordIndex) result))) + <| throwError InvalidSetOrListObject + -- 17.2. + if + | Just (Object set) <- KM.lookup (show KeywordSet) result -> eoNormalizeObject set + | Just set <- KM.lookup (show KeywordSet) result -> pure set + | otherwise -> eoNormalizeObject result + -- + | otherwise -> eoNormalizeObject result + +-- + +expandArrayItem :: Monad m => Value -> JLDET e m Array +expandArrayItem item = do + JLDEEnv{..} <- ask + + -- 5.2.1. + item' <- exExpand item id + + -- 5.2.2. + activeContext <- gets jldeStateActiveContext + let item'' = case item' of + Array a + | Just activeProperty <- jldeEnvActiveProperty + , Just term <- lookupTerm activeProperty activeContext + , S.member (show KeywordList) (termDefinitionContainerMapping term) -> + toListObject <| Array a + _ -> item' + + case item'' of + -- 5.2.3. + Array a -> pure <| V.filter valueIsNotNull a + Null -> pure mempty + _ -> pure <| V.singleton item'' + +-- + +expandValue :: Monad m => Text -> Value -> JLDET e m Object +expandValue activeProperty value = do + definition <- gets <| lookupTerm activeProperty <. jldeStateActiveContext + + case definition >>= termDefinitionTypeMapping of + -- 1. 2. + Just typeMapping + | String stringValue <- value + , typeMapping `isKeyword` [KeywordId, KeywordVocab] -> + KM.singleton (show KeywordId) <. maybe Null String <$> evExpandIri stringValue \params -> + params + { eiParamsDocumentRelative = True + , eiParamsVocab = typeMapping == show KeywordVocab + } + -- 3. 4. + | typeMapping `isNotKeyword` [KeywordId, KeywordVocab, KeywordNone] -> + pure <| KM.fromList [(show KeywordType, String typeMapping), (show KeywordValue, value)] + -- 5. + _ | String _ <- value -> do + defaultLanguage <- gets <| activeContextDefaultLanguage <. jldeStateActiveContext + defaultDirection <- gets <| activeContextDefaultBaseDirection <. jldeStateActiveContext + + -- 5.1. 5.2. 5.3. 5.4. + KM.singleton (show KeywordValue) value + |> case definition >>= termDefinitionLanguageMapping of + Nothing + | Just (Language def) <- defaultLanguage -> KM.insert (show KeywordLanguage) (String def) + | otherwise -> id + Just NoLanguage -> id + Just (Language lang) -> KM.insert (show KeywordLanguage) (String lang) + |> case definition >>= termDefinitionDirectionMapping of + Nothing + | Just def <- defaultDirection -> KM.insert (show KeywordDirection) (show def) + | otherwise -> id + Just NoDirection -> id + Just dir -> KM.insert (show KeywordDirection) (show dir) + |> pure + -- 6. + _ -> pure <| KM.singleton (show KeywordValue) value + +-- + +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)} + +evExpandIri :: Monad m => Text -> (EIParams -> EIParams) -> JLDET e m (Maybe Text) +evExpandIri value fn = do + JLDEEnv{..} <- ask + activeContext <- gets jldeStateActiveContext + (value', activeContext', _) <- + expandIri activeContext value fn + |> withEnvRES (const jldeEnvGlobal) + |> withStateRES jldeStateGlobal (\s jlde -> s{jldeStateGlobal = jlde}) + exModifyActiveContext <| const activeContext' + pure value' + +exExpandIri :: Monad m => Text -> JLDET e m (Maybe Text) +exExpandIri value = do + JLDEEnv{..} <- ask + activeContext <- gets jldeStateActiveContext + let params p = p{eiParamsVocab = True} + (value', activeContext', _) <- + expandIri activeContext value params + |> withEnvRES (const jldeEnvGlobal) + |> withStateRES jldeStateGlobal (\s jlde -> s{jldeStateGlobal = jlde}) + exModifyActiveContext <| const activeContext' + pure value' + +exBuildActiveContext :: Monad m => Maybe URI -> Value -> (BACParams -> BACParams) -> JLDET e m () +exBuildActiveContext baseUrl localContext fn = do + JLDEEnv{..} <- ask + activeContext <- gets jldeStateActiveContext + activeContext' <- + buildActiveContext activeContext localContext baseUrl fn + |> withEnvRES (const jldeEnvGlobal) + |> withStateRES jldeStateGlobal (\s jlde -> s{jldeStateGlobal = jlde}) + exModifyActiveContext (const activeContext') + +exExpand :: Monad m => Value -> (JLDEParams -> JLDEParams) -> JLDET e m Value +exExpand value fn = do + JLDEEnv{..} <- ask + activeContext <- gets jldeStateActiveContext + let params p = fn p{jldeParamsActiveProperty = jldeEnvActiveProperty} + expand activeContext value jldeEnvBaseUrl params + |> withEnvRES (const jldeEnvGlobal) + |> withStateRES jldeStateGlobal (\s jlde -> s{jldeStateGlobal = jlde}) + +expand' :: Monad m => Value -> JLDET e m Value +expand' = \case + -- 1. + Null -> pure Null + -- 5. + Array value -> Array <. V.concat <. V.toList <$> forM value expandArrayItem + -- 6. + Object value -> do + JLDEEnv{..} <- ask + + -- 3. + maybePropertyContext <- case jldeEnvActiveProperty of + Just activeProperty -> gets (jldeStateActiveContext .> lookupTerm activeProperty >=> termDefinitionLocalContext) + Nothing -> pure Nothing + + -- 6. + expandObject maybePropertyContext value + |> withEnvRES \env -> + env{jldeEnvFrameExpansion = jldeEnvFrameExpansion && maybePropertyContext /= Just (show KeywordDefault)} + + -- 4. + value -> do + JLDEEnv{..} <- ask + + maybePropertyTerm <- case jldeEnvActiveProperty of + Just activeProperty -> gets <| lookupTerm activeProperty <. jldeStateActiveContext + Nothing -> pure Nothing + + case jldeEnvActiveProperty of + -- 4.1. + Nothing -> pure Null + -- + Just activeProperty + -- 4.1. + | activeProperty == show KeywordGraph -> pure Null + -- 4.2. + | Just propertyTerm <- maybePropertyTerm + , Just propertyContext <- termDefinitionLocalContext propertyTerm -> do + exBuildActiveContext (termDefinitionBaseUrl propertyTerm) propertyContext id + Object <$> expandValue activeProperty value + -- 4.3. + | otherwise -> Object <$> expandValue activeProperty value + +expand :: Monad m => ActiveContext -> Value -> URI -> (JLDEParams -> JLDEParams) -> JLDT e m Value +expand activeContext value baseUrl paramsFn = + expand' value + |> withEnvRES env + |> withStateRES st (const jldeStateGlobal) + where + JLDEParams{..} = + paramsFn + JLDEParams + { jldeParamsFrameExpansion = False + , jldeParamsFromMap = False + , jldeParamsBaseUrl = baseUrl + , jldeParamsActiveProperty = Nothing + } + + env global = + JLDEEnv + { jldeEnvGlobal = global + , jldeEnvFrameExpansion = jldeParamsFrameExpansion + , jldeEnvFromMap = jldeParamsFromMap + , jldeEnvBaseUrl = jldeParamsBaseUrl + , jldeEnvActiveProperty = jldeParamsActiveProperty + } + + st global = + JLDEState + { jldeStateGlobal = global + , jldeStateActiveContext = activeContext + } diff --git a/src/Data/JLD/Mime.hs b/src/Data/JLD/Mime.hs new file mode 100644 index 0000000..64158e8 --- /dev/null +++ b/src/Data/JLD/Mime.hs @@ -0,0 +1,6 @@ +module Data.JLD.Mime (mimeType) where + +import Data.JLD.Prelude + +mimeType :: ByteString +mimeType = "application/ld+json" diff --git a/src/Data/JLD/Model/ActiveContext.hs b/src/Data/JLD/Model/ActiveContext.hs new file mode 100644 index 0000000..5423036 --- /dev/null +++ b/src/Data/JLD/Model/ActiveContext.hs @@ -0,0 +1,44 @@ +module Data.JLD.Model.ActiveContext ( ActiveContext (..), newActiveContext, lookupTerm, containsProtectedTerm,) where + +import Data.JLD.Prelude + +import Data.JLD.Model.Direction (Direction) +import Data.JLD.Model.InverseContext (InverseContext) +import Data.JLD.Model.Language (Language) +import Data.JLD.Model.TermDefinition (TermDefinition (..)) + +import Data.Map.Strict qualified as M (lookup) +import Data.RDF (IRIRef) +import Text.URI (URI) + +data ActiveContext = ActiveContext + { activeContextTerms :: Map Text TermDefinition + , activeContextBaseIri :: Maybe IRIRef + , activeContextBaseUrl :: Maybe URI + , activeContextInverseContext :: InverseContext + , activeContextPreviousContext :: Maybe ActiveContext + , activeContextVocabularyMapping :: Maybe Text + , activeContextDefaultLanguage :: Maybe Language + , activeContextDefaultBaseDirection :: Maybe Direction + } + deriving (Eq, Show) + +newActiveContext :: (ActiveContext -> ActiveContext) -> ActiveContext +newActiveContext fn = + fn + ActiveContext + { activeContextTerms = mempty + , activeContextBaseIri = Nothing + , activeContextBaseUrl = Nothing + , activeContextInverseContext = mempty + , activeContextPreviousContext = Nothing + , activeContextVocabularyMapping = Nothing + , activeContextDefaultLanguage = Nothing + , activeContextDefaultBaseDirection = Nothing + } + +lookupTerm :: Text -> ActiveContext -> Maybe TermDefinition +lookupTerm key ActiveContext{..} = M.lookup key activeContextTerms + +containsProtectedTerm :: ActiveContext -> Bool +containsProtectedTerm = activeContextTerms .> any termDefinitionProtectedFlag diff --git a/src/Data/JLD/Model/Direction.hs b/src/Data/JLD/Model/Direction.hs new file mode 100644 index 0000000..2ed8e87 --- /dev/null +++ b/src/Data/JLD/Model/Direction.hs @@ -0,0 +1,13 @@ +module Data.JLD.Model.Direction (Direction (..)) where + +import Data.JLD.Prelude + +import Text.Show (Show (..)) + +data Direction = LTR | RTL | NoDirection + deriving (Eq, Ord) + +instance Show Direction where + show LTR = "ltr" + show RTL = "rtl" + show NoDirection = "none" diff --git a/src/Data/JLD/Model/GraphObject.hs b/src/Data/JLD/Model/GraphObject.hs new file mode 100644 index 0000000..3db9e6b --- /dev/null +++ b/src/Data/JLD/Model/GraphObject.hs @@ -0,0 +1,22 @@ +module Data.JLD.Model.GraphObject (isGraphObject, isNotGraphObject, toGraphObject) where + +import Data.JLD.Prelude + +import Data.JLD.Model.Keyword (Keyword (..), isKeyword) + +import Data.Aeson (Object, Value (..)) +import Data.Aeson.Key qualified as K (toText) +import Data.Aeson.KeyMap qualified as KM (keys, singleton, member) +import Data.Vector qualified as V (singleton) + +isGraphObject :: Value -> Bool +isGraphObject (Object o) + | KM.member (show KeywordGraph) o = + all (`isKeyword` [KeywordGraph, KeywordId, KeywordIndex, KeywordContext]) (K.toText <$> KM.keys o) +isGraphObject _ = False + +isNotGraphObject :: Value -> Bool +isNotGraphObject = isGraphObject .> not + +toGraphObject :: Value -> Object +toGraphObject = V.singleton .> Array .> KM.singleton (show KeywordGraph) diff --git a/src/Data/JLD/Model/IRI.hs b/src/Data/JLD/Model/IRI.hs new file mode 100644 index 0000000..7c054eb --- /dev/null +++ b/src/Data/JLD/Model/IRI.hs @@ -0,0 +1,46 @@ +module Data.JLD.Model.IRI ( + CompactIRI (..), + compactIriPrefix, + compactIriSuffix, + isBlankIri, + endsWithGenericDelim, + parseCompactIri, + renderCompactIri, +) where + +import Data.JLD.Prelude + +import Data.Char (isAlphaNum) +import Data.Text qualified as T (drop, findIndex, isPrefixOf, take, uncons, unsnoc) + +data CompactIRI = CompactIRI Text Text | BlankIRI Text + deriving (Show, Eq) + +compactIriPrefix :: CompactIRI -> Text +compactIriPrefix (CompactIRI prefix _) = prefix +compactIriPrefix (BlankIRI _) = "_" + +compactIriSuffix :: CompactIRI -> Text +compactIriSuffix (CompactIRI _ suffix) = suffix +compactIriSuffix (BlankIRI suffix) = suffix + +renderCompactIri :: CompactIRI -> Text +renderCompactIri iri = compactIriPrefix iri <> ":" <> compactIriSuffix iri + +parseCompactIri :: Text -> Maybe CompactIRI +parseCompactIri value + | Just idx <- (+ 1) <$> T.findIndex (== ':') (T.drop 1 value) + , prefix <- T.take idx value + , suffix <- T.drop (idx + 1) value + , not ("/" `T.isPrefixOf` suffix) + , Just (prefixFirst, _) <- T.uncons prefix + , prefixFirst == '_' || isAlphaNum prefixFirst = + Just <| if prefix == "_" then BlankIRI suffix else CompactIRI prefix suffix + | otherwise = Nothing + +isBlankIri :: Text -> Bool +isBlankIri = T.isPrefixOf "_:" + +endsWithGenericDelim :: Text -> Bool +endsWithGenericDelim (T.unsnoc -> Just (_, c)) = c `elem` (":/?#[]@" :: String) +endsWithGenericDelim _ = False diff --git a/src/Data/JLD/Model/InverseContext.hs b/src/Data/JLD/Model/InverseContext.hs new file mode 100644 index 0000000..fe4b516 --- /dev/null +++ b/src/Data/JLD/Model/InverseContext.hs @@ -0,0 +1,5 @@ +module Data.JLD.Model.InverseContext (InverseContext) where + +import Data.JLD.Prelude + +type InverseContext = Map (Text, Text, Text, Text) Text diff --git a/src/Data/JLD/Model/Keyword.hs b/src/Data/JLD/Model/Keyword.hs new file mode 100644 index 0000000..10835a9 --- /dev/null +++ b/src/Data/JLD/Model/Keyword.hs @@ -0,0 +1,135 @@ +module Data.JLD.Model.Keyword ( + Keyword (..), + parseKeyword, + isKeyword, + isNotKeyword, + allKeywords, + isKeywordLike, +) where + +import Data.JLD.Prelude hiding (show) + +import Data.Char (isAlpha) +import Data.Foldable qualified as F +import Data.Text qualified as T (all, null, uncons) +import Text.Show (Show (..)) + +data Keyword + = KeywordAny + | KeywordBase + | KeywordContainer + | KeywordContext + | KeywordDefault + | KeywordDirection + | KeywordEmbed + | KeywordExplicit + | KeywordFirst + | KeywordGraph + | KeywordId + | KeywordImport + | KeywordIncluded + | KeywordIndex + | KeywordJson + | KeywordLanguage + | KeywordList + | KeywordNest + | KeywordNone + | KeywordNull + | KeywordOmitDefault + | KeywordPrefix + | KeywordPreserve + | KeywordPropagate + | KeywordProtected + | KeywordRequireAll + | KeywordReverse + | KeywordSet + | KeywordType + | KeywordValue + | KeywordVersion + | KeywordVocab + deriving (Eq, Ord) + +instance Show Keyword where + show = \case + KeywordAny -> "@any" + KeywordBase -> "@base" + KeywordContainer -> "@container" + KeywordContext -> "@context" + KeywordDefault -> "@default" + KeywordDirection -> "@direction" + KeywordEmbed -> "@embed" + KeywordExplicit -> "@explicit" + KeywordFirst -> "@first" + KeywordGraph -> "@graph" + KeywordId -> "@id" + KeywordImport -> "@import" + KeywordIncluded -> "@included" + KeywordIndex -> "@index" + KeywordJson -> "@json" + KeywordLanguage -> "@language" + KeywordList -> "@list" + KeywordNest -> "@nest" + KeywordNone -> "@none" + KeywordNull -> "@null" + KeywordOmitDefault -> "@omitDefault" + KeywordPrefix -> "@prefix" + KeywordPreserve -> "@preserve" + KeywordPropagate -> "@propagate" + KeywordProtected -> "@protected" + KeywordRequireAll -> "@requireAll" + KeywordReverse -> "@reverse" + KeywordSet -> "@set" + KeywordType -> "@type" + KeywordValue -> "@value" + KeywordVersion -> "@version" + KeywordVocab -> "@vocab" + +parseKeyword :: Text -> Maybe Keyword +parseKeyword = \case + "@any" -> Just KeywordAny + "@base" -> Just KeywordBase + "@container" -> Just KeywordContainer + "@context" -> Just KeywordContext + "@default" -> Just KeywordDefault + "@direction" -> Just KeywordDirection + "@embed" -> Just KeywordEmbed + "@explicit" -> Just KeywordExplicit + "@first" -> Just KeywordFirst + "@graph" -> Just KeywordGraph + "@id" -> Just KeywordId + "@import" -> Just KeywordImport + "@included" -> Just KeywordIncluded + "@index" -> Just KeywordIndex + "@json" -> Just KeywordJson + "@language" -> Just KeywordLanguage + "@list" -> Just KeywordList + "@nest" -> Just KeywordNest + "@none" -> Just KeywordNone + "@null" -> Just KeywordNull + "@omitDefault" -> Just KeywordOmitDefault + "@prefix" -> Just KeywordPrefix + "@preserve" -> Just KeywordPreserve + "@propagate" -> Just KeywordPropagate + "@protected" -> Just KeywordProtected + "@requireAll" -> Just KeywordRequireAll + "@reverse" -> Just KeywordReverse + "@set" -> Just KeywordSet + "@type" -> Just KeywordType + "@value" -> Just KeywordValue + "@version" -> Just KeywordVersion + "@vocab" -> Just KeywordVocab + _ -> Nothing + +isKeyword :: Foldable f => Text -> f Keyword -> Bool +isKeyword (parseKeyword -> Just keyword) (F.elem keyword -> True) = True +isKeyword _ _ = False + +isNotKeyword :: Foldable f => Text -> f Keyword -> Bool +isNotKeyword s = isKeyword s .> not + +allKeywords :: Foldable f => f Text -> f Keyword -> Bool +allKeywords values keywords = all (`isKeyword` keywords) values + +isKeywordLike :: Text -> Bool +isKeywordLike (T.uncons -> Just ('@', res)) = not (T.null res) && T.all isAlpha res +isKeywordLike _ = False diff --git a/src/Data/JLD/Model/Language.hs b/src/Data/JLD/Model/Language.hs new file mode 100644 index 0000000..c24994e --- /dev/null +++ b/src/Data/JLD/Model/Language.hs @@ -0,0 +1,6 @@ +module Data.JLD.Model.Language (Language (..)) where + +import Data.JLD.Prelude + +data Language = Language Text | NoLanguage + deriving (Show, Eq) diff --git a/src/Data/JLD/Model/ListObject.hs b/src/Data/JLD/Model/ListObject.hs new file mode 100644 index 0000000..8dda349 --- /dev/null +++ b/src/Data/JLD/Model/ListObject.hs @@ -0,0 +1,24 @@ +module Data.JLD.Model.ListObject (isListObject, isNotListObject, toListObject) where + +import Data.JLD.Prelude + +import Data.JLD.Model.Keyword (Keyword (..)) + +import Data.Aeson (Value (..)) +import Data.Aeson.KeyMap qualified as KM +import Data.Vector qualified as V + +isListObject :: Value -> Bool +isListObject (Object o) = + KM.member (show KeywordList) o + && ( KM.size o == 1 + || (KM.size o == 2 && KM.member (show KeywordIndex) o) + ) +isListObject _ = False + +isNotListObject :: Value -> Bool +isNotListObject = isListObject .> not + +toListObject :: Value -> Value +toListObject value@(Array _) = Object <| KM.singleton (show KeywordList) value +toListObject value = Object <| KM.singleton (show KeywordList) (Array <| V.singleton value) diff --git a/src/Data/JLD/Model/NodeObject.hs b/src/Data/JLD/Model/NodeObject.hs new file mode 100644 index 0000000..d0bb4c5 --- /dev/null +++ b/src/Data/JLD/Model/NodeObject.hs @@ -0,0 +1,21 @@ +module Data.JLD.Model.NodeObject (isNodeObject, isNotNodeObject) where + +import Data.JLD.Prelude + +import Data.JLD.Model.Keyword (Keyword (..)) + +import Data.Aeson (Value (..)) +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap qualified as KM + +isNodeObject :: Value -> Bool +isNodeObject (Object o) = + ( not (KM.member (show KeywordValue) o) + && not (KM.member (show KeywordList) o) + && not (KM.member (show KeywordSet) o) + ) + || (KM.keys o == ([KeywordContext, KeywordGraph] <&> show .> K.fromText)) +isNodeObject _ = False + +isNotNodeObject :: Value -> Bool +isNotNodeObject = isNodeObject .> not diff --git a/src/Data/JLD/Model/TermDefinition.hs b/src/Data/JLD/Model/TermDefinition.hs new file mode 100644 index 0000000..5f39eee --- /dev/null +++ b/src/Data/JLD/Model/TermDefinition.hs @@ -0,0 +1,43 @@ +module Data.JLD.Model.TermDefinition (TermDefinition (..), newTermDefinition) where + +import Data.JLD.Prelude + +import Data.JLD.Model.Direction (Direction) +import Data.JLD.Model.Language (Language) + +import Data.Aeson (Value) +import Text.URI (URI) + +data TermDefinition = TermDefinition + { termDefinitionIriMapping :: Maybe Text + , termDefinitionPrefixFlag :: Bool + , termDefinitionProtectedFlag :: Bool + , termDefinitionReversePropertyFlag :: Bool + , termDefinitionBaseUrl :: Maybe URI + , termDefinitionLocalContext :: Maybe Value + , termDefinitionContainerMapping :: Set Text + , termDefinitionIndexMapping :: Maybe Text + , termDefinitionNestValue :: Maybe Text + , termDefinitionTypeMapping :: Maybe Text + , termDefinitionDirectionMapping :: Maybe Direction + , termDefinitionLanguageMapping :: Maybe Language + } + deriving (Show, Eq) + +newTermDefinition :: Bool -> (TermDefinition -> TermDefinition) -> TermDefinition +newTermDefinition protectedFlag fn = + fn + TermDefinition + { termDefinitionIriMapping = Nothing + , termDefinitionPrefixFlag = False + , termDefinitionProtectedFlag = protectedFlag + , termDefinitionReversePropertyFlag = False + , termDefinitionBaseUrl = Nothing + , termDefinitionLocalContext = Nothing + , termDefinitionContainerMapping = mempty + , termDefinitionIndexMapping = Nothing + , termDefinitionNestValue = Nothing + , termDefinitionTypeMapping = Nothing + , termDefinitionDirectionMapping = Nothing + , termDefinitionLanguageMapping = Nothing + } diff --git a/src/Data/JLD/Model/URI.hs b/src/Data/JLD/Model/URI.hs new file mode 100644 index 0000000..07cf8a9 --- /dev/null +++ b/src/Data/JLD/Model/URI.hs @@ -0,0 +1,13 @@ +module Data.JLD.Model.URI (parseUri, uriToIri) where + +import Data.JLD.Prelude + +import Data.RDF (IRIRef, parseIRI) +import Text.Megaparsec (MonadParsec (..), Parsec, runParser) +import Text.URI (URI, parser, render) + +parseUri :: Text -> Maybe URI +parseUri = runParser (parser <* eof :: Parsec Void Text URI) "" .> either (const Nothing) Just + +uriToIri :: URI -> Maybe IRIRef +uriToIri = render .> parseIRI .> either (const Nothing) Just diff --git a/src/Data/JLD/Model/ValueObject.hs b/src/Data/JLD/Model/ValueObject.hs new file mode 100644 index 0000000..79bd94f --- /dev/null +++ b/src/Data/JLD/Model/ValueObject.hs @@ -0,0 +1,27 @@ +module Data.JLD.Model.ValueObject (isValueObject, isValueObject', isNotValueObject, isNotValueObject', valueObjectValue) where + +import Data.JLD.Prelude + +import Data.JLD.Model.Keyword (Keyword (..), isNotKeyword) + +import Data.Aeson (Object, Value (..)) +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap qualified as KM + +isValueObject :: Value -> Bool +isValueObject (Object o) = isValueObject' o +isValueObject _ = False + +isValueObject' :: Object -> Bool +isValueObject' = KM.member (show KeywordValue) + +isNotValueObject :: Value -> Bool +isNotValueObject (Object o) = isNotValueObject' o +isNotValueObject _ = False + +isNotValueObject' :: Object -> Bool +isNotValueObject' = KM.keys .> fmap K.toText .> any (`isNotKeyword` [KeywordType, KeywordValue, KeywordDirection, KeywordLanguage, KeywordIndex]) + +valueObjectValue :: Value -> Maybe Value +valueObjectValue (Object o) = KM.lookup (show KeywordValue) o +valueObjectValue _ = Nothing diff --git a/src/Data/JLD/Monad.hs b/src/Data/JLD/Monad.hs new file mode 100644 index 0000000..3ae929d --- /dev/null +++ b/src/Data/JLD/Monad.hs @@ -0,0 +1,86 @@ +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/Options.hs b/src/Data/JLD/Options.hs new file mode 100644 index 0000000..d6ec51d --- /dev/null +++ b/src/Data/JLD/Options.hs @@ -0,0 +1,34 @@ +module Data.JLD.Options ( + Document (..), + ContextCache, + DocumentCache, + JLDVersion (..), + DocumentLoader (..), + hoistDocumentLoader, +) where + +import Data.JLD.Prelude + +import Data.Aeson (Object, Value) +import Text.Show (Show (..)) +import Text.URI (URI) + +data Document = Document + { documentUri :: URI + , documentContent :: Object + } + deriving (Show, Eq) + +type ContextCache = Map Text Value + +type DocumentCache = Map Text Document + +newtype DocumentLoader e m = DocumentLoader {runDocumentLoader :: URI -> m (Either e Value)} + +instance Show (DocumentLoader e m) where + show _ = "DocumentLoader" + +data JLDVersion = JLD1_0 | JLD1_1 deriving (Show, Eq) + +hoistDocumentLoader :: (forall a. m a -> n a) -> DocumentLoader e m -> DocumentLoader e n +hoistDocumentLoader map' (DocumentLoader loader) = DocumentLoader <| loader .> map' diff --git a/src/Data/JLD/Prelude.hs b/src/Data/JLD/Prelude.hs new file mode 100644 index 0000000..5be118b --- /dev/null +++ b/src/Data/JLD/Prelude.hs @@ -0,0 +1,4 @@ +module Data.JLD.Prelude (module Flow, module Relude) where + +import Flow +import Relude diff --git a/src/Data/JLD/Util.hs b/src/Data/JLD/Util.hs new file mode 100644 index 0000000..82cbdee --- /dev/null +++ b/src/Data/JLD/Util.hs @@ -0,0 +1,118 @@ +module Data.JLD.Util ( + valueContains, + valueContainsAny, + valueIsTrue, + valueIsString, + valueIsArray, + valueIsNotArray, + valueIsEmptyArray, + valueIsScalar, + valueToString, + valueIsNotString, + valueIsNotNull, + flattenSingletonArray, + valueToArray, + allStrings, + ifindM, + getMapDefault, + mapAddValue, +) where + +import Data.JLD.Prelude + +import Data.Aeson (Array, Key, Object, Value (..)) +import Data.Aeson.Key qualified as K (fromText) +import Data.Aeson.KeyMap qualified as KM (insert, lookup, member) +import Data.Foldable qualified as F (Foldable (..), elem) +import Data.Foldable.WithIndex (FoldableWithIndex (..), ifoldlM) +import Data.Vector (Vector) +import Data.Vector qualified as V (fromList, null, singleton, snoc, uncons) + +valueContains :: Text -> Value -> Bool +valueContains text = \case + String s -> s == text + Array a -> elem (String text) a + Object o -> KM.member (K.fromText text) o + _ -> False + +valueContainsAny :: (Foldable f, Functor f) => f Text -> Value -> Bool +valueContainsAny texts = \case + String s -> s `F.elem` texts + Array a -> any (`elem` a) <| String <$> texts + Object o -> any (\text -> KM.member (K.fromText text) o) texts + _ -> False + +valueIsTrue :: Value -> Bool +valueIsTrue (Bool True) = True +valueIsTrue _ = False + +valueIsString :: Value -> Bool +valueIsString (String _) = True +valueIsString _ = False + +valueIsNotString :: Value -> Bool +valueIsNotString = valueIsString .> not + +valueIsArray :: Value -> Bool +valueIsArray (Array _) = True +valueIsArray _ = False + +valueIsNotArray :: Value -> Bool +valueIsNotArray = valueIsArray .> not + +valueIsEmptyArray :: Value -> Bool +valueIsEmptyArray (Array a) = V.null a +valueIsEmptyArray _ = False + +valueIsScalar :: Value -> Bool +valueIsScalar = \case + String _ -> True + Number _ -> True + Bool _ -> True + _ -> False + +valueToString :: Value -> Maybe Text +valueToString (String s) = Just s +valueToString _ = Nothing + +valueIsNotNull :: Value -> Bool +valueIsNotNull Null = False +valueIsNotNull _ = True + +flattenSingletonArray :: Value -> Value +flattenSingletonArray = \case + Array (V.uncons -> Just (value, V.null -> True)) -> value + value -> value + +valueToArray :: Value -> Array +valueToArray = \case + Array a -> a + value -> V.singleton value + +allStrings :: Array -> Maybe (Vector Text) +allStrings = foldl' go (Just mempty) + where + go :: Maybe (Vector Text) -> Value -> Maybe (Vector Text) + go (Just a) (String s) = Just <| V.snoc a s + go _ _ = Nothing + +ifindM :: (FoldableWithIndex i f, Monad m) => (i -> a -> m Bool) -> f a -> m (Maybe a) +ifindM p = ifoldlM (\i r x -> p i x <&> bool r (Just x)) Nothing + +getMapDefault :: Key -> Object -> Object +getMapDefault key obj = case KM.lookup key obj of + Just (Object o) -> o + _ -> mempty + +mapAddValue :: Key -> Value -> Bool -> Object -> Object +mapAddValue key value True object = mapAddValue key value False <| KM.insert key (Array array) object + where + array = case KM.lookup key object of + Just (Array a) -> a + Just original -> V.singleton original + Nothing -> mempty +mapAddValue key (Array value) False object = foldl' (\o v -> mapAddValue key v False o) object value +mapAddValue key value False object = case KM.lookup key object of + Just (Array a) -> KM.insert key (Array <| V.snoc a value) object + Just original -> KM.insert key (Array <| V.fromList [original, value]) object + Nothing -> KM.insert key value object -- cgit v1.2.3-70-g09d2