Run daml-ghc tests with full validation in the scenario service (#1546)

* Run daml-ghc tests with full validation in the scenario service

Fixes #128

* Swap default of optScenarioValidation

compiler/scenario-service/client/src/DA/Daml/LF/ScenarioServiceClient.hs

@@ -8,6 +8,7 @@ module DA.Daml.LF.ScenarioServiceClient
   , Handle
   , withScenarioService
   , Context(..)
+  , LowLevel.LightValidation(..)
   , LowLevel.ContextId
   , getNewCtx
   , deleteCtx
@@ -72,6 +73,7 @@ data Context = Context
   { ctxModules :: MS.Map Hash (LF.ModuleName, BS.ByteString)
   , ctxPackages :: [(LF.PackageId, BS.ByteString)]
   , ctxDamlLfVersion :: LF.Version
+  , ctxLightValidation :: LowLevel.LightValidation
   }
 
 getNewCtx :: Handle -> Context -> IO (Either LowLevel.BackendError LowLevel.ContextId)
@@ -94,6 +96,7 @@ getNewCtx Handle{..} Context{..} = withLock hContextLock $ do
       loadPackages
       (S.toList unloadPackages)
       ctxDamlLfVersion
+      ctxLightValidation
   writeIORef hLoadedPackages newLoadedPackages
   writeIORef hLoadedModules ctxModules
   res <- LowLevel.updateCtx hLowLevelHandle hContextId ctxUpdate

compiler/scenario-service/client/src/DA/Daml/LF/ScenarioServiceClient/LowLevel.hs

@@ -19,6 +19,7 @@ module DA.Daml.LF.ScenarioServiceClient.LowLevel
   , deleteCtx
   , gcCtxs
   , ContextUpdate(..)
+  , LightValidation(..)
   , updateCtx
   , runScenario
   , SS.ScenarioResult(..)
@@ -78,12 +79,16 @@ data Handle = Handle
 newtype ContextId = ContextId { getContextId :: Int64 }
   deriving (NFData, Eq, Show)
 
+-- | If true, the scenario service server only runs a subset of validations.
+newtype LightValidation = LightValidation { getLightValidation :: Bool }
+
 data ContextUpdate = ContextUpdate
   { updLoadModules :: ![(LF.ModuleName, BS.ByteString)]
   , updUnloadModules :: ![LF.ModuleName]
   , updLoadPackages :: ![(LF.PackageId, BS.ByteString)]
   , updUnloadPackages :: ![LF.PackageId]
   , updDamlLfVersion :: LF.Version
+  , updLightValidation :: LightValidation
   }
 
 encodeModule :: LF.Version -> LF.Module -> BS.ByteString
@@ -236,8 +241,12 @@ updateCtx Handle{..} (ContextId ctxId) ContextUpdate{..} = do
   res <-
     performRequest
       (SS.scenarioServiceUpdateContext ssClient)
-      (optRequestTimeout hOptions)
-      (SS.UpdateContextRequest ctxId (Just updModules) (Just updPackages) True)
+      (optRequestTimeout hOptions) $
+      SS.UpdateContextRequest
+          ctxId
+          (Just updModules)
+          (Just updPackages)
+          (getLightValidation updLightValidation)
   pure (void res)
   where
     updModules =

daml-foundations/daml-ghc/ghc-compiler/src/DA/Daml/GHC/Compiler/Options.hs

@@ -4,6 +4,7 @@
 module DA.Daml.GHC.Compiler.Options
     ( Options(..)
     , EnableScenarioService(..)
+    , ScenarioValidation(..)
     , defaultOptionsIO
     , defaultOptions
     , mkOptions
@@ -67,8 +68,16 @@ data Options = Options
     -- ^ custom options, parsed by GHC option parser, overriding DynFlags
   , optScenarioService :: EnableScenarioService
     -- ^ Controls whether the scenario service is started.
+  , optScenarioValidation :: ScenarioValidation
+    -- ^ Controls whether the scenario service server runs all checks
+    -- or only a subset of them. This is mostly used to run additional
+    -- checks on CI while keeping the IDE fast.
   } deriving Show
 
+data ScenarioValidation
+    = ScenarioValidationLight
+    | ScenarioValidationFull
+    deriving Show
 
 newtype EnableScenarioService = EnableScenarioService { getEnableScenarioService :: Bool }
     deriving Show
@@ -223,6 +232,7 @@ defaultOptions mbVersion =
         , optDebug = False
         , optGhcCustomOpts = []
         , optScenarioService = EnableScenarioService True
+        , optScenarioValidation = ScenarioValidationFull
         }
 
 getBaseDir :: IO FilePath

daml-foundations/daml-ghc/ide/src/Development/IDE/State/Rules/Daml.hs

@@ -10,7 +10,7 @@ import Control.Concurrent.Extra
 import Control.Exception
 import Control.Monad.Except
 import Control.Monad.Extra
-import DA.Daml.GHC.Compiler.Options(Options(..))
+import DA.Daml.GHC.Compiler.Options
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.UTF8 as BS
 import Data.Either.Extra
@@ -177,10 +177,14 @@ contextForFile file = do
     encodedModules <-
         mapM (\m -> fmap (\(hash, bs) -> (hash, (LF.moduleName m, bs))) (encodeModule lfVersion m)) $
         NM.toList $ LF.packageModules pkg
+    DamlEnv{..} <- getDamlServiceEnv
     pure SS.Context
         { ctxModules = Map.fromList encodedModules
         , ctxPackages = map (\(pId, _, p, _) -> (pId, p)) (Map.elems pkgMap)
         , ctxDamlLfVersion = lfVersion
+        , ctxLightValidation = case envScenarioValidation of
+              ScenarioValidationFull -> SS.LightValidation False
+              ScenarioValidationLight -> SS.LightValidation True
         }
 
 worldForFile :: FilePath -> Action LF.World
@@ -214,10 +218,21 @@ createScenarioContextRule =
         liftIO $ modifyVar_ scenarioContextsVar $ pure . Map.insert file ctxId
         pure ([], Just ctxId)
 
+-- | This helper should be used instead of GenerateDalf/GenerateRawDalf
+-- for generating modules that are sent to the scenario service.
+-- It switches between GenerateRawDalf and GenerateDalf depending
+-- on whether we only do light or full validation.
+dalfForScenario :: FilePath -> Action LF.Module
+dalfForScenario file = do
+    DamlEnv{..} <- getDamlServiceEnv
+    case envScenarioValidation of
+        ScenarioValidationLight -> use_ GenerateRawDalf file
+        ScenarioValidationFull -> use_ GenerateDalf file
+
 runScenariosRule :: Rules ()
 runScenariosRule =
     define $ \RunScenarios file -> do
-      m <- use_ GenerateRawDalf file
+      m <- dalfForScenario file
       world <- worldForFile file
       let scenarios = scenariosInModule m
           toDiagnostic :: LF.ValueRef -> Either SS.Error SS.ScenarioResult -> Maybe FileDiagnostic
@@ -380,7 +395,7 @@ encodeModuleRule =
         fs <- transitiveModuleDeps <$> use_ GetDependencies file
         files <- discardInternalModules fs
         encodedDeps <- uses_ EncodeModule files
-        m <- use_ GenerateRawDalf file
+        m <- dalfForScenario file
         let (hash, bs) = SS.encodeModule lfVersion m
         return ([], Just (mconcat $ hash : map fst encodedDeps, bs))
 

daml-foundations/daml-ghc/ide/src/Development/IDE/State/Service/Daml.hs

@@ -45,6 +45,7 @@ data DamlEnv = DamlEnv
   -- ^ The scenario contexts we used as GC roots in the last iteration.
   -- This is used to avoid unnecessary GC calls.
   , envDamlLfVersion :: LF.Version
+  , envScenarioValidation :: ScenarioValidation
   }
 
 instance IsIdeGlobal DamlEnv
@@ -60,6 +61,7 @@ mkDamlEnv opts scenarioService = do
         , envScenarioContexts = scenarioContextsVar
         , envPreviousScenarioContexts = previousScenarioContextsVar
         , envDamlLfVersion = optDamlLfVersion opts
+        , envScenarioValidation = optScenarioValidation opts
         }
 
 getDamlServiceEnv :: Action DamlEnv

daml-foundations/daml-ghc/test-src/DA/Test/GHC.hs

@@ -121,7 +121,11 @@ getIntegrationTests registerTODO scenarioService version = do
     let outdir = "daml-foundations/daml-ghc/output"
     createDirectoryIfMissing True outdir
 
-    opts <- fmap (\opts ->  opts { optThreads = 0 }) $ defaultOptionsIO (Just version)
+    opts <- defaultOptionsIO (Just version)
+    opts <- pure $ opts
+        { optThreads = 0
+        , optScenarioValidation = ScenarioValidationFull
+        }
 
     -- initialise the compiler service
     vfs <- Compile.makeVFSHandle

daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc.hs

@@ -22,7 +22,7 @@ import           DA.Cli.Args
 import qualified DA.Pretty
 import           DA.Service.Daml.Compiler.Impl.Handle as Compiler
 import DA.Service.Daml.Compiler.Impl.Scenario
-import DA.Daml.GHC.Compiler.Options (EnableScenarioService(..), projectPackageDatabase, basePackages)
+import DA.Daml.GHC.Compiler.Options
 import qualified DA.Service.Daml.LanguageServer    as Daml.LanguageServer
 import qualified DA.Daml.LF.Ast as LF
 import qualified DA.Daml.LF.Proto3.Archive as Archive
@@ -223,7 +223,11 @@ execIde telemetry (Debug debug) enableScenarioService = NS.withSocketsDo $ do
                 Logger.GCP.logOptOut loggerH
                 f loggerH
             Undecided -> f loggerH
-    opts <- liftIO $ fmap (\opt -> opt { optScenarioService = enableScenarioService }) $ defaultOptionsIO Nothing
+    opts <- defaultOptionsIO Nothing
+    opts <- pure $ opts
+        { optScenarioService = enableScenarioService
+        , optScenarioValidation = ScenarioValidationLight
+        }
     withLogger $ \loggerH ->
         withScenarioService' enableScenarioService loggerH $ \mbScenarioService -> do
             -- TODO we should allow different LF versions in the IDE.
@@ -588,6 +592,7 @@ optionsParser numProcessors enableScenarioService parsePkgName = Compiler.Option
     <*> optDebugLog
     <*> (concat <$> many optGhcCustomOptions)
     <*> pure enableScenarioService
+    <*> pure (optScenarioValidation $ defaultOptions Nothing)
   where
     optImportPath :: Parser [FilePath]
     optImportPath =