Newtype free applicatives/monads in DAML script (digital-asset#3479)

This should hopefully prevent the horrifying implementation details from leaking to users.
kgeonw · Nov 15, 2019 · 0b784bb · 0b784bb
1 parent db1b12d
commit 0b784bb
Show file tree

Hide file tree

Showing 2 changed files with 37 additions and 12 deletions.
diff --git a/daml-script/daml/Daml/Script.daml b/daml-script/daml/Daml/Script.daml
@@ -45,7 +45,8 @@ data CommandsF a
   | Exercise { tplId : TemplateTypeRep, cId : ContractId (), argE : AnyChoice, continueE : LedgerValue -> a }
   deriving Functor
 
-type Commands = Ap CommandsF
+newtype Commands a = Commands (Ap CommandsF a)
+  deriving (Functor, Applicative)
 
 data ScriptF a
   = Submit (SubmitCmd a)
@@ -60,32 +61,32 @@ data QueryACS a = QueryACS
   } deriving Functor
 
 query : forall t. Template t => Party -> Script [t]
-query p = Free $ Query (QueryACS p (templateTypeRep @t) (pure . map (fromSome . fromAnyTemplate)))
+query p = Script $ Free $ Query (QueryACS p (templateTypeRep @t) (pure . map (fromSome . fromAnyTemplate)))
 
 data AllocateParty a = AllocateParty
   { displayName : Text
   , continue : Party -> a
   } deriving Functor
 
 allocateParty : Text -> Script Party
-allocateParty displayName = Free (AllocParty $ AllocateParty displayName pure)
+allocateParty displayName = Script $ Free (AllocParty $ AllocateParty displayName pure)
 
 data SubmitCmd a = SubmitCmd { party : Party, commands : Commands a }
   deriving Functor
 
 submit : Party -> Commands a -> Script a
-submit p cmds = Free (fmap pure $ Submit $ SubmitCmd p cmds)
+submit p cmds = Script $ Free (fmap pure $ Submit $ SubmitCmd p cmds)
 
-type Script = Free ScriptF
+newtype Script a = Script (Free ScriptF a)
+  deriving (Functor, Applicative, Action)
 
 data LedgerValue = LedgerValue {}
 
 fromLedgerValue : LedgerValue -> a
 fromLedgerValue = error "foobar"
 
 createCmd : Template t => t -> Commands (ContractId t)
-createCmd arg = Ap (\f -> f (Create (toAnyTemplate arg) identity) (pure coerceContractId))
+createCmd arg = Commands $ Ap (\f -> f (Create (toAnyTemplate arg) identity) (pure coerceContractId))
 
 exerciseCmd : forall t c r. Choice t c r => ContractId t -> c -> Commands r
-exerciseCmd cId arg = Ap (\f -> f (Exercise (templateTypeRep @t) (coerceContractId cId) (toAnyChoice @t arg) identity) (pure fromLedgerValue))
-
+exerciseCmd cId arg = Commands $ Ap (\f -> f (Exercise (templateTypeRep @t) (coerceContractId cId) (toAnyChoice @t arg) identity) (pure fromLedgerValue))
diff --git a/daml-script/runner/src/main/scala/com/digitalasset/daml/lf/engine/script/Runner.scala b/daml-script/runner/src/main/scala/com/digitalasset/daml/lf/engine/script/Runner.scala
@@ -18,7 +18,7 @@ import com.digitalasset.daml.lf.data.FrontStack
 import com.digitalasset.daml.lf.data.Ref._
 import com.digitalasset.daml.lf.engine.ValueTranslator
 import com.digitalasset.daml.lf.language.Ast._
-import com.digitalasset.daml.lf.speedy.{Compiler, Pretty, Speedy, SValue}
+import com.digitalasset.daml.lf.speedy.{Compiler, Pretty, Speedy, SValue, TraceLog}
 import com.digitalasset.daml.lf.speedy.SExpr._
 import com.digitalasset.daml.lf.speedy.SResult._
 import com.digitalasset.daml.lf.speedy.SValue._
@@ -110,10 +110,10 @@ class Runner(
       implicit ec: ExecutionContext,
       mat: ActorMaterializer): Future[SValue] = {
     val scriptExpr = EVal(scriptId)
-    val machine =
+    var machine =
       Speedy.Machine.fromSExpr(compiler.compile(scriptExpr), false, compiledPackages)
 
-    def go(): Future[SValue] = {
+    def stepToValue() = {
       while (!machine.isFinal) {
         machine.step() match {
           case SResultContinue => ()
@@ -125,17 +125,41 @@ class Runner(
           }
         }
       }
+      // TODO Share this logic with the trigger runner
+      var traceEmpty = true
       machine.traceLog.iterator.foreach {
         case (msg, optLoc) =>
+          traceEmpty = false
           println(s"TRACE ${Pretty.prettyLoc(optLoc).render(80)}: $msg")
       }
+      if (!traceEmpty) {
+        machine = machine.copy(traceLog = TraceLog(machine.traceLog.capacity))
+      }
+    }
+
+    stepToValue()
+    machine.toSValue match {
+      // Unwrap Script newtype
+      case SRecord(_, _, vals) if vals.size == 1 => {
+        machine.ctrl = Speedy.CtrlExpr(SEValue(vals.get(0)))
+      }
+      case v => throw new ConverterException(s"Expected record with 1 field but got $v")
+    }
+
+    def go(): Future[SValue] = {
+      stepToValue()
       machine.toSValue match {
         case SVariant(_, "Free", v) => {
           v match {
             case SVariant(_, "Submit", v) => {
               v match {
                 case SRecord(_, _, vals) if vals.size == 2 => {
-                  val freeAp = vals.get(1)
+                  val freeAp = vals.get(1) match {
+                    // Unwrap Commands newtype
+                    case SRecord(_, _, vals) if vals.size == 1 => vals.get(0)
+                    case v =>
+                      throw new ConverterException(s"Expected record with 1 field but got $v")
+                  }
                   val requestOrErr = for {
                     party <- Converter.toParty(vals.get(0))
                     commands <- Converter.toCommands(compiledPackages, freeAp)