Support for the polymorphic record updates

lib/Language/PureScript/Backend/Lua.hs

@@ -10,6 +10,7 @@ module Language.PureScript.Backend.Lua
 import Control.Monad (ap)
 import Control.Monad.Oops (CouldBe, Variant)
 import Control.Monad.Oops qualified as Oops
+import Control.Monad.Trans.Accum (AccumT, add, runAccumT)
 import Data.DList qualified as DList
 import Data.List qualified as List
 import Data.Set qualified as Set
@@ -32,7 +33,19 @@ import Language.PureScript.Names qualified as PS
 import Path (Abs, Dir, Path, toFilePath)
 import Prelude hiding (exp, local)
 
-type LuaM e a = StateT Natural (ExceptT (Variant e) IO) a
+type LuaM e a =
+  AccumT UsesObjectUpdate (StateT Natural (ExceptT (Variant e) IO)) a
+
+data UsesObjectUpdate = NoObjectUpdate | UsesObjectUpdate
+  deriving stock (Eq, Ord, Show)
+
+instance Semigroup UsesObjectUpdate where
+  _ <> UsesObjectUpdate = UsesObjectUpdate
+  UsesObjectUpdate <> _ = UsesObjectUpdate
+  NoObjectUpdate <> NoObjectUpdate = NoObjectUpdate
+
+instance Monoid UsesObjectUpdate where
+  mempty = NoObjectUpdate
 
 data Error
   = UnexpectedRefBound ModuleName IR.Exp
@@ -49,41 +62,42 @@ fromUberModule
   → Linker.UberModule
   → ExceptT (Variant e) IO Lua.Chunk
 fromUberModule foreigns needsRuntimeLazy appOrModule uber = (`evalStateT` 0) do
-  bindings ←
-    Linker.uberModuleBindings uber & foldMapM \case
-      IR.Standalone (IR.QName modname name, irExp) → do
-        exp ← fromExp foreigns Set.empty modname irExp
-        pure $ DList.singleton (Lua.local1 (fromQName modname name) exp)
-      IR.RecursiveGroup recGroup → do
-        recBinds ← forM (toList recGroup) \(IR.QName modname name, irExp) →
-          (fromQName modname name,) <$> fromExp foreigns Set.empty modname irExp
-        let declarations = Lua.local0 . fst <$> DList.fromList recBinds
-            assignments = DList.fromList do
-              recBinds <&> \(name, exp) → Lua.assign (Lua.VarName name) exp
-        pure $ declarations <> assignments
-
-  returnExp ←
-    case appOrModule of
-      AsModule modname →
-        Lua.table <$> do
-          forM (uberModuleExports uber) \(fromName → name, expr) →
-            Lua.tableRowNV name <$> fromExp foreigns mempty modname expr
-      AsApplication modname ident → do
-        case List.lookup name (uberModuleExports uber) of
-          Just expr → do
-            entry ← fromExp foreigns mempty modname expr
-            pure $ Lua.functionCall entry []
-          _ → Oops.throw $ AppEntryPointNotFound modname ident
-       where
-        name = IR.identToName ident
+  (chunk, usesObjectUpdate) ← (`runAccumT` NoObjectUpdate) do
+    bindings ←
+      Linker.uberModuleBindings uber & foldMapM \case
+        IR.Standalone (IR.QName modname name, irExp) → do
+          exp ← fromExp foreigns Set.empty modname irExp
+          pure $ DList.singleton (Lua.local1 (fromQName modname name) exp)
+        IR.RecursiveGroup recGroup → do
+          recBinds ← forM (toList recGroup) \(IR.QName modname name, irExp) →
+            (fromQName modname name,) <$> fromExp foreigns Set.empty modname irExp
+          let declarations = Lua.local0 . fst <$> DList.fromList recBinds
+              assignments = DList.fromList do
+                recBinds <&> \(name, exp) → Lua.assign (Lua.VarName name) exp
+          pure $ declarations <> assignments
+
+    returnExp ←
+      case appOrModule of
+        AsModule modname →
+          Lua.table <$> do
+            forM (uberModuleExports uber) \(fromName → name, expr) →
+              Lua.tableRowNV name <$> fromExp foreigns mempty modname expr
+        AsApplication modname ident → do
+          case List.lookup name (uberModuleExports uber) of
+            Just expr → do
+              entry ← fromExp foreigns mempty modname expr
+              pure $ Lua.functionCall entry []
+            _ → Oops.throw $ AppEntryPointNotFound modname ident
+         where
+          name = IR.identToName ident
+
+    pure $ DList.snoc bindings (Lua.Return (Lua.ann returnExp))
 
   pure . mconcat $
-    [ if usesPrimModule uber then [Fixture.prim] else empty
-    , if untag needsRuntimeLazy && usesRuntimeLazy uber
-        then pure Fixture.runtimeLazy
-        else empty
-    , DList.toList bindings
-    , [Lua.Return (Lua.ann returnExp)]
+    [ [Fixture.prim | usesPrimModule uber]
+    , [Fixture.runtimeLazy | untag needsRuntimeLazy && usesRuntimeLazy uber]
+    , [Fixture.objectUpdate | UsesObjectUpdate ← [usesObjectUpdate]]
+    , DList.toList chunk
     ]
 
 fromQName ∷ ModuleName → IR.Name → Lua.Name
@@ -149,17 +163,19 @@ fromExp foreigns topLevelNames modname ir = case ir of
     flip Lua.varIndex (Lua.Integer (fromIntegral index)) <$> go (IR.unAnn expr)
   IR.ObjectProp expr propName →
     flip Lua.varField (fromPropName propName) <$> go (IR.unAnn expr)
-  IR.ObjectUpdate _expr _patches →
-    Prelude.error "fromObjectUpdate is not implemented"
+  IR.ObjectUpdate expr propValues → do
+    add UsesObjectUpdate
+    obj ← go (IR.unAnn expr)
+    vals ←
+      Lua.table <$> for (toList propValues) \(propName, IR.unAnn → e) →
+        Lua.tableRowNV (fromPropName propName) <$> go e
+    pure $ Lua.functionCall (Lua.varName Fixture.objectUpdateName) [obj, vals]
   IR.Abs param expr → do
     e ← go $ IR.unAnn expr
     luaParam ←
       Lua.ParamNamed
         <$> case IR.unAnn param of
-          IR.ParamUnused → do
-            index ← get
-            modify' (+ 1)
-            pure $ Lua.unsafeName ("unused" <> show index)
+          IR.ParamUnused → uniqueName "unused"
           IR.ParamNamed name → pure (fromName name)
     pure $ Lua.functionDef [luaParam] [Lua.return e]
   IR.App expr param → do
@@ -227,5 +243,11 @@ fromIfThenElse cond thenExp elseExp = Lua.functionCall fun []
 --------------------------------------------------------------------------------
 -- Helpers ---------------------------------------------------------------------
 
+uniqueName ∷ MonadState Natural m ⇒ Text → m Lua.Name
+uniqueName prefix = do
+  index ← get
+  modify' (+ 1)
+  pure $ Lua.unsafeName (prefix <> show index)
+
 qualifyName ∷ ModuleName → Lua.Name → Lua.Name
 qualifyName modname = Name.join2 (fromModuleName modname)

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

@@ -2,6 +2,7 @@
 
 module Language.PureScript.Backend.Lua.Fixture where
 
+import Data.String.Interpolate (__i)
 import Language.PureScript.Backend.Lua.Name (Name, name)
 import Language.PureScript.Backend.Lua.Name qualified as Name
 import Language.PureScript.Backend.Lua.Types hiding (var)
@@ -12,39 +13,52 @@ import Language.PureScript.Backend.Lua.Types hiding (var)
 prim ∷ Statement
 prim = local1 (Name.join2 [name|Prim|] [name|undefined|]) Nil
 
+runtimeLazyName ∷ Name
+runtimeLazyName = [name|_S___runtime_lazy|]
+
 runtimeLazy ∷ Statement
-runtimeLazy = local1 [name|_S___runtime_lazy|] do
-  let fun ∷ Name → [Statement] → Exp
-      fun n = Function [((), ParamNamed n)] . fmap ann
-      var ∷ Name → Var
-      var = VarName
-      ret ∷ Exp → Statement
-      ret = Return . ann
-  fun [name|name|] . pure . ret . fun [name|init|] $
-    [ local1 [name|state|] (Integer 0)
-    , local1 [name|val|] Nil
-    , ret . functionDef [] $
-        [ ifThenElse
-            (varName [name|state|] `equalTo` Integer 2)
-            [ret (varName [name|val|])]
-            [ ifThenElse
-                (varName [name|state|] `equalTo` Integer 1)
-                ( pure . ret $
-                    functionCall
-                      (varName [name|error|])
-                      [ binOp
-                          Concat
-                          (varName [name|name|])
-                          ( String
-                              " was needed before it finished initializing"
-                          )
-                      ]
-                )
-                [ var [name|state|] `assign` Integer 1
-                , var [name|val|] `assign` functionCall (varName [name|init|]) []
-                , var [name|state|] `assign` Integer 2
-                , ret (varName [name|val|])
-                ]
-            ]
-        ]
-    ]
+runtimeLazy =
+  ForeignSourceCode
+    [__i|
+      local function #{Name.toText runtimeLazyName}(name)
+        return function(init)
+          return function()
+            local state = 0
+            local val = nil
+            if state == 2 then
+              return val
+            else
+              if state == 1 then
+                return error(name .. " was needed before it finished initializing")
+              else
+                state = 1
+                val = init()
+                state = 2
+                return val
+              end
+            end
+          end
+        end
+      end
+    |]
+
+objectUpdateName ∷ Name
+objectUpdateName = [name|_S___object_update|]
+
+objectUpdate ∷ Statement
+objectUpdate =
+  ForeignSourceCode
+    [__i|
+      local function #{Name.toText objectUpdateName}(o, patches)
+        local o_copy = {}
+        for k, v in pairs(o) do
+          local patch_v = patches
+          if patch_v ~= nil then
+            o_copy[k] = patch_v
+          else
+            o_copy[k] = v
+          end
+        end
+        return o_copy
+      end
+    |]

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

@@ -40,7 +40,7 @@ everywhereExpM f g = goe
       tableRows ← forM rows \case
         TableRowKV (Ann k) (Ann v) → tableRowKV <$> goe k <*> goe v
         TableRowNV n (Ann e) → tableRowNV n <$> goe e
-      f $ tableCtor tableRows
+      f $ table tableRows
     UnOp op (Ann e) →
       f . unOp op =<< goe e
     BinOp op (Ann e1) (Ann e2) →

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

@@ -272,9 +272,6 @@ functionDef params body = Function (ann <$> params) (ann <$> body)
 functionCall ∷ Exp → [Exp] → Exp
 functionCall f args = FunctionCall (ann f) (ann <$> args)
 
-tableCtor ∷ [TableRow] → Exp
-tableCtor = TableCtor . fmap ann
-
 unOp ∷ UnaryOp → Exp → Exp
 unOp op e = UnOp op (ann e)
 

pslua.cabal

@@ -97,6 +97,7 @@ common shared
     , relude                       ^>=1.2
     , scientific                   ^>=0.3.7.0
     , shower                       ^>=0.2.0.3
+    , string-interpolate           ^>=0.3.2.1
     , tagged                       ^>=0.8.6.1
     , template-haskell             ^>=2.18
     , text                         ^>=1.2.5.0

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

@@ -132,7 +132,7 @@ binOp ∷ Gen Lua.Exp
 binOp = Lua.binOp <$> Gen.enumBounded <*> expression <*> expression
 
 table ∷ Gen Lua.Exp
-table = Lua.tableCtor <$> Gen.list (Range.linear 0 5) tableRow
+table = Lua.table <$> Gen.list (Range.linear 0 5) tableRow
 
 recursiveVar ∷ Gen Lua.Exp
 recursiveVar = do

test/ps/golden/Golden/TestRecordsUpdate.purs

@@ -0,0 +1,21 @@
+module Golden.TestRecordsUpdate where
+
+type R = { x :: Int, y :: Boolean, z :: Z }
+type Z = { z :: String , p :: Char }
+
+r :: R
+r = { x: 1, y: true, z: { z: "foo", p: 'a' } }
+
+test1 :: R
+test1 = r { x = 2 }
+
+test2 :: R -> R
+test2 = _ { y = false }
+
+test3 :: R -> R
+test3 = _ { z { p = 'b' } }
+
+type Poly r = { x :: Int, y :: Char | r }
+
+test4 :: forall r. Poly r -> Poly r
+test4 = _ { x = 1 }

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

@@ -1,5 +1,5 @@
 local Prim_I_undefined = nil
-local _S___runtime_lazy = function(name)
+local function _S___runtime_lazy(name)
   return function(init)
     return function()
       local state = 0

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

@@ -0,0 +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]}}