From 11d0fb47c292a0ca25a9c377499d2b221d97a5cb Mon Sep 17 00:00:00 2001 From: Volpeon Date: Fri, 26 May 2023 07:40:13 +0200 Subject: Init --- src/Data/JLD/Expansion.hs | 942 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 942 insertions(+) create mode 100644 src/Data/JLD/Expansion.hs (limited to 'src/Data/JLD/Expansion.hs') 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 + } -- cgit v1.3.1