From 838ed8229ed13959d9235b5eafae959e8b8421c4 Mon Sep 17 00:00:00 2001 From: Volpeon Date: Sat, 27 May 2023 20:36:26 +0200 Subject: Added Node Map Generation algorithm --- jsonld.cabal | 3 +- src/Data/JLD.hs | 1 + src/Data/JLD/Error.hs | 2 + src/Data/JLD/Expansion.hs | 5 +- src/Data/JLD/Expansion/Context.hs | 27 ++-- src/Data/JLD/Flattening/NodeMap.hs | 302 +++++++++++++++++++++++++++++++++++++ src/Data/JLD/Model/NodeMap.hs | 45 ++++++ src/Data/JLD/NodeMap.hs | 88 ----------- src/Data/JLD/Util.hs | 19 +-- 9 files changed, 375 insertions(+), 117 deletions(-) create mode 100644 src/Data/JLD/Flattening/NodeMap.hs create mode 100644 src/Data/JLD/Model/NodeMap.hs delete mode 100644 src/Data/JLD/NodeMap.hs diff --git a/jsonld.cabal b/jsonld.cabal index 1308318..9c9650c 100644 --- a/jsonld.cabal +++ b/jsonld.cabal @@ -29,6 +29,7 @@ library Data.JLD.Expansion Data.JLD.Expansion.Context Data.JLD.Expansion.Global + Data.JLD.Flattening.NodeMap Data.JLD.Mime Data.JLD.Model.ActiveContext Data.JLD.Model.Direction @@ -38,11 +39,11 @@ library Data.JLD.Model.Keyword Data.JLD.Model.Language Data.JLD.Model.ListObject + Data.JLD.Model.NodeMap Data.JLD.Model.NodeObject Data.JLD.Model.TermDefinition Data.JLD.Model.URI Data.JLD.Model.ValueObject - Data.JLD.NodeMap Data.JLD.Options Data.JLD.Prelude Data.JLD.Util diff --git a/src/Data/JLD.hs b/src/Data/JLD.hs index 1f894bb..c5c28eb 100644 --- a/src/Data/JLD.hs +++ b/src/Data/JLD.hs @@ -3,6 +3,7 @@ module Data.JLD ( module Data.JLD.Error, module Data.JLD.Options, JLDExpansionParams (..), + JLDExpansionState (..), expand, ) where diff --git a/src/Data/JLD/Error.hs b/src/Data/JLD/Error.hs index 91c2a0b..fe59df0 100644 --- a/src/Data/JLD/Error.hs +++ b/src/Data/JLD/Error.hs @@ -41,6 +41,7 @@ data JLDError e | InvalidTypedValue | InvalidSetOrListObject | InvalidScopedContext + | ConflictingIndexes deriving (Eq, Show) toJldErrorCode :: JLDError e -> Text @@ -79,3 +80,4 @@ toJldErrorCode InvalidLanguageTaggedValue = "invalid language-tagged value" toJldErrorCode InvalidTypedValue = "invalid typed value" toJldErrorCode InvalidSetOrListObject = "invalid set or list object" toJldErrorCode InvalidScopedContext = "invalid scoped context" +toJldErrorCode ConflictingIndexes = "conflicting indexes" diff --git a/src/Data/JLD/Expansion.hs b/src/Data/JLD/Expansion.hs index ff2d9c3..79a992d 100644 --- a/src/Data/JLD/Expansion.hs +++ b/src/Data/JLD/Expansion.hs @@ -24,7 +24,6 @@ import Data.JLD.Util ( valueContains, valueIsEmptyArray, valueIsNotArray, - valueIsNotNull, valueIsNotString, valueIsScalar, valueIsString, @@ -760,7 +759,7 @@ expandObject maybePropertyContext value = do -- 16. | Just resultType <- KM.lookup (show KeywordType) result -> eoNormalizeObject - <| if valueIsNotArray resultType && valueIsNotNull resultType + <| if valueIsNotArray resultType && resultType /= Null then KM.insert (show KeywordType) (Array <| V.singleton resultType) result else result -- 17. @@ -797,7 +796,7 @@ expandArrayItem item = do case item'' of -- 5.2.3. - Array a -> pure <| V.filter valueIsNotNull a + Array a -> pure <| V.filter (/= Null) a Null -> pure mempty _ -> pure <| V.singleton item'' diff --git a/src/Data/JLD/Expansion/Context.hs b/src/Data/JLD/Expansion/Context.hs index ce61644..99daba0 100644 --- a/src/Data/JLD/Expansion/Context.hs +++ b/src/Data/JLD/Expansion/Context.hs @@ -13,7 +13,7 @@ import Data.JLD.Model.Language (Language (..)) import Data.JLD.Model.TermDefinition (TermDefinition (..), newTermDefinition) import Data.JLD.Model.URI (parseUri, uriToIri) import Data.JLD.Options (ContextCache, Document (..), DocumentCache, DocumentLoader (..), JLDVersion (..)) -import Data.JLD.Util (flattenSingletonArray, valueContains, valueContainsAny, valueIsTrue, valueToArray) +import Data.JLD.Util (flattenSingletonArray, valueContains, valueContainsAny, valueToArray) import Control.Monad.Except (MonadError (..)) import Data.Aeson (Object, Value (..)) @@ -73,7 +73,7 @@ bacBuildTermDefinition contextDefinition baseUrl term = do p { btdParamsBaseUrl = baseUrl , btdParamsOverrideProtectedFlag = bacEnvOverrideProtected - , btdParamsProtectedFlag = contextDefinition |> KM.lookup (show KeywordProtected) .> maybe False valueIsTrue + , btdParamsProtectedFlag = contextDefinition |> KM.lookup (show KeywordProtected) .> maybe False (== Bool True) , btdParamsRemoteContexts = remoteContexts } (activeContext', _) <- @@ -246,20 +246,19 @@ bacProcessItem baseUrl item = do Nothing -> pure () -- 5.13. + let filteredKeywords = + [ KeywordBase + , KeywordDirection + , KeywordImport + , KeywordLanguage + , KeywordPropagate + , KeywordProtected + , KeywordVersion + , KeywordVocab + ] KM.keys contextDefinition' |> fmap K.toText - .> filter - ( `isNotKeyword` - [ KeywordBase - , KeywordDirection - , KeywordImport - , KeywordLanguage - , KeywordPropagate - , KeywordProtected - , KeywordVersion - , KeywordVocab - ] - ) + .> filter (`isNotKeyword` filteredKeywords) .> mapM_ (bacBuildTermDefinition contextDefinition' baseUrl) -- 5.3. _ -> throwError <| Left InvalidLocalContext diff --git a/src/Data/JLD/Flattening/NodeMap.hs b/src/Data/JLD/Flattening/NodeMap.hs new file mode 100644 index 0000000..3747402 --- /dev/null +++ b/src/Data/JLD/Flattening/NodeMap.hs @@ -0,0 +1,302 @@ +module Data.JLD.Flattening.NodeMap (NodeMap, BNMParams (..), buildNodeMap) where + +import Data.JLD.Prelude + +import Data.JLD.Control.Monad.RES (REST, execREST, withErrorRES') +import Data.JLD.Error (JLDError (..)) +import Data.JLD.Model.IRI (isBlankIri) +import Data.JLD.Model.Keyword (Keyword (..), isNotKeyword) +import Data.JLD.Model.NodeMap (NodeMap) +import Data.JLD.Model.NodeMap qualified as N (hasKey2, hasKey3, insert, lookup3, memberArray, modifyArray) +import Data.JLD.Model.NodeObject (isNodeObject) +import Data.JLD.Util (valueIsScalar, valueToArray, valueToNonNullArray) + +import Control.Monad.Except (MonadError (..)) +import Data.Aeson (Array, Object, Value (..)) +import Data.Aeson.Key qualified as K (toText) +import Data.Aeson.KeyMap qualified as KM (filterWithKey, insert, lookup, member, singleton) +import Data.Foldable.WithIndex (iforM_) +import Data.Map.Strict qualified as M (insert, lookup) +import Data.Vector qualified as V (singleton, snoc, uniq) + +type BNMT e m = REST BNMEnv (Either (JLDError e) ()) BNMState m + +data BNMEnv = BNMEnv + { bnmEnvActiveGraph :: Text + , bnmEnvActiveSubject :: Maybe Text + , bnmEnvActiveProperty :: Maybe Text + , bnmEnvReferenceNode :: Maybe Object + } + deriving (Show) + +data BNMState = BNMState + { bnmStateNodeMap :: NodeMap + , bnmStateList :: Maybe Array + , bnmStateIdentifierCounter :: Int + , bnmStateIdentifierMap :: Map Text Text + } + deriving (Show, Eq) + +data BNMParams = BNMParams + { bnmParamsNodeMap :: NodeMap + , bnmParamsActiveGraph :: Text + , bnmParamsActiveSubject :: Maybe Text + , bnmParamsActiveProperty :: Maybe Text + , bnmParamsList :: Maybe Array + , bnmParamsReferenceNode :: Maybe Object + } + deriving (Show, Eq) + +listToObject :: Maybe Array -> Value +listToObject = Object <. KM.singleton (show KeywordList) <. Array <. fromMaybe mempty + +bnmModifyNodeMap :: Monad m => (NodeMap -> NodeMap) -> BNMT e m () +bnmModifyNodeMap fn = modify \s -> s{bnmStateNodeMap = fn (bnmStateNodeMap s)} + +bnmModifyList :: Monad m => (Maybe Array -> Maybe Array) -> BNMT e m () +bnmModifyList fn = modify \s -> s{bnmStateList = fn (bnmStateList s)} + +bnmModifyIdentifierCounter :: Monad m => (Int -> Int) -> BNMT e m () +bnmModifyIdentifierCounter fn = modify \s -> s{bnmStateIdentifierCounter = fn (bnmStateIdentifierCounter s)} + +bnmModifyIdentifierMap :: Monad m => (Map Text Text -> Map Text Text) -> BNMT e m () +bnmModifyIdentifierMap fn = modify \s -> s{bnmStateIdentifierMap = fn (bnmStateIdentifierMap s)} + +bnmCreateIdentifier :: Monad m => Maybe Text -> BNMT e m Text +bnmCreateIdentifier Nothing = do + n <- gets bnmStateIdentifierCounter + "_:b" <> show n <$ bnmModifyIdentifierCounter (const <| n + 1) +bnmCreateIdentifier (Just identifier) = + gets (bnmStateIdentifierMap .> M.lookup identifier) >>= \case + Just nodeId -> pure nodeId + Nothing -> do + nodeId <- bnmCreateIdentifier Nothing + nodeId <$ bnmModifyIdentifierMap (M.insert identifier nodeId) + +bnmBuildNodeMap :: Monad m => Value -> (BNMParams -> BNMParams) -> BNMT e m (Maybe Array) +bnmBuildNodeMap value paramsFn = do + BNMEnv{..} <- ask + nodeMap <- gets bnmStateNodeMap + let params p = + paramsFn + p + { bnmParamsNodeMap = nodeMap + , bnmParamsActiveGraph = bnmEnvActiveGraph + , bnmParamsActiveSubject = bnmEnvActiveSubject + , bnmParamsActiveProperty = bnmEnvActiveProperty + } + (nodeMap', list) <- buildNodeMap value params + bnmModifyNodeMap <| const nodeMap' + pure list + +buildNodeMap' :: Monad m => Value -> BNMT e m () +buildNodeMap' element = case element of + -- 1. + Array elementArray -> forM_ elementArray (buildNodeMap' .> withErrorRES' (either (Left .> throwError) pure)) + -- 2. + Object elementObject -> do + BNMEnv{..} <- ask + + -- 3. + elementObject' <- case KM.lookup (show KeywordType) elementObject of + Just type' -> do + types <- + Array <$> forM (valueToArray type') \case + String item | isBlankIri item -> String <$> bnmCreateIdentifier (Just item) + item -> pure item + pure <| KM.insert (show KeywordType) types elementObject + -- + Nothing -> pure elementObject + + if + -- 4. + | KM.member (show KeywordValue) elementObject' -> + gets bnmStateList >>= \case + -- 4.1. + Nothing -> + gets (bnmStateNodeMap .> N.lookup3 bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty) >>= \case + -- 4.1.1. + Just (Array activePropertyValue) + | notElem element activePropertyValue -> + bnmModifyNodeMap + <. N.insert bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty + <. Array + <| V.snoc activePropertyValue element + | otherwise -> pure () + -- 4.2.2 + _ -> + bnmModifyNodeMap + <. N.insert bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty + <. Array + <| V.singleton element + -- 4.2. + Just list -> bnmModifyList <. const <. Just <| V.snoc list element + -- 5. + | Just elemList <- KM.lookup (show KeywordList) elementObject' -> do + -- 5.1. 5.2. + subList <- listToObject <$> bnmBuildNodeMap elemList id + + gets bnmStateList >>= \case + -- 5.3. + Nothing -> + bnmModifyNodeMap + <. N.modifyArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty + <| flip V.snoc subList + -- 5.4. + Just stateList -> bnmModifyList <. const <. Just <| V.snoc stateList subList + -- 6. + | isNodeObject (Object elementObject') -> do + id' <- case KM.lookup (show KeywordId) elementObject' of + -- 6.1. + Just (String idValue) | isBlankIri idValue -> bnmCreateIdentifier <| Just idValue + Just _ -> throwError <| Right () + -- 6.2. + Nothing -> bnmCreateIdentifier Nothing + + -- 6.3. + nodeMap <- gets bnmStateNodeMap + when (N.hasKey2 bnmEnvActiveGraph (Just id') nodeMap) do + bnmModifyNodeMap <| N.insert bnmEnvActiveGraph (Just id') (Just <| show KeywordId) (String id') + + nodeMap' <- gets bnmStateNodeMap + if + -- 6.5. + | Just referenceNode <- bnmEnvReferenceNode -> + unless (N.memberArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty (Object referenceNode) nodeMap') do + bnmModifyNodeMap + <. N.modifyArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty + <| flip V.snoc (Object referenceNode) + -- 6.6. + | isJust bnmEnvActiveProperty -> do + -- 6.6.1. + let reference = Object <| KM.singleton (show KeywordId) (String id') + + gets bnmStateList >>= \case + -- 6.6.2. + Nothing -> + unless (N.memberArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty reference nodeMap') do + bnmModifyNodeMap + <. N.modifyArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty + <| flip V.snoc reference + -- 6.6.3. + Just stateList -> bnmModifyList <. const <. Just <| V.snoc stateList reference + -- + | otherwise -> pure () + + -- 6.7. + case KM.lookup (show KeywordType) elementObject' of + Just typeValue -> do + nodeType <- + Array + <. V.uniq + <. (<> valueToNonNullArray typeValue) + <. fromMaybe mempty + <. fmap valueToNonNullArray + <$> gets (bnmStateNodeMap .> N.lookup3 bnmEnvActiveGraph (Just id') (Just <| show KeywordType)) + bnmModifyNodeMap <| N.insert bnmEnvActiveGraph (Just id') (Just <| show KeywordType) nodeType + -- + Nothing -> pure () + + -- 6.8. + nodeMap'' <- gets bnmStateNodeMap + case KM.lookup (show KeywordIndex) elementObject' of + Just indexValue + | N.hasKey3 bnmEnvActiveGraph (Just id') (Just <| show KeywordIndex) nodeMap'' -> throwError <| Left ConflictingIndexes + | otherwise -> bnmModifyNodeMap <| N.insert bnmEnvActiveGraph (Just id') (Just <| show KeywordType) indexValue + -- + Nothing -> pure () + + -- 6.9. + case KM.lookup (show KeywordReverse) elementObject' of + Just (Object reverseMap) -> do + -- 6.9.1. + let referenced = KM.singleton (show KeywordId) (String id') + + -- 6.9.3. + iforM_ reverseMap \key -> + valueToArray .> mapM_ \value -> do + void <| bnmBuildNodeMap value \params -> + params + { bnmParamsReferenceNode = Just referenced + , bnmParamsActiveProperty = Just <| K.toText key + } + pure () + -- + _ -> pure () + + -- 6.10. + case KM.lookup (show KeywordGraph) elementObject' of + Just graphValue -> + void <| bnmBuildNodeMap graphValue \params -> params{bnmParamsActiveGraph = id'} + -- + _ -> pure () + + -- 6.11. + case KM.lookup (show KeywordIncluded) elementObject' of + Just includedValue -> + void <| bnmBuildNodeMap includedValue id + -- + _ -> pure () + + let filteredKeywords = [KeywordId, KeywordType, KeywordIndex, KeywordReverse, KeywordGraph, KeywordIncluded] + elementObject'' = KM.filterWithKey (\key _ -> isNotKeyword (K.toText key) filteredKeywords) elementObject' + + -- 6.12. + iforM_ elementObject'' \(K.toText -> property) value -> + if value == Null || valueIsScalar value + then pure () + else do + -- 6.12.1. + property' <- + if isBlankIri property + then bnmCreateIdentifier <| Just property + else pure property + + -- 6.12.2. + gets (bnmStateNodeMap .> N.hasKey3 bnmEnvActiveGraph (Just id') (Just property')) >>= \case + True -> pure () + False -> bnmModifyNodeMap <| N.insert bnmEnvActiveGraph (Just id') (Just property') (Array mempty) + + void <| bnmBuildNodeMap value \params -> + params + { bnmParamsActiveSubject = Just id' + , bnmParamsActiveProperty = Just property + } + + -- + | otherwise -> pure () + pure () + -- + _ -> pure () + +buildNodeMap :: Monad m => Value -> (BNMParams -> BNMParams) -> m (NodeMap, Maybe Array) +buildNodeMap document paramsFn = do + BNMState{..} <- buildNodeMap' document |> execREST env st + pure (bnmStateNodeMap, bnmStateList) + where + BNMParams{..} = + paramsFn + BNMParams + { bnmParamsNodeMap = mempty + , bnmParamsActiveGraph = show KeywordDefault + , bnmParamsActiveSubject = Nothing + , bnmParamsActiveProperty = Nothing + , bnmParamsList = mempty + , bnmParamsReferenceNode = Nothing + } + + env = + BNMEnv + { bnmEnvActiveGraph = bnmParamsActiveGraph + , bnmEnvActiveSubject = bnmParamsActiveSubject + , bnmEnvActiveProperty = bnmParamsActiveProperty + , bnmEnvReferenceNode = bnmParamsReferenceNode + } + + st = + BNMState + { bnmStateNodeMap = bnmParamsNodeMap + , bnmStateList = bnmParamsList + , bnmStateIdentifierCounter = 1 + , bnmStateIdentifierMap = mempty + } diff --git a/src/Data/JLD/Model/NodeMap.hs b/src/Data/JLD/Model/NodeMap.hs new file mode 100644 index 0000000..48db17e --- /dev/null +++ b/src/Data/JLD/Model/NodeMap.hs @@ -0,0 +1,45 @@ +module Data.JLD.Model.NodeMap (NodeMap, lookup, lookup2, lookup3, insert, modifyArray, hasKey2, hasKey3, memberArray) where + +import Data.JLD.Prelude hiding (modify) + +import Data.Aeson (Array, Value (..)) +import Data.JLD.Util (valueToArray) +import Data.Map.Strict qualified as M (alter, insert, lookup, member) + +type PropertyKey = Maybe Text +type PropertyMap = Map PropertyKey Value + +type SubjectKey = Maybe Text +type SubjectMap = Map SubjectKey PropertyMap + +type GraphKey = Text +type NodeMap = Map GraphKey SubjectMap + +lookup :: GraphKey -> NodeMap -> Maybe SubjectMap +lookup = M.lookup + +lookup2 :: GraphKey -> SubjectKey -> NodeMap -> Maybe PropertyMap +lookup2 graphName subject nodeMap = M.lookup graphName nodeMap >>= M.lookup subject + +lookup3 :: GraphKey -> SubjectKey -> PropertyKey -> NodeMap -> Maybe Value +lookup3 graphName subject property nodeMap = + M.lookup graphName nodeMap >>= M.lookup subject >>= M.lookup property + +modifyArray :: GraphKey -> SubjectKey -> PropertyKey -> (Array -> Array) -> NodeMap -> NodeMap +modifyArray graphName subject property fn = + M.alter (Just <. M.alter (Just <. M.alter (Just <. Array <. fn <. maybe mempty valueToArray) property <. fromMaybe mempty) subject <. fromMaybe mempty) graphName + +insert :: GraphKey -> SubjectKey -> PropertyKey -> Value -> NodeMap -> NodeMap +insert graphName subject property value = + M.alter (Just <. M.alter (Just <. M.insert property value <. fromMaybe mempty) subject <. fromMaybe mempty) graphName + +hasKey2 :: GraphKey -> SubjectKey -> NodeMap -> Bool +hasKey2 graphName subject nodeMap = maybe False (M.member subject) <| M.lookup graphName nodeMap + +hasKey3 :: GraphKey -> SubjectKey -> PropertyKey -> NodeMap -> Bool +hasKey3 graphName subject property nodeMap = maybe False (M.member property) <| M.lookup subject =<< M.lookup graphName nodeMap + +memberArray :: GraphKey -> SubjectKey -> PropertyKey -> Value -> NodeMap -> Bool +memberArray graphName subject property value nodeMap = case lookup3 graphName subject property nodeMap of + Just (Array a) -> value `elem` a + _ -> False diff --git a/src/Data/JLD/NodeMap.hs b/src/Data/JLD/NodeMap.hs deleted file mode 100644 index 0c40c9a..0000000 --- a/src/Data/JLD/NodeMap.hs +++ /dev/null @@ -1,88 +0,0 @@ -module Data.JLD.NodeMap (NodeMap, BNMParams (..)) where - -import Data.JLD.Prelude - -import Data.JLD.Control.Monad.RES (REST, execREST, runREST, withEnvRES, withErrorRES, withErrorRES', withStateRES) -import Data.JLD.Error (JLDError (..)) -import Data.JLD.Model.ActiveContext (ActiveContext (..), containsProtectedTerm, lookupTerm, newActiveContext) -import Data.JLD.Model.Direction (Direction (..)) -import Data.JLD.Model.IRI (CompactIRI (..), endsWithGenericDelim, isBlankIri, parseCompactIri) -import Data.JLD.Model.Keyword (Keyword (..), allKeywords, isKeyword, isKeywordLike, isNotKeyword, parseKeyword) -import Data.JLD.Model.Language (Language (..)) -import Data.JLD.Model.TermDefinition (TermDefinition (..), newTermDefinition) -import Data.JLD.Model.URI (parseUri, uriToIri) -import Data.JLD.Options (ContextCache, Document (..), DocumentCache, DocumentLoader (..), JLDVersion (..)) -import Data.JLD.Util (flattenSingletonArray, valueContains, valueContainsAny, valueIsTrue, valueToArray) - -import Control.Monad.Except (MonadError (..)) -import Data.Aeson (Object, Value (..)) -import Data.Aeson.Key qualified as K (fromText, toText) -import Data.Aeson.KeyMap qualified as KM (delete, keys, lookup, member, size) -import Data.Map.Strict qualified as M (delete, insert, lookup) -import Data.RDF (parseIRI, parseRelIRI, resolveIRI, serializeIRI, validateIRI) -import Data.Set qualified as S (insert, member, notMember, size) -import Data.Text qualified as T (drop, dropEnd, elem, findIndex, isPrefixOf, null, take, toLower) -import Data.Vector qualified as V (length) -import Text.URI (URI, isPathAbsolute, relativeTo) -import Text.URI qualified as U (render) - -type NodeMap = Map (Text, Text, Text) Value - -type BNMT e m = REST BNMEnv (JLDError e) BNMState m - -data BNMEnv = BNMEnv - { bnmEnvDocument :: Value - , bnmEnvActiveGraph :: Text - , bnmEnvActiveSubject :: Maybe Text - , bnmEnvActiveProperty :: Maybe Text - } - deriving (Show) - -newtype BNMState = BNMState - { bnmStateNodeMap :: NodeMap - } - deriving (Show, Eq) - -data BNMParams = BNMParams - { bnmParamsNodeMap :: NodeMap - , bnmParamsActiveGraph :: Text - , bnmParamsActiveSubject :: Maybe Text - , bnmParamsActiveProperty :: Maybe Text - , bnmParamsList :: Map Text Value - } - deriving (Show, Eq) - -bnmModifyNodeMap :: Monad m => (NodeMap -> NodeMap) -> BNMT e m () -bnmModifyNodeMap fn = modify \s -> s{bnmStateNodeMap = fn (bnmStateNodeMap s)} - -buildNodeMap' :: Monad m => BNMT e m () -buildNodeMap' = do - pure () - -buildNodeMap :: Monad m => Value -> (BNMParams -> BNMParams) -> m NodeMap -buildNodeMap document paramsFn = do - BNMState{..} <- buildNodeMap' |> execREST env st - pure bnmStateNodeMap - where - BNMParams{..} = - paramsFn - BNMParams - { bnmParamsNodeMap = mempty - , bnmParamsActiveGraph = show KeywordDefault - , bnmParamsActiveSubject = Nothing - , bnmParamsActiveProperty = Nothing - , bnmParamsList = mempty - } - - env = - BNMEnv - { bnmEnvDocument = document - , bnmEnvActiveGraph = bnmParamsActiveGraph - , bnmEnvActiveSubject = bnmParamsActiveSubject - , bnmEnvActiveProperty = bnmParamsActiveProperty - } - - st = - BNMState - { bnmStateNodeMap = bnmParamsNodeMap - } diff --git a/src/Data/JLD/Util.hs b/src/Data/JLD/Util.hs index 82cbdee..26b2755 100644 --- a/src/Data/JLD/Util.hs +++ b/src/Data/JLD/Util.hs @@ -1,7 +1,6 @@ module Data.JLD.Util ( valueContains, valueContainsAny, - valueIsTrue, valueIsString, valueIsArray, valueIsNotArray, @@ -9,9 +8,9 @@ module Data.JLD.Util ( valueIsScalar, valueToString, valueIsNotString, - valueIsNotNull, flattenSingletonArray, valueToArray, + valueToNonNullArray, allStrings, ifindM, getMapDefault, @@ -26,7 +25,7 @@ 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) +import Data.Vector qualified as V (filter, fromList, null, singleton, snoc, uncons) valueContains :: Text -> Value -> Bool valueContains text = \case @@ -42,10 +41,6 @@ valueContainsAny texts = \case 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 @@ -75,10 +70,6 @@ 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 @@ -89,6 +80,12 @@ valueToArray = \case Array a -> a value -> V.singleton value +valueToNonNullArray :: Value -> Array +valueToNonNullArray = \case + Null -> mempty + Array a -> V.filter (/= Null) a + value -> V.singleton value + allStrings :: Array -> Maybe (Vector Text) allStrings = foldl' go (Just mempty) where -- cgit v1.2.3-70-g09d2