Serialize package metadata and stop parsing packages twice (#5607)

This PR finally puts together the refactorings from the last two PRs:

1. We now write out a JSON file (because JSON seems like a reasonable
   choice and it doesn’t really matter) containing the main unit ids
   when setting up the package db.
2. When initializing the GHC session, we now simply read that file
   instead of reading the daml.yaml again and parsing all
   dependencies and data-dependencies again.

changelog_begin
changelog_end

compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs

@@ -35,6 +35,7 @@ import Development.IDE.Core.OfInterest
 import Development.IDE.GHC.Util
 import Development.IDE.Types.Logger hiding (Priority)
 import DA.Daml.Options
+import DA.Daml.Options.Packaging.Metadata
 import DA.Daml.Options.Types
 import qualified Text.PrettyPrint.Annotated.HughesPJClass as HughesPJPretty
 import Development.IDE.Types.Location as Base
@@ -530,7 +531,13 @@ damlGhcSessionRule opts@Options{..} = do
         let base = mkBaseUnits (optUnitId opts)
         inferredPackages <- liftIO $ case mbProjectRoot of
             Just projectRoot | getInferDependantPackages optInferDependantPackages ->
-                dependantUnitsFromDamlYaml optDamlLfVersion projectRoot
+                -- We catch doesNotExistError which could happen if the
+                -- package db has never been initialized. In that case, we simply
+                -- infer no extra packages.
+                catchJust
+                    (guard . isDoesNotExistError)
+                    (directDependencies <$> readMetadata projectRoot)
+                    (const $ pure [])
             _ -> pure []
         optPackageImports <- pure $ map mkPackageFlag (base ++ inferredPackages) ++ optPackageImports
         env <- liftIO $ runGhcFast $ do

compiler/damlc/daml-opts/BUILD.bazel

@@ -8,8 +8,9 @@ load(
 
 da_haskell_library(
     name = "daml-opts-types",
-    srcs = ["daml-opts-types/DA/Daml/Options/Types.hs"],
+    srcs = glob(["daml-opts-types/**/*.hs"]),
     hackage_deps = [
+        "aeson",
         "base",
         "directory",
         "extra",

compiler/damlc/daml-opts/daml-opts-types/DA/Daml/Options/Packaging/Metadata.hs

@@ -0,0 +1,64 @@
+-- Copyright (c) 2020 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module DA.Daml.Options.Packaging.Metadata
+  ( PackageDbMetadata(..),
+    writeMetadata,
+    readMetadata,
+  ) where
+
+import Data.Aeson
+import DA.Daml.Options.Types (projectPackageDatabase)
+import Development.IDE.Types.Location
+import GHC.Generics
+import qualified "ghc-lib-parser" Module as Ghc
+import System.FilePath
+
+-- | Metadata about an initialized package db. We write this to a JSON
+-- file in the package db after the package db has been initialized.
+--
+-- While we can technically reconstruct all this information by
+-- reading the DARs again, this is unnecessarily wasteful.
+--
+-- In the future, we should also be able to include enough metadata in here
+-- to decide whether we need to reinitialize the package db or not.
+data PackageDbMetadata = PackageDbMetadata
+  { directDependencies :: [Ghc.UnitId]
+  -- ^ Unit ids of direct dependencies. These are exposed by default
+  } deriving Generic
+
+instance ToJSON PackageDbMetadata
+instance FromJSON PackageDbMetadata
+
+-- Orphan instances for converting UnitIds to/from JSON.
+instance ToJSON Ghc.UnitId where
+    toJSON unitId = toJSON (Ghc.unitIdString unitId)
+
+instance FromJSON Ghc.UnitId where
+    parseJSON s = Ghc.stringToUnitId <$> parseJSON s
+
+-- | Given the path to the project root, write out the package db metadata.
+writeMetadata :: NormalizedFilePath -> PackageDbMetadata -> IO ()
+writeMetadata projectRoot metadata = do
+    encodeFile (metadataFile projectRoot) metadata
+
+-- | Given the path to the project root, read the package db metadata.
+-- Throws an exception if the file does not exist or
+-- the format cannot be parsed.
+readMetadata :: NormalizedFilePath -> IO PackageDbMetadata
+readMetadata projectRoot = do
+    errOrRes <- eitherDecodeFileStrict' (metadataFile projectRoot)
+    case errOrRes of
+        Right metadata -> pure metadata
+        Left err -> fail ("Could not decode package metadata: " <> err)
+
+-- | Given the path to the project root return the path
+-- where the metadata is stored.
+metadataFile :: NormalizedFilePath -> FilePath
+metadataFile projectRoot =
+    fromNormalizedFilePath projectRoot </>
+    projectPackageDatabase </>
+    "metadata.json"
+

compiler/damlc/daml-opts/daml-opts/DA/Daml/Options.hs

@@ -9,7 +9,6 @@
 -- | Set up the GHC monad in a way that works for us
 module DA.Daml.Options
     ( checkDFlags
-    , dependantUnitsFromDamlYaml
     , expandSdkPackages
     , fakeDynFlags
     , findProjectRoot
@@ -24,14 +23,11 @@ module DA.Daml.Options
     , PackageDynFlags(..)
     ) where
 
-import qualified "zip-archive" Codec.Archive.Zip as ZipArchive
 import Control.Exception
 import Control.Exception.Safe (handleIO)
 import Control.Concurrent.Extra
 import Control.Monad.Extra
 import qualified CmdLineParser as Cmd (warnMsg)
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as BSL
 import Data.IORef
 import Data.List
 import Data.Maybe (fromMaybe)
@@ -57,16 +53,10 @@ import System.FilePath
 import qualified DA.Daml.LF.Ast.Version as LF
 
 import DA.Bazel.Runfiles
-import qualified DA.Daml.LF.Proto3.Archive as Archive
-import DA.Daml.LF.Reader
-import DA.Daml.LF.Ast.Util
-import DA.Daml.Project.Config
 import DA.Daml.Project.Consts
-import DA.Daml.Project.Types (ConfigError, ProjectPath(..))
 import DA.Daml.Project.Util
 import DA.Daml.Options.Types
 import DA.Daml.Preprocessor
-import qualified DA.Pretty
 import Development.IDE.GHC.Util
 import qualified Development.IDE.Types.Options as Ghcide
 import SdkVersion (damlStdlib)
@@ -473,54 +463,3 @@ mkBaseUnits optMbPackageName
   | otherwise =
       [ stringToUnitId "daml-prim"
       , damlStdlib ]
-
-dependantUnitsFromDamlYaml :: LF.Version -> NormalizedFilePath -> IO [UnitId]
-dependantUnitsFromDamlYaml lfVersion root = do
-  (deps,dataDeps) <- depsFromDamlYaml (ProjectPath $ fromNormalizedFilePath root)
-  deps <- expandSdkPackages lfVersion (filter (`notElem` basePackages) deps)
-  calcUnitsFromDeps root (deps ++ dataDeps)
-
-depsFromDamlYaml :: ProjectPath -> IO ([FilePath],[FilePath])
-depsFromDamlYaml projectPath = do
-  try (readProjectConfig projectPath) >>= \case
-    Left (_::ConfigError) -> return ([],[])
-    Right project -> return $ projectDeps project
-
-projectDeps :: ProjectConfig -> ([FilePath],[FilePath])
-projectDeps project = do
-  let deps = fromMaybe [] $ either (error . show) id $ queryProjectConfig ["dependencies"] project
-  let dataDeps = fromMaybe [] $ either (error . show) id $ queryProjectConfig ["data-dependencies"] project
-  (deps,dataDeps)
-
-calcUnitsFromDeps :: NormalizedFilePath -> [FilePath] -> IO [UnitId]
-calcUnitsFromDeps root deps = do
-  let (fpDars, fpDalfs) = partition ((== ".dar") . takeExtension) deps
-  entries <- mapM (mainEntryOfDar root) fpDars
-  let dalfsFromDars =
-        [ ( ZipArchive.eRelativePath e
-          , BSL.toStrict $ ZipArchive.fromEntry e)
-        | e <- entries ]
-  dalfsFromFps <-
-    forM fpDalfs $ \fp -> do
-      bs <- BS.readFile (fromNormalizedFilePath root </> fp)
-      pure (fp, bs)
-  let mainDalfs = dalfsFromDars ++ dalfsFromFps
-  forM mainDalfs $ \(file, dalf) -> do
-    (pkgId, pkg) <-
-        either (fail . DA.Pretty.renderPretty) pure $
-        Archive.decodeArchive Archive.DecodeAsMain dalf
-    let (name, mbVersion) = packageMetadataFromFile file pkg pkgId
-    pure (pkgNameVersion name mbVersion)
-
-mainEntryOfDar :: NormalizedFilePath -> FilePath -> IO ZipArchive.Entry
-mainEntryOfDar root fp = do
-  bs <- BSL.readFile (fromNormalizedFilePath root </> fp)
-  let archive = ZipArchive.toArchive bs
-  dalfManifest <- either fail pure $ readDalfManifest archive
-  getEntry (mainDalfPath dalfManifest) archive
-
--- | Get an entry from a dar or fail.
-getEntry :: FilePath -> ZipArchive.Archive -> IO ZipArchive.Entry
-getEntry fp dar =
-  maybe (fail $ "Package does not contain " <> fp) pure $
-  ZipArchive.findEntryByPath fp dar

compiler/damlc/lib/DA/Cli/Damlc/Packaging.hs

@@ -47,6 +47,7 @@ import DA.Daml.Compiler.ExtractDar (extractDar,ExtractedDar(..))
 import qualified DA.Daml.LF.Ast as LF
 import DA.Daml.LF.Ast.Optics (packageRefs)
 import qualified DA.Daml.LF.Proto3.Archive as Archive
+import DA.Daml.Options.Packaging.Metadata
 import DA.Daml.Options.Types
 import DA.Daml.Package.Config
 import qualified DA.Pretty
@@ -177,6 +178,8 @@ createProjectPackageDb projectRoot opts thisSdkVer deps dataDeps
             deps
             dependenciesInPkgDb
             exposedModules
+
+    writeMetadata projectRoot (PackageDbMetadata (mainUnitIds dependencyInfo))
   where
     dbPath = projectPackageDatabase </> lfVersionString (optDamlLfVersion opts)
     clearPackageDb = do