Extend the scenario service with DAML Script support (#6929)

* Extend the scenario service with DAML Script support This adds most of the infrastructure for running DAML Script via the scenario service which means it runs as part of DAML Studio and `daml test`. This is hidden behind a feature flag so we can land this and parallelize the remaining tasks. The main things that are missing are: 1. `createAndExerciseCmd` and `exerciseByKeyCmd`. 2. Party management needs some work and listing parties is unsupported. 3. Time management 4. Potentially some better error handling (we need to go through SResult and SError and see what is relevant for us). Overall, it is already in a very usable state and there is a decent range of tests. closes #3688 changelog_begin changelog_end * Update compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs Co-authored-by: Andreas Herrmann <42969706+aherrmann-da@users.noreply.github.com> * Fix name for actor system and pool changelog_begin changelog_end Co-authored-by: Andreas Herrmann <42969706+aherrmann-da@users.noreply.github.com>
digital-asset · Aug 5, 2020 · ad9d8c2 · ad9d8c2
1 parent 2ee3ae3
commit ad9d8c2
Show file tree

Hide file tree

Showing 20 changed files with 975 additions and 37 deletions.
diff --git a/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs b/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs
@@ -228,6 +228,10 @@ getDalfDependencies files = do
 runScenarios :: NormalizedFilePath -> Action (Maybe [(VirtualResource, Either SS.Error SS.ScenarioResult)])
 runScenarios file = use RunScenarios file
 
+
+runScripts :: NormalizedFilePath -> Action (Maybe [(VirtualResource, Either SS.Error SS.ScenarioResult)])
+runScripts file = use RunScripts file
+
 -- | Get a list of the scenarios in a given file
 getScenarioNames :: NormalizedFilePath -> Action (Maybe [VirtualResource])
 getScenarioNames file = fmap f <$> use GenerateRawDalf file
@@ -799,6 +803,36 @@ runScenariosRule =
       let (diags, results) = unzip scenarioResults
       pure (catMaybes diags, Just results)
 
+runScriptsRule :: Options -> Rules ()
+runScriptsRule opts =
+    define $ \RunScripts file -> do
+      m <- dalfForScenario file
+      world <- worldForFile file
+      let scenarios = map fst $ scriptsInModule (optEnableScripts opts) m
+          toDiagnostic :: LF.ValueRef -> Either SS.Error SS.ScenarioResult -> Maybe FileDiagnostic
+          toDiagnostic scenario (Left err) =
+              Just $ (file, ShowDiag,) $ Diagnostic
+              { _range = maybe noRange sourceLocToRange mbLoc
+              , _severity = Just DsError
+              , _source = Just "Script"
+              , _message = Pretty.renderPlain $ formatScenarioError world err
+              , _code = Nothing
+              , _tags = Nothing
+              , _relatedInformation = Nothing
+              }
+            where scenarioName = LF.qualObject scenario
+                  mbLoc = NM.lookup scenarioName (LF.moduleValues m) >>= LF.dvalLocation
+          toDiagnostic _ (Right _) = Nothing
+      Just scenarioService <- envScenarioService <$> getDamlServiceEnv
+      ctxRoot <- use_ GetScenarioRoot file
+      ctxId <- use_ CreateScenarioContext ctxRoot
+      scenarioResults <-
+          liftIO $ forM scenarios $ \scenario -> do
+              (vr, res) <- runScript scenarioService file ctxId scenario
+              pure (toDiagnostic scenario res, (vr, res))
+      let (diags, results) = unzip scenarioResults
+      pure (catMaybes diags, Just results)
+
 encodeModule :: LF.Version -> LF.Module -> Action (SS.Hash, BS.ByteString)
 encodeModule lfVersion m =
     case LF.moduleSource m of
@@ -909,12 +943,17 @@ ofInterestRule opts = do
         -- compile and notify any errors
         let runScenarios file = do
                 world <- worldForFile file
-                mbVrs <- use RunScenarios file
-                forM_ (fromMaybe [] mbVrs) $ \(vr, res) -> do
+                mbScenarioVrs <- use RunScenarios file
+                mbScriptVrs <-
+                    if getEnableScripts (optEnableScripts opts)
+                        then use RunScripts file
+                        else pure (Just [])
+                let vrs = fromMaybe [] mbScenarioVrs ++ fromMaybe [] mbScriptVrs
+                forM_ vrs $ \(vr, res) -> do
                     let doc = formatScenarioResult world res
                     when (vr `HashSet.member` openVRs) $
                         sendEvent $ vrChangedNotification vr doc
-                let vrScenarioNames = Set.fromList $ fmap (vrScenarioName . fst) (concat $ maybeToList mbVrs)
+                let vrScenarioNames = Set.fromList $ fmap (vrScenarioName . fst) vrs
                 forM_ (HashMap.lookupDefault [] file openVRsByFile) $ \ovr -> do
                     when (not $ vrScenarioName ovr `Set.member` vrScenarioNames) $
                         sendEvent $ vrNoteSetNotification ovr $ LF.scenarioNotInFileNote $
@@ -1029,6 +1068,13 @@ runScenario scenarioService file ctxId scenario = do
     let vr = VRScenario file (LF.unExprValName scenarioName)
     pure (vr, res)
 
+runScript :: SS.Handle -> NormalizedFilePath -> SS.ContextId -> LF.ValueRef -> IO (VirtualResource, Either SS.Error SS.ScenarioResult)
+runScript scenarioService file ctxId scenario = do
+    res <- SS.runScript scenarioService ctxId scenario
+    let scenarioName = LF.qualObject scenario
+    let vr = VRScenario file (LF.unExprValName scenarioName)
+    pure (vr, res)
+
 encodeModuleRule :: Options -> Rules ()
 encodeModuleRule options =
     define $ \EncodeModule file -> do
@@ -1120,6 +1166,17 @@ scenariosInModule m =
     [ (LF.Qualified LF.PRSelf (LF.moduleName m) (LF.dvalName val), LF.dvalLocation val)
     | val <- NM.toList (LF.moduleValues m), LF.getIsTest (LF.dvalIsTest val)]
 
+
+scriptsInModule :: EnableScripts -> LF.Module -> [(LF.ValueRef, Maybe LF.SourceLoc)]
+scriptsInModule (EnableScripts enable) m
+  | not enable = []
+  | otherwise =
+    [ (LF.Qualified LF.PRSelf (LF.moduleName m) (LF.dvalName val), LF.dvalLocation val)
+    | val <- NM.toList (LF.moduleValues m)
+    , T.head (LF.unExprValName (LF.dvalName val)) /= '$'
+    , LF.TConApp (LF.Qualified _ (LF.ModuleName ["Daml", "Script"]) (LF.TypeConName ["Script"])) _ <-  [LF.dvalType val]
+    ]
+
 getDamlLfVersion :: Action LF.Version
 getDamlLfVersion = envDamlLfVersion <$> getDamlServiceEnv
 
@@ -1168,6 +1225,7 @@ damlRule opts = do
     generateRawPackageRule opts
     generatePackageDepsRule opts
     runScenariosRule
+    runScriptsRule opts
     getScenarioRootsRule
     getScenarioRootRule
     getDlintDiagnosticsRule

diff --git a/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Service/Daml.hs b/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Service/Daml.hs
@@ -58,6 +58,7 @@ data DamlEnv = DamlEnv
   , envDamlLfVersion :: LF.Version
   , envSkipScenarioValidation :: SkipScenarioValidation
   , envIsGenerated :: Bool
+  , envEnableScripts :: EnableScripts
   }
 
 instance IsIdeGlobal DamlEnv
@@ -75,6 +76,7 @@ mkDamlEnv opts scenarioService = do
         , envDamlLfVersion = optDamlLfVersion opts
         , envSkipScenarioValidation = optSkipScenarioValidation opts
         , envIsGenerated = optIsGenerated opts
+        , envEnableScripts = optEnableScripts opts
         }
 
 getDamlServiceEnv :: Action DamlEnv

diff --git a/compiler/damlc/daml-ide/src/DA/Daml/LanguageServer/CodeLens.hs b/compiler/damlc/daml-ide/src/DA/Daml/LanguageServer/CodeLens.hs
@@ -33,13 +33,15 @@ handle ide (CodeLensParams (TextDocumentIdentifier uri) _) = Right <$> do
     mbResult <- case uriToFilePath' uri of
         Just (toNormalizedFilePath' -> filePath) -> do
           logInfo (ideLogger ide) $ "CodeLens request for file: " <> T.pack (fromNormalizedFilePath filePath)
-          mbModMapping <- runAction ide (useWithStale GenerateRawDalf filePath)
+          (mbModMapping, DamlEnv{..}) <- runAction ide $
+              (,) <$> useWithStale GenerateRawDalf filePath
+                  <*> getDamlServiceEnv
           case mbModMapping of
               Nothing -> pure []
               Just (mod, mapping) ->
                   pure
-                      [ virtualResourceToCodeLens (range, "Scenario: " <> name, vr)
-                      | (valRef, Just loc) <- scenariosInModule mod
+                      [ virtualResourceToCodeLens (range, prefix <> name, vr)
+                      | (prefix, (valRef, Just loc)) <- map ("Scenario: ",) (scenariosInModule mod) ++ map ("Script: ",) (scriptsInModule envEnableScripts mod)
                       , let name = LF.unExprValName (LF.qualObject valRef)
                       , let vr = VRScenario filePath name
                       , Just range <- [toCurrentRange mapping $ sourceLocToRange loc]

diff --git a/compiler/damlc/daml-opts/daml-opts-types/DA/Daml/Options/Types.hs b/compiler/damlc/daml-opts/daml-opts-types/DA/Daml/Options/Types.hs
@@ -6,6 +6,7 @@
 module DA.Daml.Options.Types
     ( Options(..)
     , EnableScenarioService(..)
+    , EnableScripts(..)
     , SkipScenarioValidation(..)
     , DlintUsage(..)
     , Haddock(..)
@@ -75,6 +76,9 @@ data Options = Options
     -- ^ custom options, parsed by GHC option parser, overriding DynFlags
   , optScenarioService :: EnableScenarioService
     -- ^ Controls whether the scenario service is started.
+  , optEnableScripts :: EnableScripts
+    -- ^ Whether scripts should be run by the scenario service.
+    -- This will be switched to True by default once it has stabilized.
   , optSkipScenarioValidation :: SkipScenarioValidation
     -- ^ Controls whether the scenario service server run package validations.
     -- This is mostly used to run additional checks on CI while keeping the IDE fast.
@@ -124,6 +128,9 @@ newtype SkipScenarioValidation = SkipScenarioValidation { getSkipScenarioValidat
 newtype EnableScenarioService = EnableScenarioService { getEnableScenarioService :: Bool }
     deriving Show
 
+newtype EnableScripts = EnableScripts { getEnableScripts :: Bool }
+    deriving Show
+
 damlArtifactDir :: FilePath
 damlArtifactDir = ".daml"
 
@@ -175,6 +182,7 @@ defaultOptions mbVersion =
         , optDebug = False
         , optGhcCustomOpts = []
         , optScenarioService = EnableScenarioService True
+        , optEnableScripts = EnableScripts False
         , optSkipScenarioValidation = SkipScenarioValidation False
         , optDlintUsage = DlintDisabled
         , optIsGenerated = False

diff --git a/compiler/damlc/daml-rule-types/src/Development/IDE/Core/RuleTypes/Daml.hs b/compiler/damlc/daml-rule-types/src/Development/IDE/Core/RuleTypes/Daml.hs
@@ -94,6 +94,8 @@ instance NFData VirtualResource
 -- | Runs all scenarios in the given file (but not scenarios in imports).
 type instance RuleResult RunScenarios = [(VirtualResource, Either SS.Error SS.ScenarioResult)]
 
+type instance RuleResult RunScripts = [(VirtualResource, Either SS.Error SS.ScenarioResult)]
+
 -- | Encode a module and produce a hash of the module and all its transitive dependencies.
 -- The hash is used to decide if a module needs to be reloaded in the scenario service.
 type instance RuleResult EncodeModule = (SS.Hash, BS.ByteString)
@@ -202,6 +204,12 @@ instance Binary   RunScenarios
 instance Hashable RunScenarios
 instance NFData   RunScenarios
 
+data RunScripts = RunScripts
+    deriving (Eq, Show, Typeable, Generic)
+instance Binary   RunScripts
+instance Hashable RunScripts
+instance NFData   RunScripts
+
 data EncodeModule = EncodeModule
     deriving (Eq, Show, Typeable, Generic)
 instance Binary   EncodeModule

diff --git a/compiler/damlc/lib/DA/Cli/Damlc/Test.hs b/compiler/damlc/lib/DA/Cli/Damlc/Test.hs
@@ -62,7 +62,8 @@ testRun h inFiles lfVersion color mbJUnitOutput  = do
     results <- runActionSync h $
         Shake.forP files $ \file -> do
             mbScenarioResults <- runScenarios file
-            results <- case mbScenarioResults of
+            mbScriptResults <- runScripts file
+            results <- case liftM2 (++) mbScenarioResults mbScriptResults of
                 Nothing -> failedTestOutput h file
                 Just scenarioResults -> do
                     -- failures are printed out through diagnostics, so just print the sucesses

diff --git a/compiler/damlc/lib/DA/Cli/Options.hs b/compiler/damlc/lib/DA/Cli/Options.hs
@@ -207,6 +207,10 @@ enableScenarioOpt :: Parser EnableScenarioService
 enableScenarioOpt = EnableScenarioService <$>
     flagYesNoAuto "scenarios" True "Enable/disable support for running scenarios" idm
 
+enableScriptsOpt :: Parser EnableScripts
+enableScriptsOpt = EnableScripts <$>
+    flagYesNoAuto "daml-script" False "Enable/disable support for running DAML Scripts" internal
+
 dlintEnabledOpt :: Parser DlintUsage
 dlintEnabledOpt = DlintEnabled
   <$> strOption
@@ -270,6 +274,7 @@ optionsParser numProcessors enableScenarioService parsePkgName = do
     let optIgnorePackageMetadata = IgnorePackageMetadata False
     let optEnableOfInterestRule = True
     optCppPath <- optCppPath
+    optEnableScripts <- enableScriptsOpt
 
     return Options{..}
   where

diff --git a/compiler/damlc/tests/BUILD.bazel b/compiler/damlc/tests/BUILD.bazel
@@ -713,6 +713,45 @@ da_haskell_test(
     ],
 )
 
+da_haskell_test(
+    name = "script-service",
+    srcs = ["src/DA/Test/ScriptService.hs"],
+    data = [
+        "//compiler/damlc/pkg-db",
+        "//compiler/damlc/stable-packages",
+        "//compiler/scenario-service/server:scenario_service_jar",
+        "//daml-script/daml:daml-script.dar",
+        ghc_pkg,
+    ],
+    hackage_deps = [
+        "base",
+        "directory",
+        "data-default",
+        "extra",
+        "filepath",
+        "ghcide",
+        "haskell-lsp-types",
+        "unordered-containers",
+        "regex-tdfa",
+        "tasty",
+        "tasty-hunit",
+        "text",
+    ],
+    main_function = "DA.Test.ScriptService.main",
+    deps = [
+        "//:sdk-version-hs-lib",
+        "//compiler/damlc:damlc-lib",
+        "//compiler/damlc/daml-ide-core",
+        "//compiler/damlc/daml-opts:daml-opts-types",
+        "//compiler/damlc/daml-package-config",
+        "//compiler/damlc/daml-rule-types",
+        "//compiler/scenario-service/client",
+        "//daml-assistant:daml-project-config",
+        "//libs-haskell/bazel-runfiles",
+        "//libs-haskell/da-hs-base",
+    ],
+)
+
 sh_test(
     name = "stable-packages",
     srcs = ["src/stable-packages.sh"],