Add an initial version of DAML script

The code still needs a fair amount of cleanup but it seems to work and there is a test so I’d like to do the cleanup in-tree after merging the current state
digital-asset · Nov 12, 2019 · 10d5d40 · 10d5d40
1 parent 0a3636e
commit 10d5d40
Show file tree

Hide file tree

Showing 11 changed files with 965 additions and 0 deletions.
diff --git a/daml-lf/interpreter/BUILD.bazel b/daml-lf/interpreter/BUILD.bazel
@@ -17,6 +17,7 @@ da_scala_library(
     visibility = [
         "//compiler/scenario-service:__subpackages__",
         "//daml-lf:__subpackages__",
+        "//daml-script:__subpackages__",
         "//ledger:__subpackages__",
         "//triggers:__subpackages__",
     ],

diff --git a/daml-script/daml/BUILD.bazel b/daml-script/daml/BUILD.bazel
@@ -0,0 +1,30 @@
+# Copyright (c) 2019 The DAML Authors. All rights reserved.
+# SPDX-License-Identifier: Apache-2.0
+
+# TODO Once daml_compile uses build instead of package we should use
+# daml_compile instead of a genrule.
+
+genrule(
+    name = "daml-script",
+    srcs = glob(["**/*.daml"]),
+    outs = ["daml-script.dar"],
+    cmd = """
+      set -eou pipefail
+      TMP_DIR=$$(mktemp -d)
+      mkdir -p $$TMP_DIR/daml/Daml
+      cp -L $(location Daml/Script.daml) $$TMP_DIR/daml/Daml
+      cat << EOF > $$TMP_DIR/daml.yaml
+sdk-version: 0.0.0
+name: daml-script
+source: daml
+version: 0.0.1
+dependencies:
+  - daml-stdlib
+  - daml-prim
+EOF
+      $(location //compiler/damlc) build --target=1.dev --project-root=$$TMP_DIR -o $$PWD/$(location daml-script.dar)
+      rm -rf $$TMP_DIR
+    """,
+    tools = ["//compiler/damlc"],
+    visibility = ["//visibility:public"],
+)
diff --git a/daml-script/daml/Daml/Script.daml b/daml-script/daml/Daml/Script.daml
@@ -0,0 +1,91 @@
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+daml 1.2
+module Daml.Script where
+
+import DA.Optional
+
+-- | A free monad
+data Free f a
+  = Pure a
+  | Free (f (Free f a))
+
+instance Functor f => Functor (Free f) where
+  fmap f (Pure a) = Pure (f a)
+  fmap f (Free x) = Free (fmap f <$> x)
+
+instance Functor f => Applicative (Free f) where
+  pure = Pure
+  Pure f <*> Pure a = Pure (f a)
+  Pure f <*> Free x = Free (fmap f <$> x)
+  Free x <*> my     = Free ((<*> my) <$> x)
+
+instance Functor f => Action (Free f) where
+  Pure a >>= f = f a
+  Free x >>= f = Free ((>>= f) <$> x)
+
+-- | A free applicative, since we don’t have existentials we have to use the weird RankNTypes encoding, this is isomorphic to
+-- forall b. Ap f b (Ap f (b -> a))
+data Ap f a
+  = PureA a
+  | Ap (forall r. (forall b. f b -> Ap f (b -> a) -> r) -> r)
+
+instance Functor (Ap f) where
+  fmap f (PureA x) = PureA (f x)
+  fmap f (Ap c) = Ap (\c' -> c (\a b -> c' a (fmap (f .) b)))
+
+instance Applicative (Ap f) where
+  pure = PureA
+  PureA f <*> x = fmap f x
+  Ap c <*> x = Ap (\c' -> c (\a b -> c' a (flip <$> b <*> x)))
+
+data CommandsF a
+  = Create { argC : AnyTemplate, continueC : ContractId () -> a }
+  | Exercise { tplId : TemplateTypeRep, cId : ContractId (), argE : AnyChoice, continueE : LedgerValue -> a }
+  deriving Functor
+
+type Commands = Ap CommandsF
+
+data ScriptF a
+  = Submit (SubmitCmd a)
+  | Query (QueryACS a)
+  | AllocParty (AllocateParty a)
+  deriving Functor
+
+data QueryACS a = QueryACS
+  { party : Party
+  , tplId : TemplateTypeRep
+  , continue : [AnyTemplate] -> a
+  } deriving Functor
+
+query : forall t. Template t => Party -> Script [t]
+query p = 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)
+
+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)
+
+type Script = Free ScriptF
+
+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))
+
+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))
+
diff --git a/daml-script/runner/BUILD.bazel b/daml-script/runner/BUILD.bazel
@@ -0,0 +1,39 @@
+# Copyright (c) 2019 The DAML Authors. All rights reserved.
+# SPDX-License-Identifier: Apache-2.0
+
+load(
+    "//bazel_tools:scala.bzl",
+    "da_scala_binary",
+    "da_scala_library",
+)
+
+da_scala_library(
+    name = "script-runner-lib",
+    srcs = glob(["src/main/scala/**/*.scala"]),
+    resources = glob(["src/main/resources/**/*"]),
+    visibility = ["//visibility:public"],
+    deps = [
+        "//daml-lf/archive:daml_lf_archive_reader",
+        "//daml-lf/archive:daml_lf_dev_archive_java_proto",
+        "//daml-lf/data",
+        "//daml-lf/interpreter",
+        "//daml-lf/language",
+        "//daml-lf/transaction",
+        "//language-support/scala/bindings",
+        "//language-support/scala/bindings-akka",
+        "//ledger-api/rs-grpc-bridge",
+        "//ledger/ledger-api-client",
+        "//ledger/ledger-api-common",
+        "@maven//:com_github_scopt_scopt_2_12",
+        "@maven//:com_typesafe_akka_akka_stream_2_12",
+        "@maven//:org_scalaz_scalaz_core_2_12",
+        "@maven//:org_typelevel_paiges_core_2_12",
+    ],
+)
+
+da_scala_binary(
+    name = "script-runner",
+    main_class = "com.daml.script.RunnerMain",
+    visibility = ["//visibility:public"],
+    deps = [":script-runner-lib"],
+)
diff --git a/daml-script/runner/src/main/resources/logback.xml b/daml-script/runner/src/main/resources/logback.xml
@@ -0,0 +1,15 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<configuration>
+    <appender name="STDOUT" class="ch.qos.logback.core.ConsoleAppender">
+        <encoder>
+            <pattern>%d{HH:mm:ss.SSS} [%thread] %-5level %logger{36} - %msg%n</pattern>
+        </encoder>
+    </appender>
+
+    <logger name="io.netty" level="WARN" />
+    <logger name="io.grpc.netty" level="WARN" />
+
+    <root level="INFO">
+        <appender-ref ref="STDOUT" />
+    </root>
+</configuration>