Add a module-prefixes field to rename all modules in a pkg (#6105)

* Add a module-prefixes field to rename all modules in a pkg This PR adds a `module-prefixes` field to `daml.yaml` a a shorthand for specifying a `--package` flag that renames all modules in a package to have the same prefix. The docs are updated to describe how you can use this field and there is a test case that makes sure it works. fixes #4948 changelog_begin - [DAML Compiler] You can now use the new ``module-prefixes`` field in ``daml.yaml`` to add a prefix to all modules from a dependency. This is particularly useful for handling colliding module names during upgrades. See https://docs.daml.com/daml/reference/packages.html#handling-module-name-collisions for more information. changelog_end * Update compiler/damlc/daml-opts/daml-opts-types/DA/Daml/Options/Packaging/Metadata.hs Co-authored-by: Martin Huschenbett <martin.huschenbett@posteo.me> * Improve docs and fix broken suggestion changelog_begin changelog_end Co-authored-by: Martin Huschenbett <martin.huschenbett@posteo.me>
digital-asset · May 28, 2020 · 2ccbd7f · 2ccbd7f
1 parent 6108c92
commit 2ccbd7f
Show file tree

Hide file tree

Showing 14 changed files with 195 additions and 35 deletions.
diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Base.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Base.hs
@@ -43,7 +43,7 @@ newtype PackageId = PackageId{unPackageId :: T.Text}
 -- > ([A-Z][a-zA-Z0-9_]*)(\.[A-Z][a-zA-Z0-9_]*)*
 newtype ModuleName = ModuleName{unModuleName :: [T.Text]}
     deriving stock (Eq, Data, Generic, Ord, Show)
-    deriving newtype (Hashable, NFData)
+    deriving newtype (Hashable, NFData, ToJSON, FromJSON)
 
 -- | Name for a type synonym. Must match the regex
 --

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
@@ -539,17 +539,22 @@ damlGhcSessionRule opts@Options{..} = do
     -- (or the equivalent thereof for rules with cut off).
     defineEarlyCutoff $ \(DamlGhcSession mbProjectRoot) _file -> assert (null $ fromNormalizedFilePath _file) $ do
         let base = mkBaseUnits (optUnitId opts)
-        inferredPackages <- liftIO $ case mbProjectRoot of
-            Just projectRoot | getInferDependantPackages optInferDependantPackages ->
+        extraPkgFlags <- liftIO $ case mbProjectRoot of
+            Just projectRoot | not (getIgnorePackageMetadata optIgnorePackageMetadata) ->
                 -- We catch doesNotExistError which could happen if the
-                -- package db has never been initialized. In that case, we simply
-                -- infer no extra packages.
-                catchJust
+                -- package db has never been initialized. In that case, we
+                -- return no extra package flags.
+                handleJust
                     (guard . isDoesNotExistError)
-                    (directDependencies <$> readMetadata projectRoot)
-                    (const $ pure [])
+                    (const $ pure []) $ do
+                    PackageDbMetadata{..} <- readMetadata projectRoot
+                    let mainPkgs = map mkPackageFlag directDependencies
+                    let renamings =
+                            map (\(unitId, (prefix, modules)) -> renamingToFlag unitId prefix modules)
+                                (Map.toList moduleRenamings)
+                    pure (mainPkgs ++ renamings)
             _ -> pure []
-        optPackageImports <- pure $ map mkPackageFlag (base ++ inferredPackages) ++ optPackageImports
+        optPackageImports <- pure $ map mkPackageFlag base ++ extraPkgFlags ++ optPackageImports
         env <- liftIO $ runGhcFast $ do
             setupDamlGHC opts
             GHC.getSession

diff --git a/compiler/damlc/daml-opts/BUILD.bazel b/compiler/damlc/daml-opts/BUILD.bazel
@@ -12,6 +12,7 @@ da_haskell_library(
     hackage_deps = [
         "aeson",
         "base",
+        "containers",
         "directory",
         "extra",
         "filepath",
@@ -25,6 +26,7 @@ da_haskell_library(
     visibility = ["//visibility:public"],
     deps = [
         "//compiler/daml-lf-ast",
+        "//compiler/damlc/daml-package-config",
         "//libs-haskell/bazel-runfiles",
         "//libs-haskell/da-hs-base",
     ],

diff --git a/compiler/damlc/daml-opts/daml-opts-types/DA/Daml/Options/Packaging/Metadata.hs b/compiler/damlc/daml-opts/daml-opts-types/DA/Daml/Options/Packaging/Metadata.hs
@@ -1,16 +1,24 @@
 -- 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,
+    renamingToFlag,
   ) where
 
 import Data.Aeson
-import DA.Daml.Options.Types (projectPackageDatabase)
+import DA.Daml.Package.Config ()
+import Data.Map.Strict (Map)
+import qualified Data.Text as T
+import qualified DA.Daml.LF.Ast as LF
+import DA.Daml.Options.Types
+    ( projectPackageDatabase
+    , ModRenaming(..)
+    , PackageArg(..)
+    , PackageFlag(..)
+    )
 import Development.IDE.Types.Location
 import GHC.Generics
 import qualified "ghc-lib-parser" Module as Ghc
@@ -27,18 +35,31 @@ import System.FilePath
 data PackageDbMetadata = PackageDbMetadata
   { directDependencies :: [Ghc.UnitId]
   -- ^ Unit ids of direct dependencies. These are exposed by default
+  , moduleRenamings :: Map Ghc.UnitId (Ghc.ModuleName, [LF.ModuleName])
+  -- ^ Map frm GHC unit id to the prefix and a list of all modules in this package.
+  -- We do not bother differentiating between exposed and unexposed modules
+  -- since we already warn on non-exposed modules anyway and this
+  -- is intended for data-dependencies where everything is exposed.
   } deriving Generic
 
+renamingToFlag :: Ghc.UnitId -> Ghc.ModuleName -> [LF.ModuleName] -> PackageFlag
+renamingToFlag unitId prefix modules =
+    ExposePackage
+        ("Prefix " <> Ghc.unitIdString unitId <> " with " <> Ghc.moduleNameString prefix)
+        (UnitIdArg unitId)
+        ModRenaming
+          { modRenamingWithImplicit = False
+          , modRenamings =
+            [ ( Ghc.mkModuleName s
+              , Ghc.mkModuleName (Ghc.moduleNameString prefix ++ "." ++ s))
+            | m <- modules
+            , let s = T.unpack (LF.moduleNameString m)
+            ]
+          }
+
 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
@@ -61,4 +82,3 @@ metadataFile projectRoot =
     fromNormalizedFilePath projectRoot </>
     projectPackageDatabase </>
     "metadata.json"
-
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
@@ -10,7 +10,7 @@ module DA.Daml.Options.Types
     , DlintUsage(..)
     , Haddock(..)
     , IncrementalBuild(..)
-    , InferDependantPackages(..)
+    , IgnorePackageMetadata(..)
     , PackageFlag(..)
     , ModRenaming(..)
     , PackageArg(..)
@@ -93,8 +93,11 @@ data Options = Options
     -- ^ Enable CPP, by giving filepath to the executable.
   , optIncrementalBuild :: IncrementalBuild
   -- ^ Whether to do an incremental on-disk build as opposed to keeping everything in memory.
-  , optInferDependantPackages :: InferDependantPackages
-  -- ^ Whether to infer --package flags from deps/data-deps contained in daml.yaml
+  , optIgnorePackageMetadata :: IgnorePackageMetadata
+  -- ^ Whether to ignore the package metadata generated from the daml.yaml
+  -- This is set to True when building data-dependency packages where we
+  -- have precise package flags and don’t want to use the daml.yaml from the
+  -- main package.
   , optEnableOfInterestRule :: Bool
   -- ^ Whether we should enable the of interest rule that automatically compiles all
   -- modules to DALFs or not. This is required in the IDE but we can disable it
@@ -104,7 +107,7 @@ data Options = Options
 newtype IncrementalBuild = IncrementalBuild { getIncrementalBuild :: Bool }
   deriving Show
 
-newtype InferDependantPackages = InferDependantPackages { getInferDependantPackages :: Bool }
+newtype IgnorePackageMetadata = IgnorePackageMetadata { getIgnorePackageMetadata :: Bool }
   deriving Show
 
 newtype Haddock = Haddock Bool
@@ -180,7 +183,7 @@ defaultOptions mbVersion =
         , optHaddock = Haddock False
         , optCppPath = Nothing
         , optIncrementalBuild = IncrementalBuild False
-        , optInferDependantPackages = InferDependantPackages True
+        , optIgnorePackageMetadata = IgnorePackageMetadata False
         , optEnableOfInterestRule = True
         }
 

diff --git a/compiler/damlc/daml-package-config/BUILD.bazel b/compiler/damlc/daml-package-config/BUILD.bazel
@@ -10,6 +10,7 @@ da_haskell_library(
     name = "daml-package-config",
     srcs = glob(["src/**/*.hs"]),
     hackage_deps = [
+        "aeson",
         "base",
         "containers",
         "ghc-lib-parser",

diff --git a/compiler/damlc/daml-package-config/src/DA/Daml/Package/Config.hs b/compiler/damlc/daml-package-config/src/DA/Daml/Package/Config.hs
@@ -1,6 +1,8 @@
 -- Copyright (c) 2020 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
 
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 -- | Types and functions for dealing with package config in daml.yaml
 module DA.Daml.Package.Config
     ( PackageConfigFields (..)
@@ -18,7 +20,12 @@ import SdkVersion
 
 import Control.Exception.Safe (throwIO)
 import Control.Monad (when)
+import qualified Data.Aeson as A
+import qualified Data.Aeson.Encoding as A
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
 import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
 import qualified Data.Yaml as Y
 import qualified Module as Ghc
 import System.IO (hPutStrLn, stderr)
@@ -33,6 +40,10 @@ data PackageConfigFields = PackageConfigFields
     -- we might not have a version. In `damlc build` this is always set to `Just`.
     , pDependencies :: [String]
     , pDataDependencies :: [String]
+    , pModulePrefixes :: Map Ghc.UnitId Ghc.ModuleName
+    -- ^ Map from unit ids to a prefix for all modules in that package.
+    -- If this is specified, all modules from the package will be remapped
+    -- under the given prefix.
     , pSdkVersion :: PackageSdkVersion
     }
 
@@ -52,6 +63,7 @@ parseProjectConfig project = do
     pVersion <- Just <$> queryProjectConfigRequired ["version"] project
     pDependencies <- queryProjectConfigRequired ["dependencies"] project
     pDataDependencies <- fromMaybe [] <$> queryProjectConfig ["data-dependencies"] project
+    pModulePrefixes <- fromMaybe Map.empty <$> queryProjectConfig ["module-prefixes"] project
     pSdkVersion <- queryProjectConfigRequired ["sdk-version"] project
     Right PackageConfigFields {..}
 
@@ -91,3 +103,23 @@ withPackageConfig projectPath f = do
     pkgConfig' <- overrideSdkVersion pkgConfig
     let pkgConfig'' = replaceSdkVersionWithGhcPkgVersion pkgConfig'
     f pkgConfig''
+
+-- | Orphans because I’m too lazy to newtype everything.
+instance A.FromJSON Ghc.ModuleName where
+    parseJSON = A.withText "ModuleName" $ \t -> pure $ Ghc.mkModuleName (T.unpack t)
+
+instance A.ToJSON Ghc.ModuleName where
+    toJSON m = A.toJSON (Ghc.moduleNameString m)
+
+instance A.FromJSON Ghc.UnitId where
+    parseJSON = A.withText "UnitId" $ \t -> pure $ Ghc.stringToUnitId (T.unpack t)
+
+instance A.FromJSONKey Ghc.UnitId where
+    fromJSONKey = A.FromJSONKeyText $ \t -> Ghc.stringToUnitId (T.unpack t)
+
+instance A.ToJSON Ghc.UnitId where
+    toJSON unitId = A.toJSON (Ghc.unitIdString unitId)
+
+instance A.ToJSONKey Ghc.UnitId where
+    toJSONKey =
+        A.ToJSONKeyText (T.pack . Ghc.unitIdString) (A.text . T.pack . Ghc.unitIdString)
diff --git a/compiler/damlc/lib/DA/Cli/Damlc.hs b/compiler/damlc/lib/DA/Cli/Damlc.hs
@@ -54,6 +54,7 @@ import Data.FileEmbed (embedFile)
 import qualified Data.HashSet as HashSet
 import Data.List.Extra
 import qualified Data.List.Split as Split
+import qualified Data.Map.Strict as Map
 import Data.Maybe
 import qualified Data.Text.Extended as T
 import Development.IDE.Core.API
@@ -535,7 +536,7 @@ initPackageDb opts (InitPkgDb shouldInit) =
         when isProject $ do
             projRoot <- getCurrentDirectory
             withPackageConfig defaultProjectPath $ \PackageConfigFields {..} ->
-                createProjectPackageDb (toNormalizedFilePath' projRoot) opts pSdkVersion pDependencies pDataDependencies
+                createProjectPackageDb (toNormalizedFilePath' projRoot) opts pSdkVersion pModulePrefixes pDependencies pDataDependencies
 
 execBuild :: ProjectOpts -> Options -> Maybe FilePath -> IncrementalBuild -> InitPkgDb -> Command
 execBuild projectOpts opts mbOutFile incrementalBuild initPkgDb =
@@ -648,6 +649,7 @@ execPackage projectOpts filePath opts mbOutFile dalfInput =
                               , pDependencies = []
                               , pDataDependencies = []
                               , pSdkVersion = PackageSdkVersion SdkVersion.sdkVersion
+                              , pModulePrefixes = Map.empty
                               }
                             (toNormalizedFilePath' $ fromMaybe ifaceDir $ optIfaceDir opts)
                             dalfInput

diff --git a/compiler/damlc/lib/DA/Cli/Damlc/Packaging.hs b/compiler/damlc/lib/DA/Cli/Damlc/Packaging.hs
@@ -69,8 +69,8 @@ import SdkVersion
 --   ledger. Based on the DAML-LF we generate dummy interface files
 --   and then remap references to those dummy packages to the original DAML-LF
 --   package id.
-createProjectPackageDb :: NormalizedFilePath -> Options -> PackageSdkVersion -> [FilePath] -> [FilePath] -> IO ()
-createProjectPackageDb projectRoot opts thisSdkVer deps dataDeps
+createProjectPackageDb :: NormalizedFilePath -> Options -> PackageSdkVersion -> MS.Map UnitId GHC.ModuleName -> [FilePath] -> [FilePath] -> IO ()
+createProjectPackageDb projectRoot opts thisSdkVer modulePrefixes deps dataDeps
   | null dataDeps && all (`elem` basePackages) deps =
     -- Initializing the package db is expensive since it requires calling GenerateStablePackages and GeneratePackageMap.
     --Therefore we only do it if we actually have a dependency.
@@ -142,6 +142,10 @@ createProjectPackageDb projectRoot opts thisSdkVer deps dataDeps
     exposedModules <- getExposedModules opts projectRoot
 
     let (depGraph, vertexToNode) = buildLfPackageGraph dalfsFromDataDependencies stablePkgs dependenciesInPkgDb
+
+
+    validatedModulePrefixes <- either exitWithError pure (prefixModules modulePrefixes (dalfsFromDependencies <> dalfsFromDataDependencies))
+
     -- Iterate over the dependency graph in topological order.
     -- We do a topological sort on the transposed graph which ensures that
     -- the packages with no dependencies come first and we
@@ -179,7 +183,7 @@ createProjectPackageDb projectRoot opts thisSdkVer deps dataDeps
             dependenciesInPkgDb
             exposedModules
 
-    writeMetadata projectRoot (PackageDbMetadata (mainUnitIds dependencyInfo))
+    writeMetadata projectRoot (PackageDbMetadata (mainUnitIds dependencyInfo) validatedModulePrefixes)
   where
     dbPath = projectPackageDatabase </> lfVersionString (optDamlLfVersion opts)
     clearPackageDb = do
@@ -244,8 +248,8 @@ generateAndInstallIfaceFiles dalf src opts workDir dbPath projectPackageDatabase
                   baseImports ++
                   depImps
             -- When compiling dummy interface files for a data-dependency,
-            -- we know all package flags so we don’t need to infer anything.
-            , optInferDependantPackages = InferDependantPackages False
+            -- we know all package flags so we don’t need to consult metadata.
+            , optIgnorePackageMetadata = IgnorePackageMetadata True
             }
 
     res <- withDamlIdeState opts loggerH diagnosticsLogger $ \ide ->
@@ -547,7 +551,7 @@ getExposedModules opts projectRoot = do
     -- do not matter and can be actively harmful since we might have picked up
     -- some from the daml.yaml if they are explicitly specified.
     opts <- pure opts
-        { optInferDependantPackages = InferDependantPackages False
+        { optIgnorePackageMetadata = IgnorePackageMetadata True
         , optPackageImports = []
         }
     hscEnv <-
@@ -650,3 +654,23 @@ decodeDalf dependenciesInPkgDb path bytes = do
 getDarsFromDependencies :: Set LF.PackageId -> [ExtractedDar] -> IO [DecodedDar]
 getDarsFromDependencies dependenciesInPkgDb depsExtracted =
     either fail pure $ mapM (decodeDar dependenciesInPkgDb) depsExtracted
+
+-- | Given the prefixes declared in daml.yaml
+-- and the list of decoded dalfs, validate that
+-- the prefixes point to packages that exist
+-- and associate them with all modules in the given package.
+-- We run this after checking for unit id collisions so we assume
+-- that the unit ids in the decoded dalfs are unique.
+prefixModules
+    :: MS.Map UnitId GHC.ModuleName
+    -> [DecodedDalf]
+    -> Either String (MS.Map UnitId (GHC.ModuleName, [LF.ModuleName]))
+prefixModules prefixes dalfs = do
+    MS.traverseWithKey f prefixes
+  where unitIdMap = MS.fromList [(decodedUnitId, decodedDalfPkg) | DecodedDalf{..} <- dalfs]
+        f unitId prefix = case MS.lookup unitId unitIdMap of
+            Nothing -> Left ("Could not find package " <> unitIdString unitId)
+            Just pkg -> Right
+                ( prefix
+                , NM.names . LF.packageModules . LF.extPackagePkg $ LF.dalfPackagePkg pkg
+                )
diff --git a/compiler/damlc/lib/DA/Cli/Options.hs b/compiler/damlc/lib/DA/Cli/Options.hs
@@ -267,7 +267,7 @@ optionsParser numProcessors enableScenarioService parsePkgName = do
     let optCoreLinting = False
     let optHaddock = Haddock False
     let optIncrementalBuild = IncrementalBuild False
-    let optInferDependantPackages = InferDependantPackages True
+    let optIgnorePackageMetadata = IgnorePackageMetadata False
     let optEnableOfInterestRule = True
     optCppPath <- optCppPath