aboutsummaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Data/JLD.hs40
-rw-r--r--src/Data/JLD/Flattening.hs2
-rw-r--r--src/Data/JLD/Flattening/NodeMap.hs78
3 files changed, 88 insertions, 32 deletions
diff --git a/src/Data/JLD.hs b/src/Data/JLD.hs
index d7688d0..a7042dc 100644
--- a/src/Data/JLD.hs
+++ b/src/Data/JLD.hs
@@ -4,6 +4,7 @@ module Data.JLD (
4 module Data.JLD.Options, 4 module Data.JLD.Options,
5 JLDExpansionParams (..), 5 JLDExpansionParams (..),
6 JLDExpansionState (..), 6 JLDExpansionState (..),
7 JLDFlatteningParams (..),
7 expand, 8 expand,
8 flatten, 9 flatten,
9) where 10) where
@@ -100,9 +101,44 @@ expand document baseUrl paramsFn = do
100 101
101 pure (result', state') 102 pure (result', state')
102 103
103flatten :: Monad m => Value -> URI -> (JLDExpansionParams () m -> JLDExpansionParams e m) -> m (Either (JLDError e) Value, JLDExpansionState) 104data JLDFlatteningParams e m = JLDFlatteningParams
105 { jldFlatteningParamsDocumentLoader :: DocumentLoader e m
106 , jldFlatteningParamsProcessingMode :: JLDVersion
107 , jldFlatteningParamsMaxRemoteContexts :: Int
108 , jldFlatteningParamsExpandContext :: Maybe Value
109 , jldFlatteningParamsFrameExpansion :: Bool
110 , jldFlatteningParamsState :: JLDExpansionState
111 , jldFlatteningParamsCompactArrays :: Bool
112 }
113 deriving (Show)
114
115flatten :: Monad m => Value -> URI -> (JLDFlatteningParams () m -> JLDFlatteningParams e m) -> m (Either (JLDError e) Value, JLDExpansionState)
104flatten document baseUrl paramsFn = do 116flatten document baseUrl paramsFn = do
105 (result, state') <- expand document baseUrl paramsFn 117 let JLDFlatteningParams{..} =
118 paramsFn
119 JLDFlatteningParams
120 { jldFlatteningParamsDocumentLoader = DocumentLoader <. const <. pure <| Left ()
121 , jldFlatteningParamsProcessingMode = JLD1_1
122 , jldFlatteningParamsMaxRemoteContexts = 20
123 , jldFlatteningParamsExpandContext = Nothing
124 , jldFlatteningParamsFrameExpansion = False
125 , jldFlatteningParamsState =
126 JLDExpansionState
127 { jldExpansionStateContextCache = mempty
128 , jldExpansionStateDocumentCache = mempty
129 }
130 , jldFlatteningParamsCompactArrays = True
131 }
132 expansionParams =
133 JLDExpansionParams
134 { jldExpansionParamsDocumentLoader = jldFlatteningParamsDocumentLoader
135 , jldExpansionParamsProcessingMode = jldFlatteningParamsProcessingMode
136 , jldExpansionParamsMaxRemoteContexts = jldFlatteningParamsMaxRemoteContexts
137 , jldExpansionParamsExpandContext = jldFlatteningParamsExpandContext
138 , jldExpansionParamsFrameExpansion = jldFlatteningParamsFrameExpansion
139 , jldExpansionParamsState = jldFlatteningParamsState
140 }
141 (result, state') <- expand document baseUrl (const expansionParams)
106 case result of 142 case result of
107 Left err -> pure (Left err, state') 143 Left err -> pure (Left err, state')
108 Right expanded -> fmap (,state') <. runExceptT <| F.flatten expanded 144 Right expanded -> fmap (,state') <. runExceptT <| F.flatten expanded
diff --git a/src/Data/JLD/Flattening.hs b/src/Data/JLD/Flattening.hs
index 2bfd8dd..3a8c726 100644
--- a/src/Data/JLD/Flattening.hs
+++ b/src/Data/JLD/Flattening.hs
@@ -34,7 +34,7 @@ collectNodesStep ar node
34flatten :: Monad m => Value -> JLDFlatteningT e m Value 34flatten :: Monad m => Value -> JLDFlatteningT e m Value
35flatten element = do 35flatten element = do
36 -- 1. 2. 36 -- 1. 2.
37 nodeMap <- fst <$> buildNodeMap element id 37 (nodeMap, _, _, _) <- buildNodeMap element id
38 38
39 -- 3. 4. 39 -- 3. 4.
40 let defaultGraph = fromMaybe mempty <| M.lookup (show KeywordDefault) nodeMap 40 let defaultGraph = fromMaybe mempty <| M.lookup (show KeywordDefault) nodeMap
diff --git a/src/Data/JLD/Flattening/NodeMap.hs b/src/Data/JLD/Flattening/NodeMap.hs
index 65db9ab..6c35302 100644
--- a/src/Data/JLD/Flattening/NodeMap.hs
+++ b/src/Data/JLD/Flattening/NodeMap.hs
@@ -19,6 +19,7 @@ import Data.Aeson.KeyMap qualified as KM (filterWithKey, insert, lookup, member,
19import Data.Foldable.WithIndex (FoldableWithIndex (..), iforM_) 19import Data.Foldable.WithIndex (FoldableWithIndex (..), iforM_)
20import Data.Map.Strict qualified as M (insert, lookup) 20import Data.Map.Strict qualified as M (insert, lookup)
21import Data.Vector qualified as V (singleton, snoc, uniq) 21import Data.Vector qualified as V (singleton, snoc, uniq)
22import Debug.Pretty.Simple (pTraceShowM)
22 23
23type BNMT e m = REST BNMEnv (Either (JLDError e) ()) BNMState m 24type BNMT e m = REST BNMEnv (Either (JLDError e) ()) BNMState m
24 25
@@ -45,6 +46,8 @@ data BNMParams = BNMParams
45 , bnmParamsActiveProperty :: Maybe Text 46 , bnmParamsActiveProperty :: Maybe Text
46 , bnmParamsList :: Maybe Array 47 , bnmParamsList :: Maybe Array
47 , bnmParamsReferenceNode :: Maybe Object 48 , bnmParamsReferenceNode :: Maybe Object
49 , bnmParamsIdentifierCounter :: Int
50 , bnmParamsIdentifierMap :: Map Text Text
48 } 51 }
49 deriving (Show, Eq) 52 deriving (Show, Eq)
50 53
@@ -78,19 +81,26 @@ bnmBuildNodeMap :: Monad m => Value -> (BNMParams -> BNMParams) -> BNMT e m (May
78bnmBuildNodeMap value paramsFn = do 81bnmBuildNodeMap value paramsFn = do
79 BNMEnv{..} <- ask 82 BNMEnv{..} <- ask
80 nodeMap <- gets bnmStateNodeMap 83 nodeMap <- gets bnmStateNodeMap
84 identifierCounter <- gets bnmStateIdentifierCounter
85 identifierMap <- gets bnmStateIdentifierMap
81 let params p = 86 let params p =
82 paramsFn 87 paramsFn
83 p 88 p
84 { bnmParamsNodeMap = nodeMap 89 { bnmParamsNodeMap = nodeMap
85 , bnmParamsActiveGraph = bnmEnvActiveGraph 90 , bnmParamsActiveGraph = bnmEnvActiveGraph
86 , bnmParamsActiveSubject = bnmEnvActiveSubject 91 , bnmParamsIdentifierCounter = identifierCounter
87 , bnmParamsActiveProperty = bnmEnvActiveProperty 92 , bnmParamsIdentifierMap = identifierMap
88 } 93 }
89 (nodeMap', list) <- 94 (nodeMap', list, identifierCounter', identifierMap') <-
90 buildNodeMap value params |> runExceptT >=> \case 95 buildNodeMap value params |> runExceptT >=> \case
91 Left err -> throwError <| Left err 96 Left err -> throwError <| Left err
92 Right a -> pure a 97 Right a -> pure a
93 bnmModifyNodeMap <| const nodeMap' 98 modify \st ->
99 st
100 { bnmStateNodeMap = nodeMap'
101 , bnmStateIdentifierCounter = identifierCounter'
102 , bnmStateIdentifierMap = identifierMap'
103 }
94 pure list 104 pure list
95 105
96buildNodeMap' :: Monad m => Value -> BNMT e m () 106buildNodeMap' :: Monad m => Value -> BNMT e m ()
@@ -138,7 +148,14 @@ buildNodeMap' element = case element of
138 -- 5. 148 -- 5.
139 | Just elemList <- KM.lookup (show KeywordList) elementObject' -> do 149 | Just elemList <- KM.lookup (show KeywordList) elementObject' -> do
140 -- 5.1. 5.2. 150 -- 5.1. 5.2.
141 subList <- listToObject <$> bnmBuildNodeMap elemList id 151 subList <-
152 listToObject <$> bnmBuildNodeMap elemList \params ->
153 params
154 { bnmParamsActiveSubject = bnmEnvActiveSubject
155 , bnmParamsActiveProperty = bnmEnvActiveProperty
156 , bnmParamsList = Just mempty
157 , bnmParamsReferenceNode = bnmEnvReferenceNode
158 }
142 159
143 gets bnmStateList >>= \case 160 gets bnmStateList >>= \case
144 -- 5.3. 161 -- 5.3.
@@ -152,24 +169,25 @@ buildNodeMap' element = case element of
152 | isNodeObject (Object elementObject') -> do 169 | isNodeObject (Object elementObject') -> do
153 id' <- case KM.lookup (show KeywordId) elementObject' of 170 id' <- case KM.lookup (show KeywordId) elementObject' of
154 -- 6.1. 171 -- 6.1.
155 Just (String idValue) | isBlankIri idValue -> bnmCreateIdentifier <| Just idValue 172 Just (String idValue)
173 | isBlankIri idValue -> bnmCreateIdentifier (Just idValue)
174 | otherwise -> pure idValue
156 Just _ -> throwError <| Right () 175 Just _ -> throwError <| Right ()
157 -- 6.2. 176 -- 6.2.
158 Nothing -> bnmCreateIdentifier Nothing 177 Nothing -> bnmCreateIdentifier Nothing
159 178
160 -- 6.3. 179 -- 6.3.
161 nodeMap <- gets bnmStateNodeMap 180 bnmModifyNodeMap \nodeMap ->
162 when (N.hasKey2 bnmEnvActiveGraph (Just id') nodeMap) do 181 if N.hasKey2 bnmEnvActiveGraph (Just id') nodeMap
163 bnmModifyNodeMap <| N.insert bnmEnvActiveGraph (Just id') (Just <| show KeywordId) (String id') 182 then nodeMap
183 else N.insert bnmEnvActiveGraph (Just id') (Just <| show KeywordId) (String id') nodeMap
164 184
165 nodeMap' <- gets bnmStateNodeMap
166 if 185 if
167 -- 6.5. 186 -- 6.5.
168 | Just referenceNode <- bnmEnvReferenceNode -> 187 | Just referenceNode <- bnmEnvReferenceNode -> bnmModifyNodeMap \nodeMap ->
169 unless (N.memberArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty (Object referenceNode) nodeMap') do 188 if N.memberArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty (Object referenceNode) nodeMap
170 bnmModifyNodeMap 189 then nodeMap
171 <. N.modifyArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty 190 else N.modifyArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty (`V.snoc` Object referenceNode) nodeMap
172 <| flip V.snoc (Object referenceNode)
173 -- 6.6. 191 -- 6.6.
174 | isJust bnmEnvActiveProperty -> do 192 | isJust bnmEnvActiveProperty -> do
175 -- 6.6.1. 193 -- 6.6.1.
@@ -177,11 +195,10 @@ buildNodeMap' element = case element of
177 195
178 gets bnmStateList >>= \case 196 gets bnmStateList >>= \case
179 -- 6.6.2. 197 -- 6.6.2.
180 Nothing -> 198 Nothing -> bnmModifyNodeMap \nodeMap ->
181 unless (N.memberArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty reference nodeMap') do 199 if N.memberArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty reference nodeMap
182 bnmModifyNodeMap 200 then nodeMap
183 <. N.modifyArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty 201 else N.modifyArray bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty (`V.snoc` reference) nodeMap
184 <| flip V.snoc reference
185 -- 6.6.3. 202 -- 6.6.3.
186 Just stateList -> bnmModifyList <. const <. Just <| V.snoc stateList reference 203 Just stateList -> bnmModifyList <. const <. Just <| V.snoc stateList reference
187 -- 204 --
@@ -202,10 +219,10 @@ buildNodeMap' element = case element of
202 Nothing -> pure () 219 Nothing -> pure ()
203 220
204 -- 6.8. 221 -- 6.8.
205 nodeMap'' <- gets bnmStateNodeMap 222 nodeMap' <- gets bnmStateNodeMap
206 case KM.lookup (show KeywordIndex) elementObject' of 223 case KM.lookup (show KeywordIndex) elementObject' of
207 Just indexValue 224 Just indexValue
208 | N.hasKey3 bnmEnvActiveGraph (Just id') (Just <| show KeywordIndex) nodeMap'' -> throwError <| Left ConflictingIndexes 225 | N.hasKey3 bnmEnvActiveGraph (Just id') (Just <| show KeywordIndex) nodeMap' -> throwError <| Left ConflictingIndexes
209 | otherwise -> bnmModifyNodeMap <| N.insert bnmEnvActiveGraph (Just id') (Just <| show KeywordType) indexValue 226 | otherwise -> bnmModifyNodeMap <| N.insert bnmEnvActiveGraph (Just id') (Just <| show KeywordType) indexValue
210 -- 227 --
211 Nothing -> pure () 228 Nothing -> pure ()
@@ -257,9 +274,10 @@ buildNodeMap' element = case element of
257 else pure property 274 else pure property
258 275
259 -- 6.12.2. 276 -- 6.12.2.
260 gets (bnmStateNodeMap .> N.hasKey3 bnmEnvActiveGraph (Just id') (Just property')) >>= \case 277 bnmModifyNodeMap \nodeMap ->
261 True -> pure () 278 if N.hasKey3 bnmEnvActiveGraph (Just id') (Just property') nodeMap
262 False -> bnmModifyNodeMap <| N.insert bnmEnvActiveGraph (Just id') (Just property') (Array mempty) 279 then nodeMap
280 else N.insert bnmEnvActiveGraph (Just id') (Just property') (Array mempty) nodeMap
263 281
264 void <| bnmBuildNodeMap value \params -> 282 void <| bnmBuildNodeMap value \params ->
265 params 283 params
@@ -273,12 +291,12 @@ buildNodeMap' element = case element of
273 -- 291 --
274 _ -> pure () 292 _ -> pure ()
275 293
276buildNodeMap :: Monad m => Value -> (BNMParams -> BNMParams) -> JLDFlatteningT e m (NodeMap, Maybe Array) 294buildNodeMap :: Monad m => Value -> (BNMParams -> BNMParams) -> JLDFlatteningT e m (NodeMap, Maybe Array, Int, Map Text Text)
277buildNodeMap document paramsFn = do 295buildNodeMap document paramsFn = do
278 (result, BNMState{..}) <- buildNodeMap' document |> runREST env st 296 (result, BNMState{..}) <- buildNodeMap' document |> runREST env st
279 case result of 297 case result of
280 Left (Left err) -> throwError err 298 Left (Left err) -> throwError err
281 _ -> pure (bnmStateNodeMap, bnmStateList) 299 _ -> pure (bnmStateNodeMap, bnmStateList, bnmStateIdentifierCounter, bnmStateIdentifierMap)
282 where 300 where
283 BNMParams{..} = 301 BNMParams{..} =
284 paramsFn 302 paramsFn
@@ -289,6 +307,8 @@ buildNodeMap document paramsFn = do
289 , bnmParamsActiveProperty = Nothing 307 , bnmParamsActiveProperty = Nothing
290 , bnmParamsList = mempty 308 , bnmParamsList = mempty
291 , bnmParamsReferenceNode = Nothing 309 , bnmParamsReferenceNode = Nothing
310 , bnmParamsIdentifierCounter = 0
311 , bnmParamsIdentifierMap = mempty
292 } 312 }
293 313
294 env = 314 env =
@@ -303,8 +323,8 @@ buildNodeMap document paramsFn = do
303 BNMState 323 BNMState
304 { bnmStateNodeMap = bnmParamsNodeMap 324 { bnmStateNodeMap = bnmParamsNodeMap
305 , bnmStateList = bnmParamsList 325 , bnmStateList = bnmParamsList
306 , bnmStateIdentifierCounter = 1 326 , bnmStateIdentifierCounter = bnmParamsIdentifierCounter
307 , bnmStateIdentifierMap = mempty 327 , bnmStateIdentifierMap = bnmParamsIdentifierMap
308 } 328 }
309 329
310mergeNodeMaps :: NodeMap -> NodeMap 330mergeNodeMaps :: NodeMap -> NodeMap