From 11d0fb47c292a0ca25a9c377499d2b221d97a5cb Mon Sep 17 00:00:00 2001 From: Volpeon Date: Fri, 26 May 2023 07:40:13 +0200 Subject: Init --- .gitignore | 4 + CHANGELOG.md | 11 + LICENSE | 30 + README.md | 1 + Setup.hs | 2 + jsonld.cabal | 123 ++++ package.yaml | 78 +++ src/Data/JLD.hs | 83 +++ 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 ++++ stack.yaml | 68 +++ stack.yaml.lock | 20 + test/Spec.hs | 24 + test/Test/Expansion.hs | 141 +++++ 33 files changed, 3310 insertions(+) create mode 100644 .gitignore create mode 100644 CHANGELOG.md create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 jsonld.cabal create mode 100644 package.yaml create mode 100644 src/Data/JLD.hs 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 create mode 100644 stack.yaml create mode 100644 stack.yaml.lock create mode 100644 test/Spec.hs create mode 100644 test/Test/Expansion.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..612326f --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +.stack-work/ +*~ + +.vscode diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..8cae68f --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `jsonld` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - YYYY-MM-DD diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..5ef71ac --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2023 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/README.md b/README.md new file mode 100644 index 0000000..8f8725f --- /dev/null +++ b/README.md @@ -0,0 +1 @@ +# jsonld diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/jsonld.cabal b/jsonld.cabal new file mode 100644 index 0000000..d4b3835 --- /dev/null +++ b/jsonld.cabal @@ -0,0 +1,123 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.35.1. +-- +-- see: https://github.com/sol/hpack + +name: jsonld +version: 0.1.0.0 +description: Please see the README on GitHub at +author: Volpeon +maintainer: me@volpeon.ink +copyright: 2023 Volpeon +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +library + exposed-modules: + Data.JLD + Data.JLD.Context + Data.JLD.Control.Monad.RES + Data.JLD.Error + Data.JLD.Expansion + Data.JLD.Mime + Data.JLD.Model.ActiveContext + Data.JLD.Model.Direction + Data.JLD.Model.GraphObject + Data.JLD.Model.InverseContext + Data.JLD.Model.IRI + Data.JLD.Model.Keyword + Data.JLD.Model.Language + Data.JLD.Model.ListObject + Data.JLD.Model.NodeObject + Data.JLD.Model.TermDefinition + Data.JLD.Model.URI + Data.JLD.Model.ValueObject + Data.JLD.Monad + Data.JLD.Options + Data.JLD.Prelude + Data.JLD.Util + other-modules: + Paths_jsonld + hs-source-dirs: + src + default-extensions: + BlockArguments + FlexibleContexts + ImportQualifiedPost + LambdaCase + MultiWayIf + NoImplicitPrelude + OverloadedStrings + RankNTypes + RecordWildCards + TupleSections + ViewPatterns + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wno-unticked-promoted-constructors -Wpartial-fields -Wredundant-constraints + build-depends: + aeson + , base >=4.7 && <5 + , containers + , flow + , indexed-traversable + , megaparsec + , modern-uri + , mtl + , rdf4h + , relude + , req + , tasty + , tasty-expected-failure + , tasty-hunit + , text + , transformers + , vector + , vector-algorithms + default-language: Haskell2010 + +test-suite jsonld-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.Expansion + Paths_jsonld + hs-source-dirs: + test + default-extensions: + BlockArguments + FlexibleContexts + ImportQualifiedPost + LambdaCase + MultiWayIf + NoImplicitPrelude + OverloadedStrings + RankNTypes + RecordWildCards + TupleSections + ViewPatterns + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wno-unticked-promoted-constructors -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base >=4.7 && <5 + , containers + , flow + , indexed-traversable + , jsonld + , megaparsec + , modern-uri + , mtl + , rdf4h + , relude + , req + , tasty + , tasty-expected-failure + , tasty-hunit + , text + , transformers + , vector + , vector-algorithms + default-language: Haskell2010 diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..5419b71 --- /dev/null +++ b/package.yaml @@ -0,0 +1,78 @@ +name: jsonld +version: 0.1.0.0 +license: BSD3 +author: "Volpeon" +maintainer: "me@volpeon.ink" +copyright: "2023 Volpeon" + +extra-source-files: + - README.md + - CHANGELOG.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: + - base >= 4.7 && < 5 + - aeson + - containers + - flow + - indexed-traversable + - megaparsec + - modern-uri + - mtl + - rdf4h + - relude + - req + - tasty + - tasty-expected-failure + - tasty-hunit + - text + - transformers + - vector + - vector-algorithms + +default-extensions: + - BlockArguments + - FlexibleContexts + - ImportQualifiedPost + - LambdaCase + - MultiWayIf + - NoImplicitPrelude + - OverloadedStrings + - RankNTypes + - RecordWildCards + - TupleSections + - ViewPatterns + +ghc-options: + - -Wall + - -Wcompat + - -Widentities + - -Wincomplete-record-updates + - -Wincomplete-uni-patterns + - -Wmissing-export-lists + - -Wmissing-home-modules + - -Wno-unticked-promoted-constructors + - -Wpartial-fields + - -Wredundant-constraints + +library: + source-dirs: src + +tests: + jsonld-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - jsonld diff --git a/src/Data/JLD.hs b/src/Data/JLD.hs new file mode 100644 index 0000000..d60e5a1 --- /dev/null +++ b/src/Data/JLD.hs @@ -0,0 +1,83 @@ +module Data.JLD ( + module Data.JLD.Mime, + module Data.JLD.Error, + module Data.JLD.Options, + JLDExpandParams (..), + expand, +) where + +import Data.JLD.Prelude + +import Data.JLD.Context (buildActiveContext) +import Data.JLD.Control.Monad.RES (evalREST, runREST) +import Data.JLD.Error +import Data.JLD.Expansion (JLDEParams (..)) +import Data.JLD.Expansion qualified as E (expand) +import Data.JLD.Mime +import Data.JLD.Model.ActiveContext (ActiveContext (..), newActiveContext) +import Data.JLD.Model.Keyword (Keyword (..)) +import Data.JLD.Model.URI (uriToIri) +import Data.JLD.Monad (JLDEnv, JLDState, newEnv, newState) +import Data.JLD.Options +import Data.JLD.Util (flattenSingletonArray, valueToArray) + +import Data.Aeson (Value (..)) +import Data.Aeson.KeyMap qualified as KM +import Data.Vector qualified as V (singleton) +import Text.URI (URI) + +data JLDExpandParams e m = JLDExpandParams + { jldExpandParamsExpandContext :: Maybe Value + , jldExpandParamsFrameExpansion :: Bool + , jldExpandParamsEnv :: JLDEnv e m + , jldExpandParamsState :: JLDState + } + deriving (Show) + +expand :: Monad m => Value -> URI -> (JLDExpandParams () m -> JLDExpandParams e m) -> m (Either (JLDError e) Value, JLDState) +expand document baseUrl paramsFn = do + let JLDExpandParams{..} = + paramsFn + JLDExpandParams + { jldExpandParamsExpandContext = Nothing + , jldExpandParamsFrameExpansion = False + , jldExpandParamsEnv = newEnv id + , jldExpandParamsState = newState id + } + + activeContext = newActiveContext \ac -> ac{activeContextBaseUrl = Just baseUrl, activeContextBaseIri = uriToIri baseUrl} + expansionParams p = p{jldeParamsFrameExpansion = jldExpandParamsFrameExpansion} + + -- 6. + let maybeExpandContext = + jldExpandParamsExpandContext <&> flattenSingletonArray .> \case + Array expandedContext -> Array expandedContext + (Object expandedContext) | Just ctx <- KM.lookup (show KeywordContext) expandedContext -> ctx + expandedContext -> Array <| V.singleton expandedContext + + activeContext' <- case maybeExpandContext of + Just expandContext -> + buildActiveContext activeContext expandContext (Just baseUrl) id + |> evalREST jldExpandParamsEnv jldExpandParamsState + |> fmap (fromRight activeContext) + Nothing -> pure activeContext + + -- 8. + (result, state') <- + E.expand activeContext' document baseUrl expansionParams + |> runREST jldExpandParamsEnv jldExpandParamsState + + let result' = case result of + -- 8.1. + Right (Object expanded) + | KM.size expanded == 1 + , Just expanded' <- KM.lookup (show KeywordGraph) expanded -> + Right <. Array <| valueToArray expanded' + -- 8.2. + Right Null -> Right <| Array mempty + -- 8.3. + Right expanded -> Right <. Array <| valueToArray expanded + -- + Left err -> Left err + + pure (result', state') 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 diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..5657fbc --- /dev/null +++ b/stack.yaml @@ -0,0 +1,68 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/22.yaml + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: + - . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] +extra-deps: + - rdf4h-5.0.1 +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of Stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.9" +# +# Override the architecture used by Stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by Stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..40b7e41 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,20 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: rdf4h-5.0.1@sha256:76ecd4aa6b536add8d7c6c13aedd3e028d492d0044f28dba9eb130cfed063fdc,6470 + pantry-tree: + sha256: 4c81222dbdb1a97adfb7f47421c404e6144c704e6806501d8e7d259f106b0fdd + size: 4230 + original: + hackage: rdf4h-5.0.1 +snapshots: +- completed: + sha256: dcf4fc28f12d805480ddbe8eb8c370e11db12f0461d0110a4240af27ac88d725 + size: 650255 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/22.yaml + original: + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/22.yaml diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..c58bbfa --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,24 @@ +import Data.JLD.Prelude + +import Data.JLD.Mime (mimeType) +import Test.Expansion (W3CExpansionTestList, expansionTests) + +import Test.Tasty + +import Network.HTTP.Req (GET (..), NoReqBody (..), defaultHttpConfig, header, https, jsonResponse, req, responseBody, runReq, (/:)) + +tests :: W3CExpansionTestList -> TestTree +tests jldExpansionTestList = + testGroup + "Tests" + [ expansionTests jldExpansionTestList + ] + +main :: IO () +main = do + jldExpansionTestList <- runReq defaultHttpConfig do + responseBody <$> req GET w3cExpansionTestListUrl NoReqBody jsonResponse (header "Accept" mimeType) + + defaultMain <| tests jldExpansionTestList + where + w3cExpansionTestListUrl = https "w3c.github.io" /: "json-ld-api" /: "tests" /: "expand-manifest.jsonld" diff --git a/test/Test/Expansion.hs b/test/Test/Expansion.hs new file mode 100644 index 0000000..33397f4 --- /dev/null +++ b/test/Test/Expansion.hs @@ -0,0 +1,141 @@ +module Test.Expansion (W3CExpansionTestList, expansionTests) where + +import Data.JLD.Prelude + +import Data.JLD (DocumentLoader (..), JLDExpandParams (..), JLDVersion (..), expand, mimeType, toJldErrorCode) +import Data.JLD.Model.URI (parseUri) +import Data.JLD.Monad (JLDEnv (..), newEnv) + +import Test.Tasty +import Test.Tasty.ExpectedFailure (ignoreTestBecause) +import Test.Tasty.HUnit + +import Data.Aeson (FromJSON, Value (..), (.:), (.:?)) +import Data.Aeson.Types (FromJSON (..), prependFailure, typeMismatch) +import Data.Maybe (fromJust) +import Network.HTTP.Req (GET (..), NoReqBody (..), defaultHttpConfig, header, jsonResponse, req, responseBody, runReq, useHttpsURI, useURI) +import Text.URI (URI, mkURI, relativeTo) + +data W3CExpansionTestOption = W3CExpansionTestOption + { w3cExpansionTestOptionSpecVersion :: Maybe Text + , w3cExpansionTestOptionProcessingMode :: Maybe Text + , w3cExpansionTestOptionBase :: Maybe Text + , w3cExpansionTestOptionExpandContext :: Maybe Text + } + deriving (Show) + +instance FromJSON W3CExpansionTestOption where + parseJSON (Object v) = + W3CExpansionTestOption + <$> (v .:? "specVersion") + <*> (v .:? "processingMode") + <*> (v .:? "base") + <*> (v .:? "expandContext") + parseJSON invalid = prependFailure "parsing Coord failed, " (typeMismatch "Object" invalid) + +data W3CExpansionTest = W3CExpansionTest + { w3cExpansionTestName :: Text + , w3cExpansionTestInput :: Text + , w3cExpansionTestExpect :: Maybe Text + , w3cExpansionTestExpectErrorCode :: Maybe Text + , w3cExpansionTestOption :: Maybe W3CExpansionTestOption + } + deriving (Show) + +instance FromJSON W3CExpansionTest where + parseJSON (Object v) = + W3CExpansionTest + <$> (v .: "name") + <*> (v .: "input") + <*> (v .:? "expect") + <*> (v .:? "expectErrorCode") + <*> (v .:? "option") + parseJSON invalid = prependFailure "parsing Coord failed, " (typeMismatch "Object" invalid) + +newtype W3CExpansionTestList = W3CExpansionTestList + { w3cExpansionSequence :: [W3CExpansionTest] + } + deriving (Show) + +instance FromJSON W3CExpansionTestList where + parseJSON (Object v) = W3CExpansionTestList <$> (v .: "sequence") + parseJSON invalid = prependFailure "parsing Coord failed, " (typeMismatch "Object" invalid) + +documentLoader :: MonadIO m => DocumentLoader Text m +documentLoader = DocumentLoader \uri -> + runReq defaultHttpConfig <| case useURI uri of + Just (Left (httpUri, options)) -> Right <. responseBody <$> req GET httpUri NoReqBody jsonResponse (options <> header "Accept" mimeType) + Just (Right (httpsUri, options)) -> Right <. responseBody <$> req GET httpsUri NoReqBody jsonResponse (options <> header "Accept" mimeType) + Nothing -> pure <| Left "Invalid URI" + +fetchTest :: URI -> IO Value +fetchTest url = do + let (reqUrl, reqOptions) = fromJust <| useHttpsURI url + runReq defaultHttpConfig do + res <- req GET reqUrl NoReqBody jsonResponse (reqOptions <> header "Accept" mimeType) + pure <| responseBody res + +parseOptions :: URI -> URI -> Maybe W3CExpansionTestOption -> IO (URI, JLDExpandParams () IO -> JLDExpandParams Text IO) +parseOptions baseUrl inputUrl maybeOptions = do + expandContext <- case maybeOptions >>= w3cExpansionTestOptionExpandContext of + Just rawUrl -> do + url <- fromJust <. (`relativeTo` baseUrl) <$> mkURI rawUrl + Just <$> fetchTest url + Nothing -> pure Nothing + + let params p = + p + { jldExpandParamsEnv = env' + , jldExpandParamsExpandContext = expandContext <|> jldExpandParamsExpandContext p + } + + pure (expandBaseUrl, params) + where + expandBaseUrl = fromMaybe inputUrl (parseUri =<< w3cExpansionTestOptionBase =<< maybeOptions) + + env = newEnv \e -> e{jldEnvDocumentLoader = documentLoader} + env' = case maybeOptions >>= w3cExpansionTestOptionProcessingMode of + Just "json-ld-1.0" -> env{jldEnvProcessingMode = JLD1_0} + Just "json-ld-1.1" -> env{jldEnvProcessingMode = JLD1_1} + _ -> env + +expansionTests :: W3CExpansionTestList -> TestTree +expansionTests testList = testGroup "Expansion" <| uncurry expansionTest <$> (take 999 <. drop 0 <| zip (w3cExpansionSequence testList) [1 ..]) + +expansionTest :: W3CExpansionTest -> Int -> TestTree +expansionTest W3CExpansionTest{..} (show .> (<> ". " <> toString w3cExpansionTestName) -> testName) + | Just "json-ld-1.0" <- w3cExpansionTestOptionSpecVersion =<< w3cExpansionTestOption = + ignoreTestBecause "specVersion json-ld-1.0 is not supported" + <| testCase testName do pure () + -- + | Just expectUrlRaw <- w3cExpansionTestExpect = + testCase testName do + baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/" + inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cExpansionTestInput + expectUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI expectUrlRaw + + inputJld <- fetchTest inputUrl + expectJld <- fetchTest expectUrl + + (expandBaseUrl, params) <- parseOptions baseUrl inputUrl w3cExpansionTestOption + (result, _) <- expand inputJld expandBaseUrl params + + -- pTraceShowM (expectJLD, result) + + result @?= Right expectJld + -- + | Just expectErrorRaw <- w3cExpansionTestExpectErrorCode = + testCase testName do + baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/" + inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cExpansionTestInput + + inputJld <- fetchTest inputUrl + + (expandBaseUrl, params) <- parseOptions baseUrl inputUrl w3cExpansionTestOption + (result, _) <- expand inputJld expandBaseUrl params + + (result |> first toJldErrorCode) @?= Left expectErrorRaw + -- + | otherwise = + testCase testName do + assertFailure <| "Unhandled test type" -- cgit v1.2.3-54-g00ecf