diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Data/JLD.hs | 1 | ||||
| -rw-r--r-- | src/Data/JLD/Error.hs | 2 | ||||
| -rw-r--r-- | src/Data/JLD/Expansion.hs | 5 | ||||
| -rw-r--r-- | src/Data/JLD/Expansion/Context.hs | 27 | ||||
| -rw-r--r-- | src/Data/JLD/Flattening/NodeMap.hs | 302 | ||||
| -rw-r--r-- | src/Data/JLD/Model/NodeMap.hs | 45 | ||||
| -rw-r--r-- | src/Data/JLD/NodeMap.hs | 88 | ||||
| -rw-r--r-- | src/Data/JLD/Util.hs | 19 |
8 files changed, 373 insertions, 116 deletions
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 ( | |||
| 3 | module Data.JLD.Error, | 3 | module Data.JLD.Error, |
| 4 | module Data.JLD.Options, | 4 | module Data.JLD.Options, |
| 5 | JLDExpansionParams (..), | 5 | JLDExpansionParams (..), |
| 6 | JLDExpansionState (..), | ||
| 6 | expand, | 7 | expand, |
| 7 | ) where | 8 | ) where |
| 8 | 9 | ||
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 | |||
| 41 | | InvalidTypedValue | 41 | | InvalidTypedValue |
| 42 | | InvalidSetOrListObject | 42 | | InvalidSetOrListObject |
| 43 | | InvalidScopedContext | 43 | | InvalidScopedContext |
| 44 | | ConflictingIndexes | ||
| 44 | deriving (Eq, Show) | 45 | deriving (Eq, Show) |
| 45 | 46 | ||
| 46 | toJldErrorCode :: JLDError e -> Text | 47 | toJldErrorCode :: JLDError e -> Text |
| @@ -79,3 +80,4 @@ toJldErrorCode InvalidLanguageTaggedValue = "invalid language-tagged value" | |||
| 79 | toJldErrorCode InvalidTypedValue = "invalid typed value" | 80 | toJldErrorCode InvalidTypedValue = "invalid typed value" |
| 80 | toJldErrorCode InvalidSetOrListObject = "invalid set or list object" | 81 | toJldErrorCode InvalidSetOrListObject = "invalid set or list object" |
| 81 | toJldErrorCode InvalidScopedContext = "invalid scoped context" | 82 | toJldErrorCode InvalidScopedContext = "invalid scoped context" |
| 83 | 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 ( | |||
| 24 | valueContains, | 24 | valueContains, |
| 25 | valueIsEmptyArray, | 25 | valueIsEmptyArray, |
| 26 | valueIsNotArray, | 26 | valueIsNotArray, |
| 27 | valueIsNotNull, | ||
| 28 | valueIsNotString, | 27 | valueIsNotString, |
| 29 | valueIsScalar, | 28 | valueIsScalar, |
| 30 | valueIsString, | 29 | valueIsString, |
| @@ -760,7 +759,7 @@ expandObject maybePropertyContext value = do | |||
| 760 | -- 16. | 759 | -- 16. |
| 761 | | Just resultType <- KM.lookup (show KeywordType) result -> | 760 | | Just resultType <- KM.lookup (show KeywordType) result -> |
| 762 | eoNormalizeObject | 761 | eoNormalizeObject |
| 763 | <| if valueIsNotArray resultType && valueIsNotNull resultType | 762 | <| if valueIsNotArray resultType && resultType /= Null |
| 764 | then KM.insert (show KeywordType) (Array <| V.singleton resultType) result | 763 | then KM.insert (show KeywordType) (Array <| V.singleton resultType) result |
| 765 | else result | 764 | else result |
| 766 | -- 17. | 765 | -- 17. |
| @@ -797,7 +796,7 @@ expandArrayItem item = do | |||
| 797 | 796 | ||
| 798 | case item'' of | 797 | case item'' of |
| 799 | -- 5.2.3. | 798 | -- 5.2.3. |
| 800 | Array a -> pure <| V.filter valueIsNotNull a | 799 | Array a -> pure <| V.filter (/= Null) a |
| 801 | Null -> pure mempty | 800 | Null -> pure mempty |
| 802 | _ -> pure <| V.singleton item'' | 801 | _ -> pure <| V.singleton item'' |
| 803 | 802 | ||
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 (..)) | |||
| 13 | import Data.JLD.Model.TermDefinition (TermDefinition (..), newTermDefinition) | 13 | import Data.JLD.Model.TermDefinition (TermDefinition (..), newTermDefinition) |
| 14 | import Data.JLD.Model.URI (parseUri, uriToIri) | 14 | import Data.JLD.Model.URI (parseUri, uriToIri) |
| 15 | import Data.JLD.Options (ContextCache, Document (..), DocumentCache, DocumentLoader (..), JLDVersion (..)) | 15 | import Data.JLD.Options (ContextCache, Document (..), DocumentCache, DocumentLoader (..), JLDVersion (..)) |
| 16 | import Data.JLD.Util (flattenSingletonArray, valueContains, valueContainsAny, valueIsTrue, valueToArray) | 16 | import Data.JLD.Util (flattenSingletonArray, valueContains, valueContainsAny, valueToArray) |
| 17 | 17 | ||
| 18 | import Control.Monad.Except (MonadError (..)) | 18 | import Control.Monad.Except (MonadError (..)) |
| 19 | import Data.Aeson (Object, Value (..)) | 19 | import Data.Aeson (Object, Value (..)) |
| @@ -73,7 +73,7 @@ bacBuildTermDefinition contextDefinition baseUrl term = do | |||
| 73 | p | 73 | p |
| 74 | { btdParamsBaseUrl = baseUrl | 74 | { btdParamsBaseUrl = baseUrl |
| 75 | , btdParamsOverrideProtectedFlag = bacEnvOverrideProtected | 75 | , btdParamsOverrideProtectedFlag = bacEnvOverrideProtected |
| 76 | , btdParamsProtectedFlag = contextDefinition |> KM.lookup (show KeywordProtected) .> maybe False valueIsTrue | 76 | , btdParamsProtectedFlag = contextDefinition |> KM.lookup (show KeywordProtected) .> maybe False (== Bool True) |
| 77 | , btdParamsRemoteContexts = remoteContexts | 77 | , btdParamsRemoteContexts = remoteContexts |
| 78 | } | 78 | } |
| 79 | (activeContext', _) <- | 79 | (activeContext', _) <- |
| @@ -246,20 +246,19 @@ bacProcessItem baseUrl item = do | |||
| 246 | Nothing -> pure () | 246 | Nothing -> pure () |
| 247 | 247 | ||
| 248 | -- 5.13. | 248 | -- 5.13. |
| 249 | let filteredKeywords = | ||
| 250 | [ KeywordBase | ||
| 251 | , KeywordDirection | ||
| 252 | , KeywordImport | ||
| 253 | , KeywordLanguage | ||
| 254 | , KeywordPropagate | ||
| 255 | , KeywordProtected | ||
| 256 | , KeywordVersion | ||
| 257 | , KeywordVocab | ||
| 258 | ] | ||
| 249 | KM.keys contextDefinition' | 259 | KM.keys contextDefinition' |
| 250 | |> fmap K.toText | 260 | |> fmap K.toText |
| 251 | .> filter | 261 | .> filter (`isNotKeyword` filteredKeywords) |
| 252 | ( `isNotKeyword` | ||
| 253 | [ KeywordBase | ||
| 254 | , KeywordDirection | ||
| 255 | , KeywordImport | ||
| 256 | , KeywordLanguage | ||
| 257 | , KeywordPropagate | ||
| 258 | , KeywordProtected | ||
| 259 | , KeywordVersion | ||
| 260 | , KeywordVocab | ||
| 261 | ] | ||
| 262 | ) | ||
| 263 | .> mapM_ (bacBuildTermDefinition contextDefinition' baseUrl) | 262 | .> mapM_ (bacBuildTermDefinition contextDefinition' baseUrl) |
| 264 | -- 5.3. | 263 | -- 5.3. |
| 265 | _ -> throwError <| Left InvalidLocalContext | 264 | _ -> 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 @@ | |||
| 1 | module Data.JLD.Flattening.NodeMap (NodeMap, BNMParams (..), buildNodeMap) where | ||
| 2 | |||
| 3 | import Data.JLD.Prelude | ||
| 4 | |||
| 5 | import Data.JLD.Control.Monad.RES (REST, execREST, withErrorRES') | ||
| 6 | import Data.JLD.Error (JLDError (..)) | ||
| 7 | import Data.JLD.Model.IRI (isBlankIri) | ||
| 8 | import Data.JLD.Model.Keyword (Keyword (..), isNotKeyword) | ||
| 9 | import Data.JLD.Model.NodeMap (NodeMap) | ||
| 10 | import Data.JLD.Model.NodeMap qualified as N (hasKey2, hasKey3, insert, lookup3, memberArray, modifyArray) | ||
| 11 | import Data.JLD.Model.NodeObject (isNodeObject) | ||
| 12 | import Data.JLD.Util (valueIsScalar, valueToArray, valueToNonNullArray) | ||
| 13 | |||
| 14 | import Control.Monad.Except (MonadError (..)) | ||
| 15 | import Data.Aeson (Array, Object, Value (..)) | ||
| 16 | import Data.Aeson.Key qualified as K (toText) | ||
| 17 | import Data.Aeson.KeyMap qualified as KM (filterWithKey, insert, lookup, member, singleton) | ||
| 18 | import Data.Foldable.WithIndex (iforM_) | ||
| 19 | import Data.Map.Strict qualified as M (insert, lookup) | ||
| 20 | import Data.Vector qualified as V (singleton, snoc, uniq) | ||
| 21 | |||
| 22 | type BNMT e m = REST BNMEnv (Either (JLDError e) ()) BNMState m | ||
| 23 | |||
| 24 | data BNMEnv = BNMEnv | ||
| 25 | { bnmEnvActiveGraph :: Text | ||
| 26 | , bnmEnvActiveSubject :: Maybe Text | ||
| 27 | , bnmEnvActiveProperty :: Maybe Text | ||
| 28 | , bnmEnvReferenceNode :: Maybe Object | ||
| 29 | } | ||
| 30 | deriving (Show) | ||
| 31 | |||
| 32 | data BNMState = BNMState | ||
| 33 | { bnmStateNodeMap :: NodeMap | ||
| 34 | , bnmStateList :: Maybe Array | ||
| 35 | , bnmStateIdentifierCounter :: Int | ||
| 36 | , bnmStateIdentifierMap :: Map Text Text | ||
| 37 | } | ||
| 38 | deriving (Show, Eq) | ||
| 39 | |||
| 40 | data BNMParams = BNMParams | ||
| 41 | { bnmParamsNodeMap :: NodeMap | ||
| 42 | , bnmParamsActiveGraph :: Text | ||
| 43 | , bnmParamsActiveSubject :: Maybe Text | ||
| 44 | , bnmParamsActiveProperty :: Maybe Text | ||
| 45 | , bnmParamsList :: Maybe Array | ||
| 46 | , bnmParamsReferenceNode :: Maybe Object | ||
| 47 | } | ||
| 48 | deriving (Show, Eq) | ||
| 49 | |||
| 50 | listToObject :: Maybe Array -> Value | ||
| 51 | listToObject = Object <. KM.singleton (show KeywordList) <. Array <. fromMaybe mempty | ||
| 52 | |||
| 53 | bnmModifyNodeMap :: Monad m => (NodeMap -> NodeMap) -> BNMT e m () | ||
| 54 | bnmModifyNodeMap fn = modify \s -> s{bnmStateNodeMap = fn (bnmStateNodeMap s)} | ||
| 55 | |||
| 56 | bnmModifyList :: Monad m => (Maybe Array -> Maybe Array) -> BNMT e m () | ||
| 57 | bnmModifyList fn = modify \s -> s{bnmStateList = fn (bnmStateList s)} | ||
| 58 | |||
| 59 | bnmModifyIdentifierCounter :: Monad m => (Int -> Int) -> BNMT e m () | ||
| 60 | bnmModifyIdentifierCounter fn = modify \s -> s{bnmStateIdentifierCounter = fn (bnmStateIdentifierCounter s)} | ||
| 61 | |||
| 62 | bnmModifyIdentifierMap :: Monad m => (Map Text Text -> Map Text Text) -> BNMT e m () | ||
| 63 | bnmModifyIdentifierMap fn = modify \s -> s{bnmStateIdentifierMap = fn (bnmStateIdentifierMap s)} | ||
| 64 | |||
| 65 | bnmCreateIdentifier :: Monad m => Maybe Text -> BNMT e m Text | ||
| 66 | bnmCreateIdentifier Nothing = do | ||
| 67 | n <- gets bnmStateIdentifierCounter | ||
| 68 | "_:b" <> show n <$ bnmModifyIdentifierCounter (const <| n + 1) | ||
| 69 | bnmCreateIdentifier (Just identifier) = | ||
| 70 | gets (bnmStateIdentifierMap .> M.lookup identifier) >>= \case | ||
| 71 | Just nodeId -> pure nodeId | ||
| 72 | Nothing -> do | ||
| 73 | nodeId <- bnmCreateIdentifier Nothing | ||
| 74 | nodeId <$ bnmModifyIdentifierMap (M.insert identifier nodeId) | ||
| 75 | |||
| 76 | bnmBuildNodeMap :: Monad m => Value -> (BNMParams -> BNMParams) -> BNMT e m (Maybe Array) | ||
| 77 | bnmBuildNodeMap value paramsFn = do | ||
| 78 | BNMEnv{..} <- ask | ||
| 79 | nodeMap <- gets bnmStateNodeMap | ||
| 80 | let params p = | ||
| 81 | paramsFn | ||
| 82 | p | ||
| 83 | { bnmParamsNodeMap = nodeMap | ||
| 84 | , bnmParamsActiveGraph = bnmEnvActiveGraph | ||
| 85 | , bnmParamsActiveSubject = bnmEnvActiveSubject | ||
| 86 | , bnmParamsActiveProperty = bnmEnvActiveProperty | ||
| 87 | } | ||
| 88 | (nodeMap', list) <- buildNodeMap value params | ||
| 89 | bnmModifyNodeMap <| const nodeMap' | ||
| 90 | pure list | ||
| 91 | |||
| 92 | buildNodeMap' :: Monad m => Value -> BNMT e m () | ||
| 93 | buildNodeMap' element = case element of | ||
| 94 | -- 1. | ||
| 95 | Array elementArray -> forM_ elementArray (buildNodeMap' .> withErrorRES' (either (Left .> throwError) pure)) | ||
| 96 | -- 2. | ||
| 97 | Object elementObject -> do | ||
| 98 | BNMEnv{..} <- ask | ||
| 99 | |||
| 100 | -- 3. | ||
| 101 | elementObject' <- case KM.lookup (show KeywordType) elementObject of | ||
| 102 | Just type' -> do | ||
| 103 | types <- | ||
| 104 | Array <$> forM (valueToArray type') \case | ||
| 105 | String item | isBlankIri item -> String <$> bnmCreateIdentifier (Just item) | ||
| 106 | item -> pure item | ||
| 107 | pure <| KM.insert (show KeywordType) types elementObject | ||
| 108 | -- | ||
| 109 | Nothing -> pure elementObject | ||
| 110 | |||
| 111 | if | ||
| 112 | -- 4. | ||
| 113 | | KM.member (show KeywordValue) elementObject' -> | ||
| 114 | gets bnmStateList >>= \case | ||
| 115 | -- 4.1. | ||
| 116 | Nothing -> | ||
| 117 | gets (bnmStateNodeMap .> N.lookup3 bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty) >>= \case | ||
| 118 | -- 4.1.1. | ||
| 119 | Just (Array activePropertyValue) | ||
| 120 | | notElem element activePropertyValue -> | ||
| 121 | bnmModifyNodeMap | ||
| 122 | <. N.insert bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty | ||
| 123 | <. Array | ||
| 124 | <| V.snoc activePropertyValue element | ||
| 125 | | otherwise -> pure () | ||
| 126 | -- 4.2.2 | ||
| 127 | _ -> | ||
| 128 | bnmModifyNodeMap | ||
| 129 | <. N.insert bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty | ||
| 130 | <. Array | ||
| 131 | <| V.singleton element | ||
| 132 | -- 4.2. | ||
| 133 | Just list -> bnmModifyList <. const <. Just <| V.snoc list element | ||
| 134 | -- 5. | ||
| 135 | | Just elemList <- KM.lookup (show KeywordList) elementObject' -> do | ||
| 136 | -- 5.1. 5.2. | ||
| 137 | subList <- listToObject <$> bnmBuildNodeMap elemList id | ||
| 138 | |||
| 139 | gets bnmStateList >>= \case | ||
| 140 | -- 5.3. | ||
| 141 | Nothing -> | ||
| 142 | bnmModifyNodeMap | ||
| 143 | <. N.modifyArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty | ||
| 144 | <| flip V.snoc subList | ||
| 145 | -- 5.4. | ||
| 146 | Just stateList -> bnmModifyList <. const <. Just <| V.snoc stateList subList | ||
| 147 | -- 6. | ||
| 148 | | isNodeObject (Object elementObject') -> do | ||
| 149 | id' <- case KM.lookup (show KeywordId) elementObject' of | ||
| 150 | -- 6.1. | ||
| 151 | Just (String idValue) | isBlankIri idValue -> bnmCreateIdentifier <| Just idValue | ||
| 152 | Just _ -> throwError <| Right () | ||
| 153 | -- 6.2. | ||
| 154 | Nothing -> bnmCreateIdentifier Nothing | ||
| 155 | |||
| 156 | -- 6.3. | ||
| 157 | nodeMap <- gets bnmStateNodeMap | ||
| 158 | when (N.hasKey2 bnmEnvActiveGraph (Just id') nodeMap) do | ||
| 159 | bnmModifyNodeMap <| N.insert bnmEnvActiveGraph (Just id') (Just <| show KeywordId) (String id') | ||
| 160 | |||
| 161 | nodeMap' <- gets bnmStateNodeMap | ||
| 162 | if | ||
| 163 | -- 6.5. | ||
| 164 | | Just referenceNode <- bnmEnvReferenceNode -> | ||
| 165 | unless (N.memberArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty (Object referenceNode) nodeMap') do | ||
| 166 | bnmModifyNodeMap | ||
| 167 | <. N.modifyArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty | ||
| 168 | <| flip V.snoc (Object referenceNode) | ||
| 169 | -- 6.6. | ||
| 170 | | isJust bnmEnvActiveProperty -> do | ||
| 171 | -- 6.6.1. | ||
| 172 | let reference = Object <| KM.singleton (show KeywordId) (String id') | ||
| 173 | |||
| 174 | gets bnmStateList >>= \case | ||
| 175 | -- 6.6.2. | ||
| 176 | Nothing -> | ||
| 177 | unless (N.memberArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty reference nodeMap') do | ||
| 178 | bnmModifyNodeMap | ||
| 179 | <. N.modifyArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty | ||
| 180 | <| flip V.snoc reference | ||
| 181 | -- 6.6.3. | ||
| 182 | Just stateList -> bnmModifyList <. const <. Just <| V.snoc stateList reference | ||
| 183 | -- | ||
| 184 | | otherwise -> pure () | ||
| 185 | |||
| 186 | -- 6.7. | ||
| 187 | case KM.lookup (show KeywordType) elementObject' of | ||
| 188 | Just typeValue -> do | ||
| 189 | nodeType <- | ||
| 190 | Array | ||
| 191 | <. V.uniq | ||
| 192 | <. (<> valueToNonNullArray typeValue) | ||
| 193 | <. fromMaybe mempty | ||
| 194 | <. fmap valueToNonNullArray | ||
| 195 | <$> gets (bnmStateNodeMap .> N.lookup3 bnmEnvActiveGraph (Just id') (Just <| show KeywordType)) | ||
| 196 | bnmModifyNodeMap <| N.insert bnmEnvActiveGraph (Just id') (Just <| show KeywordType) nodeType | ||
| 197 | -- | ||
| 198 | Nothing -> pure () | ||
| 199 | |||
| 200 | -- 6.8. | ||
| 201 | nodeMap'' <- gets bnmStateNodeMap | ||
| 202 | case KM.lookup (show KeywordIndex) elementObject' of | ||
| 203 | Just indexValue | ||
| 204 | | N.hasKey3 bnmEnvActiveGraph (Just id') (Just <| show KeywordIndex) nodeMap'' -> throwError <| Left ConflictingIndexes | ||
| 205 | | otherwise -> bnmModifyNodeMap <| N.insert bnmEnvActiveGraph (Just id') (Just <| show KeywordType) indexValue | ||
| 206 | -- | ||
| 207 | Nothing -> pure () | ||
| 208 | |||
| 209 | -- 6.9. | ||
| 210 | case KM.lookup (show KeywordReverse) elementObject' of | ||
| 211 | Just (Object reverseMap) -> do | ||
| 212 | -- 6.9.1. | ||
| 213 | let referenced = KM.singleton (show KeywordId) (String id') | ||
| 214 | |||
| 215 | -- 6.9.3. | ||
| 216 | iforM_ reverseMap \key -> | ||
| 217 | valueToArray .> mapM_ \value -> do | ||
| 218 | void <| bnmBuildNodeMap value \params -> | ||
| 219 | params | ||
| 220 | { bnmParamsReferenceNode = Just referenced | ||
| 221 | , bnmParamsActiveProperty = Just <| K.toText key | ||
| 222 | } | ||
| 223 | pure () | ||
| 224 | -- | ||
| 225 | _ -> pure () | ||
| 226 | |||
| 227 | -- 6.10. | ||
| 228 | case KM.lookup (show KeywordGraph) elementObject' of | ||
| 229 | Just graphValue -> | ||
| 230 | void <| bnmBuildNodeMap graphValue \params -> params{bnmParamsActiveGraph = id'} | ||
| 231 | -- | ||
| 232 | _ -> pure () | ||
| 233 | |||
| 234 | -- 6.11. | ||
| 235 | case KM.lookup (show KeywordIncluded) elementObject' of | ||
| 236 | Just includedValue -> | ||
| 237 | void <| bnmBuildNodeMap includedValue id | ||
| 238 | -- | ||
| 239 | _ -> pure () | ||
| 240 | |||
| 241 | let filteredKeywords = [KeywordId, KeywordType, KeywordIndex, KeywordReverse, KeywordGraph, KeywordIncluded] | ||
| 242 | elementObject'' = KM.filterWithKey (\key _ -> isNotKeyword (K.toText key) filteredKeywords) elementObject' | ||
| 243 | |||
| 244 | -- 6.12. | ||
| 245 | iforM_ elementObject'' \(K.toText -> property) value -> | ||
| 246 | if value == Null || valueIsScalar value | ||
| 247 | then pure () | ||
| 248 | else do | ||
| 249 | -- 6.12.1. | ||
| 250 | property' <- | ||
| 251 | if isBlankIri property | ||
| 252 | then bnmCreateIdentifier <| Just property | ||
| 253 | else pure property | ||
| 254 | |||
| 255 | -- 6.12.2. | ||
| 256 | gets (bnmStateNodeMap .> N.hasKey3 bnmEnvActiveGraph (Just id') (Just property')) >>= \case | ||
| 257 | True -> pure () | ||
| 258 | False -> bnmModifyNodeMap <| N.insert bnmEnvActiveGraph (Just id') (Just property') (Array mempty) | ||
| 259 | |||
| 260 | void <| bnmBuildNodeMap value \params -> | ||
| 261 | params | ||
| 262 | { bnmParamsActiveSubject = Just id' | ||
| 263 | , bnmParamsActiveProperty = Just property | ||
| 264 | } | ||
| 265 | |||
| 266 | -- | ||
| 267 | | otherwise -> pure () | ||
| 268 | pure () | ||
| 269 | -- | ||
| 270 | _ -> pure () | ||
| 271 | |||
| 272 | buildNodeMap :: Monad m => Value -> (BNMParams -> BNMParams) -> m (NodeMap, Maybe Array) | ||
| 273 | buildNodeMap document paramsFn = do | ||
| 274 | BNMState{..} <- buildNodeMap' document |> execREST env st | ||
| 275 | pure (bnmStateNodeMap, bnmStateList) | ||
| 276 | where | ||
| 277 | BNMParams{..} = | ||
| 278 | paramsFn | ||
| 279 | BNMParams | ||
| 280 | { bnmParamsNodeMap = mempty | ||
| 281 | , bnmParamsActiveGraph = show KeywordDefault | ||
| 282 | , bnmParamsActiveSubject = Nothing | ||
| 283 | , bnmParamsActiveProperty = Nothing | ||
| 284 | , bnmParamsList = mempty | ||
| 285 | , bnmParamsReferenceNode = Nothing | ||
| 286 | } | ||
| 287 | |||
| 288 | env = | ||
| 289 | BNMEnv | ||
| 290 | { bnmEnvActiveGraph = bnmParamsActiveGraph | ||
| 291 | , bnmEnvActiveSubject = bnmParamsActiveSubject | ||
| 292 | , bnmEnvActiveProperty = bnmParamsActiveProperty | ||
| 293 | , bnmEnvReferenceNode = bnmParamsReferenceNode | ||
| 294 | } | ||
| 295 | |||
| 296 | st = | ||
| 297 | BNMState | ||
| 298 | { bnmStateNodeMap = bnmParamsNodeMap | ||
| 299 | , bnmStateList = bnmParamsList | ||
| 300 | , bnmStateIdentifierCounter = 1 | ||
| 301 | , bnmStateIdentifierMap = mempty | ||
| 302 | } | ||
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 @@ | |||
| 1 | module Data.JLD.Model.NodeMap (NodeMap, lookup, lookup2, lookup3, insert, modifyArray, hasKey2, hasKey3, memberArray) where | ||
| 2 | |||
| 3 | import Data.JLD.Prelude hiding (modify) | ||
| 4 | |||
| 5 | import Data.Aeson (Array, Value (..)) | ||
| 6 | import Data.JLD.Util (valueToArray) | ||
| 7 | import Data.Map.Strict qualified as M (alter, insert, lookup, member) | ||
| 8 | |||
| 9 | type PropertyKey = Maybe Text | ||
| 10 | type PropertyMap = Map PropertyKey Value | ||
| 11 | |||
| 12 | type SubjectKey = Maybe Text | ||
| 13 | type SubjectMap = Map SubjectKey PropertyMap | ||
| 14 | |||
| 15 | type GraphKey = Text | ||
| 16 | type NodeMap = Map GraphKey SubjectMap | ||
| 17 | |||
| 18 | lookup :: GraphKey -> NodeMap -> Maybe SubjectMap | ||
| 19 | lookup = M.lookup | ||
| 20 | |||
| 21 | lookup2 :: GraphKey -> SubjectKey -> NodeMap -> Maybe PropertyMap | ||
| 22 | lookup2 graphName subject nodeMap = M.lookup graphName nodeMap >>= M.lookup subject | ||
| 23 | |||
| 24 | lookup3 :: GraphKey -> SubjectKey -> PropertyKey -> NodeMap -> Maybe Value | ||
| 25 | lookup3 graphName subject property nodeMap = | ||
| 26 | M.lookup graphName nodeMap >>= M.lookup subject >>= M.lookup property | ||
| 27 | |||
| 28 | modifyArray :: GraphKey -> SubjectKey -> PropertyKey -> (Array -> Array) -> NodeMap -> NodeMap | ||
| 29 | modifyArray graphName subject property fn = | ||
| 30 | M.alter (Just <. M.alter (Just <. M.alter (Just <. Array <. fn <. maybe mempty valueToArray) property <. fromMaybe mempty) subject <. fromMaybe mempty) graphName | ||
| 31 | |||
| 32 | insert :: GraphKey -> SubjectKey -> PropertyKey -> Value -> NodeMap -> NodeMap | ||
| 33 | insert graphName subject property value = | ||
| 34 | M.alter (Just <. M.alter (Just <. M.insert property value <. fromMaybe mempty) subject <. fromMaybe mempty) graphName | ||
| 35 | |||
| 36 | hasKey2 :: GraphKey -> SubjectKey -> NodeMap -> Bool | ||
| 37 | hasKey2 graphName subject nodeMap = maybe False (M.member subject) <| M.lookup graphName nodeMap | ||
| 38 | |||
| 39 | hasKey3 :: GraphKey -> SubjectKey -> PropertyKey -> NodeMap -> Bool | ||
| 40 | hasKey3 graphName subject property nodeMap = maybe False (M.member property) <| M.lookup subject =<< M.lookup graphName nodeMap | ||
| 41 | |||
| 42 | memberArray :: GraphKey -> SubjectKey -> PropertyKey -> Value -> NodeMap -> Bool | ||
| 43 | memberArray graphName subject property value nodeMap = case lookup3 graphName subject property nodeMap of | ||
| 44 | Just (Array a) -> value `elem` a | ||
| 45 | _ -> 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 @@ | |||
| 1 | module Data.JLD.NodeMap (NodeMap, BNMParams (..)) where | ||
| 2 | |||
| 3 | import Data.JLD.Prelude | ||
| 4 | |||
| 5 | import Data.JLD.Control.Monad.RES (REST, execREST, runREST, withEnvRES, withErrorRES, withErrorRES', withStateRES) | ||
| 6 | import Data.JLD.Error (JLDError (..)) | ||
| 7 | import Data.JLD.Model.ActiveContext (ActiveContext (..), containsProtectedTerm, lookupTerm, newActiveContext) | ||
| 8 | import Data.JLD.Model.Direction (Direction (..)) | ||
| 9 | import Data.JLD.Model.IRI (CompactIRI (..), endsWithGenericDelim, isBlankIri, parseCompactIri) | ||
| 10 | import Data.JLD.Model.Keyword (Keyword (..), allKeywords, isKeyword, isKeywordLike, isNotKeyword, parseKeyword) | ||
| 11 | import Data.JLD.Model.Language (Language (..)) | ||
| 12 | import Data.JLD.Model.TermDefinition (TermDefinition (..), newTermDefinition) | ||
| 13 | import Data.JLD.Model.URI (parseUri, uriToIri) | ||
| 14 | import Data.JLD.Options (ContextCache, Document (..), DocumentCache, DocumentLoader (..), JLDVersion (..)) | ||
| 15 | import Data.JLD.Util (flattenSingletonArray, valueContains, valueContainsAny, valueIsTrue, valueToArray) | ||
| 16 | |||
| 17 | import Control.Monad.Except (MonadError (..)) | ||
| 18 | import Data.Aeson (Object, Value (..)) | ||
| 19 | import Data.Aeson.Key qualified as K (fromText, toText) | ||
| 20 | import Data.Aeson.KeyMap qualified as KM (delete, keys, lookup, member, size) | ||
| 21 | import Data.Map.Strict qualified as M (delete, insert, lookup) | ||
| 22 | import Data.RDF (parseIRI, parseRelIRI, resolveIRI, serializeIRI, validateIRI) | ||
| 23 | import Data.Set qualified as S (insert, member, notMember, size) | ||
| 24 | import Data.Text qualified as T (drop, dropEnd, elem, findIndex, isPrefixOf, null, take, toLower) | ||
| 25 | import Data.Vector qualified as V (length) | ||
| 26 | import Text.URI (URI, isPathAbsolute, relativeTo) | ||
| 27 | import Text.URI qualified as U (render) | ||
| 28 | |||
| 29 | type NodeMap = Map (Text, Text, Text) Value | ||
| 30 | |||
| 31 | type BNMT e m = REST BNMEnv (JLDError e) BNMState m | ||
| 32 | |||
| 33 | data BNMEnv = BNMEnv | ||
| 34 | { bnmEnvDocument :: Value | ||
| 35 | , bnmEnvActiveGraph :: Text | ||
| 36 | , bnmEnvActiveSubject :: Maybe Text | ||
| 37 | , bnmEnvActiveProperty :: Maybe Text | ||
| 38 | } | ||
| 39 | deriving (Show) | ||
| 40 | |||
| 41 | newtype BNMState = BNMState | ||
| 42 | { bnmStateNodeMap :: NodeMap | ||
| 43 | } | ||
| 44 | deriving (Show, Eq) | ||
| 45 | |||
| 46 | data BNMParams = BNMParams | ||
| 47 | { bnmParamsNodeMap :: NodeMap | ||
| 48 | , bnmParamsActiveGraph :: Text | ||
| 49 | , bnmParamsActiveSubject :: Maybe Text | ||
| 50 | , bnmParamsActiveProperty :: Maybe Text | ||
| 51 | , bnmParamsList :: Map Text Value | ||
| 52 | } | ||
| 53 | deriving (Show, Eq) | ||
| 54 | |||
| 55 | bnmModifyNodeMap :: Monad m => (NodeMap -> NodeMap) -> BNMT e m () | ||
| 56 | bnmModifyNodeMap fn = modify \s -> s{bnmStateNodeMap = fn (bnmStateNodeMap s)} | ||
| 57 | |||
| 58 | buildNodeMap' :: Monad m => BNMT e m () | ||
| 59 | buildNodeMap' = do | ||
| 60 | pure () | ||
| 61 | |||
| 62 | buildNodeMap :: Monad m => Value -> (BNMParams -> BNMParams) -> m NodeMap | ||
| 63 | buildNodeMap document paramsFn = do | ||
| 64 | BNMState{..} <- buildNodeMap' |> execREST env st | ||
| 65 | pure bnmStateNodeMap | ||
| 66 | where | ||
| 67 | BNMParams{..} = | ||
| 68 | paramsFn | ||
| 69 | BNMParams | ||
| 70 | { bnmParamsNodeMap = mempty | ||
| 71 | , bnmParamsActiveGraph = show KeywordDefault | ||
| 72 | , bnmParamsActiveSubject = Nothing | ||
| 73 | , bnmParamsActiveProperty = Nothing | ||
| 74 | , bnmParamsList = mempty | ||
| 75 | } | ||
| 76 | |||
| 77 | env = | ||
| 78 | BNMEnv | ||
| 79 | { bnmEnvDocument = document | ||
| 80 | , bnmEnvActiveGraph = bnmParamsActiveGraph | ||
| 81 | , bnmEnvActiveSubject = bnmParamsActiveSubject | ||
| 82 | , bnmEnvActiveProperty = bnmParamsActiveProperty | ||
| 83 | } | ||
| 84 | |||
| 85 | st = | ||
| 86 | BNMState | ||
| 87 | { bnmStateNodeMap = bnmParamsNodeMap | ||
| 88 | } | ||
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 @@ | |||
| 1 | module Data.JLD.Util ( | 1 | module Data.JLD.Util ( |
| 2 | valueContains, | 2 | valueContains, |
| 3 | valueContainsAny, | 3 | valueContainsAny, |
| 4 | valueIsTrue, | ||
| 5 | valueIsString, | 4 | valueIsString, |
| 6 | valueIsArray, | 5 | valueIsArray, |
| 7 | valueIsNotArray, | 6 | valueIsNotArray, |
| @@ -9,9 +8,9 @@ module Data.JLD.Util ( | |||
| 9 | valueIsScalar, | 8 | valueIsScalar, |
| 10 | valueToString, | 9 | valueToString, |
| 11 | valueIsNotString, | 10 | valueIsNotString, |
| 12 | valueIsNotNull, | ||
| 13 | flattenSingletonArray, | 11 | flattenSingletonArray, |
| 14 | valueToArray, | 12 | valueToArray, |
| 13 | valueToNonNullArray, | ||
| 15 | allStrings, | 14 | allStrings, |
| 16 | ifindM, | 15 | ifindM, |
| 17 | getMapDefault, | 16 | getMapDefault, |
| @@ -26,7 +25,7 @@ import Data.Aeson.KeyMap qualified as KM (insert, lookup, member) | |||
| 26 | import Data.Foldable qualified as F (Foldable (..), elem) | 25 | import Data.Foldable qualified as F (Foldable (..), elem) |
| 27 | import Data.Foldable.WithIndex (FoldableWithIndex (..), ifoldlM) | 26 | import Data.Foldable.WithIndex (FoldableWithIndex (..), ifoldlM) |
| 28 | import Data.Vector (Vector) | 27 | import Data.Vector (Vector) |
| 29 | import Data.Vector qualified as V (fromList, null, singleton, snoc, uncons) | 28 | import Data.Vector qualified as V (filter, fromList, null, singleton, snoc, uncons) |
| 30 | 29 | ||
| 31 | valueContains :: Text -> Value -> Bool | 30 | valueContains :: Text -> Value -> Bool |
| 32 | valueContains text = \case | 31 | valueContains text = \case |
| @@ -42,10 +41,6 @@ valueContainsAny texts = \case | |||
| 42 | Object o -> any (\text -> KM.member (K.fromText text) o) texts | 41 | Object o -> any (\text -> KM.member (K.fromText text) o) texts |
| 43 | _ -> False | 42 | _ -> False |
| 44 | 43 | ||
| 45 | valueIsTrue :: Value -> Bool | ||
| 46 | valueIsTrue (Bool True) = True | ||
| 47 | valueIsTrue _ = False | ||
| 48 | |||
| 49 | valueIsString :: Value -> Bool | 44 | valueIsString :: Value -> Bool |
| 50 | valueIsString (String _) = True | 45 | valueIsString (String _) = True |
| 51 | valueIsString _ = False | 46 | valueIsString _ = False |
| @@ -75,10 +70,6 @@ valueToString :: Value -> Maybe Text | |||
| 75 | valueToString (String s) = Just s | 70 | valueToString (String s) = Just s |
| 76 | valueToString _ = Nothing | 71 | valueToString _ = Nothing |
| 77 | 72 | ||
| 78 | valueIsNotNull :: Value -> Bool | ||
| 79 | valueIsNotNull Null = False | ||
| 80 | valueIsNotNull _ = True | ||
| 81 | |||
| 82 | flattenSingletonArray :: Value -> Value | 73 | flattenSingletonArray :: Value -> Value |
| 83 | flattenSingletonArray = \case | 74 | flattenSingletonArray = \case |
| 84 | Array (V.uncons -> Just (value, V.null -> True)) -> value | 75 | Array (V.uncons -> Just (value, V.null -> True)) -> value |
| @@ -89,6 +80,12 @@ valueToArray = \case | |||
| 89 | Array a -> a | 80 | Array a -> a |
| 90 | value -> V.singleton value | 81 | value -> V.singleton value |
| 91 | 82 | ||
| 83 | valueToNonNullArray :: Value -> Array | ||
| 84 | valueToNonNullArray = \case | ||
| 85 | Null -> mempty | ||
| 86 | Array a -> V.filter (/= Null) a | ||
| 87 | value -> V.singleton value | ||
| 88 | |||
| 92 | allStrings :: Array -> Maybe (Vector Text) | 89 | allStrings :: Array -> Maybe (Vector Text) |
| 93 | allStrings = foldl' go (Just mempty) | 90 | allStrings = foldl' go (Just mempty) |
| 94 | where | 91 | where |
