diff options
author | Volpeon <github@volpeon.ink> | 2023-06-24 08:58:22 +0200 |
---|---|---|
committer | Volpeon <github@volpeon.ink> | 2023-06-24 08:58:22 +0200 |
commit | b19440a4a30828f12f8eafaa7292152ecf733334 (patch) | |
tree | 00210fae1f860d76bb5319d10167d744c5d4037d /src/Data/JLD | |
parent | Small code optimization (diff) | |
download | hs-jsonld-b19440a4a30828f12f8eafaa7292152ecf733334.tar.gz hs-jsonld-b19440a4a30828f12f8eafaa7292152ecf733334.tar.bz2 hs-jsonld-b19440a4a30828f12f8eafaa7292152ecf733334.zip |
WIP: Compaction
Diffstat (limited to 'src/Data/JLD')
-rw-r--r-- | src/Data/JLD/Compaction/Global.hs | 13 | ||||
-rw-r--r-- | src/Data/JLD/Compaction/IRI.hs | 342 | ||||
-rw-r--r-- | src/Data/JLD/Compaction/InverseContext.hs | 54 | ||||
-rw-r--r-- | src/Data/JLD/Expansion.hs | 30 | ||||
-rw-r--r-- | src/Data/JLD/Expansion/Context.hs | 36 | ||||
-rw-r--r-- | src/Data/JLD/Flattening/NodeMap.hs | 4 | ||||
-rw-r--r-- | src/Data/JLD/Model/ActiveContext.hs | 6 | ||||
-rw-r--r-- | src/Data/JLD/Model/GraphObject.hs | 19 | ||||
-rw-r--r-- | src/Data/JLD/Model/ListObject.hs | 16 | ||||
-rw-r--r-- | src/Data/JLD/Util.hs | 8 |
10 files changed, 472 insertions, 56 deletions
diff --git a/src/Data/JLD/Compaction/Global.hs b/src/Data/JLD/Compaction/Global.hs new file mode 100644 index 0000000..76b2db7 --- /dev/null +++ b/src/Data/JLD/Compaction/Global.hs | |||
@@ -0,0 +1,13 @@ | |||
1 | module Data.JLD.Compaction.Global (JLDCompactionT, JLDCompactionEnv (..)) where | ||
2 | |||
3 | import Data.JLD.Prelude | ||
4 | |||
5 | import Data.JLD.Error (JLDError) | ||
6 | import Data.JLD.Options (JLDVersion (..)) | ||
7 | |||
8 | type JLDCompactionT e m = ReaderT JLDCompactionEnv (ExceptT (JLDError e) m) | ||
9 | |||
10 | newtype JLDCompactionEnv = JLDCompactionEnv | ||
11 | { jldCompactionEnvProcessingMode :: JLDVersion | ||
12 | } | ||
13 | deriving (Show) | ||
diff --git a/src/Data/JLD/Compaction/IRI.hs b/src/Data/JLD/Compaction/IRI.hs new file mode 100644 index 0000000..34379d2 --- /dev/null +++ b/src/Data/JLD/Compaction/IRI.hs | |||
@@ -0,0 +1,342 @@ | |||
1 | module Data.JLD.Compaction.IRI (compactIri) where | ||
2 | |||
3 | import Data.JLD.Prelude | ||
4 | |||
5 | import Data.JLD (JLDError (InvalidKeywordValue), JLDVersion (JLD1_0)) | ||
6 | import Data.JLD.Compaction.Global (JLDCompactionEnv (jldCompactionEnvProcessingMode), JLDCompactionT) | ||
7 | import Data.JLD.Compaction.InverseContext (buildInverseContext) | ||
8 | import Data.JLD.Control.Monad.RES (REST, evalREST, runREST, withEnvRES, withStateRES) | ||
9 | import Data.JLD.Model.ActiveContext (ActiveContext (..)) | ||
10 | import Data.JLD.Model.InverseContext (InverseContext) | ||
11 | |||
12 | import Control.Monad.Except (MonadError (..)) | ||
13 | import Data.Aeson (Value (..)) | ||
14 | import Data.Aeson.KeyMap qualified as KM (lookup, member, size) | ||
15 | import Data.JLD.Model.Direction (Direction (..)) | ||
16 | import Data.JLD.Model.GraphObject (isGraphObject', isNotGraphObject, isNotGraphObject') | ||
17 | import Data.JLD.Model.Keyword (Keyword (..)) | ||
18 | import Data.JLD.Model.Language (Language (..)) | ||
19 | import Data.JLD.Model.ListObject (isListObject') | ||
20 | import Data.JLD.Model.ValueObject (isValueObject') | ||
21 | import Data.JLD.Util (valueToArray) | ||
22 | import Data.Set qualified as S | ||
23 | import Data.Text (toLower) | ||
24 | import Data.Text qualified as T (drop, findIndex, isPrefixOf, take) | ||
25 | import Data.Vector (Vector, (!?)) | ||
26 | import Data.Vector qualified as V (cons, snoc) | ||
27 | |||
28 | type CIT e m = REST CIEnv (JLDError e) CIState m | ||
29 | |||
30 | data CIEnv = CIEnv | ||
31 | { ciEnvGlobal :: JLDCompactionEnv | ||
32 | , ciEnvActiveContext :: ActiveContext | ||
33 | , ciEnvValue :: Maybe Value | ||
34 | , ciEnvVocab :: Bool | ||
35 | , ciEnvReverse :: Bool | ||
36 | } | ||
37 | deriving (Show) | ||
38 | |||
39 | data CIState = CIState | ||
40 | { ciStateContainers :: Set Text | ||
41 | , ciStateTypeLanguage :: Keyword | ||
42 | , ciStateTypeLanguageValue :: Text | ||
43 | , ciStatePreferredValues :: Vector Text | ||
44 | } | ||
45 | deriving (Show, Eq) | ||
46 | |||
47 | data CIParams = CIParams | ||
48 | { ciParamsActiveContext :: ActiveContext | ||
49 | , ciParamsValue :: Maybe Value | ||
50 | , ciParamsVocab :: Bool | ||
51 | , ciParamsReverse :: Bool | ||
52 | } | ||
53 | deriving (Show, Eq) | ||
54 | |||
55 | ciModifyContainers :: Monad m => (Set Text -> Set Text) -> CIT e m () | ||
56 | ciModifyContainers fn = modify \s -> s{ciStateContainers = fn (ciStateContainers s)} | ||
57 | |||
58 | ciModifyPreferredValues :: Monad m => (Vector Text -> Vector Text) -> CIT e m () | ||
59 | ciModifyPreferredValues fn = modify \s -> s{ciStatePreferredValues = fn (ciStatePreferredValues s)} | ||
60 | |||
61 | ciPutTypeLanguage :: Monad m => Keyword -> CIT e m () | ||
62 | ciPutTypeLanguage v = modify \s -> s{ciStateTypeLanguage = v} | ||
63 | |||
64 | ciPutTypeLanguageValue :: Monad m => Text -> CIT e m () | ||
65 | ciPutTypeLanguageValue v = modify \s -> s{ciStateTypeLanguageValue = v} | ||
66 | |||
67 | compactIri4 :: Monad m => InverseContext -> Text -> CIT e m (Maybe Text) | ||
68 | compactIri4 inverseContext var = do | ||
69 | CIEnv{..} <- ask | ||
70 | let ActiveContext{..} = ciEnvActiveContext | ||
71 | |||
72 | -- 4.1. | ||
73 | let defaultLanguage = case (activeContextDefaultLanguage, activeContextDefaultBaseDirection) of | ||
74 | (Just (Language language), Just dir) -> language <> show dir | ||
75 | (Nothing, Just dir) -> "_" <> show dir | ||
76 | _ -> show KeywordNone | ||
77 | |||
78 | -- 4.2. | ||
79 | value = case ciEnvValue of | ||
80 | Just v@(Object o) -> case KM.lookup (show KeywordPreserve) o of | ||
81 | Just Null -> Just v | ||
82 | Just preserve -> valueToArray preserve !? 0 | ||
83 | _ -> Just v | ||
84 | _ -> Nothing | ||
85 | |||
86 | -- 4.5. | ||
87 | case value of | ||
88 | Just (Object o) | ||
89 | | KM.member (show KeywordIndex) o && isNotGraphObject' o -> | ||
90 | ciModifyContainers | ||
91 | <| S.insert (show KeywordIndex) | ||
92 | .> S.insert (show KeywordIndex <> show KeywordSet) | ||
93 | _ -> pure () | ||
94 | |||
95 | case value of | ||
96 | -- 4.6. | ||
97 | _ | ciEnvReverse -> do | ||
98 | ciPutTypeLanguage KeywordType | ||
99 | ciPutTypeLanguageValue <| show KeywordReverse | ||
100 | -- | ||
101 | Just (Object o) | ||
102 | -- 4.7. | ||
103 | | isListObject' o | ||
104 | , Just (Array list) <- KM.lookup (show KeywordList) o -> do | ||
105 | -- 4.7.1. | ||
106 | unless (KM.member (show KeywordIndex) o) <| ciModifyContainers (S.insert (show KeywordList)) | ||
107 | |||
108 | -- 4.7.4. | ||
109 | let go (commonType, commonLanguage) item | ||
110 | -- 4.7.4.8. | ||
111 | | commonLanguage == Just (show KeywordNone) | ||
112 | , commonType == Just (show KeywordNone) = | ||
113 | (commonType, commonLanguage) | ||
114 | -- | ||
115 | | otherwise = (Just commonType', Just commonLanguage') | ||
116 | where | ||
117 | (itemLanguage, itemType) = case item of | ||
118 | Object objectItem | ||
119 | | KM.member (show KeywordValue) objectItem -> | ||
120 | if | ||
121 | -- 4.7.4.2.1. | ||
122 | | Just (String dir) <- KM.lookup (show KeywordDirection) objectItem | ||
123 | , Just (String lang) <- KM.lookup (show KeywordLanguage) objectItem -> | ||
124 | (toLower lang <> "_" <> toLower dir, show KeywordId) | ||
125 | | Just (String dir) <- KM.lookup (show KeywordDirection) objectItem -> | ||
126 | ("_" <> toLower dir, show KeywordId) | ||
127 | -- 4.7.4.2.2. | ||
128 | | Just (String lang) <- KM.lookup (show KeywordLanguage) objectItem -> | ||
129 | (toLower lang, show KeywordId) | ||
130 | -- 4.7.4.2.3. | ||
131 | | Just (String type') <- KM.lookup (show KeywordType) objectItem -> | ||
132 | (show KeywordNone, type') | ||
133 | -- 4.7.4.2.4. | ||
134 | | otherwise -> | ||
135 | (show KeywordNone, show KeywordId) | ||
136 | -- 4.7.4.2.4. | ||
137 | _ -> (show KeywordNone, show KeywordId) | ||
138 | |||
139 | commonLanguage' = case commonLanguage of | ||
140 | -- 4.7.4.4. | ||
141 | Nothing -> itemLanguage | ||
142 | -- 4.7.4.5. | ||
143 | Just lang | ||
144 | | itemLanguage /= lang | ||
145 | , Object itemObject <- item | ||
146 | , KM.member (show KeywordValue) itemObject -> | ||
147 | show KeywordNone | ||
148 | | otherwise -> lang | ||
149 | |||
150 | commonType' = case commonType of | ||
151 | Nothing -> itemType | ||
152 | Just it | ||
153 | | itemType /= it -> show KeywordNone | ||
154 | | otherwise -> it | ||
155 | |||
156 | -- 4.7.3. 4.7.5. 4.7.6. | ||
157 | (commonType'', commonLanguage'') = | ||
158 | list | ||
159 | |> foldl' go (Nothing, if null list then Just defaultLanguage else Nothing) | ||
160 | .> bimap (fromMaybe (show KeywordNone)) (fromMaybe (show KeywordNone)) | ||
161 | |||
162 | -- 4.7.7. | ||
163 | if commonType'' /= show KeywordNone | ||
164 | then do | ||
165 | ciPutTypeLanguage KeywordType | ||
166 | ciPutTypeLanguageValue (show commonType'') | ||
167 | else -- 4.7.8. | ||
168 | ciPutTypeLanguageValue (show commonLanguage'') | ||
169 | -- 4.8. | ||
170 | | isGraphObject' o -> do | ||
171 | -- 4.8.1. | ||
172 | when (KM.member (show KeywordIndex) o) do | ||
173 | ciModifyContainers | ||
174 | <| S.insert (show KeywordGraph <> show KeywordIndex) | ||
175 | .> S.insert (show KeywordGraph <> show KeywordIndex <> show KeywordSet) | ||
176 | -- 4.8.2. | ||
177 | when (KM.member (show KeywordId) o) do | ||
178 | ciModifyContainers | ||
179 | <| S.insert (show KeywordGraph <> show KeywordId) | ||
180 | .> S.insert (show KeywordGraph <> show KeywordId <> show KeywordSet) | ||
181 | -- 4.8.3. | ||
182 | ciModifyContainers | ||
183 | <| S.insert (show KeywordGraph) | ||
184 | .> S.insert (show KeywordGraph <> show KeywordSet) | ||
185 | .> S.insert (show KeywordSet) | ||
186 | -- 4.8.4. | ||
187 | unless (KM.member (show KeywordIndex) o) do | ||
188 | ciModifyContainers | ||
189 | <| S.insert (show KeywordGraph <> show KeywordIndex) | ||
190 | .> S.insert (show KeywordGraph <> show KeywordIndex <> show KeywordSet) | ||
191 | -- 4.8.5. | ||
192 | unless (KM.member (show KeywordId) o) do | ||
193 | ciModifyContainers | ||
194 | <| S.insert (show KeywordGraph <> show KeywordId) | ||
195 | .> S.insert (show KeywordGraph <> show KeywordId <> show KeywordSet) | ||
196 | -- 4.8.6. | ||
197 | ciModifyContainers | ||
198 | <| S.insert (show KeywordIndex) | ||
199 | .> S.insert (show KeywordIndex <> show KeywordSet) | ||
200 | -- 4.8.7. | ||
201 | ciPutTypeLanguage KeywordType | ||
202 | ciPutTypeLanguageValue (show KeywordId) | ||
203 | -- 4.9. 4.9.1. | ||
204 | | isValueObject' o -> do | ||
205 | if | ||
206 | -- 4.9.1.1. | ||
207 | | Just (String dir) <- KM.lookup (show KeywordDirection) o | ||
208 | , Just (String lang) <- KM.lookup (show KeywordLanguage) o | ||
209 | , not (KM.member (show KeywordIndex) o) -> do | ||
210 | ciPutTypeLanguageValue (toLower lang <> "_" <> toLower dir) | ||
211 | ciModifyContainers | ||
212 | <| S.insert (show KeywordLanguage) | ||
213 | .> S.insert (show KeywordLanguage <> show KeywordSet) | ||
214 | | Just (String dir) <- KM.lookup (show KeywordDirection) o | ||
215 | , not (KM.member (show KeywordIndex) o) -> do | ||
216 | ciPutTypeLanguageValue ("_" <> toLower dir) | ||
217 | ciModifyContainers | ||
218 | <| S.insert (show KeywordLanguage) | ||
219 | .> S.insert (show KeywordLanguage <> show KeywordSet) | ||
220 | -- 4.9.1.2. | ||
221 | | Just (String lang) <- KM.lookup (show KeywordLanguage) o | ||
222 | , not (KM.member (show KeywordIndex) o) -> do | ||
223 | ciPutTypeLanguageValue (toLower lang) | ||
224 | ciModifyContainers | ||
225 | <| S.insert (show KeywordLanguage) | ||
226 | .> S.insert (show KeywordLanguage <> show KeywordSet) | ||
227 | -- 4.9.1.3. | ||
228 | | Just (String type') <- KM.lookup (show KeywordType) o -> do | ||
229 | ciPutTypeLanguage KeywordType | ||
230 | ciPutTypeLanguageValue type' | ||
231 | -- | ||
232 | | otherwise -> pure () | ||
233 | -- 4.9.3. | ||
234 | ciModifyContainers <| S.insert (show KeywordSet) | ||
235 | -- 4.9.2. | ||
236 | _ -> do | ||
237 | ciPutTypeLanguage KeywordType | ||
238 | ciPutTypeLanguageValue (show KeywordId) | ||
239 | -- 4.9.3. | ||
240 | ciModifyContainers | ||
241 | <| S.insert (show KeywordId) | ||
242 | .> S.insert (show KeywordId <> show KeywordSet) | ||
243 | .> S.insert (show KeywordType) | ||
244 | .> S.insert (show KeywordSet <> show KeywordType) | ||
245 | .> S.insert (show KeywordSet) | ||
246 | |||
247 | -- 4.10. | ||
248 | ciModifyContainers <| S.insert (show KeywordNone) | ||
249 | |||
250 | -- 4.11. | ||
251 | case value of | ||
252 | Just (Object o) | ||
253 | | jldCompactionEnvProcessingMode ciEnvGlobal /= JLD1_0 | ||
254 | , not (KM.member (show KeywordIndex) o) -> | ||
255 | ciModifyContainers | ||
256 | <| S.insert (show KeywordIndex) | ||
257 | .> S.insert (show KeywordIndex <> show KeywordSet) | ||
258 | _ | ||
259 | | jldCompactionEnvProcessingMode ciEnvGlobal /= JLD1_0 -> | ||
260 | ciModifyContainers | ||
261 | <| S.insert (show KeywordIndex) | ||
262 | .> S.insert (show KeywordIndex <> show KeywordSet) | ||
263 | -- | ||
264 | | otherwise -> pure () | ||
265 | |||
266 | -- 4.12. | ||
267 | case value of | ||
268 | Just (Object o) | ||
269 | | jldCompactionEnvProcessingMode ciEnvGlobal /= JLD1_0 | ||
270 | , KM.member (show KeywordIndex) o | ||
271 | , KM.size o == 1 -> | ||
272 | ciModifyContainers | ||
273 | <| S.insert (show KeywordLanguage) | ||
274 | .> S.insert (show KeywordLanguage <> show KeywordSet) | ||
275 | -- | ||
276 | _ -> pure () | ||
277 | |||
278 | -- 4.15. | ||
279 | typeLanguageValue <- gets ciStateTypeLanguageValue | ||
280 | when (typeLanguageValue == show KeywordReverse) <| ciModifyPreferredValues (V.cons (show KeywordReverse)) | ||
281 | |||
282 | -- 4.16. | ||
283 | case value of | ||
284 | Just (Object o) | ||
285 | | typeLanguageValue == show KeywordReverse || typeLanguageValue == show KeywordId | ||
286 | , Just idValue <- KM.lookup (show KeywordId) o -> case idValue of | ||
287 | String idValue' -> pure () | ||
288 | _ -> throwError <| InvalidKeywordValue KeywordId idValue | ||
289 | -- | ||
290 | _ -> pure () | ||
291 | |||
292 | -- | ||
293 | pure Nothing | ||
294 | |||
295 | compactIri' :: Monad m => Text -> CIT e m (Text, InverseContext) | ||
296 | compactIri' var = do | ||
297 | CIEnv{..} <- ask | ||
298 | |||
299 | -- 2. 3. | ||
300 | let inverseContext = case activeContextInverseContext ciEnvActiveContext of | ||
301 | Nothing -> buildInverseContext ciEnvActiveContext | ||
302 | Just ic -> ic | ||
303 | |||
304 | compactIri4 inverseContext var >>= \case | ||
305 | Just var' -> pure (var', inverseContext) | ||
306 | Nothing -> pure (var, inverseContext) | ||
307 | |||
308 | compactIri :: Monad m => ActiveContext -> Text -> (CIParams -> CIParams) -> JLDCompactionT e m (Text, InverseContext) | ||
309 | compactIri activeContext var paramsFn = do | ||
310 | envGlobal <- ask | ||
311 | result <- | ||
312 | compactIri' var | ||
313 | |> evalREST (env envGlobal) st | ||
314 | case result of | ||
315 | Left err -> throwError err | ||
316 | Right res -> pure res | ||
317 | where | ||
318 | CIParams{..} = | ||
319 | paramsFn | ||
320 | CIParams | ||
321 | { ciParamsActiveContext = activeContext | ||
322 | , ciParamsValue = Nothing | ||
323 | , ciParamsVocab = False | ||
324 | , ciParamsReverse = False | ||
325 | } | ||
326 | |||
327 | env global = | ||
328 | CIEnv | ||
329 | { ciEnvGlobal = global | ||
330 | , ciEnvActiveContext = ciParamsActiveContext | ||
331 | , ciEnvValue = ciParamsValue | ||
332 | , ciEnvVocab = ciParamsVocab | ||
333 | , ciEnvReverse = ciParamsReverse | ||
334 | } | ||
335 | |||
336 | st = | ||
337 | CIState | ||
338 | { ciStateContainers = mempty | ||
339 | , ciStateTypeLanguage = KeywordLanguage | ||
340 | , ciStateTypeLanguageValue = show KeywordNull | ||
341 | , ciStatePreferredValues = mempty | ||
342 | } | ||
diff --git a/src/Data/JLD/Compaction/InverseContext.hs b/src/Data/JLD/Compaction/InverseContext.hs new file mode 100644 index 0000000..b351e34 --- /dev/null +++ b/src/Data/JLD/Compaction/InverseContext.hs | |||
@@ -0,0 +1,54 @@ | |||
1 | module Data.JLD.Compaction.InverseContext (buildInverseContext) where | ||
2 | |||
3 | import Data.JLD.Prelude | ||
4 | |||
5 | import Data.JLD.Model.ActiveContext (ActiveContext (..)) | ||
6 | import Data.JLD.Model.Direction (Direction (..)) | ||
7 | import Data.JLD.Model.InverseContext (InverseContext) | ||
8 | import Data.JLD.Model.Keyword (Keyword (..)) | ||
9 | import Data.JLD.Model.Language (Language (Language)) | ||
10 | import Data.JLD.Model.TermDefinition (TermDefinition (..)) | ||
11 | |||
12 | import Data.Map qualified as M | ||
13 | |||
14 | processTerm :: Text -> InverseContext -> Text -> TermDefinition -> InverseContext | ||
15 | processTerm defaultLangDir out termName TermDefinition{..} | ||
16 | | Just variableName <- termDefinitionIriMapping = | ||
17 | out | ||
18 | |> M.insert (variableName, container, show KeywordAny, show KeywordNone) termName | ||
19 | .> if | ||
20 | | termDefinitionReversePropertyFlag -> | ||
21 | M.insert (variableName, container, show KeywordType, show KeywordReverse) termName | ||
22 | | termDefinitionTypeMapping == Just (show KeywordNone) -> | ||
23 | M.insert (variableName, container, show KeywordLanguage, show KeywordAny) termName | ||
24 | .> M.insert (variableName, container, show KeywordType, show KeywordAny) termName | ||
25 | | Just typeMapping <- termDefinitionTypeMapping -> | ||
26 | M.insert (variableName, container, show KeywordType, typeMapping) termName | ||
27 | | Just langDir <- maybeLangDir -> | ||
28 | M.insert (variableName, container, show KeywordLanguage, langDir) termName | ||
29 | | otherwise -> | ||
30 | M.insert (variableName, container, show KeywordLanguage, defaultLangDir) termName | ||
31 | .> M.insert (variableName, container, show KeywordLanguage, show KeywordNone) termName | ||
32 | .> M.insert (variableName, container, show KeywordType, show KeywordNone) termName | ||
33 | | otherwise = out | ||
34 | where | ||
35 | container = if null termDefinitionContainerMapping then show KeywordNone else fold termDefinitionContainerMapping | ||
36 | maybeLangDir = case (termDefinitionLanguageMapping, termDefinitionDirectionMapping) of | ||
37 | (Just (Language language), Just LTR) -> Just <| language <> "_ltr" | ||
38 | (Just (Language language), Just RTL) -> Just <| language <> "_rtl" | ||
39 | (Just (Language language), _) -> Just <| language | ||
40 | (Just _, Just LTR) -> Just "_ltr" | ||
41 | (Just _, Just RTL) -> Just "_rtl" | ||
42 | (Just _, _) -> Just <| show KeywordNull | ||
43 | (Nothing, Just LTR) -> Just "_ltr" | ||
44 | (Nothing, Just RTL) -> Just "_rtl" | ||
45 | (Nothing, Just NoDirection) -> Just <| show KeywordNone | ||
46 | (Nothing, Nothing) -> Nothing | ||
47 | |||
48 | buildInverseContext :: ActiveContext -> InverseContext | ||
49 | buildInverseContext ActiveContext{..} = M.foldlWithKey (processTerm defaultLangDir) mempty activeContextTerms | ||
50 | where | ||
51 | defaultLangDir = case (activeContextDefaultBaseDirection, activeContextDefaultLanguage) of | ||
52 | (Just bd, Just (Language dl)) -> dl <> "_" <> show bd | ||
53 | (Just bd, _) -> "_" <> show bd | ||
54 | (_, _) -> show KeywordNone | ||
diff --git a/src/Data/JLD/Expansion.hs b/src/Data/JLD/Expansion.hs index beb10a3..983c126 100644 --- a/src/Data/JLD/Expansion.hs +++ b/src/Data/JLD/Expansion.hs | |||
@@ -39,7 +39,7 @@ import Data.Foldable.WithIndex (ifoldlM, iforM_) | |||
39 | import Data.RDF (parseIRI) | 39 | import Data.RDF (parseIRI) |
40 | import Data.Set qualified as S (insert, member) | 40 | import Data.Set qualified as S (insert, member) |
41 | import Data.Text qualified as T (elem, toLower) | 41 | import Data.Text qualified as T (elem, toLower) |
42 | import Data.Vector qualified as V (catMaybes, concat, cons, filter, fromList, mapMaybeM, maximum, modify, null, singleton, snoc, toList) | 42 | import Data.Vector qualified as V (catMaybes, concat, cons, filter, fromList, mapMaybeM, maximum, modify, null, snoc, toList) |
43 | import Data.Vector.Algorithms.Merge qualified as V | 43 | import Data.Vector.Algorithms.Merge qualified as V |
44 | import Text.URI (URI) | 44 | import Text.URI (URI) |
45 | 45 | ||
@@ -190,16 +190,16 @@ eo1314ExpandKeywordItem inputType key keyword value = do | |||
190 | } | 190 | } |
191 | case maybeExpandedStringValue of | 191 | case maybeExpandedStringValue of |
192 | Just expandedStringValue | 192 | Just expandedStringValue |
193 | | jldeEnvFrameExpansion -> pure <. Just <. Array <. V.singleton <| String expandedStringValue | 193 | | jldeEnvFrameExpansion -> pure <. Just <. Array <. pure <| String expandedStringValue |
194 | | otherwise -> pure <. Just <| String expandedStringValue | 194 | | otherwise -> pure <. Just <| String expandedStringValue |
195 | Nothing -> pure <| Just Null | 195 | Nothing -> pure <| Just Null |
196 | -- | 196 | -- |
197 | Object (KM.null -> True) | jldeEnvFrameExpansion -> do | 197 | Object (KM.null -> True) | jldeEnvFrameExpansion -> do |
198 | pure <. Just <. Array <. V.singleton <| Object mempty | 198 | pure <. Just <. Array <. pure <| Object mempty |
199 | -- | 199 | -- |
200 | Array (allStrings -> Just arrayValue) | jldeEnvFrameExpansion && not (V.null arrayValue) -> do | 200 | Array (allStrings -> Just arrayValue) | jldeEnvFrameExpansion && not (V.null arrayValue) -> do |
201 | Just <. Array <. V.concat <. V.toList <$> forM arrayValue \item -> do | 201 | Just <. Array <. V.concat <. V.toList <$> forM arrayValue \item -> do |
202 | V.singleton <. maybe Null String <$> eo1314ExpandIriAC item \params -> | 202 | pure <. maybe Null String <$> eo1314ExpandIriAC item \params -> |
203 | params | 203 | params |
204 | { eiParamsDocumentRelative = True | 204 | { eiParamsDocumentRelative = True |
205 | , eiParamsVocab = False | 205 | , eiParamsVocab = False |
@@ -233,7 +233,7 @@ eo1314ExpandKeywordItem inputType key keyword value = do | |||
233 | -- 13.4.4.4. | 233 | -- 13.4.4.4. |
234 | Array (allStrings -> Just arrayValue) -> | 234 | Array (allStrings -> Just arrayValue) -> |
235 | Array <. V.concat <. V.toList <$> forM arrayValue \item -> do | 235 | Array <. V.concat <. V.toList <$> forM arrayValue \item -> do |
236 | V.singleton <. maybe Null String <$> eo1314ExpandIriTC item \params -> | 236 | pure <. maybe Null String <$> eo1314ExpandIriTC item \params -> |
237 | params | 237 | params |
238 | { eiParamsDocumentRelative = True | 238 | { eiParamsDocumentRelative = True |
239 | , eiParamsVocab = True | 239 | , eiParamsVocab = True |
@@ -264,7 +264,7 @@ eo1314ExpandKeywordItem inputType key keyword value = do | |||
264 | -- 13.4.6.4. | 264 | -- 13.4.6.4. |
265 | gets <| eo1314StateResult .> KM.lookup (show KeywordIncluded) .> \case | 265 | gets <| eo1314StateResult .> KM.lookup (show KeywordIncluded) .> \case |
266 | Just (Array includedValue) -> Just <. Array <| includedValue <> expandedValue | 266 | Just (Array includedValue) -> Just <. Array <| includedValue <> expandedValue |
267 | Just includedValue -> Just <. Array <| V.singleton includedValue <> expandedValue | 267 | Just includedValue -> Just <. Array <| pure includedValue <> expandedValue |
268 | Nothing -> Just <| Array expandedValue | 268 | Nothing -> Just <| Array expandedValue |
269 | -- 13.4.7. | 269 | -- 13.4.7. |
270 | KeywordValue -> do | 270 | KeywordValue -> do |
@@ -277,9 +277,9 @@ eo1314ExpandKeywordItem inputType key keyword value = do | |||
277 | -- 13.4.7.2. | 277 | -- 13.4.7.2. |
278 | _ | value == Null || valueIsScalar value -> do | 278 | _ | value == Null || valueIsScalar value -> do |
279 | if jldeEnvFrameExpansion | 279 | if jldeEnvFrameExpansion |
280 | then pure <. Array <| V.singleton value | 280 | then pure <. Array <| pure value |
281 | else pure value | 281 | else pure value |
282 | Object (KM.null -> True) | jldeEnvFrameExpansion -> pure <. Array <| V.singleton value | 282 | Object (KM.null -> True) | jldeEnvFrameExpansion -> pure <. Array <| pure value |
283 | Array (all valueIsString -> True) | jldeEnvFrameExpansion -> pure value | 283 | Array (all valueIsString -> True) | jldeEnvFrameExpansion -> pure value |
284 | -- | 284 | -- |
285 | _ -> throwError InvalidValueObjectValue | 285 | _ -> throwError InvalidValueObjectValue |
@@ -291,7 +291,7 @@ eo1314ExpandKeywordItem inputType key keyword value = do | |||
291 | -- 13.4.8. | 291 | -- 13.4.8. |
292 | KeywordLanguage -> case value of | 292 | KeywordLanguage -> case value of |
293 | String stringValue | 293 | String stringValue |
294 | | jldeEnvFrameExpansion -> pure <. Just <. Array <. V.singleton <. String <| T.toLower stringValue | 294 | | jldeEnvFrameExpansion -> pure <. Just <. Array <. pure <. String <| T.toLower stringValue |
295 | | otherwise -> pure <. Just <. String <| T.toLower stringValue | 295 | | otherwise -> pure <. Just <. String <| T.toLower stringValue |
296 | Object (KM.null -> True) | jldeEnvFrameExpansion -> pure <| Just value | 296 | Object (KM.null -> True) | jldeEnvFrameExpansion -> pure <| Just value |
297 | Array (all valueIsString -> True) | jldeEnvFrameExpansion -> pure <| Just value | 297 | Array (all valueIsString -> True) | jldeEnvFrameExpansion -> pure <| Just value |
@@ -301,7 +301,7 @@ eo1314ExpandKeywordItem inputType key keyword value = do | |||
301 | | JLD1_0 <- jldExpansionEnvProcessingMode -> pure Nothing | 301 | | JLD1_0 <- jldExpansionEnvProcessingMode -> pure Nothing |
302 | | otherwise -> case value of | 302 | | otherwise -> case value of |
303 | String ((`elem` ["ltr", "rtl"]) -> True) | 303 | String ((`elem` ["ltr", "rtl"]) -> True) |
304 | | jldeEnvFrameExpansion -> pure <. Just <. Array <| V.singleton value | 304 | | jldeEnvFrameExpansion -> pure <. Just <. Array <| pure value |
305 | | otherwise -> pure <| Just value | 305 | | otherwise -> pure <| Just value |
306 | Object (KM.null -> True) | jldeEnvFrameExpansion -> pure <| Just value | 306 | Object (KM.null -> True) | jldeEnvFrameExpansion -> pure <| Just value |
307 | Array (all valueIsString -> True) | jldeEnvFrameExpansion -> pure <| Just value | 307 | Array (all valueIsString -> True) | jldeEnvFrameExpansion -> pure <| Just value |
@@ -319,7 +319,7 @@ eo1314ExpandKeywordItem inputType key keyword value = do | |||
319 | expandedValue <- eo1314ExpandAC jldeEnvActiveProperty value id | 319 | expandedValue <- eo1314ExpandAC jldeEnvActiveProperty value id |
320 | case expandedValue of | 320 | case expandedValue of |
321 | Array _ -> pure <| Just expandedValue | 321 | Array _ -> pure <| Just expandedValue |
322 | _ -> pure <. Just <. Array <| V.singleton expandedValue | 322 | _ -> pure <. Just <. Array <| pure expandedValue |
323 | -- 13.4.12. | 323 | -- 13.4.12. |
324 | KeywordSet -> Just <$> eo1314ExpandAC jldeEnvActiveProperty value id | 324 | KeywordSet -> Just <$> eo1314ExpandAC jldeEnvActiveProperty value id |
325 | -- 13.4.13. | 325 | -- 13.4.13. |
@@ -491,7 +491,7 @@ eo1314ExpandNonKeywordItem key expandedProperty value = do | |||
491 | let maybeExistingValues = expandedIndexKey >>= (`KM.lookup` item) | 491 | let maybeExistingValues = expandedIndexKey >>= (`KM.lookup` item) |
492 | 492 | ||
493 | indexPropertyValues = | 493 | indexPropertyValues = |
494 | V.singleton (Object reExpandedIndex) | 494 | pure (Object reExpandedIndex) |
495 | |> case maybeExistingValues of | 495 | |> case maybeExistingValues of |
496 | Just (Array existingValues) -> (<> existingValues) | 496 | Just (Array existingValues) -> (<> existingValues) |
497 | Just existingValue -> (`V.snoc` existingValue) | 497 | Just existingValue -> (`V.snoc` existingValue) |
@@ -526,7 +526,7 @@ eo1314ExpandNonKeywordItem key expandedProperty value = do | |||
526 | , expandedIndex /= show KeywordNone -> do | 526 | , expandedIndex /= show KeywordNone -> do |
527 | let types = case KM.lookup (show KeywordType) item of | 527 | let types = case KM.lookup (show KeywordType) item of |
528 | Just existingType -> V.cons expandedIndex <| valueToArray existingType | 528 | Just existingType -> V.cons expandedIndex <| valueToArray existingType |
529 | Nothing -> V.singleton expandedIndex | 529 | Nothing -> pure expandedIndex |
530 | pure <. KM.insert (show KeywordType) (Array types) <| item | 530 | pure <. KM.insert (show KeywordType) (Array types) <| item |
531 | -- 13.8.3.7.6. | 531 | -- 13.8.3.7.6. |
532 | | otherwise -> pure item | 532 | | otherwise -> pure item |
@@ -755,7 +755,7 @@ expandObject maybePropertyContext value = do | |||
755 | | Just resultType <- KM.lookup (show KeywordType) result -> | 755 | | Just resultType <- KM.lookup (show KeywordType) result -> |
756 | eoNormalizeObject | 756 | eoNormalizeObject |
757 | <| if valueIsNotArray resultType && resultType /= Null | 757 | <| if valueIsNotArray resultType && resultType /= Null |
758 | then KM.insert (show KeywordType) (Array <| V.singleton resultType) result | 758 | then KM.insert (show KeywordType) (Array <| pure resultType) result |
759 | else result | 759 | else result |
760 | -- 17. | 760 | -- 17. |
761 | | KM.member (show KeywordList) result || KM.member (show KeywordSet) result -> do | 761 | | KM.member (show KeywordList) result || KM.member (show KeywordSet) result -> do |
@@ -793,7 +793,7 @@ expandArrayItem item = do | |||
793 | -- 5.2.3. | 793 | -- 5.2.3. |
794 | Array a -> pure <| V.filter (/= Null) a | 794 | Array a -> pure <| V.filter (/= Null) a |
795 | Null -> pure mempty | 795 | Null -> pure mempty |
796 | _ -> pure <| V.singleton item'' | 796 | _ -> pure <| pure item'' |
797 | 797 | ||
798 | -- | 798 | -- |
799 | 799 | ||
diff --git a/src/Data/JLD/Expansion/Context.hs b/src/Data/JLD/Expansion/Context.hs index 99daba0..21350c8 100644 --- a/src/Data/JLD/Expansion/Context.hs +++ b/src/Data/JLD/Expansion/Context.hs | |||
@@ -96,8 +96,8 @@ bacBuildActiveContext context uri = do | |||
96 | activeContext' <- | 96 | activeContext' <- |
97 | buildActiveContext activeContext context (Just uri) params | 97 | buildActiveContext activeContext context (Just uri) params |
98 | |> withEnvRES (const bacEnvGlobal) | 98 | |> withEnvRES (const bacEnvGlobal) |
99 | |> withErrorRES Left | 99 | .> withErrorRES Left |
100 | |> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global}) | 100 | .> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global}) |
101 | bacModifyActiveContext <| const activeContext' | 101 | bacModifyActiveContext <| const activeContext' |
102 | 102 | ||
103 | bacProcessItem :: Monad m => Maybe URI -> Value -> BACT e m () | 103 | bacProcessItem :: Monad m => Maybe URI -> Value -> BACT e m () |
@@ -200,8 +200,8 @@ bacProcessItem baseUrl item = do | |||
200 | (maybeVocabMapping, activeContext', _) <- | 200 | (maybeVocabMapping, activeContext', _) <- |
201 | expandIri activeContext value params | 201 | expandIri activeContext value params |
202 | |> withEnvRES (const bacEnvGlobal) | 202 | |> withEnvRES (const bacEnvGlobal) |
203 | |> withErrorRES Left | 203 | .> withErrorRES Left |
204 | |> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global}) | 204 | .> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global}) |
205 | bacModifyActiveContext <| const activeContext' | 205 | bacModifyActiveContext <| const activeContext' |
206 | 206 | ||
207 | case maybeVocabMapping of | 207 | case maybeVocabMapping of |
@@ -218,7 +218,7 @@ bacProcessItem baseUrl item = do | |||
218 | -- 5.9.2. | 218 | -- 5.9.2. |
219 | Just Null -> bacModifyActiveContext \ac -> ac{activeContextDefaultLanguage = Just NoLanguage} | 219 | Just Null -> bacModifyActiveContext \ac -> ac{activeContextDefaultLanguage = Just NoLanguage} |
220 | -- 5.9.3. | 220 | -- 5.9.3. |
221 | Just (String language) -> bacModifyActiveContext \ac -> ac{activeContextDefaultLanguage = Just <| Language language} | 221 | Just (String language) -> bacModifyActiveContext \ac -> ac{activeContextDefaultLanguage = Just <. Language <| T.toLower language} |
222 | Just _ -> throwError <| Left InvalidDefaultLanguage | 222 | Just _ -> throwError <| Left InvalidDefaultLanguage |
223 | -- | 223 | -- |
224 | Nothing -> pure () | 224 | Nothing -> pure () |
@@ -345,8 +345,8 @@ buildActiveContext activeContext localContext baseUrl paramsFn = do | |||
345 | BACState{..} <- | 345 | BACState{..} <- |
346 | (buildActiveContext' localContext baseUrl >> get) | 346 | (buildActiveContext' localContext baseUrl >> get) |
347 | |> withEnvRES env | 347 | |> withEnvRES env |
348 | |> withErrorRES' (either throwError (const get)) | 348 | .> withErrorRES' (either throwError (const get)) |
349 | |> withStateRES st (const bacStateGlobal) | 349 | .> withStateRES st (const bacStateGlobal) |
350 | pure bacStateActiveContext | 350 | pure bacStateActiveContext |
351 | where | 351 | where |
352 | BACParams{..} = | 352 | BACParams{..} = |
@@ -504,7 +504,7 @@ expandIri activeContext value paramsFn = do | |||
504 | (value', EIState{..}) <- | 504 | (value', EIState{..}) <- |
505 | (expandIri' value >>= \v -> gets (v,)) | 505 | (expandIri' value >>= \v -> gets (v,)) |
506 | |> withEnvRES env | 506 | |> withEnvRES env |
507 | |> withStateRES st (const eiStateGlobal) | 507 | .> withStateRES st (const eiStateGlobal) |
508 | pure (value', eiStateActiveContext, eiStateDefined) | 508 | pure (value', eiStateActiveContext, eiStateDefined) |
509 | where | 509 | where |
510 | EIParams{..} = | 510 | EIParams{..} = |
@@ -616,8 +616,8 @@ btdExpandIri value = do | |||
616 | (expanded, activeContext', defined') <- | 616 | (expanded, activeContext', defined') <- |
617 | expandIri activeContext value params | 617 | expandIri activeContext value params |
618 | |> withEnvRES (const btdEnvGlobal) | 618 | |> withEnvRES (const btdEnvGlobal) |
619 | |> withErrorRES Left | 619 | .> withErrorRES Left |
620 | |> withStateRES btdStateGlobal (\btd global -> btd{btdStateGlobal = global}) | 620 | .> withStateRES btdStateGlobal (\btd global -> btd{btdStateGlobal = global}) |
621 | modify \s -> | 621 | modify \s -> |
622 | s | 622 | s |
623 | { btdStateActiveContext = activeContext' | 623 | { btdStateActiveContext = activeContext' |
@@ -634,8 +634,8 @@ btdBuildTermDefinition term = do | |||
634 | (activeContext', defined') <- | 634 | (activeContext', defined') <- |
635 | buildTermDefinition activeContext btdEnvLocalContext term params | 635 | buildTermDefinition activeContext btdEnvLocalContext term params |
636 | |> withEnvRES (const btdEnvGlobal) | 636 | |> withEnvRES (const btdEnvGlobal) |
637 | |> withErrorRES Left | 637 | .> withErrorRES Left |
638 | |> withStateRES btdStateGlobal (\btd global -> btd{btdStateGlobal = global}) | 638 | .> withStateRES btdStateGlobal (\btd global -> btd{btdStateGlobal = global}) |
639 | modify \env -> | 639 | modify \env -> |
640 | env | 640 | env |
641 | { btdStateActiveContext = activeContext' | 641 | { btdStateActiveContext = activeContext' |
@@ -891,9 +891,9 @@ buildTermDefinition' term = do | |||
891 | } | 891 | } |
892 | buildActiveContext activeContext context btdEnvBaseUrl params | 892 | buildActiveContext activeContext context btdEnvBaseUrl params |
893 | |> withEnvRES (const btdEnvGlobal) | 893 | |> withEnvRES (const btdEnvGlobal) |
894 | |> withStateRES btdStateGlobal (\btd global -> btd{btdStateGlobal = global}) | 894 | .> withStateRES btdStateGlobal (\btd global -> btd{btdStateGlobal = global}) |
895 | |> withErrorRES (const <| Left InvalidScopedContext) | 895 | .> withErrorRES (const <| Left InvalidScopedContext) |
896 | |> void | 896 | .> void |
897 | 897 | ||
898 | -- 21.4. | 898 | -- 21.4. |
899 | btdModifyTermDefinition \d -> | 899 | btdModifyTermDefinition \d -> |
@@ -909,7 +909,7 @@ buildTermDefinition' term = do | |||
909 | -- 22. | 909 | -- 22. |
910 | case KM.lookup (show KeywordLanguage) valueObject of | 910 | case KM.lookup (show KeywordLanguage) valueObject of |
911 | Just Null -> btdModifyTermDefinition \d -> d{termDefinitionLanguageMapping = Just NoLanguage} | 911 | Just Null -> btdModifyTermDefinition \d -> d{termDefinitionLanguageMapping = Just NoLanguage} |
912 | Just (String language) -> btdModifyTermDefinition \d -> d{termDefinitionLanguageMapping = Just <| Language language} | 912 | Just (String language) -> btdModifyTermDefinition \d -> d{termDefinitionLanguageMapping = Just <. Language <| T.toLower language} |
913 | Just _ -> throwError <| Left InvalidLanguageMapping | 913 | Just _ -> throwError <| Left InvalidLanguageMapping |
914 | Nothing -> pure () | 914 | Nothing -> pure () |
915 | 915 | ||
@@ -985,8 +985,8 @@ buildTermDefinition activeContext localContext term paramsFn = do | |||
985 | BTDState{..} <- | 985 | BTDState{..} <- |
986 | (buildTermDefinition' term >> get) | 986 | (buildTermDefinition' term >> get) |
987 | |> withEnvRES env | 987 | |> withEnvRES env |
988 | |> withErrorRES' (either throwError (const get)) | 988 | .> withErrorRES' (either throwError (const get)) |
989 | |> withStateRES st (const btdStateGlobal) | 989 | .> withStateRES st (const btdStateGlobal) |
990 | pure (btdStateActiveContext, btdStateDefined) | 990 | pure (btdStateActiveContext, btdStateDefined) |
991 | where | 991 | where |
992 | BTDParams{..} = | 992 | BTDParams{..} = |
diff --git a/src/Data/JLD/Flattening/NodeMap.hs b/src/Data/JLD/Flattening/NodeMap.hs index 06af2d4..ef09757 100644 --- a/src/Data/JLD/Flattening/NodeMap.hs +++ b/src/Data/JLD/Flattening/NodeMap.hs | |||
@@ -18,7 +18,7 @@ import Data.Aeson.Key qualified as K (toText) | |||
18 | import Data.Aeson.KeyMap qualified as KM (filterWithKey, insert, lookup, member, singleton) | 18 | import Data.Aeson.KeyMap qualified as KM (filterWithKey, insert, lookup, member, singleton) |
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 (snoc, uniq) |
22 | 22 | ||
23 | type BNMT e m = REST BNMEnv (Either (JLDError e) ()) BNMState m | 23 | type BNMT e m = REST BNMEnv (Either (JLDError e) ()) BNMState m |
24 | 24 | ||
@@ -133,7 +133,7 @@ buildNodeMap' element = case element of | |||
133 | N.insert bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty (Array <| V.snoc activePropertyValue element) nodeMap | 133 | N.insert bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty (Array <| V.snoc activePropertyValue element) nodeMap |
134 | | otherwise -> nodeMap | 134 | | otherwise -> nodeMap |
135 | -- 4.2.2 | 135 | -- 4.2.2 |
136 | _ -> N.insert bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty (Array <| V.singleton element) nodeMap | 136 | _ -> N.insert bnmEnvActiveGraph bnmEnvActiveSubject bnmEnvActiveProperty (Array <| pure element) nodeMap |
137 | -- 4.2. | 137 | -- 4.2. |
138 | Just list -> bnmModifyList <. const <. Just <| V.snoc list element | 138 | Just list -> bnmModifyList <. const <. Just <| V.snoc list element |
139 | -- 5. | 139 | -- 5. |
diff --git a/src/Data/JLD/Model/ActiveContext.hs b/src/Data/JLD/Model/ActiveContext.hs index 5423036..f2118c4 100644 --- a/src/Data/JLD/Model/ActiveContext.hs +++ b/src/Data/JLD/Model/ActiveContext.hs | |||
@@ -1,4 +1,4 @@ | |||
1 | module Data.JLD.Model.ActiveContext ( ActiveContext (..), newActiveContext, lookupTerm, containsProtectedTerm,) where | 1 | module Data.JLD.Model.ActiveContext (ActiveContext (..), newActiveContext, lookupTerm, containsProtectedTerm) where |
2 | 2 | ||
3 | import Data.JLD.Prelude | 3 | import Data.JLD.Prelude |
4 | 4 | ||
@@ -15,7 +15,7 @@ data ActiveContext = ActiveContext | |||
15 | { activeContextTerms :: Map Text TermDefinition | 15 | { activeContextTerms :: Map Text TermDefinition |
16 | , activeContextBaseIri :: Maybe IRIRef | 16 | , activeContextBaseIri :: Maybe IRIRef |
17 | , activeContextBaseUrl :: Maybe URI | 17 | , activeContextBaseUrl :: Maybe URI |
18 | , activeContextInverseContext :: InverseContext | 18 | , activeContextInverseContext :: Maybe InverseContext |
19 | , activeContextPreviousContext :: Maybe ActiveContext | 19 | , activeContextPreviousContext :: Maybe ActiveContext |
20 | , activeContextVocabularyMapping :: Maybe Text | 20 | , activeContextVocabularyMapping :: Maybe Text |
21 | , activeContextDefaultLanguage :: Maybe Language | 21 | , activeContextDefaultLanguage :: Maybe Language |
@@ -30,7 +30,7 @@ newActiveContext fn = | |||
30 | { activeContextTerms = mempty | 30 | { activeContextTerms = mempty |
31 | , activeContextBaseIri = Nothing | 31 | , activeContextBaseIri = Nothing |
32 | , activeContextBaseUrl = Nothing | 32 | , activeContextBaseUrl = Nothing |
33 | , activeContextInverseContext = mempty | 33 | , activeContextInverseContext = Nothing |
34 | , activeContextPreviousContext = Nothing | 34 | , activeContextPreviousContext = Nothing |
35 | , activeContextVocabularyMapping = Nothing | 35 | , activeContextVocabularyMapping = Nothing |
36 | , activeContextDefaultLanguage = Nothing | 36 | , activeContextDefaultLanguage = Nothing |
diff --git a/src/Data/JLD/Model/GraphObject.hs b/src/Data/JLD/Model/GraphObject.hs index 3db9e6b..4d7d3ad 100644 --- a/src/Data/JLD/Model/GraphObject.hs +++ b/src/Data/JLD/Model/GraphObject.hs | |||
@@ -1,4 +1,4 @@ | |||
1 | module Data.JLD.Model.GraphObject (isGraphObject, isNotGraphObject, toGraphObject) where | 1 | module Data.JLD.Model.GraphObject (isGraphObject, isGraphObject', isNotGraphObject, isNotGraphObject', toGraphObject) where |
2 | 2 | ||
3 | import Data.JLD.Prelude | 3 | import Data.JLD.Prelude |
4 | 4 | ||
@@ -6,17 +6,22 @@ import Data.JLD.Model.Keyword (Keyword (..), isKeyword) | |||
6 | 6 | ||
7 | import Data.Aeson (Object, Value (..)) | 7 | import Data.Aeson (Object, Value (..)) |
8 | import Data.Aeson.Key qualified as K (toText) | 8 | import Data.Aeson.Key qualified as K (toText) |
9 | import Data.Aeson.KeyMap qualified as KM (keys, singleton, member) | 9 | import Data.Aeson.KeyMap qualified as KM (keys, member, singleton) |
10 | import Data.Vector qualified as V (singleton) | ||
11 | 10 | ||
12 | isGraphObject :: Value -> Bool | 11 | isGraphObject :: Value -> Bool |
13 | isGraphObject (Object o) | 12 | isGraphObject (Object o) = isGraphObject' o |
14 | | KM.member (show KeywordGraph) o = | ||
15 | all (`isKeyword` [KeywordGraph, KeywordId, KeywordIndex, KeywordContext]) (K.toText <$> KM.keys o) | ||
16 | isGraphObject _ = False | 13 | isGraphObject _ = False |
17 | 14 | ||
15 | isGraphObject' :: Object -> Bool | ||
16 | isGraphObject' o = | ||
17 | KM.member (show KeywordGraph) o | ||
18 | && all (`isKeyword` [KeywordGraph, KeywordId, KeywordIndex, KeywordContext]) (K.toText <$> KM.keys o) | ||
19 | |||
18 | isNotGraphObject :: Value -> Bool | 20 | isNotGraphObject :: Value -> Bool |
19 | isNotGraphObject = isGraphObject .> not | 21 | isNotGraphObject = isGraphObject .> not |
20 | 22 | ||
23 | isNotGraphObject' :: Object -> Bool | ||
24 | isNotGraphObject' = isGraphObject' .> not | ||
25 | |||
21 | toGraphObject :: Value -> Object | 26 | toGraphObject :: Value -> Object |
22 | toGraphObject = V.singleton .> Array .> KM.singleton (show KeywordGraph) | 27 | toGraphObject = pure .> Array .> KM.singleton (show KeywordGraph) |
diff --git a/src/Data/JLD/Model/ListObject.hs b/src/Data/JLD/Model/ListObject.hs index 8dda349..6277d24 100644 --- a/src/Data/JLD/Model/ListObject.hs +++ b/src/Data/JLD/Model/ListObject.hs | |||
@@ -1,24 +1,26 @@ | |||
1 | module Data.JLD.Model.ListObject (isListObject, isNotListObject, toListObject) where | 1 | module Data.JLD.Model.ListObject (isListObject, isListObject', isNotListObject, toListObject) where |
2 | 2 | ||
3 | import Data.JLD.Prelude | 3 | import Data.JLD.Prelude |
4 | 4 | ||
5 | import Data.JLD.Model.Keyword (Keyword (..)) | 5 | import Data.JLD.Model.Keyword (Keyword (..)) |
6 | 6 | ||
7 | import Data.Aeson (Value (..)) | 7 | import Data.Aeson (Object, Value (..)) |
8 | import Data.Aeson.KeyMap qualified as KM | 8 | import Data.Aeson.KeyMap qualified as KM (member, singleton, size) |
9 | import Data.Vector qualified as V | ||
10 | 9 | ||
11 | isListObject :: Value -> Bool | 10 | isListObject :: Value -> Bool |
12 | isListObject (Object o) = | 11 | isListObject (Object o) = isListObject' o |
12 | isListObject _ = False | ||
13 | |||
14 | isListObject' :: Object -> Bool | ||
15 | isListObject' o = | ||
13 | KM.member (show KeywordList) o | 16 | KM.member (show KeywordList) o |
14 | && ( KM.size o == 1 | 17 | && ( KM.size o == 1 |
15 | || (KM.size o == 2 && KM.member (show KeywordIndex) o) | 18 | || (KM.size o == 2 && KM.member (show KeywordIndex) o) |
16 | ) | 19 | ) |
17 | isListObject _ = False | ||
18 | 20 | ||
19 | isNotListObject :: Value -> Bool | 21 | isNotListObject :: Value -> Bool |
20 | isNotListObject = isListObject .> not | 22 | isNotListObject = isListObject .> not |
21 | 23 | ||
22 | toListObject :: Value -> Value | 24 | toListObject :: Value -> Value |
23 | toListObject value@(Array _) = Object <| KM.singleton (show KeywordList) value | 25 | toListObject value@(Array _) = Object <| KM.singleton (show KeywordList) value |
24 | toListObject value = Object <| KM.singleton (show KeywordList) (Array <| V.singleton value) | 26 | toListObject value = Object <| KM.singleton (show KeywordList) (Array <| pure value) |
diff --git a/src/Data/JLD/Util.hs b/src/Data/JLD/Util.hs index 26b2755..8d84778 100644 --- a/src/Data/JLD/Util.hs +++ b/src/Data/JLD/Util.hs | |||
@@ -25,7 +25,7 @@ import Data.Aeson.KeyMap qualified as KM (insert, lookup, member) | |||
25 | import Data.Foldable qualified as F (Foldable (..), elem) | 25 | import Data.Foldable qualified as F (Foldable (..), elem) |
26 | import Data.Foldable.WithIndex (FoldableWithIndex (..), ifoldlM) | 26 | import Data.Foldable.WithIndex (FoldableWithIndex (..), ifoldlM) |
27 | import Data.Vector (Vector) | 27 | import Data.Vector (Vector) |
28 | import Data.Vector qualified as V (filter, fromList, null, singleton, snoc, uncons) | 28 | import Data.Vector qualified as V (filter, fromList, null, snoc, uncons) |
29 | 29 | ||
30 | valueContains :: Text -> Value -> Bool | 30 | valueContains :: Text -> Value -> Bool |
31 | valueContains text = \case | 31 | valueContains text = \case |
@@ -78,13 +78,13 @@ flattenSingletonArray = \case | |||
78 | valueToArray :: Value -> Array | 78 | valueToArray :: Value -> Array |
79 | valueToArray = \case | 79 | valueToArray = \case |
80 | Array a -> a | 80 | Array a -> a |
81 | value -> V.singleton value | 81 | value -> pure value |
82 | 82 | ||
83 | valueToNonNullArray :: Value -> Array | 83 | valueToNonNullArray :: Value -> Array |
84 | valueToNonNullArray = \case | 84 | valueToNonNullArray = \case |
85 | Null -> mempty | 85 | Null -> mempty |
86 | Array a -> V.filter (/= Null) a | 86 | Array a -> V.filter (/= Null) a |
87 | value -> V.singleton value | 87 | value -> pure value |
88 | 88 | ||
89 | allStrings :: Array -> Maybe (Vector Text) | 89 | allStrings :: Array -> Maybe (Vector Text) |
90 | allStrings = foldl' go (Just mempty) | 90 | allStrings = foldl' go (Just mempty) |
@@ -106,7 +106,7 @@ mapAddValue key value True object = mapAddValue key value False <| KM.insert key | |||
106 | where | 106 | where |
107 | array = case KM.lookup key object of | 107 | array = case KM.lookup key object of |
108 | Just (Array a) -> a | 108 | Just (Array a) -> a |
109 | Just original -> V.singleton original | 109 | Just original -> pure original |
110 | Nothing -> mempty | 110 | Nothing -> mempty |
111 | mapAddValue key (Array value) False object = foldl' (\o v -> mapAddValue key v False o) object value | 111 | mapAddValue key (Array value) False object = foldl' (\o v -> mapAddValue key v False o) object value |
112 | mapAddValue key value False object = case KM.lookup key object of | 112 | mapAddValue key value False object = case KM.lookup key object of |