Move SSD truth application to typed Kotlin
ober
2a922e0ba340d6a07cf43fb3f835589e7a0fbd78
--- a/.build.yml +++ b/.build.yml @@ -5,7 +5,7 @@ packages: - make=4.4.1-r4 sources: # Build dependency: full immutable commit, mirrored in dependencies.lock.json. - - "https://git.sr.ht/~lisp/jerboa#72e8809c61fd49a715fcdaaf693e3e07708fe363" + - "https://git.sr.ht/~lisp/jerboa#95eb94930e82dc21c387b51cd97081a239c98931" # The second source is the build subject selected by the SourceHut submitter. - https://git.sr.ht/~lisp/jerboa-android tasks: @@ -14,6 +14,6 @@ tasks: test "$(apk info -v chez-scheme)" = chez-scheme-10.3.0-r2 test "$(apk info -v git)" = git-2.54.0-r0 test "$(apk info -v make)" = make-4.4.1-r4 - test "$(git -C ../jerboa rev-parse HEAD)" = 72e8809c61fd49a715fcdaaf693e3e07708fe363 - test "$(git -C ../jerboa rev-parse 'HEAD^{tree}')" = b412f8d52319fd8fdd64e2044ffd0bd2d308c194 + test "$(git -C ../jerboa rev-parse HEAD)" = 95eb94930e82dc21c387b51cd97081a239c98931 + test "$(git -C ../jerboa rev-parse 'HEAD^{tree}')" = 3d2c0da525a711c886d8e2372daf89240d01f96f JERBOA="chez --libdirs .:../jerboa/lib --script" make test --- a/dependencies.lock.json +++ b/dependencies.lock.json @@ -11,8 +11,8 @@ "generator_runtime": { "name": "jerboa", "repository": "https://git.sr.ht/~lisp/jerboa", - "commit": "72e8809c61fd49a715fcdaaf693e3e07708fe363", - "tree": "b412f8d52319fd8fdd64e2044ffd0bd2d308c194" + "commit": "95eb94930e82dc21c387b51cd97081a239c98931", + "tree": "3d2c0da525a711c886d8e2372daf89240d01f96f" }, "assurance_tools": { "osv_scanner": { --- a/scripts/verify-supply-chain.sh +++ b/scripts/verify-supply-chain.sh @@ -3,8 +3,8 @@ set -eu repo=$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd -P) lock="$repo/dependencies.lock.json" -jerboa_commit=72e8809c61fd49a715fcdaaf693e3e07708fe363 # gitsafe:ignore -jerboa_tree=b412f8d52319fd8fdd64e2044ffd0bd2d308c194 # gitsafe:ignore +jerboa_commit=95eb94930e82dc21c387b51cd97081a239c98931 # gitsafe:ignore +jerboa_tree=3d2c0da525a711c886d8e2372daf89240d01f96f # gitsafe:ignore gradle_sha=20f1b1176237254a6fc204d8434196fa11a4cfb387567519c61556e8710aed78 jdk_macos_sha=8fa1eff40bb637a33613b2ccb8b12c70dc3661cc22cf8e784943715769a05336 jdk_linux_sha=d8afc263758141a66e0e3aafc321e783f7016696f4eaea067d340a269037d331 --- a/templates/ssd-review.ss +++ b/templates/ssd-review.ss @@ -3647,7 +3647,7 @@ cell)) (def (remapAndAddTruthCells (session : SsdSession) (group : SsdGroup) - (truthCells : (List SsdCell)) + (truthCells : (MutableList SsdCell)) (usedIds : (MutableSet String))) : Unit (if (= (list-size truthCells) (int32 0)) (begin) @@ -3668,6 +3668,65 @@ (mutable-list-clear! (SsdGroup-cellIds group)) (mutable-list-add-all! (SsdGroup-cellIds group) remappedIds))))))) + (typed-kotlin-file "com/sfb/ssdreview/TruthApply.kt" + (kotlin-imports (org json JSONArray) (org json JSONObject)) + (typed-library (com sfb ssdreview) + (export applyTruthJsonToSession) + (type JSONObject) + (type JSONArray) + (type Int32) + (type SsdGroup) + (type SsdCell) + (def (truthApplyJsonArrayOrEmpty (json : JSONObject) (key : String)) : JSONArray + (let ((items (json-object-opt-json-array json key))) + (if (nullable-null? items) + (json-array-empty) + (nullable-get items)))) + (def (applyTruthGroupJsonToSession (session : SsdSession) + (groupJson : JSONObject) + (usedIds : (MutableSet String)) + (target : (MutableList SsdGroup))) : Unit + (let ((parsed (ssdGroupFromTruthJson groupJson))) + (let ((group (pair-first parsed))) + (begin + (remapAndAddTruthCells session group (pair-second parsed) usedIds) + (suppressOverlappingCandidateGroups session group) + (mutable-list-add! target group))))) + (def (applyTruthGroupArrayToSession (session : SsdSession) + (groups : JSONArray) + (usedIds : (MutableSet String)) + (target : (MutableList SsdGroup))) : Unit + (begin + (for/fold ((ignored (int32 0))) + ((i (in-range (int32 0) (json-array-length groups)))) + (begin + (applyTruthGroupJsonToSession + session + (json-array-get-json-object groups i) + usedIds + target) + ignored)) + (begin))) + (def (applyTruthJsonToSession (session : SsdSession) (truth : JSONObject)) : Unit + (begin + (SsdSession-ssdArea-set! + session + (jsonRect (json-object-opt-json-array truth "ssd_area"))) + (let ((cellIds (ssdSessionCellIdSet session))) + (begin + (applyTruthGroupArrayToSession + session + (truthApplyJsonArrayOrEmpty truth "groups") + cellIds + (SsdSession-groups session)) + (applyTruthGroupArrayToSession + session + (truthApplyJsonArrayOrEmpty truth "suppressed_groups") + cellIds + (SsdSession-suppressedGroups session)) + (ssdSessionPruneGroupsOutsideSsdArea session) + (begin))))))) + (typed-kotlin-file "com/sfb/ssdreview/PathSafety.kt" (typed-library (com sfb ssdreview) (export safePathComponent safeLeaf safeZipEntryName validSourceKey validatedSourceKey) @@ -6286,23 +6345,7 @@ "" " fun applyTruth(session: SsdSession) {" " val truth = loadTruth(session) ?: return" - " session.ssdArea = jsonRect(truth.optJSONArray(\"ssd_area\"))" - " val groups = truth.optJSONArray(\"groups\") ?: JSONArray()" - " val cellIds = ssdSessionCellIdSet(session)" - " for (i in 0 until groups.length()) {" - " val (group, truthCells) = ssdGroupFromTruthJson(groups.getJSONObject(i))" - " remapAndAddTruthCells(session, group, truthCells, cellIds)" - " suppressOverlappingCandidateGroups(session, group)" - " session.groups.add(group)" - " }" - " val suppressed = truth.optJSONArray(\"suppressed_groups\") ?: JSONArray()" - " for (i in 0 until suppressed.length()) {" - " val (group, truthCells) = ssdGroupFromTruthJson(suppressed.getJSONObject(i))" - " remapAndAddTruthCells(session, group, truthCells, cellIds)" - " suppressOverlappingCandidateGroups(session, group)" - " session.suppressedGroups.add(group)" - " }" - " ssdSessionPruneGroupsOutsideSsdArea(session)" + " applyTruthJsonToSession(session, truth)" " }" "" " private class LimitedInputStream(input: InputStream, private val limit: Long) : FilterInputStream(input) {"