Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Newtype free applicatives/monads in DAML script #3479

Merged
merged 1 commit into from
Nov 15, 2019
Merged

Newtype free applicatives/monads in DAML script #3479

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
17 changes: 9 additions & 8 deletions daml-script/daml/Daml/Script.daml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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))
32 changes: 28 additions & 4 deletions daml-script/runner/src/main/scala/com/digitalasset/daml/lf/engine/script/Runner.scala
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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._
Expand Down Expand Up @@ -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 => ()
Expand All @@ -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)
Expand Down