Skip to content

Commit ca05e66

Browse files
jbertholdjberthold
committed
implement more Map hooks and LIST.get
1 parent 530d574 commit ca05e66

File tree

1 file changed

+175
-30
lines changed

1 file changed

+175
-30
lines changed

‎booster/library/Booster/Builtin.hs

Lines changed: 175 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -22,10 +22,15 @@ import Data.ByteString.Char8 (ByteString, pack, unpack)
2222
import Data.List (findIndex, partition)
2323
import Data.Map (Map)
2424
import Data.Map qualified as Map
25+
import Data.Set qualified as Set
2526
import Data.Text (Text)
2627
import Prettyprinter (pretty, vsep)
2728
import Text.Read (readMaybe)
2829

30+
import Booster.Definition.Attributes.Base (
31+
KCollectionSymbolNames (..),
32+
KListDefinition (..),
33+
)
2934
import Booster.Pattern.Base
3035
import Booster.Pattern.Bool
3136
import Booster.Pattern.Util
@@ -62,6 +67,9 @@ t `shouldHaveSort` s
6267
, pretty t
6368
]
6469

70+
isConstructorLike_ :: Term -> Bool
71+
isConstructorLike_ = (.isConstructorLike) . getAttributes
72+
6573
------------------------------------------------------------
6674
-- BOOL hooks
6775

@@ -197,23 +205,78 @@ builtinsMAP :: Map ByteString BuiltinFunction
197205
builtinsMAP =
198206
Map.mapKeys ("MAP." <>) $
199207
Map.fromList
200-
[ "lookup" ~~> mapLookupHook
208+
[ "update" ~~> mapUpdateHook
209+
, "remove" ~~> mapRemoveHook
210+
, -- removeAll: requires a Set argument
211+
"size" ~~> mapSizeHook
212+
, "lookup" ~~> mapLookupHook
201213
, "lookupOrDefault" ~~> mapLookupOrDefaultHook
202214
, "in_keys" ~~> mapInKeysHook
203-
, "update" ~~> mapUpdateHook
215+
, -- keys: requires internal Set construction
216+
"keys_list" ~~> mapKeysListHook
217+
, "values" ~~> mapValuesHook
218+
, "inclusion" ~~> mapInclusionHook
204219
]
205220

221+
mapUpdateHook :: BuiltinFunction
222+
mapUpdateHook args
223+
| [KMap def pairs mbRest, key, newValue] <- args = do
224+
case findIndex ((== key) . fst) pairs of
225+
Just idx ->
226+
-- key was found (syntactically), update pairs list
227+
let newPairs = take idx pairs <> ((key, newValue) : drop (idx + 1) pairs)
228+
in pure $ Just $ KMap def newPairs mbRest
229+
Nothing -- key could be in unevaluated or opaque part
230+
| Just _ <- mbRest ->
231+
pure Nothing -- have opaque part, no result
232+
| any (not . isConstructorLike_ . fst) pairs ->
233+
pure Nothing -- have unevaluated keys, no result
234+
| otherwise -> -- key certain to be absent, no rest: add pair
235+
pure $ Just $ KMap def ((key, newValue) : pairs) Nothing
236+
| [_other, _, _] <- args =
237+
pure Nothing -- not an internalised map, maybe a function call
238+
| otherwise =
239+
throwE . renderText $ "MAP.update: wrong arity " <> pretty (length args)
240+
241+
mapRemoveHook :: BuiltinFunction
242+
mapRemoveHook args
243+
| [m@(KMap def pairs mbRest), key] <- args = do
244+
case findIndex ((== key) . fst) pairs of
245+
Just idx ->
246+
-- key was found (syntactically), remove it
247+
let newPairs = take idx pairs <> drop (idx + 1) pairs
248+
in pure $ Just $ KMap def newPairs mbRest
249+
Nothing -- key could be in unevaluated or opaque part
250+
| Just _ <- mbRest ->
251+
pure Nothing -- have opaque part, no result
252+
| any (not . isConstructorLike_ . fst) pairs ->
253+
pure Nothing -- have unevaluated keys, no result
254+
| otherwise -> -- key certain to be absent, no rest: map unchanged
255+
pure $ Just m
256+
| [_other, _] <- args =
257+
pure Nothing -- not an internalised map, maybe a function call
258+
| otherwise =
259+
throwE . renderText $ "MAP.remove: wrong arity " <> pretty (length args)
260+
261+
mapSizeHook :: BuiltinFunction
262+
mapSizeHook args
263+
| [KMap _ pairs Nothing] <- args =
264+
-- no opaque part, size is association count
265+
pure $ Just $ intTerm (fromIntegral $ length pairs)
266+
| [_other, _] <- args =
267+
pure Nothing -- not an internalised map, maybe a function call
268+
| otherwise =
269+
throwE . renderText $ "MAP.lookup: wrong arity " <> pretty (length args)
270+
206271
mapLookupHook :: BuiltinFunction
207272
mapLookupHook args
208273
| [KMap _ pairs _mbRest, key] <- args =
209274
-- if the key is not found, return Nothing (no result),
210275
-- regardless of whether the key _could_ still be there.
211276
pure $ lookup key pairs
212277
| [_other, _] <- args =
213-
-- other `shouldHaveSort` "SortMap"
214278
pure Nothing -- not an internalised map, maybe a function call
215279
| otherwise =
216-
-- FIXME write a helper function for arity check
217280
throwE . renderText $ "MAP.lookup: wrong arity " <> pretty (length args)
218281

219282
mapLookupOrDefaultHook :: BuiltinFunction
@@ -226,12 +289,11 @@ mapLookupOrDefaultHook args
226289
Nothing -- key could be in unevaluated or opaque part
227290
| Just _ <- mbRest ->
228291
pure Nothing -- have opaque part, no result
229-
| any ((\(Term a _) -> not a.isConstructorLike) . fst) pairs ->
292+
| any (not . isConstructorLike_ . fst) pairs ->
230293
pure Nothing -- have unevaluated keys, no result
231294
| otherwise -> -- certain that the key is not in the map
232295
pure $ Just defaultValue
233296
| [_other, _, _] <- args =
234-
-- other `shouldHaveSort` "SortMap"
235297
pure Nothing -- not an internalised map, maybe a function call
236298
| otherwise =
237299
throwE . renderText $ "MAP.lookupOrDefault: wrong arity " <> pretty (length args)
@@ -241,7 +303,7 @@ mapInKeysHook args
241303
| [key, KMap _ pairs mbRest] <- args = do
242304
-- only consider evaluated keys, return Nothing if any unevaluated ones are present
243305
let (eval'edKeys, uneval'edKeys) =
244-
partition (\(Term a _) -> a.isConstructorLike) (map fst pairs)
306+
partition isConstructorLike_ (map fst pairs)
245307
case (key `elem` eval'edKeys, key `elem` uneval'edKeys) of
246308
(True, _) ->
247309
-- constructor-like (evaluated) key is present
@@ -261,36 +323,106 @@ mapInKeysHook args
261323
| otherwise =
262324
throwE . renderText $ "MAP.in_keys: wrong arity " <> pretty (length args)
263325

264-
mapUpdateHook :: BuiltinFunction
265-
mapUpdateHook args
266-
| [KMap def pairs mbRest, key, newValue] <- args = do
267-
case findIndex ((== key) . fst) pairs of
268-
Just idx ->
269-
-- key was found (syntactically), update pairs list
270-
let newPairs = take idx pairs <> ((key, newValue) : drop (idx + 1) pairs)
271-
in pure $ Just $ KMap def newPairs mbRest
272-
Nothing -- key could be in unevaluated or opaque part
273-
| Just _ <- mbRest ->
274-
pure Nothing -- have opaque part, no result
275-
| any ((\(Term a _) -> not a.isConstructorLike) . fst) pairs ->
276-
pure Nothing -- have unevaluated keys, no result
277-
| otherwise -> -- key certain to be absent, no rest: add pair
278-
pure $ Just $ KMap def ((key, newValue) : pairs) Nothing
279-
| [_other, _, _] <- args =
280-
-- other `shouldHaveSort` "SortMap"
281-
pure Nothing -- not an internalised map, maybe a function call
282-
| otherwise =
283-
throwE . renderText $ "MAP.update: wrong arity " <> pretty (length args)
284-
285-
------------------------------------------------------------
326+
mapKeysListHook :: BuiltinFunction
327+
mapKeysListHook = \case
328+
[KMap _ pairs Nothing] ->
329+
-- known keys only, return as list
330+
pure $ Just $ KList kItemListDef (map fst pairs) Nothing
331+
[KMap _ _ (Just _)] ->
332+
-- indeterminate part
333+
pure Nothing
334+
[_arg] ->
335+
-- unevaluated
336+
pure Nothing
337+
args ->
338+
throwE . renderText $ "MAP.keys_list: wrong arity " <> pretty (length args)
339+
340+
mapValuesHook :: BuiltinFunction
341+
mapValuesHook = \case
342+
[KMap _ pairs Nothing] ->
343+
-- known values only, return as list
344+
pure $ Just $ KList kItemListDef (map snd pairs) Nothing
345+
[KMap _ _ (Just _)] ->
346+
-- indeterminate part
347+
pure Nothing
348+
[_arg] ->
349+
-- unevaluated
350+
pure Nothing
351+
args ->
352+
throwE . renderText $ "MAP.values: wrong arity " <> pretty (length args)
353+
354+
mapInclusionHook :: BuiltinFunction
355+
mapInclusionHook = \case
356+
[KMap d1 pairs1 mbRest1, KMap d2 pairs2 mbRest2]
357+
| d1 /= d2 -> -- different kinds of map
358+
pure Nothing
359+
| pairs1 == pairs2 -- syntactically identical maps
360+
, mbRest1 == mbRest2 ->
361+
pure $ Just TrueBool
362+
[KMap _ pairs1 Nothing, KMap _ pairs2 mbRest2]
363+
-- fully concrete maps
364+
| keySet pairs1 `Set.isSubsetOf` keySet pairs2 ->
365+
pure $ Just TrueBool
366+
| all isConstructorLike_ (keySet pairs1)
367+
, all isConstructorLike_ (keySet pairs2)
368+
, Nothing <- mbRest2 -> -- fully-known keys, certain to not be subset
369+
pure $ Just FalseBool
370+
| otherwise ->
371+
pure Nothing -- unevaluated keys present, indeterminate
372+
[KMap _ _ (Just _), KMap _ _ _] ->
373+
pure Nothing -- indeterminate part cannot be checked
374+
[_, _] ->
375+
pure Nothing
376+
args ->
377+
throwE . renderText $ "MAP.inclusion: wrong arity " <> pretty (length args)
378+
where
379+
keySet = Set.fromList . map fst
380+
381+
-----------------------------------------------------------
286382
-- LIST hooks
383+
287384
builtinsLIST :: Map ByteString BuiltinFunction
288385
builtinsLIST =
289386
Map.mapKeys ("LIST." <>) $
290387
Map.fromList
291-
[ "size" ~~> listSizeHook
388+
[ "get" ~~> listGetHook
389+
, "size" ~~> listSizeHook
292390
]
293391

392+
listGetHook :: BuiltinFunction
393+
listGetHook [KList _ heads mbRest, intArg] =
394+
let headLen = length heads
395+
in case fromIntegral <$> readIntTerm intArg of
396+
Nothing ->
397+
intArg `shouldHaveSort` "SortInt" >> pure Nothing
398+
Just i
399+
| 0 <= i ->
400+
if i < headLen
401+
then pure $ Just $ heads !! i -- positive index in range
402+
else -- headLen <= i
403+
case mbRest of
404+
Nothing ->
405+
-- index too large
406+
pure Nothing -- actually #Bottom
407+
Just _ ->
408+
pure Nothing
409+
| otherwise -> -- i < 0, negative index, consider rest
410+
case mbRest of
411+
Nothing
412+
| 0 <= headLen - abs i ->
413+
pure $ Just $ heads !! (headLen - abs i)
414+
| otherwise ->
415+
pure Nothing -- actually #Bottom
416+
Just (_middle, tails)
417+
| 0 <= length tails - abs i ->
418+
pure $ Just $ tails !! (length tails - abs i)
419+
| otherwise ->
420+
pure Nothing -- indeterminate middle
421+
listGetHook [_other, _] =
422+
pure Nothing
423+
listGetHook args =
424+
throwE . renderText $ "LIST.get: wrong arity " <> pretty (length args)
425+
294426
listSizeHook :: BuiltinFunction
295427
listSizeHook = \case
296428
[KList _ heads Nothing] ->
@@ -302,6 +434,19 @@ listSizeHook = \case
302434
moreArgs ->
303435
throwE . renderText $ "LIST.size: wrong arity " <> pretty (length moreArgs)
304436

437+
kItemListDef :: KListDefinition
438+
kItemListDef =
439+
KListDefinition
440+
{ symbolNames =
441+
KCollectionSymbolNames
442+
{ unitSymbolName = "Lbl'Stop'List"
443+
, elementSymbolName = "LblListItem"
444+
, concatSymbolName = "Lbl'Unds'List'Unds'"
445+
}
446+
, elementSortName = "SortKItem"
447+
, listSortName = "SortList"
448+
}
449+
305450
------------------------------------------------------------
306451
-- KEQUAL hooks
307452
builtinsKEQUAL :: Map ByteString BuiltinFunction

0 commit comments

Comments
 (0)