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 |