Include stack traces for all ScriptF commands (#8999)

This PR adds stack traces to all ScriptF commands and handles those in
the converter. Those stack traces are not yet used. To ease review,
I’ve left that for a separate PR. The plan is to use this to tackle
#8754.

changelog_begin
changelog_end

compiler/damlc/daml-stdlib-src/DA/Internal/LF.daml

@@ -183,7 +183,7 @@ instance ActionFail Update where
 -- | The `HasTime` class is for where the time is available: `Scenario` and `Update`.
 class HasTime m where
     -- | Get the current time.
-    getTime : m Time
+    getTime : HasCallStack => m Time
 
 instance HasTime Update where
     getTime = primitive @"UGetTime"

daml-script/daml/Daml/Script.daml

@@ -91,7 +91,7 @@ data ScriptF a
   | QueryContractKey (QueryContractKeyPayload a)
   | AllocParty (AllocateParty a)
   | ListKnownParties (ListKnownPartiesPayload a)
-  | GetTime (Time -> a)
+  | GetTime (GetTimePayload a)
   | SetTime (SetTimePayload a)
   | Sleep (SleepRec a)
   deriving Functor
@@ -100,12 +100,17 @@ data QueryACS a = QueryACS
   { parties : [Party]
   , tplId : TemplateTypeRep
   , continue : [(ContractId (), AnyTemplate)] -> a
+  , locations : [(Text, SrcLoc)]
   } deriving Functor
 
 -- | Query the set of active contracts of the template
 -- that are visible to the given party.
 query : forall t p. (Template t, IsParties p) => p -> Script [(ContractId t, t)]
-query p = lift $ Free $ Query (QueryACS (toParties p) (templateTypeRep @t) (pure . map (\(cid, tpl) -> (coerceContractId cid, fromSome $ fromAnyTemplate tpl))))
+query p = lift $ Free $ Query QueryACS with
+  parties = toParties p
+  tplId = templateTypeRep @t
+  continue = pure . map (\(cid, tpl) -> (coerceContractId cid, fromSome $ fromAnyTemplate tpl))
+  locations = getCallStack callStack
 
 -- | Query the set of active contracts of the template
 -- that are visible to the given party and match the given predicate.
@@ -117,42 +122,47 @@ data QueryContractIdPayload a = QueryContractIdPayload
   , tplId : TemplateTypeRep
   , cid : ContractId ()
   , continue : Optional AnyTemplate -> a
+  , locations : [(Text, SrcLoc)]
   } deriving Functor
 
 -- | Query for the contract with the given contract id.
 --
 -- Returns `None` if there is no active contract the party is a stakeholder on.
 -- This is semantically equivalent to calling `query`
 -- and filtering on the client side.
-queryContractId : forall t p. (Template t, IsParties p) => p -> ContractId t -> Script (Optional t)
+queryContractId : forall t p. (Template t, IsParties p) => HasCallStack => p -> ContractId t -> Script (Optional t)
 queryContractId p c = lift $ Free $ QueryContractId QueryContractIdPayload with
   parties = toParties p
   tplId = templateTypeRep @t
   cid = coerceContractId c
   continue = pure . fmap (fromSome . fromAnyTemplate)
+  locations = getCallStack callStack
 
 data QueryContractKeyPayload a = QueryContractKeyPayload
   { parties : [Party]
   , tplId : TemplateTypeRep
   , key : AnyContractKey
   , continue : Optional (ContractId (), AnyTemplate) -> a
+  , locations : [(Text, SrcLoc)]
   } deriving Functor
 
 -- Returns `None` if there is no active contract with the given key that
 -- the party is a stakeholder on.
 -- This is semantically equivalent to calling `query`
 -- and filtering on the client side.
-queryContractKey : forall t k p. (TemplateKey t k, IsParties p) => p -> k -> Script (Optional (ContractId t, t))
+queryContractKey : forall t k p. HasCallStack => (TemplateKey t k, IsParties p) => p -> k -> Script (Optional (ContractId t, t))
 queryContractKey p k = lift $ Free $ QueryContractKey QueryContractKeyPayload with
   parties = toParties p
   tplId = templateTypeRep @t
   key = toAnyContractKey @t k
   continue = pure . fmap (\(cid, anyTpl) -> (coerceContractId cid, fromSome (fromAnyTemplate anyTpl)))
+  locations = getCallStack callStack
 
 data SetTimePayload a = SetTimePayload
   with
     time : Time
     continue : () -> a
+    locations : [(Text, SrcLoc)]
   deriving Functor
 
 -- | Set the time via the time service.
@@ -162,10 +172,11 @@ data SetTimePayload a = SetTimePayload
 --
 -- Note that the ledger time service does not support going backwards in time.
 -- However, you can go back in time in Daml Studio.
-setTime : Time -> Script ()
+setTime : HasCallStack => Time -> Script ()
 setTime time = lift $ Free $ SetTime $ SetTimePayload with
   time
   continue = pure
+  locations = getCallStack callStack
 
 -- | Advance ledger time by the given interval.
 --
@@ -186,16 +197,19 @@ data AllocateParty a = AllocateParty
   , idHint : Text
   , participant : Optional Text
   , continue : Party -> a
+  , locations : [(Text, SrcLoc)]
   } deriving Functor
 
 data ListKnownPartiesPayload a = ListKnownPartiesPayload
   { participant : Optional Text
   , continue : [PartyDetails] -> a
+  , locations : [(Text, SrcLoc)]
   } deriving Functor
 
 data SleepRec a = SleepRec
   { duration : RelTime
   , continue : () -> a
+  , locations : [(Text, SrcLoc)]
   } deriving Functor
 
 -- | A hint to the backing participant what party id to allocate.
@@ -206,59 +220,59 @@ newtype ParticipantName = ParticipantName { participantName : Text }
 
 -- | Allocate a party with the given display name
 -- using the party management service.
-allocateParty : Text -> Script Party
-allocateParty displayName = lift $ Free $ AllocParty $ AllocateParty
-  { displayName
-  , idHint = ""
-  , participant = None
-  , continue = pure
-  }
+allocateParty : HasCallStack => Text -> Script Party
+allocateParty displayName = lift $ Free $ AllocParty $ AllocateParty with
+  displayName
+  idHint = ""
+  participant = None
+  continue = pure
+  locations = getCallStack callStack
 
 -- | Allocate a party with the given display name and id hint
 -- using the party management service.
-allocatePartyWithHint : Text -> PartyIdHint -> Script Party
-allocatePartyWithHint displayName (PartyIdHint idHint) = lift $ Free $ AllocParty $ AllocateParty
-  { displayName
-  , idHint = idHint
-  , participant = None
-  , continue = pure
-  }
+allocatePartyWithHint : HasCallStack => Text -> PartyIdHint -> Script Party
+allocatePartyWithHint displayName (PartyIdHint idHint) = lift $ Free $ AllocParty $ AllocateParty with
+  displayName
+  idHint = idHint
+  participant = None
+  continue = pure
+  locations = getCallStack callStack
 
 -- | Allocate a party with the given display name
 -- on the specified participant using the party management service.
 allocatePartyOn : Text -> ParticipantName -> Script Party
-allocatePartyOn displayName (ParticipantName participant) = lift $ Free $ AllocParty $ AllocateParty
-  { displayName
-  , idHint = ""
-  , participant = Some participant
-  , continue = pure
-  }
+allocatePartyOn displayName (ParticipantName participant) = lift $ Free $ AllocParty $ AllocateParty with
+  displayName
+  idHint = ""
+  participant = Some participant
+  continue = pure
+  locations = getCallStack callStack
 
 -- | Allocate a party with the given display name and id hint
 -- on the specified participant using the party management service.
 allocatePartyWithHintOn : Text -> PartyIdHint -> ParticipantName -> Script Party
-allocatePartyWithHintOn displayName (PartyIdHint idHint) (ParticipantName participant) = lift $ Free $ AllocParty $ AllocateParty
-  { displayName
-  , idHint = idHint
-  , participant = Some participant
-  , continue = pure
-  }
+allocatePartyWithHintOn displayName (PartyIdHint idHint) (ParticipantName participant) = lift $ Free $ AllocParty $ AllocateParty with
+  displayName
+  idHint = idHint
+  participant = Some participant
+  continue = pure
+  locations = getCallStack callStack
 
 -- | List the parties known to the default participant.
-listKnownParties : Script [PartyDetails]
+listKnownParties : HasCallStack => Script [PartyDetails]
 listKnownParties =
-  lift $ Free $ ListKnownParties $ ListKnownPartiesPayload
-    { participant = None
-    , continue = pure
-    }
+  lift $ Free $ ListKnownParties $ ListKnownPartiesPayload with
+    participant = None
+    continue = pure
+    locations = getCallStack callStack
 
 -- | List the parties known to the given participant.
-listKnownPartiesOn : ParticipantName -> Script [PartyDetails]
+listKnownPartiesOn : HasCallStack => ParticipantName -> Script [PartyDetails]
 listKnownPartiesOn (ParticipantName participant) =
-  lift $ Free $ ListKnownParties $ ListKnownPartiesPayload
-    { participant = Some participant
-    , continue = pure
-    }
+  lift $ Free $ ListKnownParties $ ListKnownPartiesPayload with
+    participant = Some participant
+    continue = pure
+    locations = getCallStack callStack
 
 -- | The party details returned by the party management service.
 data PartyDetails = PartyDetails
@@ -277,16 +291,27 @@ data PartyDetails = PartyDetails
 -- In static time mode over the JSON API, it will always
 -- return the Unix epoch.
 instance HasTime Script where
-  getTime = lift $ Free (GetTime pure)
+  getTime = lift $ Free $ GetTime GetTimePayload with
+    continue = pure
+    locations = getCallStack callStack
+
+data GetTimePayload a = GetTimePayload
+  with
+    continue : Time -> a
+    locations : [(Text, SrcLoc)]
+  deriving Functor
 
 -- | Sleep for the given duration.
 --
 -- This is primarily useful in tests
 -- where you repeatedly call `query` until a certain state is reached.
 --
 -- Note that this will sleep for the same duration in both wallcock and static time mode.
-sleep : RelTime -> Script ()
-sleep duration = lift $ Free (Sleep $ SleepRec duration pure)
+sleep : HasCallStack => RelTime -> Script ()
+sleep duration = lift $ Free $Sleep SleepRec with
+  duration = duration
+  continue = pure
+  locations = getCallStack callStack
 
 data SubmitFailure = SubmitFailure
   { status : Int

daml-script/runner/src/main/scala/com/digitalasset/daml/lf/engine/script/Converter.scala

@@ -27,6 +27,7 @@ import com.daml.script.converter.ConverterException
 import io.grpc.StatusRuntimeException
 import scalaz.std.list._
 import scalaz.std.either._
+import scalaz.std.vector._
 import scalaz.syntax.traverse._
 import scalaz.{-\/, OneAnd, \/-}
 import spray.json._
@@ -60,9 +61,18 @@ object ScriptIds {
   }
 }
 
-case class AnyTemplate(ty: Identifier, arg: SValue)
-case class AnyChoice(name: ChoiceName, arg: SValue)
-case class AnyContractKey(key: SValue)
+final case class AnyTemplate(ty: Identifier, arg: SValue)
+final case class AnyChoice(name: ChoiceName, arg: SValue)
+final case class AnyContractKey(key: SValue)
+// frames ordered from most-recent to least-recent
+final case class StackTrace(frames: Vector[Location]) {
+  // Return the most recent frame
+  def topFrame: Option[Location] =
+    frames.headOption
+}
+object StackTrace {
+  val empty: StackTrace = StackTrace(Vector.empty)
+}
 
 object Converter {
   import com.daml.script.converter.Converter._
@@ -513,50 +523,60 @@ object Converter {
     case v => Left(s"Expected SInt64 but got $v")
   }
 
-  def toOptionLocation(
+  private case class SrcLoc(
+      pkgId: PackageId,
+      module: ModuleName,
+      start: (Int, Int),
+      end: (Int, Int),
+  )
+
+  private def toSrcLoc(knownPackages: Map[String, PackageId], v: SValue): Either[String, SrcLoc] =
+    v match {
+      case SRecord(
+            _,
+            _,
+            JavaList(unitId, module, file @ _, startLine, startCol, endLine, endCol),
+          ) =>
+        for {
+          unitId <- toText(unitId)
+          packageId <- unitId match {
+            // GHC uses unit-id "main" for the current package,
+            // but the scenario context expects "-homePackageId-".
+            case "main" => PackageId.fromString("-homePackageId-")
+            case id => knownPackages.get(id).toRight(s"Unknown package $id")
+          }
+          module <- toText(module).flatMap(ModuleName.fromString(_))
+          startLine <- toInt(startLine)
+          startCol <- toInt(startCol)
+          endLine <- toInt(endLine)
+          endCol <- toInt(endCol)
+        } yield SrcLoc(packageId, module, (startLine, startCol), (endLine, endCol))
+      case _ => Left(s"Expected SrcLoc but got $v")
+    }
+
+  def toLocation(knownPackages: Map[String, PackageId], v: SValue): Either[String, Location] =
+    v match {
+      case SRecord(_, _, JavaList(definition, loc)) =>
+        for {
+          // TODO[AH] This should be the outer definition. E.g. `main` in `main = do submit ...`.
+          //   However, the call-stack only gives us access to the inner definition, `submit` in this case.
+          //   The definition is not used when pretty printing locations. So, we can ignore this for now.
+          definition <- toText(definition)
+          loc <- toSrcLoc(knownPackages, loc)
+        } yield Location(loc.pkgId, loc.module, definition, loc.start, loc.end)
+      case _ => Left(s"Expected (Text, SrcLoc) but got $v")
+    }
+
+  def toStackTrace(
       knownPackages: Map[String, PackageId],
       v: SValue,
-  ): Either[String, Option[Location]] =
+  ): Either[String, StackTrace] =
     v match {
-      case SList(list) =>
-        list.pop match {
-          case None => Right(None)
-          case Some((pair, _)) =>
-            pair match {
-              case SRecord(_, _, vals) if vals.size == 2 =>
-                for {
-                  // TODO[AH] This should be the outer definition. E.g. `main` in `main = do submit ...`.
-                  //   However, the call-stack only gives us access to the inner definition, `submit` in this case.
-                  //   The definition is not used when pretty printing locations. So, we can ignore this.
-                  definition <- toText(vals.get(0))
-                  loc <- vals.get(1) match {
-                    case SRecord(_, _, vals) if vals.size == 7 =>
-                      for {
-                        packageId <- toText(vals.get(0)).flatMap {
-                          // GHC uses unit-id "main" for the current package,
-                          // but the scenario context expects "-homePackageId-".
-                          case "main" => PackageId.fromString("-homePackageId-")
-                          case id => knownPackages.get(id).toRight(s"Unknown package $id")
-                        }
-                        module <- toText(vals.get(1)).flatMap(ModuleName.fromString(_))
-                        startLine <- toInt(vals.get(3))
-                        startCol <- toInt(vals.get(4))
-                        endLine <- toInt(vals.get(5))
-                        endCol <- toInt(vals.get(6))
-                      } yield Location(
-                        packageId,
-                        module,
-                        definition,
-                        (startLine, startCol),
-                        (endLine, endCol),
-                      )
-                    case _ => Left("Expected SRecord of Daml.Script.SrcLoc")
-                  }
-                } yield Some(loc)
-              case _ => Left("Expected SRecord of a pair")
-            }
-        }
-      case _ => Left(s"Expected SList but got $v")
+      case SList(frames) =>
+        frames.toVector.traverse(toLocation(knownPackages, _)).map(StackTrace(_))
+      case _ =>
+        new Throwable().printStackTrace();
+        Left(s"Expected SList but got $v")
     }
 
   def toParticipantName(v: SValue): Either[String, Option[Participant]] = v match {