aboutsummaryrefslogtreecommitdiffstats
path: root/src/Data/JLD/Flattening
diff options
context:
space:
mode:
Diffstat (limited to 'src/Data/JLD/Flattening')
-rw-r--r--src/Data/JLD/Flattening/NodeMap.hs302
1 files changed, 302 insertions, 0 deletions
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 @@
1module Data.JLD.Flattening.NodeMap (NodeMap, BNMParams (..), buildNodeMap) where
2
3import Data.JLD.Prelude
4
5import Data.JLD.Control.Monad.RES (REST, execREST, withErrorRES')
6import Data.JLD.Error (JLDError (..))
7import Data.JLD.Model.IRI (isBlankIri)
8import Data.JLD.Model.Keyword (Keyword (..), isNotKeyword)
9import Data.JLD.Model.NodeMap (NodeMap)
10import Data.JLD.Model.NodeMap qualified as N (hasKey2, hasKey3, insert, lookup3, memberArray, modifyArray)
11import Data.JLD.Model.NodeObject (isNodeObject)
12import Data.JLD.Util (valueIsScalar, valueToArray, valueToNonNullArray)
13
14import Control.Monad.Except (MonadError (..))
15import Data.Aeson (Array, Object, Value (..))
16import Data.Aeson.Key qualified as K (toText)
17import Data.Aeson.KeyMap qualified as KM (filterWithKey, insert, lookup, member, singleton)
18import Data.Foldable.WithIndex (iforM_)
19import Data.Map.Strict qualified as M (insert, lookup)
20import Data.Vector qualified as V (singleton, snoc, uniq)
21
22type BNMT e m = REST BNMEnv (Either (JLDError e) ()) BNMState m
23
24data BNMEnv = BNMEnv
25 { bnmEnvActiveGraph :: Text
26 , bnmEnvActiveSubject :: Maybe Text
27 , bnmEnvActiveProperty :: Maybe Text
28 , bnmEnvReferenceNode :: Maybe Object
29 }
30 deriving (Show)
31
32data BNMState = BNMState
33 { bnmStateNodeMap :: NodeMap
34 , bnmStateList :: Maybe Array
35 , bnmStateIdentifierCounter :: Int
36 , bnmStateIdentifierMap :: Map Text Text
37 }
38 deriving (Show, Eq)
39
40data 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
50listToObject :: Maybe Array -> Value
51listToObject = Object <. KM.singleton (show KeywordList) <. Array <. fromMaybe mempty
52
53bnmModifyNodeMap :: Monad m => (NodeMap -> NodeMap) -> BNMT e m ()
54bnmModifyNodeMap fn = modify \s -> s{bnmStateNodeMap = fn (bnmStateNodeMap s)}
55
56bnmModifyList :: Monad m => (Maybe Array -> Maybe Array) -> BNMT e m ()
57bnmModifyList fn = modify \s -> s{bnmStateList = fn (bnmStateList s)}
58
59bnmModifyIdentifierCounter :: Monad m => (Int -> Int) -> BNMT e m ()
60bnmModifyIdentifierCounter fn = modify \s -> s{bnmStateIdentifierCounter = fn (bnmStateIdentifierCounter s)}
61
62bnmModifyIdentifierMap :: Monad m => (Map Text Text -> Map Text Text) -> BNMT e m ()
63bnmModifyIdentifierMap fn = modify \s -> s{bnmStateIdentifierMap = fn (bnmStateIdentifierMap s)}
64
65bnmCreateIdentifier :: Monad m => Maybe Text -> BNMT e m Text
66bnmCreateIdentifier Nothing = do
67 n <- gets bnmStateIdentifierCounter
68 "_:b" <> show n <$ bnmModifyIdentifierCounter (const <| n + 1)
69bnmCreateIdentifier (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
76bnmBuildNodeMap :: Monad m => Value -> (BNMParams -> BNMParams) -> BNMT e m (Maybe Array)
77bnmBuildNodeMap 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
92buildNodeMap' :: Monad m => Value -> BNMT e m ()
93buildNodeMap' 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
272buildNodeMap :: Monad m => Value -> (BNMParams -> BNMParams) -> m (NodeMap, Maybe Array)
273buildNodeMap 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 }