1
+ {-# LANGUAGE MultiWayIf #-}
1
2
{- |
2
3
Copyright : (c) Runtime Verification, 2023
3
4
License : BSD-3-Clause
@@ -24,12 +25,14 @@ import Data.Map (Map)
24
25
import Data.Map qualified as Map
25
26
import Data.Set qualified as Set
26
27
import Data.Text (Text )
28
+ import Data.Text qualified as Text
27
29
import Prettyprinter (pretty , vsep )
28
30
import Text.Read (readMaybe )
29
31
30
32
import Booster.Definition.Attributes.Base (
31
33
KCollectionSymbolNames (.. ),
32
34
KListDefinition (.. ),
35
+ KMapDefinition (.. ),
33
36
)
34
37
import Booster.Pattern.Base
35
38
import Booster.Pattern.Bool
@@ -206,6 +209,7 @@ builtinsMAP =
206
209
Map. mapKeys (" MAP." <> ) $
207
210
Map. fromList
208
211
[ " update" ~~> mapUpdateHook
212
+ , " updateAll" ~~> mapUpdateAllHook
209
213
, " remove" ~~> mapRemoveHook
210
214
, -- removeAll: requires a Set argument
211
215
" size" ~~> mapSizeHook
@@ -238,6 +242,45 @@ mapUpdateHook args
238
242
| otherwise =
239
243
throwE . renderText $ " MAP.update: wrong arity " <> pretty (length args)
240
244
245
+ mapUpdateAllHook :: BuiltinFunction
246
+ mapUpdateAllHook [KMap def1 _ _, KMap def2 _ _]
247
+ | def1 /= def2 =
248
+ throwE $
249
+ " MAP.updateAll: incompatible maps " <>
250
+ Text. pack (show (def1. mapSortName, def2. mapSortName))
251
+ mapUpdateAllHook [original, KMap _ [] Nothing ] =
252
+ -- updates map is empty, result is original map
253
+ pure $ Just original
254
+ mapUpdateAllHook [KMap _ [] Nothing , updates] =
255
+ -- original map is empty, result is updates map
256
+ pure $ Just updates
257
+ mapUpdateAllHook [KMap _ _ (Just _), _updates] =
258
+ -- indeterminate part in original map, leave unevaluated
259
+ pure Nothing
260
+ mapUpdateAllHook [KMap def pairs1 Nothing , KMap _ pairs2 mbRest2]
261
+ -- performing the update requires all keys to be fully evaluated
262
+ -- (constructor-like) or syntactically equal.
263
+ | Set. null origKeys = -- all keys in the original map were updated (syntactically)
264
+ pure $ Just $ KMap def updated mbRest2
265
+ | Set. null updateKeys
266
+ , Nothing <- mbRest2 = -- all update keys were (syntactically) present
267
+ pure $ Just $ KMap def updated Nothing
268
+ | all isConstructorLike_ (updateKeys <> origKeys)
269
+ , Nothing <- mbRest2 = -- all untouched or added keys are fully evaluated
270
+ pure $ Just $ KMap def updated Nothing
271
+ | otherwise = -- uncertain whether all keys updated, leave unevaluated
272
+ pure Nothing
273
+ where
274
+ orig = Map. fromList pairs1
275
+ update = Map. fromList pairs2
276
+ updated = Map. assocs $ Map. unionWith (\ _ u -> u) orig update
277
+ origKeys = Set. difference (Map. keysSet orig) (Map. keysSet update)
278
+ updateKeys = Set. difference (Map. keysSet update) (Map. keysSet orig)
279
+ mapUpdateAllHook [_, _] =
280
+ pure Nothing -- at least one argument not an internalised map, leave unevaluated
281
+ mapUpdateAllHook args =
282
+ throwE . renderText $ " MAP.update: wrong arity " <> pretty (length args)
283
+
241
284
mapRemoveHook :: BuiltinFunction
242
285
mapRemoveHook args
243
286
| [m@ (KMap def pairs mbRest), key] <- args = do
0 commit comments