mirror of
https://github.com/digital-asset/daml.git
synced 2024-09-20 01:07:18 +03:00
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
This commit is contained in:
parent
7d094fac2b
commit
e922e1d2fe
@ -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
|
||||
|
@ -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",
|
||||
|
@ -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"
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user