Skip to content

Commit 032a3bf

Browse files
UnisayUnisay
committed
Support for the polymorphic record updates
1 parent fcd3e1d commit 032a3bf

File tree

11 files changed

+270
-81
lines changed

11 files changed

+270
-81
lines changed

‎lib/Language/PureScript/Backend/Lua.hs

+62-40
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@ module Language.PureScript.Backend.Lua
1010
import Control.Monad (ap)
1111
import Control.Monad.Oops (CouldBe, Variant)
1212
import Control.Monad.Oops qualified as Oops
13+
import Control.Monad.Trans.Accum (AccumT, add, runAccumT)
1314
import Data.DList qualified as DList
1415
import Data.List qualified as List
1516
import Data.Set qualified as Set
@@ -32,7 +33,19 @@ import Language.PureScript.Names qualified as PS
3233
import Path (Abs, Dir, Path, toFilePath)
3334
import Prelude hiding (exp, local)
3435

35-
type LuaM e a = StateT Natural (ExceptT (Variant e) IO) a
36+
type LuaM e a =
37+
AccumT UsesObjectUpdate (StateT Natural (ExceptT (Variant e) IO)) a
38+
39+
data UsesObjectUpdate = NoObjectUpdate | UsesObjectUpdate
40+
deriving stock (Eq, Ord, Show)
41+
42+
instance Semigroup UsesObjectUpdate where
43+
_ <> UsesObjectUpdate = UsesObjectUpdate
44+
UsesObjectUpdate <> _ = UsesObjectUpdate
45+
NoObjectUpdate <> NoObjectUpdate = NoObjectUpdate
46+
47+
instance Monoid UsesObjectUpdate where
48+
mempty = NoObjectUpdate
3649

3750
data Error
3851
= UnexpectedRefBound ModuleName IR.Exp
@@ -49,41 +62,42 @@ fromUberModule
4962
→ Linker.UberModule
5063
→ ExceptT (Variant e) IO Lua.Chunk
5164
fromUberModule foreigns needsRuntimeLazy appOrModule uber = (`evalStateT` 0) do
52-
bindings ←
53-
Linker.uberModuleBindings uber & foldMapM \case
54-
IR.Standalone (IR.QName modname name, irExp) → do
55-
exp ← fromExp foreigns Set.empty modname irExp
56-
pure $ DList.singleton (Lua.local1 (fromQName modname name) exp)
57-
IR.RecursiveGroup recGroup → do
58-
recBinds ← forM (toList recGroup) \(IR.QName modname name, irExp) →
59-
(fromQName modname name,) <$> fromExp foreigns Set.empty modname irExp
60-
let declarations = Lua.local0 . fst <$> DList.fromList recBinds
61-
assignments = DList.fromList do
62-
recBinds <&> \(name, exp) → Lua.assign (Lua.VarName name) exp
63-
pure $ declarations <> assignments
64-
65-
returnExp ←
66-
case appOrModule of
67-
AsModule modname →
68-
Lua.table <$> do
69-
forM (uberModuleExports uber) \(fromName → name, expr) →
70-
Lua.tableRowNV name <$> fromExp foreigns mempty modname expr
71-
AsApplication modname ident → do
72-
case List.lookup name (uberModuleExports uber) of
73-
Just expr → do
74-
entry ← fromExp foreigns mempty modname expr
75-
pure $ Lua.functionCall entry []
76-
_ → Oops.throw $ AppEntryPointNotFound modname ident
77-
where
78-
name = IR.identToName ident
65+
(chunk, usesObjectUpdate) ← (`runAccumT` NoObjectUpdate) do
66+
bindings ←
67+
Linker.uberModuleBindings uber & foldMapM \case
68+
IR.Standalone (IR.QName modname name, irExp) → do
69+
exp ← fromExp foreigns Set.empty modname irExp
70+
pure $ DList.singleton (Lua.local1 (fromQName modname name) exp)
71+
IR.RecursiveGroup recGroup → do
72+
recBinds ← forM (toList recGroup) \(IR.QName modname name, irExp) →
73+
(fromQName modname name,) <$> fromExp foreigns Set.empty modname irExp
74+
let declarations = Lua.local0 . fst <$> DList.fromList recBinds
75+
assignments = DList.fromList do
76+
recBinds <&> \(name, exp) → Lua.assign (Lua.VarName name) exp
77+
pure $ declarations <> assignments
78+
79+
returnExp ←
80+
case appOrModule of
81+
AsModule modname →
82+
Lua.table <$> do
83+
forM (uberModuleExports uber) \(fromName → name, expr) →
84+
Lua.tableRowNV name <$> fromExp foreigns mempty modname expr
85+
AsApplication modname ident → do
86+
case List.lookup name (uberModuleExports uber) of
87+
Just expr → do
88+
entry ← fromExp foreigns mempty modname expr
89+
pure $ Lua.functionCall entry []
90+
_ → Oops.throw $ AppEntryPointNotFound modname ident
91+
where
92+
name = IR.identToName ident
93+
94+
pure $ DList.snoc bindings (Lua.Return (Lua.ann returnExp))
7995

8096
pure . mconcat $
81-
[ if usesPrimModule uber then [Fixture.prim] else empty
82-
, if untag needsRuntimeLazy && usesRuntimeLazy uber
83-
then pure Fixture.runtimeLazy
84-
else empty
85-
, DList.toList bindings
86-
, [Lua.Return (Lua.ann returnExp)]
97+
[ [Fixture.prim | usesPrimModule uber]
98+
, [Fixture.runtimeLazy | untag needsRuntimeLazy && usesRuntimeLazy uber]
99+
, [Fixture.objectUpdate | UsesObjectUpdate ← [usesObjectUpdate]]
100+
, DList.toList chunk
87101
]
88102

89103
fromQName ∷ ModuleName → IR.Name → Lua.Name
@@ -149,17 +163,19 @@ fromExp foreigns topLevelNames modname ir = case ir of
149163
flip Lua.varIndex (Lua.Integer (fromIntegral index)) <$> go (IR.unAnn expr)
150164
IR.ObjectProp expr propName →
151165
flip Lua.varField (fromPropName propName) <$> go (IR.unAnn expr)
152-
IR.ObjectUpdate _expr _patches →
153-
Prelude.error "fromObjectUpdate is not implemented"
166+
IR.ObjectUpdate expr propValues → do
167+
add UsesObjectUpdate
168+
obj ← go (IR.unAnn expr)
169+
vals ←
170+
Lua.table <$> for (toList propValues) \(propName, IR.unAnn → e) →
171+
Lua.tableRowNV (fromPropName propName) <$> go e
172+
pure $ Lua.functionCall (Lua.varName Fixture.objectUpdateName) [obj, vals]
154173
IR.Abs param expr → do
155174
e ← go $ IR.unAnn expr
156175
luaParam ←
157176
Lua.ParamNamed
158177
<$> case IR.unAnn param of
159-
IR.ParamUnused → do
160-
index ← get
161-
modify' (+ 1)
162-
pure $ Lua.unsafeName ("unused" <> show index)
178+
IR.ParamUnused → uniqueName "unused"
163179
IR.ParamNamed name → pure (fromName name)
164180
pure $ Lua.functionDef [luaParam] [Lua.return e]
165181
IR.App expr param → do
@@ -227,5 +243,11 @@ fromIfThenElse cond thenExp elseExp = Lua.functionCall fun []
227243
--------------------------------------------------------------------------------
228244
-- Helpers ---------------------------------------------------------------------
229245

246+
uniqueName ∷ MonadState Natural m ⇒ Text → m Lua.Name
247+
uniqueName prefix = do
248+
index ← get
249+
modify' (+ 1)
250+
pure $ Lua.unsafeName (prefix <> show index)
251+
230252
qualifyName ∷ ModuleName → Lua.Name → Lua.Name
231253
qualifyName modname = Name.join2 (fromModuleName modname)

‎lib/Language/PureScript/Backend/Lua/Fixture.hs

+49-35
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22

33
module Language.PureScript.Backend.Lua.Fixture where
44

5+
import Data.String.Interpolate (__i)
56
import Language.PureScript.Backend.Lua.Name (Name, name)
67
import Language.PureScript.Backend.Lua.Name qualified as Name
78
import Language.PureScript.Backend.Lua.Types hiding (var)
@@ -12,39 +13,52 @@ import Language.PureScript.Backend.Lua.Types hiding (var)
1213
prim ∷ Statement
1314
prim = local1 (Name.join2 [name|Prim|] [name|undefined|]) Nil
1415

16+
runtimeLazyName ∷ Name
17+
runtimeLazyName = [name|_S___runtime_lazy|]
18+
1519
runtimeLazy ∷ Statement
16-
runtimeLazy = local1 [name|_S___runtime_lazy|] do
17-
let fun ∷ Name → [Statement] → Exp
18-
fun n = Function [((), ParamNamed n)] . fmap ann
19-
var ∷ Name → Var
20-
var = VarName
21-
ret ∷ Exp → Statement
22-
ret = Return . ann
23-
fun [name|name|] . pure . ret . fun [name|init|] $
24-
[ local1 [name|state|] (Integer 0)
25-
, local1 [name|val|] Nil
26-
, ret . functionDef [] $
27-
[ ifThenElse
28-
(varName [name|state|] `equalTo` Integer 2)
29-
[ret (varName [name|val|])]
30-
[ ifThenElse
31-
(varName [name|state|] `equalTo` Integer 1)
32-
( pure . ret $
33-
functionCall
34-
(varName [name|error|])
35-
[ binOp
36-
Concat
37-
(varName [name|name|])
38-
( String
39-
" was needed before it finished initializing"
40-
)
41-
]
42-
)
43-
[ var [name|state|] `assign` Integer 1
44-
, var [name|val|] `assign` functionCall (varName [name|init|]) []
45-
, var [name|state|] `assign` Integer 2
46-
, ret (varName [name|val|])
47-
]
48-
]
49-
]
50-
]
20+
runtimeLazy =
21+
ForeignSourceCode
22+
[__i|
23+
local function #{Name.toText runtimeLazyName}(name)
24+
return function(init)
25+
return function()
26+
local state = 0
27+
local val = nil
28+
if state == 2 then
29+
return val
30+
else
31+
if state == 1 then
32+
return error(name .. " was needed before it finished initializing")
33+
else
34+
state = 1
35+
val = init()
36+
state = 2
37+
return val
38+
end
39+
end
40+
end
41+
end
42+
end
43+
|]
44+
45+
objectUpdateName ∷ Name
46+
objectUpdateName = [name|_S___object_update|]
47+
48+
objectUpdate ∷ Statement
49+
objectUpdate =
50+
ForeignSourceCode
51+
[__i|
52+
local function #{Name.toText objectUpdateName}(o, patches)
53+
local o_copy = {}
54+
for k, v in pairs(o) do
55+
local patch_v = patches
56+
if patch_v ~= nil then
57+
o_copy[k] = patch_v
58+
else
59+
o_copy[k] = v
60+
end
61+
end
62+
return o_copy
63+
end
64+
|]

‎lib/Language/PureScript/Backend/Lua/Traversal.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -40,7 +40,7 @@ everywhereExpM f g = goe
4040
tableRows ← forM rows \case
4141
TableRowKV (Ann k) (Ann v) → tableRowKV <$> goe k <*> goe v
4242
TableRowNV n (Ann e) → tableRowNV n <$> goe e
43-
f $ tableCtor tableRows
43+
f $ table tableRows
4444
UnOp op (Ann e) →
4545
f . unOp op =<< goe e
4646
BinOp op (Ann e1) (Ann e2) →

‎lib/Language/PureScript/Backend/Lua/Types.hs

-3
Original file line numberDiff line numberDiff line change
@@ -272,9 +272,6 @@ functionDef params body = Function (ann <$> params) (ann <$> body)
272272
functionCall ∷ Exp → [Exp] → Exp
273273
functionCall f args = FunctionCall (ann f) (ann <$> args)
274274

275-
tableCtor ∷ [TableRow] → Exp
276-
tableCtor = TableCtor . fmap ann
277-
278275
unOp ∷ UnaryOp → Exp → Exp
279276
unOp op e = UnOp op (ann e)
280277

‎pslua.cabal

+1
Original file line numberDiff line numberDiff line change
@@ -97,6 +97,7 @@ common shared
9797
, relude ^>=1.2
9898
, scientific ^>=0.3.7.0
9999
, shower ^>=0.2.0.3
100+
, string-interpolate ^>=0.3.2.1
100101
, tagged ^>=0.8.6.1
101102
, template-haskell ^>=2.18
102103
, text ^>=1.2.5.0

‎test/Language/PureScript/Backend/Lua/Gen.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -132,7 +132,7 @@ binOp ∷ Gen Lua.Exp
132132
binOp = Lua.binOp <$> Gen.enumBounded <*> expression <*> expression
133133

134134
table ∷ Gen Lua.Exp
135-
table = Lua.tableCtor <$> Gen.list (Range.linear 0 5) tableRow
135+
table = Lua.table <$> Gen.list (Range.linear 0 5) tableRow
136136

137137
recursiveVar ∷ Gen Lua.Exp
138138
recursiveVar = do

‎test/ps/golden/Golden/TestRecordsUpdate.purs

+21
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,21 @@
1+
module Golden.TestRecordsUpdate where
2+
3+
type R = { x :: Int, y :: Boolean, z :: Z }
4+
type Z = { z :: String , p :: Char }
5+
6+
r :: R
7+
r = { x: 1, y: true, z: { z: "foo", p: 'a' } }
8+
9+
test1 :: R
10+
test1 = r { x = 2 }
11+
12+
test2 :: R -> R
13+
test2 = _ { y = false }
14+
15+
test3 :: R -> R
16+
test3 = _ { z { p = 'b' } }
17+
18+
type Poly r = { x :: Int, y :: Char | r }
19+
20+
test4 :: forall r. Poly r -> Poly r
21+
test4 = _ { x = 1 }

‎test/ps/output/Golden.TestHelloPrelude/golden.lua

+1-1
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
local Prim_I_undefined = nil
2-
local _S___runtime_lazy = function(name)
2+
local function _S___runtime_lazy(name)
33
return function(init)
44
return function()
55
local state = 0

‎test/ps/output/Golden.TestRecordsUpdate/corefn.json

+1
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
{"builtWith":"0.15.9","comments":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"end":[20,36],"start":[20,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[21,20],"start":[21,9]}},"argument":"v","body":{"annotation":{"meta":null,"sourceSpan":{"end":[21,20],"start":[21,9]}},"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"v","sourcePos":[0,0]}},"type":"ObjectUpdate","updates":[["x",{"annotation":{"meta":null,"sourceSpan":{"end":[21,18],"start":[21,17]}},"type":"Literal","value":{"literalType":"IntLiteral","value":1}}]]},"type":"Abs"},"identifier":"test4"},{"annotation":{"meta":null,"sourceSpan":{"end":[15,16],"start":[15,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[16,28],"start":[16,9]}},"argument":"v","body":{"annotation":{"meta":null,"sourceSpan":{"end":[16,28],"start":[16,9]}},"type":"Literal","value":{"literalType":"ObjectLiteral","value":[["x",{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"v","sourcePos":[0,0]}},"fieldName":"x","type":"Accessor"}],["y",{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"v","sourcePos":[0,0]}},"fieldName":"y","type":"Accessor"}],["z",{"annotation":{"meta":null,"sourceSpan":{"end":[16,28],"start":[16,9]}},"type":"Literal","value":{"literalType":"ObjectLiteral","value":[["z",{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[16,28],"start":[16,9]}},"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"v","sourcePos":[0,0]}},"fieldName":"z","type":"Accessor"},"fieldName":"z","type":"Accessor"}],["p",{"annotation":{"meta":null,"sourceSpan":{"end":[16,24],"start":[16,21]}},"type":"Literal","value":{"literalType":"CharLiteral","value":"b"}}]]}}]]}},"type":"Abs"},"identifier":"test3"},{"annotation":{"meta":null,"sourceSpan":{"end":[12,16],"start":[12,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[13,24],"start":[13,9]}},"argument":"v","body":{"annotation":{"meta":null,"sourceSpan":{"end":[13,24],"start":[13,9]}},"type":"Literal","value":{"literalType":"ObjectLiteral","value":[["x",{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"v","sourcePos":[0,0]}},"fieldName":"x","type":"Accessor"}],["y",{"annotation":{"meta":null,"sourceSpan":{"end":[13,22],"start":[13,17]}},"type":"Literal","value":{"literalType":"BooleanLiteral","value":false}}],["z",{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"v","sourcePos":[0,0]}},"fieldName":"z","type":"Accessor"}]]}},"type":"Abs"},"identifier":"test2"},{"annotation":{"meta":null,"sourceSpan":{"end":[6,7],"start":[6,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[7,47],"start":[7,5]}},"type":"Literal","value":{"literalType":"ObjectLiteral","value":[["x",{"annotation":{"meta":null,"sourceSpan":{"end":[7,11],"start":[7,10]}},"type":"Literal","value":{"literalType":"IntLiteral","value":1}}],["y",{"annotation":{"meta":null,"sourceSpan":{"end":[7,20],"start":[7,16]}},"type":"Literal","value":{"literalType":"BooleanLiteral","value":true}}],["z",{"annotation":{"meta":null,"sourceSpan":{"end":[7,45],"start":[7,25]}},"type":"Literal","value":{"literalType":"ObjectLiteral","value":[["z",{"annotation":{"meta":null,"sourceSpan":{"end":[7,35],"start":[7,30]}},"type":"Literal","value":{"literalType":"StringLiteral","value":"foo"}}],["p",{"annotation":{"meta":null,"sourceSpan":{"end":[7,43],"start":[7,40]}},"type":"Literal","value":{"literalType":"CharLiteral","value":"a"}}]]}}]]}},"identifier":"r"},{"annotation":{"meta":null,"sourceSpan":{"end":[9,11],"start":[9,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[10,20],"start":[10,9]}},"binds":[{"annotation":{"meta":null,"sourceSpan":{"end":[10,20],"start":[10,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[10,10],"start":[10,9]}},"type":"Var","value":{"identifier":"r","moduleName":["Golden","TestRecordsUpdate"]}},"identifier":"v"}],"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[10,20],"start":[10,9]}},"type":"Literal","value":{"literalType":"ObjectLiteral","value":[["x",{"annotation":{"meta":null,"sourceSpan":{"end":[10,18],"start":[10,17]}},"type":"Literal","value":{"literalType":"IntLiteral","value":2}}],["y",{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"v","sourcePos":[10,1]}},"fieldName":"y","type":"Accessor"}],["z",{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"v","sourcePos":[10,1]}},"fieldName":"z","type":"Accessor"}]]}},"type":"Let"},"identifier":"test1"}],"exports":["r","test1","test2","test3","test4"],"foreign":[],"imports":[{"annotation":{"meta":null,"sourceSpan":{"end":[21,20],"start":[1,1]}},"moduleName":["Golden","TestRecordsUpdate"]},{"annotation":{"meta":null,"sourceSpan":{"end":[21,20],"start":[1,1]}},"moduleName":["Prim"]}],"moduleName":["Golden","TestRecordsUpdate"],"modulePath":"golden/Golden/TestRecordsUpdate.purs","reExports":{},"sourceSpan":{"end":[21,20],"start":[1,1]}}

0 commit comments

Comments
 (0)