git.iko.soy/rowtype-yoga/purescm
on bytevector help sign in
Change record codegen to use alist->hash-table (#154)

Change record literal codegen to use `alist->hash-table` instead of `hash-table`.

commita679bbfbaa1073b6d879765dc66f8606264af807 authorAntti Holvikari <antti@anttih.com> dateSun 17 Sep 2023, 15:22 (3 years ago) parent7724839
7 files changed+28−19
compare with bytevector
unifiedsplit
src/PureScript/Backend/Chez/Runtime.purs+3−7 src/PureScript/Backend/Chez/Syntax.purs+4−3 test-snapshots/src/snapshots-input/Snapshot.Literals.Record.purs+4 test-snapshots/src/snapshots-input/Snapshot.Literals.Record.ss+5 test-snapshots/src/snapshots-output/Snapshot.Literals.Record.ss+9−6 test-snapshots/src/snapshots-output/Snapshot.Literals.ss+1−1 test-snapshots/src/snapshots-output/Snapshot.Prime.ss+2−2
src/PureScript/Backend/Chez/Runtime.purs+3−7
@@ -56,13 +56,9 @@ createMakeObjectFn = makeExportedValue "make-object" $ S.List
5656 [ S.Identifier $ scmPrefixed "lambda"
5757 , S.Identifier "args"
5858 , S.List
59− [ S.Identifier $ scmPrefixed "apply"
60− , S.Identifier "srfi:125:hash-table"
61− , S.List
62− [ S.Identifier $ scmPrefixed "cons"
63− , S.Identifier "string-comparator"
64− , S.Identifier "args"
65− ]
59+ [ S.Identifier "srfi:125:alist->hash-table"
60+ , S.Identifier "args"
61+ , S.Identifier "string-comparator"
6662 ]
6763 ]
6864
src/PureScript/Backend/Chez/Syntax.purs+4−3
@@ -124,9 +124,10 @@ app f x = List [ f, x ]
124124record :: Array (Prop ChezExpr) -> ChezExpr
125125record r = do
126126 let
127− field :: Prop ChezExpr -> Array ChezExpr
128− field (Prop k v) = [ StringExpr $ Json.stringify $ Json.fromString k, v ]
129− List $ [ Identifier $ rtPrefixed "make-object" ] <> Array.foldMap field r
127+ field :: Prop ChezExpr -> ChezExpr
128+ field (Prop k v) = List
129+ [ Identifier $ scmPrefixed "cons", StringExpr $ Json.stringify $ Json.fromString k, v ]
130+ List $ [ Identifier $ rtPrefixed "make-object" ] <> (field <$> r)
130131
131132quote :: ChezExpr -> ChezExpr
132133quote e = app (Identifier $ scmPrefixed "quote") e
test-snapshots/src/snapshots-input/Snapshot.Literals.Record.purs+4
@@ -20,13 +20,17 @@ recordUpdate = _ { fooBarBaz = 10 }
2020recordAddField :: forall r. Lacks "anotherField" r => { fooBarBaz :: Int | r } -> { fooBarBaz :: Int, anotherField :: Int | r }
2121recordAddField = Record.insert (Proxy :: _ "anotherField") 42
2222
23+foreign import minusTwo :: Int
24+
2325main :: Effect Unit
2426main = do
2527 let r = { fooBarBaz: 5 }
2628 let s = recordUpdate r
2729 let t = recordAddField s
30+ let u = { fooBarBaz: minusTwo }
2831
2932 assert $ recordAccess t == 10
3033 assert $ t.anotherField == 42
3134 assert $ recordAccess s == 10
3235 assert $ recordAccess r == 5
36+ assert $ recordAccess u == minusTwo
test-snapshots/src/snapshots-input/Snapshot.Literals.Record.ssnew file+5
@@ -0,0 +1,5 @@
1+(library (Snapshot.Literals.Record foreign)
2+ (export minusTwo)
3+ (import (chezscheme))
4+
5+ (define minusTwo -2))
test-snapshots/src/snapshots-output/Snapshot.Literals.Record.ss+9−6
@@ -5,6 +5,7 @@
55 (export
66 insert
77 main
8+ minusTwo
89 recordAccess
910 recordAddField
1011 recordUpdate)
@@ -13,11 +14,12 @@
1314 (prefix (purs runtime lib) rt:)
1415 (prefix (Record lib) Record.)
1516 (prefix (Test.Assert lib) Test.Assert.)
16− (prefix (Type.Proxy lib) Type.Proxy.))
17+ (prefix (Type.Proxy lib) Type.Proxy.)
18+ (Snapshot.Literals.Record foreign))
1719
1820 (scm:define insert
19− (((Record.insert (rt:make-object "reflectSymbol" (scm:lambda (_)
20− "anotherField"))) (scm:gensym "purs-undefined")) (scm:gensym "purs-undefined")))
21+ (((Record.insert (rt:make-object (scm:cons "reflectSymbol" (scm:lambda (_)
22+ "anotherField")))) (scm:gensym "purs-undefined")) (scm:gensym "purs-undefined")))
2123
2224 (scm:define recordUpdate
2325 (scm:lambda (v0)
@@ -34,7 +36,7 @@
3436
3537 (scm:define main
3638 (scm:let*
37− ([r0 (rt:make-object "fooBarBaz" 5)]
39+ ([r0 (rt:make-object (scm:cons "fooBarBaz" 5))]
3840 [s1 (recordUpdate r0)]
3941 [t2 ((recordAddField (scm:gensym "purs-undefined")) s1)]
4042 [_3 (Test.Assert.assert (scm:fx=? (recordAccess t2) 10))])
@@ -42,5 +44,6 @@
4244 (scm:let*
4345 ([_ (_3)]
4446 [_ ((Test.Assert.assert (scm:fx=? (rt:object-ref t2 "anotherField") 42)))]
45− [_ ((Test.Assert.assert (scm:fx=? (recordAccess s1) 10)))])
46− ((Test.Assert.assert (scm:fx=? (recordAccess r0) 5))))))))
47+ [_ ((Test.Assert.assert (scm:fx=? (recordAccess s1) 10)))]
48+ [_ ((Test.Assert.assert (scm:fx=? (recordAccess r0) 5)))])
49+ ((Test.Assert.assert (scm:fx=? (recordAccess (rt:make-object (scm:cons "fooBarBaz" minusTwo))) minusTwo))))))))
test-snapshots/src/snapshots-output/Snapshot.Literals.ss+1−1
@@ -21,7 +21,7 @@
2121 "string")
2222
2323 (scm:define record2
24− (rt:make-object "foo" "bar"))
24+ (rt:make-object (scm:cons "foo" "bar")))
2525
2626 (scm:define record
2727 (rt:make-object))
test-snapshots/src/snapshots-output/Snapshot.Prime.ss+2−2
@@ -104,11 +104,11 @@
104104 (scm:string-append ((rt:object-ref dictNormal0 "normal") a2) ((rt:object-ref dictNormal11 "normal") b3)))))))
105105
106106 (scm:define instanceName$p
107− (rt:make-object "normal" (scm:lambda (v0)
107+ (rt:make-object (scm:cons "normal" (scm:lambda (v0)
108108 (scm:cond
109109 [(F1? v0) "F1"]
110110 [(F2? v0) "F2"]
111− [scm:else (scm:raise (scm:condition (scm:make-error) (scm:make-message-condition "Failed pattern match")))]))))
111+ [scm:else (scm:raise (scm:condition (scm:make-error) (scm:make-message-condition "Failed pattern match")))])))))
112112
113113 (scm:define useInstance
114114 "F1F2")