diff options
-rw-r--r-- | src/Data/JLD/Flattening/NodeMap.hs | 31 | ||||
-rw-r--r-- | test/Test/Flattening.hs | 4 |
2 files changed, 12 insertions, 23 deletions
diff --git a/src/Data/JLD/Flattening/NodeMap.hs b/src/Data/JLD/Flattening/NodeMap.hs index 2e6b8e3..06af2d4 100644 --- a/src/Data/JLD/Flattening/NodeMap.hs +++ b/src/Data/JLD/Flattening/NodeMap.hs | |||
@@ -19,7 +19,6 @@ import Data.Aeson.KeyMap qualified as KM (filterWithKey, insert, lookup, member, | |||
19 | import Data.Foldable.WithIndex (FoldableWithIndex (..), iforM_) | 19 | import Data.Foldable.WithIndex (FoldableWithIndex (..), iforM_) |
20 | import Data.Map.Strict qualified as M (insert, lookup) | 20 | import Data.Map.Strict qualified as M (insert, lookup) |
21 | import Data.Vector qualified as V (singleton, snoc, uniq) | 21 | import Data.Vector qualified as V (singleton, snoc, uniq) |
22 | import Debug.Pretty.Simple (pTraceShowM) | ||
23 | 22 | ||
24 | type BNMT e m = REST BNMEnv (Either (JLDError e) ()) BNMState m | 23 | type BNMT e m = REST BNMEnv (Either (JLDError e) ()) BNMState m |
25 | 24 | ||
@@ -127,22 +126,14 @@ buildNodeMap' element = case element of | |||
127 | | KM.member (show KeywordValue) elementObject' -> | 126 | | KM.member (show KeywordValue) elementObject' -> |
128 | gets bnmStateList >>= \case | 127 | gets bnmStateList >>= \case |
129 | -- 4.1. | 128 | -- 4.1. |
130 | Nothing -> | 129 | Nothing -> bnmModifyNodeMap \nodeMap -> case N.lookup3 bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty nodeMap of |
131 | gets (bnmStateNodeMap .> N.lookup3 bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty) >>= \case | 130 | -- 4.1.1. |
132 | -- 4.1.1. | 131 | Just (Array activePropertyValue) |
133 | Just (Array activePropertyValue) | 132 | | element `notElem` activePropertyValue -> |
134 | | notElem element activePropertyValue -> | 133 | N.insert bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty (Array <| V.snoc activePropertyValue element) nodeMap |
135 | bnmModifyNodeMap | 134 | | otherwise -> nodeMap |
136 | <. N.insert bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty | 135 | -- 4.2.2 |
137 | <. Array | 136 | _ -> N.insert bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty (Array <| V.singleton element) nodeMap |
138 | <| V.snoc activePropertyValue element | ||
139 | | otherwise -> pure () | ||
140 | -- 4.2.2 | ||
141 | _ -> | ||
142 | bnmModifyNodeMap | ||
143 | <. N.insert bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty | ||
144 | <. Array | ||
145 | <| V.singleton element | ||
146 | -- 4.2. | 137 | -- 4.2. |
147 | Just list -> bnmModifyList <. const <. Just <| V.snoc list element | 138 | Just list -> bnmModifyList <. const <. Just <| V.snoc list element |
148 | -- 5. | 139 | -- 5. |
@@ -241,15 +232,13 @@ buildNodeMap' element = case element of | |||
241 | 232 | ||
242 | -- 6.10. | 233 | -- 6.10. |
243 | case KM.lookup (show KeywordGraph) elementObject' of | 234 | case KM.lookup (show KeywordGraph) elementObject' of |
244 | Just graphValue -> | 235 | Just graphValue -> void <| bnmBuildNodeMap graphValue \params -> params{bnmParamsActiveGraph = id'} |
245 | void <| bnmBuildNodeMap graphValue \params -> params{bnmParamsActiveGraph = id'} | ||
246 | -- | 236 | -- |
247 | _ -> pure () | 237 | _ -> pure () |
248 | 238 | ||
249 | -- 6.11. | 239 | -- 6.11. |
250 | case KM.lookup (show KeywordIncluded) elementObject' of | 240 | case KM.lookup (show KeywordIncluded) elementObject' of |
251 | Just includedValue -> | 241 | Just includedValue -> void <| bnmBuildNodeMap includedValue id |
252 | void <| bnmBuildNodeMap includedValue id | ||
253 | -- | 242 | -- |
254 | _ -> pure () | 243 | _ -> pure () |
255 | 244 | ||
diff --git a/test/Test/Flattening.hs b/test/Test/Flattening.hs index 76f5434..d452eee 100644 --- a/test/Test/Flattening.hs +++ b/test/Test/Flattening.hs | |||
@@ -55,8 +55,8 @@ flatteningTest W3CTest{..} (show .> (<> ". " <> toString w3cTestName) -> testNam | |||
55 | inputJld <- fetchTest inputUrl | 55 | inputJld <- fetchTest inputUrl |
56 | expectJld <- fetchTest expectUrl | 56 | expectJld <- fetchTest expectUrl |
57 | 57 | ||
58 | (expandBaseUrl, params) <- parseFlatteningOptions baseUrl inputUrl w3cTestOption | 58 | (flatteningBaseUrl, params) <- parseFlatteningOptions baseUrl inputUrl w3cTestOption |
59 | (result, _) <- flatten inputJld expandBaseUrl params | 59 | (result, _) <- flatten inputJld flatteningBaseUrl params |
60 | 60 | ||
61 | result @?= Right expectJld | 61 | result @?= Right expectJld |
62 | -- | 62 | -- |