From 346a965c9ee14460af1a5377fba28e31ffd4102d Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Wed, 24 Jul 2024 13:33:43 +0100 Subject: [PATCH 01/31] Check keys for structural equality --- .../daml-lf-ast/src/DA/Daml/LF/Ast/Alpha.hs | 9 +- .../daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs | 28 ++ .../src/DA/Daml/LF/TypeChecker/Error.hs | 13 + .../src/DA/Daml/LF/TypeChecker/Upgrade.hs | 308 ++++++++++++------ .../daml-compiler/src/DA/Daml/Compiler/Dar.hs | 11 +- .../src/Development/IDE/Core/Rules/Daml.hs | 22 +- .../Development/IDE/Core/RuleTypes/Daml.hs | 4 +- sdk/compiler/damlc/tests/BUILD.bazel | 3 +- .../damlc/tests/src/DA/Test/DamlcUpgrades.hs | 43 ++- sdk/daml-lf/validation/BUILD.bazel | 6 + sdk/test-common/BUILD.bazel | 64 ++++ 11 files changed, 384 insertions(+), 127 deletions(-) diff --git a/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Alpha.hs b/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Alpha.hs index b2b04e0896e9..c8f989cabe44 100644 --- a/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Alpha.hs +++ b/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Alpha.hs @@ -5,6 +5,11 @@ module DA.Daml.LF.Ast.Alpha ( alphaType , alphaExpr + , alphaType' + , initialAlphaEnv + , alphaTypeCon + , bindTypeVar + , AlphaEnv(..) ) where import qualified Data.Map.Strict as Map @@ -27,6 +32,7 @@ data AlphaEnv = AlphaEnv , boundExprVarsRhs :: !(Map.Map ExprVarName Int) -- ^ Maps bound expr variables from the right-hand-side to -- the depth of the binder which introduced them. + , tconEquivalence :: !(Qualified TypeConName -> Qualified TypeConName -> Bool) } onList :: (a -> a -> Bool) -> [a] -> [a] -> Bool @@ -77,7 +83,7 @@ alphaType' env = \case TVar x2 -> alphaTypeVar env x1 x2 _ -> False TCon c1 -> \case - TCon c2 -> alphaTypeCon c1 c2 + TCon c2 -> tconEquivalence env c1 c2 _ -> False TApp t1a t1b -> \case TApp t2a t2b -> alphaType' env t1a t2a && alphaType' env t1b t2b @@ -475,6 +481,7 @@ initialAlphaEnv = AlphaEnv , boundTypeVarsRhs = Map.empty , boundExprVarsLhs = Map.empty , boundExprVarsRhs = Map.empty + , tconEquivalence = alphaTypeCon } alphaType :: Type -> Type -> Bool diff --git a/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs b/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs index d8853faa83dd..92ecc7ea7334 100644 --- a/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs +++ b/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs @@ -16,6 +16,7 @@ import Data.List.Extra (nubSort, stripInfixEnd) import qualified Data.NameMap as NM import Module (UnitId, unitIdString, stringToUnitId) import System.FilePath +import Text.Read (readMaybe) import DA.Daml.LF.Ast.Base import DA.Daml.LF.Ast.TypeLevelNat @@ -327,3 +328,30 @@ splitUnitId (unitIdString -> unitId) = fromMaybe (PackageName (T.pack unitId), N (name, ver) <- stripInfixEnd "-" unitId guard $ all (`elem` '.' : ['0' .. '9']) ver pure (PackageName (T.pack name), Just (PackageVersion (T.pack ver))) + +-- | Take a package version of regex "(0|[1-9][0-9]*)(\.(0|[1-9][0-9]*))*" into +-- a list of integers [Integer] +splitPackageVersion + :: (PackageVersion -> a) -> PackageVersion + -> Either a [Integer] +splitPackageVersion mkError version@(PackageVersion raw) = + let pieces = T.split (== '.') raw + in + case traverse (readMaybe . T.unpack) pieces of + Nothing -> Left (mkError version) + Just versions -> Right versions + +data ComparePackageVersionError + = FirstVersionUnparseable PackageVersion + | SecondVersionUnparseable PackageVersion + deriving (Show, Eq, Ord) + +comparePackageVersion :: PackageVersion -> PackageVersion -> Either ComparePackageVersionError Ordering +comparePackageVersion v1 v2 = do + v1Pieces <- splitPackageVersion FirstVersionUnparseable v1 + v2Pieces <- splitPackageVersion SecondVersionUnparseable v2 + let pad xs target = + take + (length target `max` length xs) + (xs ++ repeat 0) + pure $ compare (pad v1Pieces v2Pieces) (pad v2Pieces v1Pieces) diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs index 1d18f3f639d5..9d97ca9a1748 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs @@ -204,12 +204,15 @@ data UnwarnableError | EUpgradeTemplateAddedKey !TypeConName !TemplateKey | EUpgradeTriedToUpgradeIface !TypeConName | EUpgradeMissingImplementation !TypeConName !TypeConName + | EUpgradeDependencyHasLowerVersionDespiteUpgrade !PackageName !PackageVersion !PackageVersion deriving (Show) data WarnableError = WEUpgradeShouldDefineIfacesAndTemplatesSeparately | WEUpgradeShouldDefineIfaceWithoutImplementation !TypeConName ![TypeConName] | WEUpgradeShouldDefineTplInSeparatePackage !TypeConName !TypeConName + | WEPastDependencyHasUnparseableVersion !PackageName !PackageVersion + | WEPresentDependencyHasUnparseableVersion !PackageName !PackageVersion deriving (Show) instance Pretty WarnableError where @@ -235,6 +238,10 @@ instance Pretty WarnableError where , "It is recommended that interfaces are defined in their own package separate from their implementations." , "Ignore this error message with the --warn-bad-interface-instances=yes flag." ] + WEPastDependencyHasUnparseableVersion pkgName version -> + "Dependency " <> pPrint pkgName <> " of upgrading package has a version which cannot be parsed: '" <> pPrint version <> "'" + WEPresentDependencyHasUnparseableVersion pkgName version -> + "Dependency " <> pPrint pkgName <> " of upgraded package has a version which cannot be parsed: '" <> pPrint version <> "'" data UpgradedRecordOrigin = TemplateBody TypeConName @@ -650,6 +657,12 @@ instance Pretty UnwarnableError where EUpgradeTemplateAddedKey template _key -> "The upgraded template " <> pPrint template <> " cannot add a key where it didn't have one previously." EUpgradeTriedToUpgradeIface iface -> "Tried to upgrade interface " <> pPrint iface <> ", but interfaces cannot be upgraded. They should be removed in any upgrading package." EUpgradeMissingImplementation tpl iface -> "Implementation of interface " <> pPrint iface <> " by template " <> pPrint tpl <> " appears in package that is being upgraded, but does not appear in this package." + EUpgradeDependencyHasLowerVersionDespiteUpgrade pkgName presentVersion pastVersion -> + vcat + [ "Dependency " <> pPrint pkgName <> " has version " <> pPrint presentVersion <> " on the upgrading package, which is older than version " <> pPrint pastVersion <> " on the upgraded package." + , "Dependency versions of upgrading packages must always be greater or equal to the dependency versions on upgraded packages." + ] + instance Pretty UpgradedRecordOrigin where pPrint = \case diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs index a9ed67297aae..f4f296b0fe2c 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs @@ -9,11 +9,12 @@ module DA.Daml.LF.TypeChecker.Upgrade ( ) where import Control.DeepSeq -import Control.Monad (unless, forM_, when) -import Control.Monad.Reader (withReaderT) +import Control.Monad (unless, forM, forM_, when) +import Control.Monad.Extra (allM, filterM) +import Control.Monad.Reader (withReaderT, local) import Control.Lens hiding (Context) import DA.Daml.LF.Ast as LF -import DA.Daml.LF.Ast.Alpha (alphaExpr, alphaType) +import DA.Daml.LF.Ast.Alpha (alphaExpr, AlphaEnv(..), initialAlphaEnv, alphaType', alphaTypeCon, bindTypeVar) import DA.Daml.LF.TypeChecker.Check (expandTypeSynonyms) import DA.Daml.LF.TypeChecker.Env import DA.Daml.LF.TypeChecker.Error @@ -24,6 +25,7 @@ import Data.Either (partitionEithers) import Data.Hashable import qualified Data.HashMap.Strict as HMS import Data.List (foldl') +import Data.Maybe (mapMaybe) import qualified Data.NameMap as NM import qualified Data.Text as T import Development.IDE.Types.Diagnostics @@ -53,19 +55,32 @@ instance Applicative Upgrading where foldU :: (a -> a -> b) -> Upgrading a -> b foldU f u = f (_past u) (_present u) +unsafeFlattenUpgrading :: Upgrading [a] -> [Upgrading a] +unsafeFlattenUpgrading = foldU (zipWith Upgrading) + -- Allows us to split the world into upgraded and non-upgraded -type TcUpgradeM = TcMF (Upgrading Gamma) +type TcUpgradeM = TcMF UpgradingEnv + +data UpgradingEnv = UpgradingEnv + { _upgradingGamma :: Upgrading Gamma + , _upgradingDeps :: [Upgrading LF.PackageId] + } + +makeLenses ''UpgradingEnv + +present' :: Functor f => (Gamma -> f Gamma) -> UpgradingEnv -> f UpgradingEnv +present' = upgradingGamma . present runGammaUnderUpgrades :: Upgrading (TcM a) -> TcUpgradeM (Upgrading a) runGammaUnderUpgrades Upgrading{ _past = pastAction, _present = presentAction } = do - pastResult <- withReaderT _past pastAction - presentResult <- withReaderT _present presentAction + pastResult <- withReaderT (_past . _upgradingGamma) pastAction + presentResult <- withReaderT (_present . _upgradingGamma) presentAction pure Upgrading { _past = pastResult, _present = presentResult } checkBothAndSingle - :: World -> (LF.UpgradedPackageId -> LF.Package -> TcUpgradeM ()) -> TcM () + :: World -> (LF.UpgradedPackageId -> LF.Package -> [(LF.PackageId, LF.Package)] -> TcUpgradeM ()) -> TcM () -> Version -> UpgradeInfo - -> Maybe (LF.PackageId, LF.Package) + -> Maybe ((LF.PackageId, LF.Package), [(LF.PackageId, LF.Package)]) -> [Diagnostic] checkBothAndSingle world checkBoth checkSingle version upgradeInfo mbUpgradedPackage = let shouldTypecheck = version `LF.supports` LF.featurePackageUpgrades && uiTypecheckUpgrades upgradeInfo @@ -90,12 +105,16 @@ checkBothAndSingle world checkBoth checkSingle version upgradeInfo mbUpgradedPac case mbUpgradedPackage of Nothing -> Right ((), []) - Just (pastPkgId, pastPkg) -> + Just ((pastPkgId, pastPkg), deps) -> let upgradingWorld = Upgrading { _past = initWorldSelf [] pastPkg, _present = world } - upgradingGamma = fmap gamma upgradingWorld + upgradingEnv = + UpgradingEnv + { _upgradingGamma = fmap gamma upgradingWorld + , _upgradingDeps = [] + } in - runGammaF upgradingGamma $ - when shouldTypecheck (checkBoth (UpgradedPackageId pastPkgId) pastPkg) + runGammaF upgradingEnv $ + when (uiTypecheckUpgrades upgradeInfo) (checkBoth (UpgradedPackageId pastPkgId) pastPkg deps) singlePkgDiagnostics :: Either Error ((), [Warning]) singlePkgDiagnostics = @@ -111,14 +130,16 @@ checkBothAndSingle world checkBoth checkSingle version upgradeInfo mbUpgradedPac extractDiagnostics bothPkgDiagnostics ++ extractDiagnostics singlePkgDiagnostics checkUpgrade - :: LF.Package + :: LF.Package -> [LF.DalfPackage] -> Version -> UpgradeInfo - -> Maybe (LF.PackageId, LF.Package) + -> Maybe ((LF.PackageId, LF.Package), [(LF.PackageId, LF.Package)]) -> [Diagnostic] -checkUpgrade pkg = +checkUpgrade pkg deps = let world = initWorldSelf [] pkg - checkBoth upgradedPkgId upgradedPkg = - checkUpgradeM upgradedPkgId (Upgrading upgradedPkg pkg) + checkBoth upgradedPkgId upgradedPkg upgradedDeps = do + deps <- checkUpgradeDependenciesM deps upgradedDeps + local (\env -> env { _upgradingDeps = deps }) $ + checkUpgradeM upgradedPkgId (Upgrading upgradedPkg pkg) checkSingle = do checkNewInterfacesAreUnused pkg checkNewInterfacesHaveNoTemplates pkg @@ -126,29 +147,66 @@ checkUpgrade pkg = checkBothAndSingle world checkBoth checkSingle checkModule - :: LF.World -> LF.Module + :: LF.World -> LF.Module -> [LF.DalfPackage] -> Version -> UpgradeInfo - -> Maybe (LF.PackageId, LF.Package) + -> Maybe ((LF.PackageId, LF.Package), [(LF.PackageId, LF.Package)]) -> [Diagnostic] -checkModule world0 module_ = +checkModule world0 module_ deps = let world = extendWorldSelf module_ world0 - checkBoth upgradedPkgId upgradedPkg = + checkBoth upgradedPkgId upgradedPkg upgradedDeps = do + deps <- checkUpgradeDependenciesM deps upgradedDeps case NM.lookup (NM.name module_) (LF.packageModules upgradedPkg) of Nothing -> pure () - Just pastModule -> + Just pastModule -> do let upgradingModule = Upgrading { _past = pastModule, _present = module_ } - in - checkModuleM upgradedPkgId upgradingModule + equalDataTypes <- structurallyEqualDataTypes upgradingModule + local (\env -> env { _upgradingDeps = deps }) $ + checkModuleM equalDataTypes upgradedPkgId upgradingModule checkSingle = do checkNewInterfacesAreUnused module_ checkNewInterfacesHaveNoTemplates module_ in checkBothAndSingle world checkBoth checkSingle +checkUpgradeDependenciesM + :: [LF.DalfPackage] + -> [(LF.PackageId, LF.Package)] + -> TcUpgradeM [Upgrading LF.PackageId] +checkUpgradeDependenciesM presentDeps pastDeps = do + let pkgToTriple :: LF.PackageId -> LF.Package -> Maybe (LF.PackageName, (LF.PackageVersion, LF.PackageId)) + pkgToTriple packageId LF.Package{packageMetadata = Just LF.PackageMetadata{packageName, packageVersion}} = Just (packageName, (packageVersion, packageId)) + pkgToTriple _ _ = Nothing + dalfPkgToTriple LF.DalfPackage{dalfPackageId,dalfPackagePkg} = + pkgToTriple dalfPackageId (extPackagePkg dalfPackagePkg) + let upgrading = Upgrading + { _past = HMS.fromList $ mapMaybe (uncurry pkgToTriple) pastDeps + , _present = HMS.fromList $ mapMaybe dalfPkgToTriple presentDeps + } + let (_del, existingDeps, _new) = extractDelExistNew upgrading + depRelations <- forM (HMS.toList existingDeps) $ \(depName, dep) -> + let versions = fmap fst dep + pkgIds = fmap snd dep + in + case foldU LF.comparePackageVersion versions of + Left (FirstVersionUnparseable presentVersion) -> do + diagnosticWithContextF present' $ + WEPresentDependencyHasUnparseableVersion depName presentVersion + pure [] + Left (SecondVersionUnparseable pastVersion) -> do + diagnosticWithContextF present' $ + WEPastDependencyHasUnparseableVersion depName pastVersion + pure [] + Right GT -> + throwWithContextF present' $ + EUpgradeDependencyHasLowerVersionDespiteUpgrade depName (_present versions) (_past versions) + _ -> pure [pkgIds] -- if past package is lesser than or equal, the dependency is a valid upgrade + pure (concat depRelations) + checkUpgradeM :: LF.UpgradedPackageId -> Upgrading LF.Package -> TcUpgradeM () checkUpgradeM upgradedPackageId package = do (upgradedModules, _new) <- checkDeleted (EUpgradeMissingModule . NM.name) $ NM.toHashMap . packageModules <$> package - forM_ upgradedModules $ checkModuleM upgradedPackageId + equalDataTypes <- structurallyEqualDataTypes package + forM_ upgradedModules $ checkModuleM equalDataTypes upgradedPackageId extractDelExistNew :: (Eq k, Hashable k) @@ -198,19 +256,19 @@ throwIfNonEmpty handleError hm = ctxHandler = case ctx of Nothing -> id - Just ctx -> withContextF present ctx + Just ctx -> withContextF present' ctx in - ctxHandler $ diagnosticWithContextF present err + ctxHandler $ diagnosticWithContextF present' err _ -> pure () -checkModuleM :: LF.UpgradedPackageId -> Upgrading LF.Module -> TcUpgradeM () -checkModuleM upgradedPackageId module_ = do +checkModuleM :: [LF.TypeConName] -> LF.UpgradedPackageId -> Upgrading LF.Module -> TcUpgradeM () +checkModuleM equalDataTypes upgradedPackageId module_ = do (existingTemplates, _new) <- checkDeleted (EUpgradeMissingTemplate . NM.name) $ NM.toHashMap . moduleTemplates <$> module_ forM_ existingTemplates $ \template -> withContextF - present + present' (ContextTemplate (_present module_) (_present template) TPWhole) - (checkTemplate module_ template) + (checkTemplate equalDataTypes module_ template) -- For a datatype, derive its context let deriveChoiceInfo :: LF.Module -> HMS.HashMap LF.TypeConName (LF.Template, LF.TemplateChoice) @@ -311,11 +369,11 @@ checkModuleM upgradedPackageId module_ = do in -- If origins don't match, record has changed origin if foldU (/=) (fst <$> origin) then - withContextF present (ContextDefDataType (_present module_) (_present dt)) $ - throwWithContextF present (EUpgradeRecordChangedOrigin (dataTypeCon (_present dt)) (fst (_past origin)) (fst (_present origin))) + withContextF present' (ContextDefDataType (_present module_) (_present dt)) $ + throwWithContextF present' (EUpgradeRecordChangedOrigin (dataTypeCon (_present dt)) (fst (_past origin)) (fst (_present origin))) else do let (presentOrigin, context) = _present origin - withContextF present context $ checkDefDataType presentOrigin dt + withContextF present' context $ checkDefDataType presentOrigin dt -- It is always invalid to keep an interface in an upgrade checkContinuedIfaces @@ -326,8 +384,8 @@ checkContinuedIfaces module_ ifaces = forM_ ifaces $ \upgradedDtIface -> let (_dt, iface) = _present upgradedDtIface in - withContextF present (ContextDefInterface (_present module_) iface IPWhole) $ - throwWithContextF present $ EUpgradeTriedToUpgradeIface (NM.name iface) + withContextF present' (ContextDefInterface (_present module_) iface IPWhole) $ + throwWithContextF present' $ EUpgradeTriedToUpgradeIface (NM.name iface) class HasModules a where getModules :: a -> NM.NameMap LF.Module @@ -393,8 +451,8 @@ checkUpgradedInterfacesAreUnused upgradedPackageId module_ newInstances = do let qualifiedTplName = Qualified PRSelf (moduleName module_) tplName ifaceInstanceHead = InterfaceInstanceHead ifaceName qualifiedTplName in - withContextF present (ContextTemplate module_ tpl (TPInterfaceInstance ifaceInstanceHead Nothing)) $ - diagnosticWithContextF present $ WEUpgradeShouldDefineTplInSeparatePackage (NM.name tpl) (LF.qualObject (NM.name implementation)) + withContextF present' (ContextTemplate module_ tpl (TPInterfaceInstance ifaceInstanceHead Nothing)) $ + diagnosticWithContextF present' $ WEUpgradeShouldDefineTplInSeparatePackage (NM.name tpl) (LF.qualObject (NM.name implementation)) where fromUpgradedPackage :: forall a. LF.Qualified a -> Bool fromUpgradedPackage identifier = @@ -409,17 +467,17 @@ instantiatedIfaces modules = foldl' (HMS.unionWith (<>)) HMS.empty $ (map . fmap , template <- NM.elems (moduleTemplates module_) ] -checkTemplate :: Upgrading Module -> Upgrading LF.Template -> TcUpgradeM () -checkTemplate module_ template = do +checkTemplate :: [LF.TypeConName] -> Upgrading Module -> Upgrading LF.Template -> TcUpgradeM () +checkTemplate equalDataTypes module_ template = do -- Check that no choices have been removed (existingChoices, _existingNew) <- checkDeleted (EUpgradeMissingChoice . NM.name) $ NM.toHashMap . tplChoices <$> template forM_ existingChoices $ \choice -> do - withContextF present (ContextTemplate (_present module_) (_present template) (TPChoice (_present choice))) $ do - checkUpgradeType (fmap chcReturnType choice) + withContextF present' (ContextTemplate (_present module_) (_present template) (TPChoice (_present choice))) $ do + checkType (fmap chcReturnType choice) (EUpgradeChoiceChangedReturnType (NM.name (_present choice))) whenDifferent "controllers" (extractFuncFromFuncThisArg . chcControllers) choice $ - warnWithContextF present $ WChoiceChangedControllers $ NM.name $ _present choice + warnWithContextF present' $ WChoiceChangedControllers $ NM.name $ _present choice let observersErr = WChoiceChangedObservers $ NM.name $ _present choice case fmap (mapENilToNothing . chcObservers) choice of @@ -428,9 +486,9 @@ checkTemplate module_ template = do Upgrading { _past = Just _past, _present = Just _present } -> do whenDifferent "observers" extractFuncFromFuncThisArg (Upgrading _past _present) - (warnWithContextF present observersErr) + (warnWithContextF present' observersErr) _ -> do - warnWithContextF present observersErr + warnWithContextF present' observersErr let authorizersErr = WChoiceChangedAuthorizers $ NM.name $ _present choice case fmap (mapENilToNothing . chcAuthorizers) choice of @@ -438,28 +496,28 @@ checkTemplate module_ template = do Upgrading { _past = Just _past, _present = Just _present } -> whenDifferent "authorizers" extractFuncFromFuncThisArg (Upgrading _past _present) - (warnWithContextF present authorizersErr) - _ -> warnWithContextF present authorizersErr + (warnWithContextF present' authorizersErr) + _ -> warnWithContextF present' authorizersErr pure choice -- This check assumes that we encode signatories etc. on a template as -- $ this, where $ is a function that contains the -- actual definition. We resolve this function and check that it is -- identical. - withContextF present (ContextTemplate (_present module_) (_present template) TPPrecondition) $ + withContextF present' (ContextTemplate (_present module_) (_present template) TPPrecondition) $ whenDifferent "precondition" (extractFuncFromCaseFuncThis . tplPrecondition) template $ - warnWithContextF present $ WTemplateChangedPrecondition $ NM.name $ _present template - withContextF present (ContextTemplate (_present module_) (_present template) TPSignatories) $ + warnWithContextF present' $ WTemplateChangedPrecondition $ NM.name $ _present template + withContextF present' (ContextTemplate (_present module_) (_present template) TPSignatories) $ whenDifferent "signatories" (extractFuncFromFuncThis . tplSignatories) template $ - warnWithContextF present $ WTemplateChangedSignatories $ NM.name $ _present template - withContextF present (ContextTemplate (_present module_) (_present template) TPObservers) $ + warnWithContextF present' $ WTemplateChangedSignatories $ NM.name $ _present template + withContextF present' (ContextTemplate (_present module_) (_present template) TPObservers) $ whenDifferent "observers" (extractFuncFromFuncThis . tplObservers) template $ - warnWithContextF present $ WTemplateChangedObservers $ NM.name $ _present template - withContextF present (ContextTemplate (_present module_) (_present template) TPAgreement) $ + warnWithContextF present' $ WTemplateChangedObservers $ NM.name $ _present template + withContextF present' (ContextTemplate (_present module_) (_present template) TPAgreement) $ whenDifferent "agreement" (extractFuncFromFuncThis . tplAgreement) template $ - warnWithContextF present $ WTemplateChangedAgreement $ NM.name $ _present template + warnWithContextF present' $ WTemplateChangedAgreement $ NM.name $ _present template - withContextF present (ContextTemplate (_present module_) (_present template) TPKey) $ do + withContextF present' (ContextTemplate (_present module_) (_present template) TPKey) $ do case fmap tplKey template of Upgrading { _past = Nothing, _present = Nothing } -> do pure () @@ -467,20 +525,21 @@ checkTemplate module_ template = do let tplKey = Upgrading pastKey presentKey -- Key type musn't change - checkUpgradeType (fmap tplKeyType tplKey) - (EUpgradeTemplateChangedKeyType (NM.name (_present template))) + iset <- isStructurallyEquivalentType initialAlphaEnv equalDataTypes (fmap tplKeyType tplKey) + when (not iset) $ + diagnosticWithContextF present' (EUpgradeTemplateChangedKeyType (NM.name (_present template))) -- But expression for computing it may whenDifferent "key expression" (extractFuncFromFuncThis . tplKeyBody) tplKey - (warnWithContextF present $ WTemplateChangedKeyExpression $ NM.name $ _present template) + (warnWithContextF present' $ WTemplateChangedKeyExpression $ NM.name $ _present template) whenDifferent "key maintainers" (extractFuncFromTyAppNil . tplKeyMaintainers) tplKey - (warnWithContextF present $ WTemplateChangedKeyMaintainers $ NM.name $ _present template) + (warnWithContextF present' $ WTemplateChangedKeyMaintainers $ NM.name $ _present template) Upgrading { _past = Just pastKey, _present = Nothing } -> - throwWithContextF present $ EUpgradeTemplateRemovedKey (NM.name (_present template)) pastKey + throwWithContextF present' $ EUpgradeTemplateRemovedKey (NM.name (_present template)) pastKey Upgrading { _past = Nothing, _present = Just presentKey } -> - throwWithContextF present $ EUpgradeTemplateAddedKey (NM.name (_present template)) presentKey + throwWithContextF present' $ EUpgradeTemplateAddedKey (NM.name (_present template)) presentKey -- TODO: Check that return type of a choice is compatible pure () @@ -497,7 +556,7 @@ checkTemplate module_ template = do in case resolvedWithPossibleError of Left err -> - warnWithContextF present (WCouldNotExtractForUpgradeChecking (T.pack field) (Just (T.pack err))) + warnWithContextF present' (WCouldNotExtractForUpgradeChecking (T.pack field) (Just (T.pack err))) Right resolvedExprs -> let exprsMatch = foldU alphaExpr $ fmap removeLocations resolvedExprs in @@ -589,10 +648,10 @@ checkDefDataType origin datatype = do let upgrade = Upgrading{..} (existing, _new) <- checkDeleted (\_ -> EUpgradeVariantRemovedVariant origin) (fmap HMS.fromList upgrade) when (not $ and $ foldU (zipWith (==)) $ fmap (map fst) upgrade) $ - throwWithContextF present (EUpgradeVariantVariantsOrderChanged origin) - different <- filterHashMapM (fmap not . isSameType) existing + throwWithContextF present' (EUpgradeVariantVariantsOrderChanged origin) + different <- filterHashMapM (fmap not . isUpgradedType) existing when (not (null different)) $ - throwWithContextF present $ EUpgradeVariantChangedVariantType origin + throwWithContextF present' $ EUpgradeVariantChangedVariantType origin Upgrading { _past = DataEnum _past, _present = DataEnum _present } -> do let upgrade = Upgrading{..} (_, _new) <- @@ -600,11 +659,11 @@ checkDefDataType origin datatype = do (\_ -> EUpgradeEnumRemovedVariant origin) (fmap (HMS.fromList . map (,())) upgrade) when (not $ and $ foldU (zipWith (==)) upgrade) $ - throwWithContextF present (EUpgradeEnumVariantsOrderChanged origin) + throwWithContextF present' (EUpgradeEnumVariantsOrderChanged origin) Upgrading { _past = DataInterface {}, _present = DataInterface {} } -> pure () _ -> - throwWithContextF present (EUpgradeMismatchDataConsVariety (dataTypeCon (_past datatype)) (dataCons (_past datatype)) (dataCons (_present datatype))) + throwWithContextF present' (EUpgradeMismatchDataConsVariety (dataTypeCon (_past datatype)) (dataCons (_past datatype)) (dataCons (_present datatype))) filterHashMapM :: (Applicative m) => (a -> m Bool) -> HMS.HashMap k a -> m (HMS.HashMap k a) filterHashMapM pred t = @@ -614,47 +673,102 @@ checkFields :: UpgradedRecordOrigin -> Upgrading [(FieldName, Type)] -> TcUpgrad checkFields origin fields = do (existing, new) <- checkDeleted (\_ -> EUpgradeRecordFieldsMissing origin) (fmap HMS.fromList fields) -- If a field from the upgraded package has had its type changed - different <- filterHashMapM (fmap not . isSameType) existing + different <- filterHashMapM (fmap not . isUpgradedType) existing when (not (HMS.null different)) $ - throwWithContextF present (EUpgradeRecordFieldsExistingChanged origin) + throwWithContextF present' (EUpgradeRecordFieldsExistingChanged origin) when (not (all newFieldOptionalType new)) $ case origin of VariantConstructor{} -> - throwWithContextF present (EUpgradeVariantAddedVariantField origin) + throwWithContextF present' (EUpgradeVariantAddedVariantField origin) _ -> - throwWithContextF present (EUpgradeRecordFieldsNewNonOptional origin) + throwWithContextF present' (EUpgradeRecordFieldsNewNonOptional origin) -- If a new field has a non-optional type -- If the order of fields changed when (not $ and $ foldU (zipWith (==)) $ fmap (map fst) fields) $ - throwWithContextF present (EUpgradeRecordFieldsOrderChanged origin) + throwWithContextF present' (EUpgradeRecordFieldsOrderChanged origin) where newFieldOptionalType (TOptional _) = True newFieldOptionalType _ = False -- Check type upgradability -checkUpgradeType :: SomeErrorOrWarning e => Upgrading Type -> e -> TcUpgradeM () -checkUpgradeType type_ err = do - sameType <- isSameType type_ - unless sameType $ diagnosticWithContextF present err +checkType :: SomeErrorOrWarning e => Upgrading Type -> e -> TcUpgradeM () +checkType type_ err = do + sameType <- isUpgradedType type_ + unless sameType $ diagnosticWithContextF present' err -isSameType :: Upgrading Type -> TcUpgradeM Bool -isSameType type_ = do +isUpgradedType :: Upgrading Type -> TcUpgradeM Bool +isUpgradedType type_ = do expandedTypes <- runGammaUnderUpgrades (expandTypeSynonyms <$> type_) - let strippedIdentifiers = fmap unifyTypes expandedTypes - pure (foldU alphaType strippedIdentifiers) - -unifyIdentifier :: Qualified a -> Qualified a -unifyIdentifier q = q { qualPackage = PRSelf } - -unifyTypes :: Type -> Type -unifyTypes typ = - case typ of - TNat n -> TNat n - TSynApp n args -> TSynApp (unifyIdentifier n) (map unifyTypes args) - TVar n -> TVar n - TCon con -> TCon (unifyIdentifier con) - TBuiltin bt -> TBuiltin bt - TApp fun arg -> TApp (unifyTypes fun) (unifyTypes arg) - TForall v body -> TForall v (unifyTypes body) - TStruct fields -> TStruct ((map . fmap) unifyTypes fields) - + deps <- view upgradingDeps + let checkSelf = alphaTypeCon + checkImport t1 t2 = + case (qualPackage t1, qualPackage t2) of + (PRImport pkgId1, PRImport pkgId2) -> + pkgId1 == pkgId2 || + Upgrading pkgId1 pkgId2 `elem` deps && removePkgId t1 == removePkgId t2 + _ -> False + tconCheck t1 t2 = checkSelf t1 t2 || checkImport t1 t2 + pure $ foldU (alphaType' initialAlphaEnv { tconEquivalence = tconCheck }) expandedTypes + +isStructurallyEquivalentType :: AlphaEnv -> [TypeConName] -> Upgrading Type -> TcUpgradeM Bool +isStructurallyEquivalentType alphaEnv identicalCons type_ = do + expandedTypes <- runGammaUnderUpgrades (expandTypeSynonyms <$> type_) + let checkSelf t1 t2 = + and + [ qualPackage t1 == PRSelf + , qualPackage t2 == PRSelf + , qualObject t2 `elem` identicalCons + , alphaTypeCon t1 t2 + ] + checkImport t1 t2 = + qualPackage t1 /= PRSelf + && qualPackage t2 /= PRSelf + && alphaTypeCon t1 t2 + tconCheck t1 t2 = checkSelf t1 t2 || checkImport t1 t2 + pure $ foldU (alphaType' alphaEnv { tconEquivalence = tconCheck }) expandedTypes + +removePkgId :: Qualified a -> Qualified a +removePkgId a = a { qualPackage = PRSelf } + +isStructurallyEquivalentDatatype :: [TypeConName] -> Upgrading DefDataType -> TcUpgradeM Bool +isStructurallyEquivalentDatatype identicalCons datatype = + let params = dataParams <$> datatype + allKindsMatch = foldU (==) (map snd <$> params) + paramNames = unsafeFlattenUpgrading (map fst <$> params) + in + if not allKindsMatch + then pure False + else + let env = foldl' (flip (foldU bindTypeVar)) initialAlphaEnv paramNames + in + case fmap dataCons datatype of + Upgrading { _past = DataRecord _past, _present = DataRecord _present } -> do + let allFieldsMatch = map fst _past == map fst _present + let types = zipWith Upgrading (map snd _past) (map snd _present) + allTypesMatch <- allM (isStructurallyEquivalentType env identicalCons) types + pure (allFieldsMatch && allTypesMatch) + Upgrading { _past = DataVariant _past, _present = DataVariant _present } -> do + let allConNamesMatch = map fst _past == map fst _present + let types = zipWith Upgrading (map snd _past) (map snd _present) + allTypesMatch <- allM (isStructurallyEquivalentType env identicalCons) types + pure (allConNamesMatch && allTypesMatch) + Upgrading { _past = DataEnum _past, _present = DataEnum _present } -> do + pure $ _past == _present + Upgrading { _past = DataInterface {}, _present = DataInterface {} } -> + pure False + _ -> + pure False + +structurallyEqualDataTypes :: HasModules a => Upgrading a -> TcUpgradeM [TypeConName] +structurallyEqualDataTypes hasModules = + let module_ = NM.toHashMap . getModules <$> hasModules + (_, existingModules, _) = extractDelExistNew module_ + (_, existingDatatypes, _) = foldMap (extractDelExistNew . fmap (NM.toHashMap . moduleDataTypes)) (HMS.elems existingModules) + in + go (HMS.toList existingDatatypes) + where + go :: [(TypeConName, Upgrading DefDataType)] -> TcUpgradeM [TypeConName] + go list = do + let names = map fst list + list' <- filterM (isStructurallyEquivalentDatatype names . snd) list + if names /= map fst list' then go list' else pure names diff --git a/sdk/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Dar.hs b/sdk/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Dar.hs index ffa884ae3a00..5a22994fffc8 100644 --- a/sdk/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Dar.hs +++ b/sdk/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Dar.hs @@ -137,15 +137,12 @@ buildDar service PackageConfigFields {..} ifDir dalfInput upgradeInfo = do let pMeta = LF.PackageMetadata { packageName = pName , packageVersion = fromMaybe (LF.PackageVersion "0.0.0") pVersion - , upgradedPackageId = LF.UpgradedPackageId . fst <$> mbUpgradedPackage + , upgradedPackageId = LF.UpgradedPackageId . fst . fst <$> mbUpgradedPackage } pkg <- case optShakeFiles opts of Nothing -> mergePkgs pMeta lfVersion . map fst <$> usesE GeneratePackage files Just _ -> generateSerializedPackage pName pVersion pMeta files - MaybeT $ - runDiagnosticCheck $ diagsToIdeResult (toNormalizedFilePath' pSrc) $ - Upgrade.checkUpgrade pkg lfVersion upgradeInfo mbUpgradedPackage MaybeT $ finalPackageCheck (toNormalizedFilePath' pSrc) pkg let pkgModuleNames = map (Ghc.mkModuleName . T.unpack) $ LF.packageModuleNames pkg @@ -163,10 +160,16 @@ buildDar service PackageConfigFields {..} ifDir dalfInput upgradeInfo = do Just _ -> pure $ Just [] -- get all dalf dependencies. dalfDependencies0 <- getDalfDependencies files + MaybeT $ + runDiagnosticCheck $ diagsToIdeResult (toNormalizedFilePath' pSrc) $ + Upgrade.checkUpgrade pkg (Map.elems dalfDependencies0) lfVersion upgradeInfo mbUpgradedPackage let dalfDependencies = [ (T.pack $ unitIdString unitId, LF.dalfPackageBytes pkg, LF.dalfPackageId pkg) | (unitId, pkg) <- Map.toList dalfDependencies0 ] + --MaybeT $ + -- runDiagnosticCheck $ diagsToIdeResult (toNormalizedFilePath' pSrc) $ + -- TypeChecker.Upgrade.checkUpgradeDependencies lfVersion pTypecheckUpgrades pkg (Map.elems dalfDependencies0) mbUpgradedPackage unstableDeps <- getUnstableDalfDependencies files let confFile = mkConfFile pName pVersion (Map.keys unstableDeps) pExposedModules pkgModuleNames pkgId let dataFiles = [confFile] diff --git a/sdk/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs b/sdk/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs index 0091e150ae2e..b2abf8c03de5 100644 --- a/sdk/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs +++ b/sdk/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs @@ -293,10 +293,11 @@ getExternalPackages file = do map LF.dalfPackagePkg (Map.elems pkgMap) <> map LF.dalfPackagePkg (Map.elems stablePackages) -- Generates and type checks the DALF for a module. -generateDalfRule :: Options -> Rules () +generateDalfRule :: SdkVersioned => Options -> Rules () generateDalfRule opts = define $ \GenerateDalf file -> do lfVersion <- getDamlLfVersion + mbDalfDependencies <- runMaybeT (getDalfDependencies [file]) WhnfPackage pkg <- use_ GeneratePackageDeps file pkgs <- getExternalPackages file let world = LF.initWorldSelf pkgs pkg @@ -307,7 +308,7 @@ generateDalfRule opts = Left err -> ([ideErrorPretty file err], Nothing) Right dalf -> let lfDiags = LF.checkModule world lfVersion dalf - upgradeDiags = Upgrade.checkModule world dalf lfVersion (optUpgradeInfo opts) upgradedPackage + upgradeDiags = Upgrade.checkModule world dalf (foldMap Map.elems mbDalfDependencies) lfVersion (optUpgradeInfo opts) upgradedPackage in second (dalf <$) (diagsToIdeResult file (lfDiags ++ upgradeDiags)) -- TODO Share code with typecheckModule in ghcide. The environment needs to be setup @@ -542,11 +543,18 @@ extractUpgradedPackageRule opts = do Nothing -> pure Nothing Just path -> use ExtractUpgradedPackageFile (toNormalizedFilePath' path) define $ \ExtractUpgradedPackageFile file -> do - ExtractedDar{edMain} <- liftIO $ extractDar (fromNormalizedFilePath file) - let bs = BSL.toStrict $ ZipArchive.fromEntry edMain - case Archive.decodeArchive Archive.DecodeAsMain bs of - Left _ -> pure ([ideErrorPretty file ("Could not decode file as a DAR." :: T.Text)], Nothing) - Right (pid, package) -> pure ([], Just (pid, package)) + ExtractedDar{edMain,edDalfs} <- liftIO $ extractDar (fromNormalizedFilePath file) + let bsMain = BSL.toStrict $ ZipArchive.fromEntry edMain + let bsDeps = BSL.toStrict . ZipArchive.fromEntry <$> edDalfs + let mainAndDeps :: Either Archive.ArchiveError ((LF.PackageId, LF.Package), [(LF.PackageId, LF.Package)]) + mainAndDeps = do + main <- Archive.decodeArchive Archive.DecodeAsMain bsMain + deps <- Archive.decodeArchive Archive.DecodeAsDependency `traverse` bsDeps + pure (main, deps) + let myThing = case mainAndDeps of + Left _ -> ([ideErrorPretty file ("Could not decode file as a DAR." :: T.Text)], Nothing) + Right mainAndDeps -> ([], Just mainAndDeps) + pure myThing readDalfPackage :: FilePath -> IO (Either FileDiagnostic LF.DalfPackage) readDalfPackage dalf = do diff --git a/sdk/compiler/damlc/daml-rule-types/src/Development/IDE/Core/RuleTypes/Daml.hs b/sdk/compiler/damlc/daml-rule-types/src/Development/IDE/Core/RuleTypes/Daml.hs index 58c8d86610ec..2cba6b34ca2e 100644 --- a/sdk/compiler/damlc/daml-rule-types/src/Development/IDE/Core/RuleTypes/Daml.hs +++ b/sdk/compiler/damlc/daml-rule-types/src/Development/IDE/Core/RuleTypes/Daml.hs @@ -318,7 +318,7 @@ instance Binary ExtractUpgradedPackage instance Hashable ExtractUpgradedPackage instance NFData ExtractUpgradedPackage -type instance RuleResult ExtractUpgradedPackage = Maybe (LF.PackageId, LF.Package) +type instance RuleResult ExtractUpgradedPackage = Maybe ((LF.PackageId, LF.Package), [(LF.PackageId, LF.Package)]) data ExtractUpgradedPackageFile = ExtractUpgradedPackageFile deriving (Eq, Show, Typeable, Generic) @@ -326,4 +326,4 @@ instance Binary ExtractUpgradedPackageFile instance Hashable ExtractUpgradedPackageFile instance NFData ExtractUpgradedPackageFile -type instance RuleResult ExtractUpgradedPackageFile = (LF.PackageId, LF.Package) +type instance RuleResult ExtractUpgradedPackageFile = ((LF.PackageId, LF.Package), [(LF.PackageId, LF.Package)]) diff --git a/sdk/compiler/damlc/tests/BUILD.bazel b/sdk/compiler/damlc/tests/BUILD.bazel index 7fae5edcdbf1..800aa20566b2 100644 --- a/sdk/compiler/damlc/tests/BUILD.bazel +++ b/sdk/compiler/damlc/tests/BUILD.bazel @@ -442,7 +442,6 @@ da_haskell_test( da_haskell_test( name = "upgrades", srcs = ["src/DA/Test/DamlcUpgrades.hs"], - compiler_flags = ["-Wno-unused-local-binds"], data = [ "//compiler/damlc", "//daml-script/daml:daml-script.dar", @@ -459,6 +458,7 @@ da_haskell_test( "//test-common:upgrades-FailsWhenAnInstanceIsDropped-files", "//test-common:upgrades-FailsWhenAnInterfaceIsDefinedInAnUpgradingPackageWhenItWasAlreadyInThePriorPackage-files", "//test-common:upgrades-FailsWhenDatatypeChangesVariety-files", + "//test-common:upgrades-FailsWhenDepsDowngradeVersions-files", "//test-common:upgrades-FailsWhenExistingFieldInTemplateChoiceIsChanged-files", "//test-common:upgrades-FailsWhenExistingFieldInTemplateIsChanged-files", "//test-common:upgrades-FailsWhenNewFieldIsAddedToTemplateChoiceWithoutOptionalType-files", @@ -493,6 +493,7 @@ da_haskell_test( "//test-common:upgrades-SucceedsWhenTwoDeeplyNestedTypeSynonymsResolveToTheSameDatatypes-files", "//test-common:upgrades-SucceedsWhenUpgradingADependency-files", "//test-common:upgrades-TemplateChangedKeyType-files", + "//test-common:upgrades-TemplateChangedKeyType2-files", "//test-common:upgrades-ValidUpgrade-files", "//test-common:upgrades-WarnsWhenAnInterfaceAndATemplateAreDefinedInTheSamePackage-files", "//test-common:upgrades-WarnsWhenAnInterfaceIsDefinedAndThenUsedInAPackageThatUpgradesIt-files", diff --git a/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs b/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs index 927bb2bb7589..9dfd98a5bcf8 100644 --- a/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs +++ b/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs @@ -369,6 +369,13 @@ tests damlc = NoDependencies False setUpgradeField + , test + "TemplateChangedKeyType2" + (FailWithError "\ESC\\[0;91merror type checking template Main.T key:\n The upgraded template T cannot change its key type.") + versionDefault + NoDependencies + False + setUpgradeField , test "RecordFieldsNewNonOptional" (FailWithError "\ESC\\[0;91merror type checking data type Main.Struct:\n The upgraded data type Struct has added new fields, but those fields are not Optional.") @@ -387,14 +394,14 @@ tests damlc = "FailsWithSynonymReturnTypeChangeInSeparatePackage" (FailWithError "\ESC\\[0;91merror type checking template Main.T choice C:\n The upgraded choice C cannot change its return type.") versionDefault - SeparateDeps + (SeparateDeps False) False setUpgradeField , test "SucceedsWhenUpgradingADependency" Succeed versionDefault - SeparateDeps + (SeparateDeps False) False setUpgradeField , test @@ -411,6 +418,13 @@ tests damlc = NoDependencies False setUpgradeField + , test + "FailsWhenDepsDowngradeVersions" + (FailWithError "\ESC\\[0;91merror type checking :\n Dependency upgrades-example-FailsWhenDepsDowngradeVersions-dep has version 0.0.1 on the upgrading package, which is older than version 0.0.2 on the upgraded package.\n Dependency versions of upgrading packages must always be greater or equal to the dependency versions on upgraded packages.") + LF.versionDefault + (SeparateDeps True) + False + setUpgradeField ] | setUpgradeField <- [True, False] ] ++ @@ -453,9 +467,6 @@ tests damlc = ] ) where - --contractKeysMinVersion :: LF.Version - --contractKeysMinVersion = LF.versionDefault - versionDefault :: LF.Version versionDefault = maxMinorVersion LF.versionDefault $ LF.versionMinor $ @@ -517,10 +528,10 @@ tests damlc = ) let sharedDir = dir "shared" let sharedDar = sharedDir "out.dar" - writeFiles sharedDir (projectFile ("upgrades-example-" <> location <> "-dep") Nothing Nothing : sharedDepFiles) + writeFiles sharedDir (projectFile "0.0.1" ("upgrades-example-" <> location <> "-dep") Nothing Nothing : sharedDepFiles) callProcessSilent damlc ["build", "--project-root", sharedDir, "-o", sharedDar] pure (Just sharedDar, Just sharedDar) - SeparateDeps -> do + SeparateDeps { shouldSwap } -> do depV1FilePaths <- listDirectory =<< testRunfile (location "dep-v1") let depV1Files = flip map depV1FilePaths $ \path -> ( "daml" path @@ -528,7 +539,7 @@ tests damlc = ) let depV1Dir = dir "shared-v1" let depV1Dar = depV1Dir "out.dar" - writeFiles depV1Dir (projectFile ("upgrades-example-" <> location <> "-dep-v1") Nothing Nothing : depV1Files) + writeFiles depV1Dir (projectFile "0.0.1" ("upgrades-example-" <> location <> "-dep") Nothing Nothing : depV1Files) callProcessSilent damlc ["build", "--project-root", depV1Dir, "-o", depV1Dar] depV2FilePaths <- listDirectory =<< testRunfile (location "dep-v2") @@ -538,19 +549,21 @@ tests damlc = ) let depV2Dir = dir "shared-v2" let depV2Dar = depV2Dir "out.dar" - writeFiles depV2Dir (projectFile ("upgrades-example-" <> location <> "-dep-v2") Nothing Nothing : depV2Files) + writeFiles depV2Dir (projectFile "0.0.2" ("upgrades-example-" <> location <> "-dep") Nothing Nothing : depV2Files) callProcessSilent damlc ["build", "--project-root", depV2Dir, "-o", depV2Dar] - pure (Just depV1Dar, Just depV2Dar) + if shouldSwap + then pure (Just depV2Dar, Just depV1Dar) + else pure (Just depV1Dar, Just depV2Dar) DependOnV1 -> pure (Nothing, Just oldDar) _ -> pure (Nothing, Nothing) - writeFiles oldDir (projectFile ("upgrades-example-" <> location) Nothing depV1Dar : oldVersion) + writeFiles oldDir (projectFile "0.0.1" ("upgrades-example-" <> location) Nothing depV1Dar : oldVersion) callProcessSilent damlc ["build", "--project-root", oldDir, "-o", oldDar] - writeFiles newDir (projectFile ("upgrades-example-" <> location <> "-v2") (if setUpgradeField then Just oldDar else Nothing) depV2Dar : newVersion) + writeFiles newDir (projectFile "0.0.2" ("upgrades-example-" <> location) (if setUpgradeField then Just oldDar else Nothing) depV2Dar : newVersion) case expectation of Succeed -> @@ -575,13 +588,13 @@ tests damlc = else when (matchTest compiledRegex stderr) $ assertFailure ("`daml build` succeeded, did not `upgrade:` field set, should NOT give a warning matching '" <> show regexWithSeverity <> "':\n" <> show stderr) where - projectFile name upgradedFile mbDep = + projectFile version name upgradedFile mbDep = ( "daml.yaml" , pure $ unlines $ [ "sdk-version: " <> sdkVersion , "name: " <> name , "source: daml" - , "version: 0.0.1" + , "version: " <> version , "dependencies:" , " - daml-prim" , " - daml-stdlib" @@ -610,4 +623,4 @@ data Dependency = NoDependencies | DependOnV1 | SeparateDep - | SeparateDeps + | SeparateDeps { shouldSwap :: Bool } diff --git a/sdk/daml-lf/validation/BUILD.bazel b/sdk/daml-lf/validation/BUILD.bazel index 593d8f78521e..0b7a0025817d 100644 --- a/sdk/daml-lf/validation/BUILD.bazel +++ b/sdk/daml-lf/validation/BUILD.bazel @@ -266,6 +266,12 @@ da_scala_test_suite( "//test-common:upgrades-SucceedsWhenATopLevelVariantAddsAVariant-v2.dar", "//test-common:upgrades-FailsWhenDatatypeChangesVariety-v1.dar", "//test-common:upgrades-FailsWhenDatatypeChangesVariety-v2.dar", + + # Test for dependency upgrades + "//test-common:upgrades-FailsWhenDepsDowngradeVersions-dep-v1.dar", + "//test-common:upgrades-FailsWhenDepsDowngradeVersions-dep-v2.dar", + "//test-common:upgrades-FailsWhenDepsDowngradeVersions-v1.dar", + "//test-common:upgrades-FailsWhenDepsDowngradeVersions-v2.dar", ], flaky = False, scala_deps = [ diff --git a/sdk/test-common/BUILD.bazel b/sdk/test-common/BUILD.bazel index 53a9f9df4c61..bad84517af14 100644 --- a/sdk/test-common/BUILD.bazel +++ b/sdk/test-common/BUILD.bazel @@ -242,6 +242,69 @@ da_scala_dar_resources_library( ] ] +[ + [ + filegroup( + name = "upgrades-{}-files".format(identifier), + srcs = glob(["src/main/daml/upgrades/{}/*/*.daml".format(identifier)]), + visibility = ["//visibility:public"], + ), + daml_compile( + name = "upgrades-{}-dep-v1".format(identifier), + srcs = glob(["src/main/daml/upgrades/{}/dep-v1/*.daml".format(identifier)]), + dependencies = ["//daml-script/daml:daml-script-2.dev.dar"], + ghc_options = default_damlc_opts + ["--ghc-option=-Wno-unused-imports"], + project_name = "upgrades-example-{}-dep".format(identifier), + target = "2.dev", + version = "1.0.0", + visibility = ["//visibility:public"], + ), + daml_compile( + name = "upgrades-{}-dep-v2".format(identifier), + srcs = glob(["src/main/daml/upgrades/{}/dep-v2/*.daml".format(identifier)]), + dependencies = ["//daml-script/daml:daml-script-2.dev.dar"], + ghc_options = default_damlc_opts + ["--ghc-option=-Wno-unused-imports"], + project_name = "upgrades-example-{}-dep".format(identifier), + target = "2.dev", + # We want to check the validity of this upgrade on the ledger + # client, not during compilation + typecheck_upgrades = False, + upgrades = "//test-common:upgrades-{}-dep-v1.dar".format(identifier), + version = "2.0.0", + visibility = ["//visibility:public"], + ), + daml_compile( + name = "upgrades-{}-v1".format(identifier), + srcs = glob(["src/main/daml/upgrades/{}/v1/*.daml".format(identifier)]), + data_dependencies = ["//test-common:upgrades-{}-dep-v2.dar".format(identifier)], + dependencies = ["//daml-script/daml:daml-script-2.dev.dar"], + ghc_options = default_damlc_opts + ["--ghc-option=-Wno-unused-imports"], + project_name = "upgrades-example-{}".format(identifier), + target = "2.dev", + version = "1.0.0", + visibility = ["//visibility:public"], + ), + daml_compile( + name = "upgrades-{}-v2".format(identifier), + srcs = glob(["src/main/daml/upgrades/{}/v2/*.daml".format(identifier)]), + data_dependencies = ["//test-common:upgrades-{}-dep-v1.dar".format(identifier)], + dependencies = ["//daml-script/daml:daml-script-2.dev.dar"], + ghc_options = default_damlc_opts + ["--ghc-option=-Wno-unused-imports"], + project_name = "upgrades-example-{}".format(identifier), + target = "2.dev", + # We want to check the validity of this upgrade on the ledger + # client, not during compilation + typecheck_upgrades = False, + upgrades = "//test-common:upgrades-{}-v1.dar".format(identifier), + version = "2.0.0", + visibility = ["//visibility:public"], + ), + ] + for identifier in [ + "FailsWhenDepsDowngradeVersions", + ] +] + [ [ filegroup( @@ -283,6 +346,7 @@ da_scala_dar_resources_library( ("MissingChoice", [], []), ("RecordFieldsNewNonOptional", [], []), ("TemplateChangedKeyType", [], []), + ("TemplateChangedKeyType2", [], []), ("ValidUpgrade", [], []), ("ValidParameterizedTypesUpgrade", [], []), ("ValidKeyTypeEquality", [], []), From 8873e1706c1acd3c1e1b9d914928bd944e31eca7 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Wed, 24 Jul 2024 15:27:57 +0100 Subject: [PATCH 02/31] Fix copied over definition for FailsWhenDepsDowngradeVersions --- sdk/test-common/BUILD.bazel | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/sdk/test-common/BUILD.bazel b/sdk/test-common/BUILD.bazel index bad84517af14..0e831f4fa0a1 100644 --- a/sdk/test-common/BUILD.bazel +++ b/sdk/test-common/BUILD.bazel @@ -252,20 +252,20 @@ da_scala_dar_resources_library( daml_compile( name = "upgrades-{}-dep-v1".format(identifier), srcs = glob(["src/main/daml/upgrades/{}/dep-v1/*.daml".format(identifier)]), - dependencies = ["//daml-script/daml:daml-script-2.dev.dar"], + dependencies = ["//daml-script/daml:daml-script-1.dev.dar"], ghc_options = default_damlc_opts + ["--ghc-option=-Wno-unused-imports"], project_name = "upgrades-example-{}-dep".format(identifier), - target = "2.dev", + target = "1.dev", version = "1.0.0", visibility = ["//visibility:public"], ), daml_compile( name = "upgrades-{}-dep-v2".format(identifier), srcs = glob(["src/main/daml/upgrades/{}/dep-v2/*.daml".format(identifier)]), - dependencies = ["//daml-script/daml:daml-script-2.dev.dar"], + dependencies = ["//daml-script/daml:daml-script-1.dev.dar"], ghc_options = default_damlc_opts + ["--ghc-option=-Wno-unused-imports"], project_name = "upgrades-example-{}-dep".format(identifier), - target = "2.dev", + target = "1.dev", # We want to check the validity of this upgrade on the ledger # client, not during compilation typecheck_upgrades = False, @@ -277,10 +277,10 @@ da_scala_dar_resources_library( name = "upgrades-{}-v1".format(identifier), srcs = glob(["src/main/daml/upgrades/{}/v1/*.daml".format(identifier)]), data_dependencies = ["//test-common:upgrades-{}-dep-v2.dar".format(identifier)], - dependencies = ["//daml-script/daml:daml-script-2.dev.dar"], + dependencies = ["//daml-script/daml:daml-script-1.dev.dar"], ghc_options = default_damlc_opts + ["--ghc-option=-Wno-unused-imports"], project_name = "upgrades-example-{}".format(identifier), - target = "2.dev", + target = "1.dev", version = "1.0.0", visibility = ["//visibility:public"], ), @@ -288,10 +288,10 @@ da_scala_dar_resources_library( name = "upgrades-{}-v2".format(identifier), srcs = glob(["src/main/daml/upgrades/{}/v2/*.daml".format(identifier)]), data_dependencies = ["//test-common:upgrades-{}-dep-v1.dar".format(identifier)], - dependencies = ["//daml-script/daml:daml-script-2.dev.dar"], + dependencies = ["//daml-script/daml:daml-script-1.dev.dar"], ghc_options = default_damlc_opts + ["--ghc-option=-Wno-unused-imports"], project_name = "upgrades-example-{}".format(identifier), - target = "2.dev", + target = "1.dev", # We want to check the validity of this upgrade on the ledger # client, not during compilation typecheck_upgrades = False, From f04ca4a2702e3241bd21409d405d16f2384413e6 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Wed, 24 Jul 2024 15:43:08 +0100 Subject: [PATCH 03/31] Track tests --- .../dep-v1/Dep.daml | 7 +++++++ .../dep-v2/Dep.daml | 7 +++++++ .../FailsWhenDepsDowngradeVersions/v1/Main.daml | 9 +++++++++ .../FailsWhenDepsDowngradeVersions/v2/Main.daml | 9 +++++++++ .../TemplateChangedKeyType2/v1/Main.daml | 15 +++++++++++++++ .../TemplateChangedKeyType2/v2/Main.daml | 16 ++++++++++++++++ 6 files changed, 63 insertions(+) create mode 100644 sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/dep-v1/Dep.daml create mode 100644 sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/dep-v2/Dep.daml create mode 100644 sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/v1/Main.daml create mode 100644 sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/v2/Main.daml create mode 100644 sdk/test-common/src/main/daml/upgrades/TemplateChangedKeyType2/v1/Main.daml create mode 100644 sdk/test-common/src/main/daml/upgrades/TemplateChangedKeyType2/v2/Main.daml diff --git a/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/dep-v1/Dep.daml b/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/dep-v1/Dep.daml new file mode 100644 index 000000000000..9382be743341 --- /dev/null +++ b/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/dep-v1/Dep.daml @@ -0,0 +1,7 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Dep where + +dep : Text +dep = "dep-v1" diff --git a/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/dep-v2/Dep.daml b/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/dep-v2/Dep.daml new file mode 100644 index 000000000000..b6d6c93bb972 --- /dev/null +++ b/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/dep-v2/Dep.daml @@ -0,0 +1,7 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Dep where + +dep : Text +dep = "dep-v2" diff --git a/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/v1/Main.daml b/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/v1/Main.daml new file mode 100644 index 000000000000..96b8316b9aea --- /dev/null +++ b/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/v1/Main.daml @@ -0,0 +1,9 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Main where + +import Dep + +self : Text +self = "v1 with " <> dep diff --git a/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/v2/Main.daml b/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/v2/Main.daml new file mode 100644 index 000000000000..70694c64e8dd --- /dev/null +++ b/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/v2/Main.daml @@ -0,0 +1,9 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Main where + +import Dep + +self : Text +self = "v2 with " <> dep diff --git a/sdk/test-common/src/main/daml/upgrades/TemplateChangedKeyType2/v1/Main.daml b/sdk/test-common/src/main/daml/upgrades/TemplateChangedKeyType2/v1/Main.daml new file mode 100644 index 000000000000..e03221710474 --- /dev/null +++ b/sdk/test-common/src/main/daml/upgrades/TemplateChangedKeyType2/v1/Main.daml @@ -0,0 +1,15 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Main where + +data TKey + = TKey1 with p : Party + | TKey2 with p : Party + +template T with + p: Party + where + signatory p + key (TKey1 p) : TKey + maintainer key.p diff --git a/sdk/test-common/src/main/daml/upgrades/TemplateChangedKeyType2/v2/Main.daml b/sdk/test-common/src/main/daml/upgrades/TemplateChangedKeyType2/v2/Main.daml new file mode 100644 index 000000000000..5d6b8d68fad3 --- /dev/null +++ b/sdk/test-common/src/main/daml/upgrades/TemplateChangedKeyType2/v2/Main.daml @@ -0,0 +1,16 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Main where + +data TKey + = TKey1 with p : Party + | TKey2 with p : Party + | TKey3 with p : Party + +template T with + p: Party + where + signatory p + key (TKey1 p) : TKey + maintainer key.p From b4c04288802eed8294cdc90795f0056768453a03 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Thu, 1 Aug 2024 16:22:05 +0100 Subject: [PATCH 04/31] Add comment to tconEquivalence, rename unsafeFlattenUpgrading to zip --- sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Alpha.hs | 3 +++ .../daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs | 6 +++--- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Alpha.hs b/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Alpha.hs index c8f989cabe44..28be0276a42d 100644 --- a/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Alpha.hs +++ b/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Alpha.hs @@ -33,6 +33,9 @@ data AlphaEnv = AlphaEnv -- ^ Maps bound expr variables from the right-hand-side to -- the depth of the binder which introduced them. , tconEquivalence :: !(Qualified TypeConName -> Qualified TypeConName -> Bool) + -- ^ Defines how names in typecons should be compared + -- Unlike above fields, this should not mutate over the course of the alpha + -- equivalence check } onList :: (a -> a -> Bool) -> [a] -> [a] -> Bool diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs index f4f296b0fe2c..749117b669c2 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs @@ -55,8 +55,8 @@ instance Applicative Upgrading where foldU :: (a -> a -> b) -> Upgrading a -> b foldU f u = f (_past u) (_present u) -unsafeFlattenUpgrading :: Upgrading [a] -> [Upgrading a] -unsafeFlattenUpgrading = foldU (zipWith Upgrading) +unsafeZipUpgrading :: Upgrading [a] -> [Upgrading a] +unsafeZipUpgrading = foldU (zipWith Upgrading) -- Allows us to split the world into upgraded and non-upgraded type TcUpgradeM = TcMF UpgradingEnv @@ -734,7 +734,7 @@ isStructurallyEquivalentDatatype :: [TypeConName] -> Upgrading DefDataType -> Tc isStructurallyEquivalentDatatype identicalCons datatype = let params = dataParams <$> datatype allKindsMatch = foldU (==) (map snd <$> params) - paramNames = unsafeFlattenUpgrading (map fst <$> params) + paramNames = unsafeZipUpgrading (map fst <$> params) in if not allKindsMatch then pure False From 9d3a67bb794d802e1cd16fb8fd94e1791b2f8c81 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Thu, 1 Aug 2024 16:22:48 +0100 Subject: [PATCH 05/31] Refactor checkBothAndSingle to initialize upgrade dependencies env --- .../src/DA/Daml/LF/TypeChecker/Upgrade.hs | 54 +++++++++---------- 1 file changed, 24 insertions(+), 30 deletions(-) diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs index 749117b669c2..915a5e278abd 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs @@ -11,7 +11,7 @@ module DA.Daml.LF.TypeChecker.Upgrade ( import Control.DeepSeq import Control.Monad (unless, forM, forM_, when) import Control.Monad.Extra (allM, filterM) -import Control.Monad.Reader (withReaderT, local) +import Control.Monad.Reader (withReaderT) import Control.Lens hiding (Context) import DA.Daml.LF.Ast as LF import DA.Daml.LF.Ast.Alpha (alphaExpr, AlphaEnv(..), initialAlphaEnv, alphaType', alphaTypeCon, bindTypeVar) @@ -78,11 +78,11 @@ runGammaUnderUpgrades Upgrading{ _past = pastAction, _present = presentAction } pure Upgrading { _past = pastResult, _present = presentResult } checkBothAndSingle - :: World -> (LF.UpgradedPackageId -> LF.Package -> [(LF.PackageId, LF.Package)] -> TcUpgradeM ()) -> TcM () - -> Version -> UpgradeInfo + :: World -> (LF.UpgradedPackageId -> LF.Package -> TcUpgradeM ()) -> TcM () + -> [LF.DalfPackage] -> Version -> UpgradeInfo -> Maybe ((LF.PackageId, LF.Package), [(LF.PackageId, LF.Package)]) -> [Diagnostic] -checkBothAndSingle world checkBoth checkSingle version upgradeInfo mbUpgradedPackage = +checkBothAndSingle world checkBoth checkSingle deps version upgradeInfo mbUpgradedPackage = let shouldTypecheck = version `LF.supports` LF.featurePackageUpgrades && uiTypecheckUpgrades upgradeInfo gamma :: World -> Gamma @@ -105,16 +105,14 @@ checkBothAndSingle world checkBoth checkSingle version upgradeInfo mbUpgradedPac case mbUpgradedPackage of Nothing -> Right ((), []) - Just ((pastPkgId, pastPkg), deps) -> + Just ((pastPkgId, pastPkg), upgradedDeps) -> let upgradingWorld = Upgrading { _past = initWorldSelf [] pastPkg, _present = world } - upgradingEnv = - UpgradingEnv - { _upgradingGamma = fmap gamma upgradingWorld - , _upgradingDeps = [] - } + upgradingGamma = fmap gamma upgradingWorld in - runGammaF upgradingEnv $ - when (uiTypecheckUpgrades upgradeInfo) (checkBoth (UpgradedPackageId pastPkgId) pastPkg deps) + runGammaF upgradingGamma $ do + deps <- checkUpgradeDependenciesM deps upgradedDeps + withReaderT (\gamma -> UpgradingEnv gamma deps) $ + when (uiTypecheckUpgrades upgradeInfo) (checkBoth (UpgradedPackageId pastPkgId) pastPkg) singlePkgDiagnostics :: Either Error ((), [Warning]) singlePkgDiagnostics = @@ -130,16 +128,14 @@ checkBothAndSingle world checkBoth checkSingle version upgradeInfo mbUpgradedPac extractDiagnostics bothPkgDiagnostics ++ extractDiagnostics singlePkgDiagnostics checkUpgrade - :: LF.Package -> [LF.DalfPackage] - -> Version -> UpgradeInfo + :: LF.Package + -> [LF.DalfPackage] -> Version -> UpgradeInfo -> Maybe ((LF.PackageId, LF.Package), [(LF.PackageId, LF.Package)]) -> [Diagnostic] -checkUpgrade pkg deps = +checkUpgrade pkg = let world = initWorldSelf [] pkg - checkBoth upgradedPkgId upgradedPkg upgradedDeps = do - deps <- checkUpgradeDependenciesM deps upgradedDeps - local (\env -> env { _upgradingDeps = deps }) $ - checkUpgradeM upgradedPkgId (Upgrading upgradedPkg pkg) + checkBoth upgradedPkgId upgradedPkg = do + checkUpgradeM upgradedPkgId (Upgrading upgradedPkg pkg) checkSingle = do checkNewInterfacesAreUnused pkg checkNewInterfacesHaveNoTemplates pkg @@ -147,21 +143,19 @@ checkUpgrade pkg deps = checkBothAndSingle world checkBoth checkSingle checkModule - :: LF.World -> LF.Module -> [LF.DalfPackage] - -> Version -> UpgradeInfo + :: LF.World -> LF.Module + -> [LF.DalfPackage] -> Version -> UpgradeInfo -> Maybe ((LF.PackageId, LF.Package), [(LF.PackageId, LF.Package)]) -> [Diagnostic] -checkModule world0 module_ deps = +checkModule world0 module_ = let world = extendWorldSelf module_ world0 - checkBoth upgradedPkgId upgradedPkg upgradedDeps = do - deps <- checkUpgradeDependenciesM deps upgradedDeps + checkBoth upgradedPkgId upgradedPkg = do case NM.lookup (NM.name module_) (LF.packageModules upgradedPkg) of Nothing -> pure () Just pastModule -> do let upgradingModule = Upgrading { _past = pastModule, _present = module_ } equalDataTypes <- structurallyEqualDataTypes upgradingModule - local (\env -> env { _upgradingDeps = deps }) $ - checkModuleM equalDataTypes upgradedPkgId upgradingModule + checkModuleM equalDataTypes upgradedPkgId upgradingModule checkSingle = do checkNewInterfacesAreUnused module_ checkNewInterfacesHaveNoTemplates module_ @@ -171,7 +165,7 @@ checkModule world0 module_ deps = checkUpgradeDependenciesM :: [LF.DalfPackage] -> [(LF.PackageId, LF.Package)] - -> TcUpgradeM [Upgrading LF.PackageId] + -> TcMF (Upgrading Gamma) [Upgrading LF.PackageId] checkUpgradeDependenciesM presentDeps pastDeps = do let pkgToTriple :: LF.PackageId -> LF.Package -> Maybe (LF.PackageName, (LF.PackageVersion, LF.PackageId)) pkgToTriple packageId LF.Package{packageMetadata = Just LF.PackageMetadata{packageName, packageVersion}} = Just (packageName, (packageVersion, packageId)) @@ -189,15 +183,15 @@ checkUpgradeDependenciesM presentDeps pastDeps = do in case foldU LF.comparePackageVersion versions of Left (FirstVersionUnparseable presentVersion) -> do - diagnosticWithContextF present' $ + diagnosticWithContextF present $ WEPresentDependencyHasUnparseableVersion depName presentVersion pure [] Left (SecondVersionUnparseable pastVersion) -> do - diagnosticWithContextF present' $ + diagnosticWithContextF present $ WEPastDependencyHasUnparseableVersion depName pastVersion pure [] Right GT -> - throwWithContextF present' $ + throwWithContextF present $ EUpgradeDependencyHasLowerVersionDespiteUpgrade depName (_present versions) (_past versions) _ -> pure [pkgIds] -- if past package is lesser than or equal, the dependency is a valid upgrade pure (concat depRelations) From a1db246e9209c457cd702e849a3a2c80723abfd1 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Thu, 1 Aug 2024 16:27:14 +0100 Subject: [PATCH 06/31] Remove redundant case, remove leftover commented code --- .../daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs | 2 -- sdk/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Dar.hs | 3 --- 2 files changed, 5 deletions(-) diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs index 915a5e278abd..b19ac1da2df3 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs @@ -748,8 +748,6 @@ isStructurallyEquivalentDatatype identicalCons datatype = pure (allConNamesMatch && allTypesMatch) Upgrading { _past = DataEnum _past, _present = DataEnum _present } -> do pure $ _past == _present - Upgrading { _past = DataInterface {}, _present = DataInterface {} } -> - pure False _ -> pure False diff --git a/sdk/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Dar.hs b/sdk/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Dar.hs index 5a22994fffc8..624350a54a8c 100644 --- a/sdk/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Dar.hs +++ b/sdk/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Dar.hs @@ -167,9 +167,6 @@ buildDar service PackageConfigFields {..} ifDir dalfInput upgradeInfo = do [ (T.pack $ unitIdString unitId, LF.dalfPackageBytes pkg, LF.dalfPackageId pkg) | (unitId, pkg) <- Map.toList dalfDependencies0 ] - --MaybeT $ - -- runDiagnosticCheck $ diagsToIdeResult (toNormalizedFilePath' pSrc) $ - -- TypeChecker.Upgrade.checkUpgradeDependencies lfVersion pTypecheckUpgrades pkg (Map.elems dalfDependencies0) mbUpgradedPackage unstableDeps <- getUnstableDalfDependencies files let confFile = mkConfFile pName pVersion (Map.keys unstableDeps) pExposedModules pkgModuleNames pkgId let dataFiles = [confFile] From 3e72feb27891a306854da2d8d6bcd1ecfc1f6dbd Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Wed, 7 Aug 2024 14:26:22 +0100 Subject: [PATCH 07/31] Reimplement dependency upgradeability checking --- .../daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs | 40 +++-- .../src/DA/Daml/LF/TypeChecker/Error.hs | 21 ++- .../src/DA/Daml/LF/TypeChecker/Upgrade.hs | 145 +++++++++++++----- sdk/compiler/damlc/tests/BUILD.bazel | 3 +- .../damlc/tests/src/DA/Test/DamlcUpgrades.hs | 11 +- sdk/daml-lf/validation/BUILD.bazel | 12 +- .../ts/codegen/src/TsCodeGenMain.hs | 11 +- sdk/test-common/BUILD.bazel | 3 +- .../dep-v1/Dep.daml | 6 + .../dep-v2/Dep.daml | 6 + .../v1/Main.daml | 8 + .../v2/Main.daml | 8 + .../dep-v1/Dep.daml | 0 .../dep-v2/Dep.daml | 0 .../v1/Main.daml | 0 .../v2/Main.daml | 0 16 files changed, 201 insertions(+), 73 deletions(-) create mode 100644 sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersionsWhileUsingDatatypes/dep-v1/Dep.daml create mode 100644 sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersionsWhileUsingDatatypes/dep-v2/Dep.daml create mode 100644 sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersionsWhileUsingDatatypes/v1/Main.daml create mode 100644 sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersionsWhileUsingDatatypes/v2/Main.daml rename sdk/test-common/src/main/daml/upgrades/{FailsWhenDepsDowngradeVersions => SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes}/dep-v1/Dep.daml (100%) rename sdk/test-common/src/main/daml/upgrades/{FailsWhenDepsDowngradeVersions => SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes}/dep-v2/Dep.daml (100%) rename sdk/test-common/src/main/daml/upgrades/{FailsWhenDepsDowngradeVersions => SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes}/v1/Main.daml (100%) rename sdk/test-common/src/main/daml/upgrades/{FailsWhenDepsDowngradeVersions => SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes}/v2/Main.daml (100%) diff --git a/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs b/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs index 92ecc7ea7334..1b3f1610674b 100644 --- a/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs +++ b/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs @@ -22,6 +22,7 @@ import DA.Daml.LF.Ast.Base import DA.Daml.LF.Ast.TypeLevelNat import DA.Daml.LF.Ast.Optics import DA.Daml.LF.Ast.Recursive +import DA.Daml.LF.Ast.Version dvalName :: DefValue -> ExprValName dvalName = fst . dvalBinder @@ -48,6 +49,20 @@ topoSortPackage pkg@Package{packageModules = mods} = do mods <- traverse isAcyclic sccs pure pkg { packageModules = NM.fromList mods } +isUtilityPackage :: Package -> Bool +isUtilityPackage pkg = + all (\mod -> + null (moduleTemplates mod) + && null (moduleInterfaces mod) + && not (any (getIsSerializable . dataSerializable) $ moduleDataTypes mod) + ) $ packageModules pkg + + +pkgSupportsUpgrades :: Package -> Bool +pkgSupportsUpgrades pkg = + not (isUtilityPackage pkg) && + packageLfVersion pkg `supports` featurePackageUpgrades + data Arg = TmArg Expr | TyArg Type @@ -333,25 +348,28 @@ splitUnitId (unitIdString -> unitId) = fromMaybe (PackageName (T.pack unitId), N -- a list of integers [Integer] splitPackageVersion :: (PackageVersion -> a) -> PackageVersion - -> Either a [Integer] + -> Either a RawPackageVersion splitPackageVersion mkError version@(PackageVersion raw) = let pieces = T.split (== '.') raw in case traverse (readMaybe . T.unpack) pieces of Nothing -> Left (mkError version) - Just versions -> Right versions + Just versions -> Right $ RawPackageVersion versions -data ComparePackageVersionError - = FirstVersionUnparseable PackageVersion - | SecondVersionUnparseable PackageVersion - deriving (Show, Eq, Ord) +newtype RawPackageVersion = RawPackageVersion [Integer] + deriving (Show) -comparePackageVersion :: PackageVersion -> PackageVersion -> Either ComparePackageVersionError Ordering -comparePackageVersion v1 v2 = do - v1Pieces <- splitPackageVersion FirstVersionUnparseable v1 - v2Pieces <- splitPackageVersion SecondVersionUnparseable v2 +padEquivalent :: RawPackageVersion -> RawPackageVersion -> ([Integer], [Integer]) +padEquivalent (RawPackageVersion v1Pieces) (RawPackageVersion v2Pieces) = let pad xs target = take (length target `max` length xs) (xs ++ repeat 0) - pure $ compare (pad v1Pieces v2Pieces) (pad v2Pieces v1Pieces) + in + (pad v1Pieces v2Pieces, pad v2Pieces v1Pieces) + +instance Ord RawPackageVersion where + compare v1 v2 = uncurry compare $ padEquivalent v1 v2 + +instance Eq RawPackageVersion where + (==) v1 v2 = uncurry (==) $ padEquivalent v1 v2 diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs index 9d97ca9a1748..20286e14b86e 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs @@ -15,6 +15,7 @@ module DA.Daml.LF.TypeChecker.Error( errorLocation, toDiagnostic, Warning(..), + PackageUpgradeOrigin(..), ) where import Control.Applicative @@ -211,8 +212,8 @@ data WarnableError = WEUpgradeShouldDefineIfacesAndTemplatesSeparately | WEUpgradeShouldDefineIfaceWithoutImplementation !TypeConName ![TypeConName] | WEUpgradeShouldDefineTplInSeparatePackage !TypeConName !TypeConName - | WEPastDependencyHasUnparseableVersion !PackageName !PackageVersion - | WEPresentDependencyHasUnparseableVersion !PackageName !PackageVersion + | WEDependencyHasUnparseableVersion !PackageName !PackageVersion !PackageUpgradeOrigin + | WEDependencyHasNoMetadataDespiteUpgradeability !PackageId !PackageUpgradeOrigin deriving (Show) instance Pretty WarnableError where @@ -238,10 +239,18 @@ instance Pretty WarnableError where , "It is recommended that interfaces are defined in their own package separate from their implementations." , "Ignore this error message with the --warn-bad-interface-instances=yes flag." ] - WEPastDependencyHasUnparseableVersion pkgName version -> - "Dependency " <> pPrint pkgName <> " of upgrading package has a version which cannot be parsed: '" <> pPrint version <> "'" - WEPresentDependencyHasUnparseableVersion pkgName version -> - "Dependency " <> pPrint pkgName <> " of upgraded package has a version which cannot be parsed: '" <> pPrint version <> "'" + WEDependencyHasUnparseableVersion pkgName version packageOrigin -> + "Dependency " <> pPrint pkgName <> " of " <> pPrint packageOrigin <> " has a version which cannot be parsed: '" <> pPrint version <> "'" + WEDependencyHasNoMetadataDespiteUpgradeability pkgId packageOrigin -> + "Dependency with package ID " <> pPrint pkgId <> " of " <> pPrint packageOrigin <> " has no metadata, despite being compiled with an SDK version that supports metadata." + +data PackageUpgradeOrigin = UpgradingPackage | UpgradedPackage + deriving (Eq, Ord, Show) + +instance Pretty PackageUpgradeOrigin where + pPrint = \case + UpgradingPackage -> "upgrading package" + UpgradedPackage -> "upgraded package" data UpgradedRecordOrigin = TemplateBody TypeConName diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs index b19ac1da2df3..e79ff8a41a28 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs @@ -25,11 +25,13 @@ import Data.Either (partitionEithers) import Data.Hashable import qualified Data.HashMap.Strict as HMS import Data.List (foldl') -import Data.Maybe (mapMaybe) import qualified Data.NameMap as NM import qualified Data.Text as T import Development.IDE.Types.Diagnostics import GHC.Generics (Generic) +import Data.Maybe (catMaybes) +import Safe (maximumByMay, minimumByMay) +import Data.Function (on) data Upgrading a = Upgrading { _past :: a @@ -61,9 +63,11 @@ unsafeZipUpgrading = foldU (zipWith Upgrading) -- Allows us to split the world into upgraded and non-upgraded type TcUpgradeM = TcMF UpgradingEnv +type UpgradingDeps = HMS.HashMap LF.PackageId (LF.PackageName, RawPackageVersion) + data UpgradingEnv = UpgradingEnv { _upgradingGamma :: Upgrading Gamma - , _upgradingDeps :: [Upgrading LF.PackageId] + , _upgradingDeps :: UpgradingDeps } makeLenses ''UpgradingEnv @@ -109,10 +113,10 @@ checkBothAndSingle world checkBoth checkSingle deps version upgradeInfo mbUpgrad let upgradingWorld = Upgrading { _past = initWorldSelf [] pastPkg, _present = world } upgradingGamma = fmap gamma upgradingWorld in - runGammaF upgradingGamma $ do + runGammaF upgradingGamma $ when (uiTypecheckUpgrades upgradeInfo) $ do deps <- checkUpgradeDependenciesM deps upgradedDeps withReaderT (\gamma -> UpgradingEnv gamma deps) $ - when (uiTypecheckUpgrades upgradeInfo) (checkBoth (UpgradedPackageId pastPkgId) pastPkg) + checkBoth (UpgradedPackageId pastPkgId) pastPkg singlePkgDiagnostics :: Either Error ((), [Warning]) singlePkgDiagnostics = @@ -165,36 +169,96 @@ checkModule world0 module_ = checkUpgradeDependenciesM :: [LF.DalfPackage] -> [(LF.PackageId, LF.Package)] - -> TcMF (Upgrading Gamma) [Upgrading LF.PackageId] + -> TcMF (Upgrading Gamma) UpgradingDeps checkUpgradeDependenciesM presentDeps pastDeps = do - let pkgToTriple :: LF.PackageId -> LF.Package -> Maybe (LF.PackageName, (LF.PackageVersion, LF.PackageId)) - pkgToTriple packageId LF.Package{packageMetadata = Just LF.PackageMetadata{packageName, packageVersion}} = Just (packageName, (packageVersion, packageId)) - pkgToTriple _ _ = Nothing - dalfPkgToTriple LF.DalfPackage{dalfPackageId,dalfPackagePkg} = - pkgToTriple dalfPackageId (extPackagePkg dalfPackagePkg) - let upgrading = Upgrading - { _past = HMS.fromList $ mapMaybe (uncurry pkgToTriple) pastDeps - , _present = HMS.fromList $ mapMaybe dalfPkgToTriple presentDeps - } - let (_del, existingDeps, _new) = extractDelExistNew upgrading - depRelations <- forM (HMS.toList existingDeps) $ \(depName, dep) -> - let versions = fmap fst dep - pkgIds = fmap snd dep - in - case foldU LF.comparePackageVersion versions of - Left (FirstVersionUnparseable presentVersion) -> do - diagnosticWithContextF present $ - WEPresentDependencyHasUnparseableVersion depName presentVersion - pure [] - Left (SecondVersionUnparseable pastVersion) -> do - diagnosticWithContextF present $ - WEPastDependencyHasUnparseableVersion depName pastVersion - pure [] - Right GT -> - throwWithContextF present $ - EUpgradeDependencyHasLowerVersionDespiteUpgrade depName (_present versions) (_past versions) - _ -> pure [pkgIds] -- if past package is lesser than or equal, the dependency is a valid upgrade - pure (concat depRelations) + initialUpgradeablePackageMap <- + fmap (HMS.fromListWith (<>) . catMaybes) $ forM pastDeps $ \pastDep -> do + let (pkgId, pkg@LF.Package{packageMetadata = mbMeta}) = pastDep + if LF.pkgSupportsUpgrades pkg + then + case mbMeta of + Nothing -> do + diagnosticWithContextF present $ WErrorToWarning $ WEDependencyHasNoMetadataDespiteUpgradeability pkgId UpgradedPackage + pure Nothing + Just meta -> do + let LF.PackageMetadata {packageName, packageVersion} = meta + case splitPackageVersion id packageVersion of + Left version -> do + diagnosticWithContextF present $ WErrorToWarning $ WEDependencyHasUnparseableVersion packageName version UpgradedPackage + pure Nothing + Right rawVersion -> + pure $ Just (packageName, [(rawVersion, pkgId, pkg)]) + else pure Nothing + + upgradeablePackageMapToDeps <$> checkAllDeps initialUpgradeablePackageMap presentDeps + where + upgradeablePackageMapToDeps :: HMS.HashMap LF.PackageName [(LF.RawPackageVersion, LF.PackageId, LF.Package)] -> UpgradingDeps + upgradeablePackageMapToDeps upgradeablePackageMap = + HMS.fromList + [ (pkgId, (pkgName, pkgVersion)) + | (pkgName, versions) <- HMS.toList upgradeablePackageMap + , (pkgVersion, pkgId, _) <- versions + ] + + checkAllDeps + :: HMS.HashMap LF.PackageName [(LF.RawPackageVersion, LF.PackageId, LF.Package)] + -> [LF.DalfPackage] + -> TcMF (Upgrading Gamma) (HMS.HashMap LF.PackageName [(LF.RawPackageVersion, LF.PackageId, LF.Package)]) + checkAllDeps upgradeablePackageMap [] = pure upgradeablePackageMap + checkAllDeps upgradeablePackageMap (pkg:rest) = do + mbNewDep <- checkOneDep upgradeablePackageMap pkg + let newUpgradeablePackageMap = + case mbNewDep of + Nothing -> upgradeablePackageMap + Just (name, pkgVersionIdAndAst) -> HMS.insertWith (<>) name [pkgVersionIdAndAst] upgradeablePackageMap + checkAllDeps newUpgradeablePackageMap rest + + checkOneDep + :: HMS.HashMap LF.PackageName [(LF.RawPackageVersion, LF.PackageId, LF.Package)] + -> LF.DalfPackage + -> TcMF (Upgrading Gamma) (Maybe (LF.PackageName, (LF.RawPackageVersion, LF.PackageId, LF.Package))) + checkOneDep upgradeablePackageMap dalfPkg = do + let LF.DalfPackage{dalfPackagePkg,dalfPackageId=presentPkgId} = dalfPkg + presentPkg = extPackagePkg dalfPackagePkg + if not (LF.pkgSupportsUpgrades presentPkg) + then pure Nothing + else + case packageMetadata presentPkg of + Just meta -> do + case HMS.lookup (packageName meta) upgradeablePackageMap of + Nothing -> pure Nothing + Just upgradedPkgs -> do + case splitPackageVersion id (packageVersion meta) of + Left version -> do + diagnosticWithContextF present $ WErrorToWarning $ WEDependencyHasUnparseableVersion (packageName meta) version UpgradedPackage + pure Nothing + Right presentVersion -> do + let equivalent = filter (\(pastVersion, pastPkgId, _) -> pastVersion == presentVersion && pastPkgId /= presentPkgId) upgradedPkgs + ordFst = compare `on` (\(v,_,_) -> v) + closestGreater = minimumByMay ordFst $ filter (\(pastVersion, _, _) -> pastVersion > presentVersion) upgradedPkgs + closestLesser = maximumByMay ordFst $ filter (\(pastVersion, _, _) -> pastVersion < presentVersion) upgradedPkgs + if not (null equivalent) + then error "two upgradeable packages with same name and version" + else do + withReaderT (\gamma -> UpgradingEnv gamma (upgradeablePackageMapToDeps upgradeablePackageMap)) $ do + case closestGreater of + Just (_, greaterPkgId, greaterPkg) -> + check (presentPkgId, presentPkg) (greaterPkgId, greaterPkg) + Nothing -> + pure () + case closestLesser of + Just (_, lesserPkgId, lesserPkg) -> + check (lesserPkgId, lesserPkg) (presentPkgId, presentPkg) + Nothing -> + pure () + pure $ Just (packageName meta, (presentVersion, presentPkgId, presentPkg)) + Nothing -> do + diagnosticWithContextF present $ WErrorToWarning $ WEDependencyHasNoMetadataDespiteUpgradeability presentPkgId UpgradingPackage + pure Nothing + + check :: (LF.PackageId, LF.Package) -> (LF.PackageId, LF.Package) -> TcUpgradeM () + check (pastPkgId, pastPkg) (_presentPkgId, presentPkg) = + checkUpgradeM (UpgradedPackageId pastPkgId) (Upgrading pastPkg presentPkg) checkUpgradeM :: LF.UpgradedPackageId -> Upgrading LF.Package -> TcUpgradeM () checkUpgradeM upgradedPackageId package = do @@ -695,13 +759,16 @@ isUpgradedType type_ = do expandedTypes <- runGammaUnderUpgrades (expandTypeSynonyms <$> type_) deps <- view upgradingDeps let checkSelf = alphaTypeCon - checkImport t1 t2 = - case (qualPackage t1, qualPackage t2) of - (PRImport pkgId1, PRImport pkgId2) -> - pkgId1 == pkgId2 || - Upgrading pkgId1 pkgId2 `elem` deps && removePkgId t1 == removePkgId t2 + checkImport pastT presentT = + case (qualPackage pastT, qualPackage presentT) of + (PRImport pastPkgId, PRImport presentPkgId) -> + pastPkgId == presentPkgId || + (case (pastPkgId `HMS.lookup` deps, presentPkgId `HMS.lookup` deps) of + (Just (pastName, pastVersion), Just (presentName, presentVersion)) -> pastName == presentName && pastVersion < presentVersion + _ -> False + ) && removePkgId pastT == removePkgId presentT _ -> False - tconCheck t1 t2 = checkSelf t1 t2 || checkImport t1 t2 + tconCheck pastT presentT = checkSelf pastT presentT || checkImport pastT presentT pure $ foldU (alphaType' initialAlphaEnv { tconEquivalence = tconCheck }) expandedTypes isStructurallyEquivalentType :: AlphaEnv -> [TypeConName] -> Upgrading Type -> TcUpgradeM Bool diff --git a/sdk/compiler/damlc/tests/BUILD.bazel b/sdk/compiler/damlc/tests/BUILD.bazel index 800aa20566b2..0314be56b7c5 100644 --- a/sdk/compiler/damlc/tests/BUILD.bazel +++ b/sdk/compiler/damlc/tests/BUILD.bazel @@ -458,7 +458,7 @@ da_haskell_test( "//test-common:upgrades-FailsWhenAnInstanceIsDropped-files", "//test-common:upgrades-FailsWhenAnInterfaceIsDefinedInAnUpgradingPackageWhenItWasAlreadyInThePriorPackage-files", "//test-common:upgrades-FailsWhenDatatypeChangesVariety-files", - "//test-common:upgrades-FailsWhenDepsDowngradeVersions-files", + "//test-common:upgrades-FailsWhenDepsDowngradeVersionsWhileUsingDatatypes-files", "//test-common:upgrades-FailsWhenExistingFieldInTemplateChoiceIsChanged-files", "//test-common:upgrades-FailsWhenExistingFieldInTemplateIsChanged-files", "//test-common:upgrades-FailsWhenNewFieldIsAddedToTemplateChoiceWithoutOptionalType-files", @@ -486,6 +486,7 @@ da_haskell_test( "//test-common:upgrades-SucceedsWhenAnInstanceIsAddedSeparateDep-files", "//test-common:upgrades-SucceedsWhenAnInstanceIsAddedUpgradedPackage-files", "//test-common:upgrades-SucceedsWhenAnInterfaceIsOnlyDefinedInTheInitialPackage-files", + "//test-common:upgrades-SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes-files", "//test-common:upgrades-SucceedsWhenNewFieldWithOptionalTypeIsAddedToTemplate-files", "//test-common:upgrades-SucceedsWhenNewFieldWithOptionalTypeIsAddedToTemplateChoice-files", "//test-common:upgrades-SucceedsWhenTemplateChoiceInputArgumentHasChanged-files", diff --git a/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs b/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs index 9dfd98a5bcf8..ba99447774b3 100644 --- a/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs +++ b/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs @@ -419,8 +419,15 @@ tests damlc = False setUpgradeField , test - "FailsWhenDepsDowngradeVersions" - (FailWithError "\ESC\\[0;91merror type checking :\n Dependency upgrades-example-FailsWhenDepsDowngradeVersions-dep has version 0.0.1 on the upgrading package, which is older than version 0.0.2 on the upgraded package.\n Dependency versions of upgrading packages must always be greater or equal to the dependency versions on upgraded packages.") + "FailsWhenDepsDowngradeVersionsWhileUsingDatatypes" + (FailWithError "\ESC\\[0;91merror type checking data type Main.Main:\n The upgraded data type Main has changed the types of some of its original fields.") + LF.versionDefault + (SeparateDeps True) + False + setUpgradeField + , test + "SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes" + Succeed LF.versionDefault (SeparateDeps True) False diff --git a/sdk/daml-lf/validation/BUILD.bazel b/sdk/daml-lf/validation/BUILD.bazel index 0b7a0025817d..237651710e18 100644 --- a/sdk/daml-lf/validation/BUILD.bazel +++ b/sdk/daml-lf/validation/BUILD.bazel @@ -268,10 +268,14 @@ da_scala_test_suite( "//test-common:upgrades-FailsWhenDatatypeChangesVariety-v2.dar", # Test for dependency upgrades - "//test-common:upgrades-FailsWhenDepsDowngradeVersions-dep-v1.dar", - "//test-common:upgrades-FailsWhenDepsDowngradeVersions-dep-v2.dar", - "//test-common:upgrades-FailsWhenDepsDowngradeVersions-v1.dar", - "//test-common:upgrades-FailsWhenDepsDowngradeVersions-v2.dar", + "//test-common:upgrades-FailsWhenDepsDowngradeVersionsWhileUsingDatatypes-dep-v1.dar", + "//test-common:upgrades-FailsWhenDepsDowngradeVersionsWhileUsingDatatypes-dep-v2.dar", + "//test-common:upgrades-FailsWhenDepsDowngradeVersionsWhileUsingDatatypes-v1.dar", + "//test-common:upgrades-FailsWhenDepsDowngradeVersionsWhileUsingDatatypes-v2.dar", + "//test-common:upgrades-SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes-dep-v1.dar", + "//test-common:upgrades-SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes-dep-v2.dar", + "//test-common:upgrades-SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes-v1.dar", + "//test-common:upgrades-SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes-v2.dar", ], flaky = False, scala_deps = [ diff --git a/sdk/language-support/ts/codegen/src/TsCodeGenMain.hs b/sdk/language-support/ts/codegen/src/TsCodeGenMain.hs index 8009ca46d3ae..8674c42aa953 100644 --- a/sdk/language-support/ts/codegen/src/TsCodeGenMain.hs +++ b/sdk/language-support/ts/codegen/src/TsCodeGenMain.hs @@ -43,6 +43,7 @@ import qualified DA.Daml.Project.Types as DATypes import qualified DA.Daml.Assistant.Version as DAVersion import qualified DA.Daml.Assistant.Env as DAEnv import qualified DA.Daml.Assistant.Util as DAUtil +import DA.Daml.LF.Ast.Version -- Version of the "@mojotech/json-type-validation" library we're using. jtvVersion :: T.Text @@ -108,7 +109,7 @@ mergePackageMap ps = fst <$> foldM merge mempty ps Either T.Text (Map.Map PackageId (PackageReference, Package), Set.Set (PackageName, PackageVersion)) merge (pkgs, usedUnitIds) (pkgId, pkg, isMain) = do let pkgIsUtil = isUtilityPackage pkg - supportsUpgrades = not pkgIsUtil && packageLfVersion pkg `supports` featurePackageUpgrades + supportsUpgrades = pkgSupportsUpgrades pkg pkgRef = case packageMetadata pkg of Just (PackageMetadata {..}) | supportsUpgrades -> @@ -153,14 +154,6 @@ main = do T.putStrLn $ "Generating " <> pkgDesc daml2js Daml2jsParams{..} -isUtilityPackage :: Package -> Bool -isUtilityPackage pkg = - all (\mod -> - null (moduleTemplates mod) - && null (moduleInterfaces mod) - && not (any (getIsSerializable . dataSerializable) $ moduleDataTypes mod) - ) $ packageModules pkg - data PackageReference = PkgNameVer (PackageName, PackageVersion) | PkgId PackageId diff --git a/sdk/test-common/BUILD.bazel b/sdk/test-common/BUILD.bazel index 0e831f4fa0a1..e8d6cef09a57 100644 --- a/sdk/test-common/BUILD.bazel +++ b/sdk/test-common/BUILD.bazel @@ -301,7 +301,8 @@ da_scala_dar_resources_library( ), ] for identifier in [ - "FailsWhenDepsDowngradeVersions", + "FailsWhenDepsDowngradeVersionsWhileUsingDatatypes", + "SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes", ] ] diff --git a/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersionsWhileUsingDatatypes/dep-v1/Dep.daml b/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersionsWhileUsingDatatypes/dep-v1/Dep.daml new file mode 100644 index 000000000000..15ece72a64dd --- /dev/null +++ b/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersionsWhileUsingDatatypes/dep-v1/Dep.daml @@ -0,0 +1,6 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Dep where + +data Dep = Dep { dep : Text } diff --git a/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersionsWhileUsingDatatypes/dep-v2/Dep.daml b/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersionsWhileUsingDatatypes/dep-v2/Dep.daml new file mode 100644 index 000000000000..15ece72a64dd --- /dev/null +++ b/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersionsWhileUsingDatatypes/dep-v2/Dep.daml @@ -0,0 +1,6 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Dep where + +data Dep = Dep { dep : Text } diff --git a/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersionsWhileUsingDatatypes/v1/Main.daml b/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersionsWhileUsingDatatypes/v1/Main.daml new file mode 100644 index 000000000000..3ce6ce2337e3 --- /dev/null +++ b/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersionsWhileUsingDatatypes/v1/Main.daml @@ -0,0 +1,8 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Main where + +import Dep + +data Main = Main { field : Dep } diff --git a/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersionsWhileUsingDatatypes/v2/Main.daml b/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersionsWhileUsingDatatypes/v2/Main.daml new file mode 100644 index 000000000000..3ce6ce2337e3 --- /dev/null +++ b/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersionsWhileUsingDatatypes/v2/Main.daml @@ -0,0 +1,8 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Main where + +import Dep + +data Main = Main { field : Dep } diff --git a/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/dep-v1/Dep.daml b/sdk/test-common/src/main/daml/upgrades/SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes/dep-v1/Dep.daml similarity index 100% rename from sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/dep-v1/Dep.daml rename to sdk/test-common/src/main/daml/upgrades/SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes/dep-v1/Dep.daml diff --git a/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/dep-v2/Dep.daml b/sdk/test-common/src/main/daml/upgrades/SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes/dep-v2/Dep.daml similarity index 100% rename from sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/dep-v2/Dep.daml rename to sdk/test-common/src/main/daml/upgrades/SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes/dep-v2/Dep.daml diff --git a/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/v1/Main.daml b/sdk/test-common/src/main/daml/upgrades/SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes/v1/Main.daml similarity index 100% rename from sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/v1/Main.daml rename to sdk/test-common/src/main/daml/upgrades/SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes/v1/Main.daml diff --git a/sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/v2/Main.daml b/sdk/test-common/src/main/daml/upgrades/SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes/v2/Main.daml similarity index 100% rename from sdk/test-common/src/main/daml/upgrades/FailsWhenDepsDowngradeVersions/v2/Main.daml rename to sdk/test-common/src/main/daml/upgrades/SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes/v2/Main.daml From 1519ffce8975d47702391b9d6ffe750717070246 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Fri, 9 Aug 2024 18:06:52 +0100 Subject: [PATCH 08/31] Add test for FailsWhenDependencyIsNotAValidUpgrade, fix version issue --- sdk/compiler/damlc/tests/BUILD.bazel | 1 + sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs | 11 +++++++++-- sdk/test-common/BUILD.bazel | 1 + 3 files changed, 11 insertions(+), 2 deletions(-) diff --git a/sdk/compiler/damlc/tests/BUILD.bazel b/sdk/compiler/damlc/tests/BUILD.bazel index 0314be56b7c5..db1b33437c5c 100644 --- a/sdk/compiler/damlc/tests/BUILD.bazel +++ b/sdk/compiler/damlc/tests/BUILD.bazel @@ -459,6 +459,7 @@ da_haskell_test( "//test-common:upgrades-FailsWhenAnInterfaceIsDefinedInAnUpgradingPackageWhenItWasAlreadyInThePriorPackage-files", "//test-common:upgrades-FailsWhenDatatypeChangesVariety-files", "//test-common:upgrades-FailsWhenDepsDowngradeVersionsWhileUsingDatatypes-files", + "//test-common:upgrades-FailsWhenDependencyIsNotAValidUpgrade-files", "//test-common:upgrades-FailsWhenExistingFieldInTemplateChoiceIsChanged-files", "//test-common:upgrades-FailsWhenExistingFieldInTemplateIsChanged-files", "//test-common:upgrades-FailsWhenNewFieldIsAddedToTemplateChoiceWithoutOptionalType-files", diff --git a/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs b/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs index ba99447774b3..5a56cb13c1c5 100644 --- a/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs +++ b/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs @@ -421,17 +421,24 @@ tests damlc = , test "FailsWhenDepsDowngradeVersionsWhileUsingDatatypes" (FailWithError "\ESC\\[0;91merror type checking data type Main.Main:\n The upgraded data type Main has changed the types of some of its original fields.") - LF.versionDefault + versionDefault (SeparateDeps True) False setUpgradeField , test "SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes" Succeed - LF.versionDefault + versionDefault (SeparateDeps True) False setUpgradeField + , test + "FailsWhenDependencyIsNotAValidUpgrade" + (Succeed) + versionDefault + (SeparateDeps False) + False + setUpgradeField ] | setUpgradeField <- [True, False] ] ++ diff --git a/sdk/test-common/BUILD.bazel b/sdk/test-common/BUILD.bazel index e8d6cef09a57..d53bef954adc 100644 --- a/sdk/test-common/BUILD.bazel +++ b/sdk/test-common/BUILD.bazel @@ -198,6 +198,7 @@ da_scala_dar_resources_library( # More more more tests ported from DamlcUpgrades.hs "FailsWithSynonymReturnTypeChangeInSeparatePackage", "SucceedsWhenUpgradingADependency", + "FailsWhenDependencyIsNotAValidUpgrade", ] ] From 56d824b8b01a8d598c1bc2a2b4fbc23d501456f3 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Fri, 9 Aug 2024 20:05:50 +0100 Subject: [PATCH 09/31] Add pre-header for checking dependencies --- .../daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs | 40 ++++++++++++- .../src/DA/Daml/LF/TypeChecker/Env.hs | 9 ++- .../src/DA/Daml/LF/TypeChecker/Error.hs | 59 ++++++++++++------- .../src/DA/Daml/LF/TypeChecker/Upgrade.hs | 52 ++++------------ .../damlc/tests/src/DA/Test/DamlcUpgrades.hs | 2 +- 5 files changed, 98 insertions(+), 64 deletions(-) diff --git a/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs b/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs index 1b3f1610674b..4a1f2301e53d 100644 --- a/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs +++ b/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs @@ -1,19 +1,24 @@ -- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} module DA.Daml.LF.Ast.Util(module DA.Daml.LF.Ast.Util) where +import Control.DeepSeq +import Control.Lens +import Control.Lens.Ast import Control.Monad import Data.List import Data.Maybe import qualified Data.Text as T -import Control.Lens -import Control.Lens.Ast +import Data.Data import Data.Functor.Foldable import qualified Data.Graph as G import Data.List.Extra (nubSort, stripInfixEnd) import qualified Data.NameMap as NM +import GHC.Generics (Generic) import Module (UnitId, unitIdString, stringToUnitId) import System.FilePath import Text.Read (readMaybe) @@ -357,7 +362,6 @@ splitPackageVersion mkError version@(PackageVersion raw) = Just versions -> Right $ RawPackageVersion versions newtype RawPackageVersion = RawPackageVersion [Integer] - deriving (Show) padEquivalent :: RawPackageVersion -> RawPackageVersion -> ([Integer], [Integer]) padEquivalent (RawPackageVersion v1Pieces) (RawPackageVersion v2Pieces) = @@ -373,3 +377,33 @@ instance Ord RawPackageVersion where instance Eq RawPackageVersion where (==) v1 v2 = uncurry (==) $ padEquivalent v1 v2 + +instance Show RawPackageVersion where + show (RawPackageVersion pieces) = intercalate "." $ map show pieces + +data Upgrading a = Upgrading + { _past :: a + , _present :: a + } + deriving (Eq, Data, Generic, NFData, Show) + +makeLenses ''Upgrading + +instance Functor Upgrading where + fmap f Upgrading{..} = Upgrading (f _past) (f _present) + +instance Foldable Upgrading where + foldMap f Upgrading{..} = f _past <> f _present + +instance Traversable Upgrading where + traverse f Upgrading{..} = Upgrading <$> f _past <*> f _present + +instance Applicative Upgrading where + pure a = Upgrading a a + (<*>) f a = Upgrading { _past = _past f (_past a), _present = _present f (_present a) } + +foldU :: (a -> a -> b) -> Upgrading a -> b +foldU f u = f (_past u) (_present u) + +unsafeZipUpgrading :: Upgrading [a] -> [Upgrading a] +unsafeZipUpgrading = foldU (zipWith Upgrading) diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Env.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Env.hs index 2dab97d87be1..af8435952b84 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Env.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Env.hs @@ -179,7 +179,14 @@ warnWithContextF :: forall m gamma. MonadGammaF gamma m => Getter gamma Gamma -> warnWithContextF = diagnosticWithContextF withContextF :: MonadGammaF gamma m => Setter' gamma Gamma -> Context -> m b -> m b -withContextF setter ctx = local (set (setter . locCtx) ctx) +withContextF setter newCtx = local (over (setter . locCtx) setCtx) + where + setCtx :: Context -> Context + setCtx oldCtx = + case (oldCtx, newCtx) of + (ContextDefUpgrading _ _ _ _, ContextDefUpgrading _ _ _ _) -> newCtx + (ContextDefUpgrading name version _ isUpgrading, _) -> ContextDefUpgrading name version newCtx isUpgrading + (_, _) -> newCtx instance SomeErrorOrWarning UnwarnableError where diagnosticWithContextF = throwWithContextF diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs index 20286e14b86e..c7787932affb 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs @@ -40,6 +40,7 @@ data Context | ContextDefValue !Module !DefValue | ContextDefException !Module !DefException | ContextDefInterface !Module !DefInterface !InterfacePart + | ContextDefUpgrading !PackageName !(Upgrading RawPackageVersion) !Context !Bool data TemplatePart = TPWhole @@ -270,6 +271,7 @@ contextLocation = \case ContextDefValue _ v -> dvalLocation v ContextDefException _ e -> exnLocation e ContextDefInterface _ i ip -> interfaceLocation i ip <|> intLocation i -- Fallback to interface header location if other locations are missing + ContextDefUpgrading _ _ _ _ -> Nothing templateLocation :: Template -> TemplatePart -> Maybe SourceLoc templateLocation t = \case @@ -320,6 +322,13 @@ instance Show Context where "exception " <> show (moduleName m) <> "." <> show (exnName e) ContextDefInterface m i p -> "interface " <> show (moduleName m) <> "." <> show (intName i) <> " " <> show p + ContextDefUpgrading pkgName pkgVersion subContext isDependency -> + let prettyPkgName = + if isDependency + then "dependency " <> T.unpack (unPackageName pkgName) + else T.unpack (unPackageName pkgName) + in + "upgrading " <> prettyPkgName <> " " <> show (_present pkgVersion) <> ", " <> show subContext instance Show TemplatePart where show = \case @@ -384,11 +393,7 @@ instance Pretty Error where EUnwarnableError err -> pPrint err EWarnableError err -> pPrint err EWarningToError warning -> pPrint warning - EContext ctx err -> - vcat - [ "error type checking " <> pretty ctx <> ":" - , nest 2 (pretty err) - ] + EContext ctx err -> prettyWithContext ctx (Right err) instance Pretty UnwarnableError where pPrint = \case @@ -681,24 +686,42 @@ instance Pretty UpgradedRecordOrigin where InterfaceBody iface -> "interface " <> pPrint iface TopLevel datatype -> "data type " <> pPrint datatype -instance Pretty Context where - pPrint = \case +prettyWithContext :: Context -> Either Warning Error -> Doc a +prettyWithContext ctx warningOrErr = + let header prettyCtx = + vcat + [ case warningOrErr of + Right _ -> "error type checking " <> prettyCtx <> ":" + Left _ -> "warning while type checking " <> prettyCtx <> ":" + , nest 2 (either pretty pretty warningOrErr) + ] + in + case ctx of ContextNone -> - string "" + header $ string "" ContextDefModule m -> - hsep [ "module" , pretty (moduleName m) ] + header $ hsep [ "module" , pretty (moduleName m) ] ContextDefTypeSyn m ts -> - hsep [ "type synonym", pretty (moduleName m) <> "." <> pretty (synName ts) ] + header $ hsep [ "type synonym", pretty (moduleName m) <> "." <> pretty (synName ts) ] ContextDefDataType m dt -> - hsep [ "data type", pretty (moduleName m) <> "." <> pretty (dataTypeCon dt) ] + header $ hsep [ "data type", pretty (moduleName m) <> "." <> pretty (dataTypeCon dt) ] ContextTemplate m t p -> - hsep [ "template", pretty (moduleName m) <> "." <> pretty (tplTypeCon t), string (show p) ] + header $ hsep [ "template", pretty (moduleName m) <> "." <> pretty (tplTypeCon t), string (show p) ] ContextDefValue m v -> - hsep [ "value", pretty (moduleName m) <> "." <> pretty (fst $ dvalBinder v) ] + header $ hsep [ "value", pretty (moduleName m) <> "." <> pretty (fst $ dvalBinder v) ] ContextDefException m e -> - hsep [ "exception", pretty (moduleName m) <> "." <> pretty (exnName e) ] + header $ hsep [ "exception", pretty (moduleName m) <> "." <> pretty (exnName e) ] ContextDefInterface m i p -> - hsep [ "interface", pretty (moduleName m) <> "." <> pretty (intName i), string (show p)] + header $ hsep [ "interface", pretty (moduleName m) <> "." <> pretty (intName i), string (show p)] + ContextDefUpgrading pkgName pkgVersion subContext isDependency -> + let prettyPkgName = if isDependency then hsep ["dependency", pretty pkgName] else pretty pkgName + upgradeOrDowngrade = if _present pkgVersion > _past pkgVersion then "upgrade" else "downgrade" + in + vcat + [ hsep [ "error while validating that", prettyPkgName, "version", string (show (_present pkgVersion)), "is a valid", upgradeOrDowngrade, "of version", string (show (_past pkgVersion)) ] + , nest 2 $ + prettyWithContext subContext warningOrErr + ] class ToDiagnostic a where toDiagnostic :: a -> Diagnostic @@ -750,11 +773,7 @@ warningLocation = \case instance Pretty Warning where pPrint = \case - WContext ctx err -> - vcat - [ "warning while type checking " <> pretty ctx <> ":" - , nest 2 (pretty err) - ] + WContext ctx warning -> prettyWithContext ctx (Left warning) WTemplateChangedPrecondition template -> "The upgraded template " <> pPrint template <> " has changed the definition of its precondition." WTemplateChangedSignatories template -> "The upgraded template " <> pPrint template <> " has changed the definition of its signatories." WTemplateChangedObservers template -> "The upgraded template " <> pPrint template <> " has changed the definition of its observers." diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs index e79ff8a41a28..3c92fc865296 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs @@ -8,7 +8,6 @@ module DA.Daml.LF.TypeChecker.Upgrade ( module DA.Daml.LF.TypeChecker.Upgrade ) where -import Control.DeepSeq import Control.Monad (unless, forM, forM_, when) import Control.Monad.Extra (allM, filterM) import Control.Monad.Reader (withReaderT) @@ -20,7 +19,6 @@ import DA.Daml.LF.TypeChecker.Env import DA.Daml.LF.TypeChecker.Error import DA.Daml.Options.Types (UpgradeInfo (..)) import Data.Bifunctor (first) -import Data.Data import Data.Either (partitionEithers) import Data.Hashable import qualified Data.HashMap.Strict as HMS @@ -28,38 +26,10 @@ import Data.List (foldl') import qualified Data.NameMap as NM import qualified Data.Text as T import Development.IDE.Types.Diagnostics -import GHC.Generics (Generic) import Data.Maybe (catMaybes) import Safe (maximumByMay, minimumByMay) import Data.Function (on) -data Upgrading a = Upgrading - { _past :: a - , _present :: a - } - deriving (Eq, Data, Generic, NFData, Show) - -makeLenses ''Upgrading - -instance Functor Upgrading where - fmap f Upgrading{..} = Upgrading (f _past) (f _present) - -instance Foldable Upgrading where - foldMap f Upgrading{..} = f _past <> f _present - -instance Traversable Upgrading where - traverse f Upgrading{..} = Upgrading <$> f _past <*> f _present - -instance Applicative Upgrading where - pure a = Upgrading a a - (<*>) f a = Upgrading { _past = _past f (_past a), _present = _present f (_present a) } - -foldU :: (a -> a -> b) -> Upgrading a -> b -foldU f u = f (_past u) (_present u) - -unsafeZipUpgrading :: Upgrading [a] -> [Upgrading a] -unsafeZipUpgrading = foldU (zipWith Upgrading) - -- Allows us to split the world into upgraded and non-upgraded type TcUpgradeM = TcMF UpgradingEnv @@ -224,13 +194,15 @@ checkUpgradeDependenciesM presentDeps pastDeps = do then pure Nothing else case packageMetadata presentPkg of - Just meta -> do - case HMS.lookup (packageName meta) upgradeablePackageMap of + Just meta -> + let PackageMetadata {packageName, packageVersion} = meta + in + case HMS.lookup packageName upgradeablePackageMap of Nothing -> pure Nothing Just upgradedPkgs -> do - case splitPackageVersion id (packageVersion meta) of + case splitPackageVersion id packageVersion of Left version -> do - diagnosticWithContextF present $ WErrorToWarning $ WEDependencyHasUnparseableVersion (packageName meta) version UpgradedPackage + diagnosticWithContextF present $ WErrorToWarning $ WEDependencyHasUnparseableVersion packageName version UpgradedPackage pure Nothing Right presentVersion -> do let equivalent = filter (\(pastVersion, pastPkgId, _) -> pastVersion == presentVersion && pastPkgId /= presentPkgId) upgradedPkgs @@ -242,16 +214,18 @@ checkUpgradeDependenciesM presentDeps pastDeps = do else do withReaderT (\gamma -> UpgradingEnv gamma (upgradeablePackageMapToDeps upgradeablePackageMap)) $ do case closestGreater of - Just (_, greaterPkgId, greaterPkg) -> - check (presentPkgId, presentPkg) (greaterPkgId, greaterPkg) + Just (greaterPkgVersion, greaterPkgId, greaterPkg) -> + withContextF present' (ContextDefUpgrading packageName (Upgrading greaterPkgVersion presentVersion) ContextNone True) $ + check (presentPkgId, presentPkg) (greaterPkgId, greaterPkg) Nothing -> pure () case closestLesser of - Just (_, lesserPkgId, lesserPkg) -> - check (lesserPkgId, lesserPkg) (presentPkgId, presentPkg) + Just (lesserPkgVersion, lesserPkgId, lesserPkg) -> + withContextF present' (ContextDefUpgrading packageName (Upgrading lesserPkgVersion presentVersion) ContextNone True) $ + check (lesserPkgId, lesserPkg) (presentPkgId, presentPkg) Nothing -> pure () - pure $ Just (packageName meta, (presentVersion, presentPkgId, presentPkg)) + pure $ Just (packageName, (presentVersion, presentPkgId, presentPkg)) Nothing -> do diagnosticWithContextF present $ WErrorToWarning $ WEDependencyHasNoMetadataDespiteUpgradeability presentPkgId UpgradingPackage pure Nothing diff --git a/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs b/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs index 5a56cb13c1c5..af56796248b5 100644 --- a/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs +++ b/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs @@ -434,7 +434,7 @@ tests damlc = setUpgradeField , test "FailsWhenDependencyIsNotAValidUpgrade" - (Succeed) + (FailWithError "\ESC\\[0;91merror while validating that dependency upgrades-example-FailsWhenDependencyIsNotAValidUpgrade-dep version 0.0.2 is a valid upgrade of version 0.0.1\n error type checking data type Dep.Dep:\n The upgraded data type Dep has added new fields, but those fields are not Optional.") versionDefault (SeparateDeps False) False From c38dc648fe863ef75469781f41f700657e8e6d94 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Fri, 9 Aug 2024 20:06:54 +0100 Subject: [PATCH 10/31] lint --- sdk/compiler/damlc/tests/BUILD.bazel | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sdk/compiler/damlc/tests/BUILD.bazel b/sdk/compiler/damlc/tests/BUILD.bazel index db1b33437c5c..5016f43408d8 100644 --- a/sdk/compiler/damlc/tests/BUILD.bazel +++ b/sdk/compiler/damlc/tests/BUILD.bazel @@ -458,8 +458,8 @@ da_haskell_test( "//test-common:upgrades-FailsWhenAnInstanceIsDropped-files", "//test-common:upgrades-FailsWhenAnInterfaceIsDefinedInAnUpgradingPackageWhenItWasAlreadyInThePriorPackage-files", "//test-common:upgrades-FailsWhenDatatypeChangesVariety-files", - "//test-common:upgrades-FailsWhenDepsDowngradeVersionsWhileUsingDatatypes-files", "//test-common:upgrades-FailsWhenDependencyIsNotAValidUpgrade-files", + "//test-common:upgrades-FailsWhenDepsDowngradeVersionsWhileUsingDatatypes-files", "//test-common:upgrades-FailsWhenExistingFieldInTemplateChoiceIsChanged-files", "//test-common:upgrades-FailsWhenExistingFieldInTemplateIsChanged-files", "//test-common:upgrades-FailsWhenNewFieldIsAddedToTemplateChoiceWithoutOptionalType-files", From 1e1ee8962c8f5ec179c9c77e0fd1568b9ffb2d9b Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Mon, 12 Aug 2024 13:37:39 +0100 Subject: [PATCH 11/31] Track FailsWhenDependencyIsNotAValidUpgrade --- .../FailsWhenDependencyIsNotAValidUpgrade/dep-v1/Dep.daml | 6 ++++++ .../FailsWhenDependencyIsNotAValidUpgrade/dep-v2/Dep.daml | 6 ++++++ .../FailsWhenDependencyIsNotAValidUpgrade/v1/Main.daml | 8 ++++++++ .../FailsWhenDependencyIsNotAValidUpgrade/v2/Main.daml | 8 ++++++++ 4 files changed, 28 insertions(+) create mode 100644 sdk/test-common/src/main/daml/upgrades/FailsWhenDependencyIsNotAValidUpgrade/dep-v1/Dep.daml create mode 100644 sdk/test-common/src/main/daml/upgrades/FailsWhenDependencyIsNotAValidUpgrade/dep-v2/Dep.daml create mode 100644 sdk/test-common/src/main/daml/upgrades/FailsWhenDependencyIsNotAValidUpgrade/v1/Main.daml create mode 100644 sdk/test-common/src/main/daml/upgrades/FailsWhenDependencyIsNotAValidUpgrade/v2/Main.daml diff --git a/sdk/test-common/src/main/daml/upgrades/FailsWhenDependencyIsNotAValidUpgrade/dep-v1/Dep.daml b/sdk/test-common/src/main/daml/upgrades/FailsWhenDependencyIsNotAValidUpgrade/dep-v1/Dep.daml new file mode 100644 index 000000000000..15ece72a64dd --- /dev/null +++ b/sdk/test-common/src/main/daml/upgrades/FailsWhenDependencyIsNotAValidUpgrade/dep-v1/Dep.daml @@ -0,0 +1,6 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Dep where + +data Dep = Dep { dep : Text } diff --git a/sdk/test-common/src/main/daml/upgrades/FailsWhenDependencyIsNotAValidUpgrade/dep-v2/Dep.daml b/sdk/test-common/src/main/daml/upgrades/FailsWhenDependencyIsNotAValidUpgrade/dep-v2/Dep.daml new file mode 100644 index 000000000000..3298bebe3538 --- /dev/null +++ b/sdk/test-common/src/main/daml/upgrades/FailsWhenDependencyIsNotAValidUpgrade/dep-v2/Dep.daml @@ -0,0 +1,6 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Dep where + +data Dep = Dep { dep : Text, nonOptionalField : Text } diff --git a/sdk/test-common/src/main/daml/upgrades/FailsWhenDependencyIsNotAValidUpgrade/v1/Main.daml b/sdk/test-common/src/main/daml/upgrades/FailsWhenDependencyIsNotAValidUpgrade/v1/Main.daml new file mode 100644 index 000000000000..3ce6ce2337e3 --- /dev/null +++ b/sdk/test-common/src/main/daml/upgrades/FailsWhenDependencyIsNotAValidUpgrade/v1/Main.daml @@ -0,0 +1,8 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Main where + +import Dep + +data Main = Main { field : Dep } diff --git a/sdk/test-common/src/main/daml/upgrades/FailsWhenDependencyIsNotAValidUpgrade/v2/Main.daml b/sdk/test-common/src/main/daml/upgrades/FailsWhenDependencyIsNotAValidUpgrade/v2/Main.daml new file mode 100644 index 000000000000..012a084a030e --- /dev/null +++ b/sdk/test-common/src/main/daml/upgrades/FailsWhenDependencyIsNotAValidUpgrade/v2/Main.daml @@ -0,0 +1,8 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Main where + +import Dep + +data Main = Main { field : Dep, optionalField : Optional Text } From 4b860237ae6d46faf96ce3e0cb93b2d03a131d4e Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Mon, 12 Aug 2024 14:12:06 +0100 Subject: [PATCH 12/31] remove unused import --- sdk/language-support/ts/codegen/src/TsCodeGenMain.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/sdk/language-support/ts/codegen/src/TsCodeGenMain.hs b/sdk/language-support/ts/codegen/src/TsCodeGenMain.hs index 8674c42aa953..1d952f0e94cd 100644 --- a/sdk/language-support/ts/codegen/src/TsCodeGenMain.hs +++ b/sdk/language-support/ts/codegen/src/TsCodeGenMain.hs @@ -43,7 +43,6 @@ import qualified DA.Daml.Project.Types as DATypes import qualified DA.Daml.Assistant.Version as DAVersion import qualified DA.Daml.Assistant.Env as DAEnv import qualified DA.Daml.Assistant.Util as DAUtil -import DA.Daml.LF.Ast.Version -- Version of the "@mojotech/json-type-validation" library we're using. jtvVersion :: T.Text From d014a533b4f87c20b32357bc8ecc09abbf0fe7e0 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Tue, 20 Aug 2024 17:08:35 +0100 Subject: [PATCH 13/31] Track self in deps for recursive datatype check Refactor to have correct gamma in scope for recursive checks --- .../src/DA/Daml/LF/TypeChecker/Upgrade.hs | 276 ++++++++++-------- 1 file changed, 158 insertions(+), 118 deletions(-) diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs index 3c92fc865296..58c8429884d6 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs @@ -11,6 +11,7 @@ module DA.Daml.LF.TypeChecker.Upgrade ( import Control.Monad (unless, forM, forM_, when) import Control.Monad.Extra (allM, filterM) import Control.Monad.Reader (withReaderT) +import Control.Monad.Reader.Class (asks) import Control.Lens hiding (Context) import DA.Daml.LF.Ast as LF import DA.Daml.LF.Ast.Alpha (alphaExpr, AlphaEnv(..), initialAlphaEnv, alphaType', alphaTypeCon, bindTypeVar) @@ -51,117 +52,138 @@ runGammaUnderUpgrades Upgrading{ _past = pastAction, _present = presentAction } presentResult <- withReaderT (_present . _upgradingGamma) presentAction pure Upgrading { _past = pastResult, _present = presentResult } -checkBothAndSingle - :: World -> (LF.UpgradedPackageId -> LF.Package -> TcUpgradeM ()) -> TcM () - -> [LF.DalfPackage] -> Version -> UpgradeInfo - -> Maybe ((LF.PackageId, LF.Package), [(LF.PackageId, LF.Package)]) - -> [Diagnostic] -checkBothAndSingle world checkBoth checkSingle deps version upgradeInfo mbUpgradedPackage = - let shouldTypecheck = version `LF.supports` LF.featurePackageUpgrades && uiTypecheckUpgrades upgradeInfo - - gamma :: World -> Gamma - gamma world = - let addBadIfaceSwapIndicator :: Gamma -> Gamma - addBadIfaceSwapIndicator = - if uiWarnBadInterfaceInstances upgradeInfo - then - addDiagnosticSwapIndicator (\case - Left WEUpgradeShouldDefineIfaceWithoutImplementation {} -> Just True - Left WEUpgradeShouldDefineTplInSeparatePackage {} -> Just True - Left WEUpgradeShouldDefineIfacesAndTemplatesSeparately {} -> Just True - _ -> Nothing) - else id - in - addBadIfaceSwapIndicator $ emptyGamma world version - - bothPkgDiagnostics :: Either Error ((), [Warning]) - bothPkgDiagnostics = - case mbUpgradedPackage of - Nothing -> - Right ((), []) - Just ((pastPkgId, pastPkg), upgradedDeps) -> - let upgradingWorld = Upgrading { _past = initWorldSelf [] pastPkg, _present = world } - upgradingGamma = fmap gamma upgradingWorld - in - runGammaF upgradingGamma $ when (uiTypecheckUpgrades upgradeInfo) $ do - deps <- checkUpgradeDependenciesM deps upgradedDeps - withReaderT (\gamma -> UpgradingEnv gamma deps) $ - checkBoth (UpgradedPackageId pastPkgId) pastPkg - - singlePkgDiagnostics :: Either Error ((), [Warning]) - singlePkgDiagnostics = - runGammaF (gamma world) $ - when shouldTypecheck checkSingle - - extractDiagnostics :: Either Error ((), [Warning]) -> [Diagnostic] - extractDiagnostics result = - case result of - Left err -> [toDiagnostic err] - Right ((), warnings) -> map toDiagnostic warnings +shouldTypecheck :: Version -> UpgradeInfo -> Bool +shouldTypecheck version upgradeInfo = version `LF.supports` LF.featurePackageUpgrades && uiTypecheckUpgrades upgradeInfo + +shouldTypecheckM :: TcMF (Version, UpgradeInfo) Bool +shouldTypecheckM = asks (uncurry shouldTypecheck) + +mkGamma :: Version -> UpgradeInfo -> World -> Gamma +mkGamma version upgradeInfo world = + let addBadIfaceSwapIndicator :: Gamma -> Gamma + addBadIfaceSwapIndicator = + if uiWarnBadInterfaceInstances upgradeInfo + then + addDiagnosticSwapIndicator (\case + Left WEUpgradeShouldDefineIfaceWithoutImplementation {} -> Just True + Left WEUpgradeShouldDefineTplInSeparatePackage {} -> Just True + Left WEUpgradeShouldDefineIfacesAndTemplatesSeparately {} -> Just True + _ -> Nothing) + else id in - extractDiagnostics bothPkgDiagnostics ++ extractDiagnostics singlePkgDiagnostics + addBadIfaceSwapIndicator $ emptyGamma world version + +gammaM :: World -> TcMF (Version, UpgradeInfo) Gamma +gammaM world = asks (flip (uncurry mkGamma) world) + +extractDiagnostics :: Version -> UpgradeInfo -> TcMF (Version, UpgradeInfo) () -> [Diagnostic] +extractDiagnostics version upgradeInfo action = + case runGammaF (version, upgradeInfo) action of + Left err -> [toDiagnostic err] + Right ((), warnings) -> map toDiagnostic warnings checkUpgrade :: LF.Package -> [LF.DalfPackage] -> Version -> UpgradeInfo -> Maybe ((LF.PackageId, LF.Package), [(LF.PackageId, LF.Package)]) -> [Diagnostic] -checkUpgrade pkg = - let world = initWorldSelf [] pkg - checkBoth upgradedPkgId upgradedPkg = do - checkUpgradeM upgradedPkgId (Upgrading upgradedPkg pkg) - checkSingle = do - checkNewInterfacesAreUnused pkg - checkNewInterfacesHaveNoTemplates pkg - in - checkBothAndSingle world checkBoth checkSingle +checkUpgrade pkg deps version upgradeInfo mbUpgradedPkg = + extractDiagnostics version upgradeInfo $ do + shouldTypecheck <- shouldTypecheckM + when shouldTypecheck $ do + case mbUpgradedPkg of + Nothing -> pure () + Just (upgradedPkg, upgradingDeps) -> do + deps <- checkUpgradeDependenciesM deps upgradingDeps + checkUpgradeBoth Nothing pkg (upgradedPkg, deps) + checkUpgradeSingle Nothing pkg + +checkUpgradeBoth :: Maybe Context -> LF.Package -> ((LF.PackageId, LF.Package), UpgradingDeps) -> TcMF (Version, UpgradeInfo) () +checkUpgradeBoth mbContext pkg ((upgradedPkgId, upgradedPkg), upgradingDeps) = + let presentWorld = initWorldSelf [] pkg + pastWorld = initWorldSelf [] upgradedPkg + upgradingWorld = Upgrading { _past = pastWorld, _present = presentWorld } + withMbContext :: TcUpgradeM () -> TcUpgradeM () + withMbContext = + case mbContext of + Nothing -> id + Just context -> withContextF present' context + in + withReaderT (\(version, upgradeInfo) -> UpgradingEnv (mkGamma version upgradeInfo <$> upgradingWorld) upgradingDeps) $ + withMbContext $ + checkUpgradeM (UpgradedPackageId upgradedPkgId) (Upgrading upgradedPkg pkg) + +checkUpgradeSingle :: Maybe Context -> LF.Package -> TcMF (Version, UpgradeInfo) () +checkUpgradeSingle mbContext pkg = + let presentWorld = initWorldSelf [] pkg + withMbContext :: TcM () -> TcM () + withMbContext = + case mbContext of + Nothing -> id + Just context -> withContext context + in + withReaderT (\(version, upgradeInfo) -> mkGamma version upgradeInfo presentWorld) $ + withMbContext $ do + checkNewInterfacesAreUnused pkg + checkNewInterfacesHaveNoTemplates pkg checkModule :: LF.World -> LF.Module -> [LF.DalfPackage] -> Version -> UpgradeInfo -> Maybe ((LF.PackageId, LF.Package), [(LF.PackageId, LF.Package)]) -> [Diagnostic] -checkModule world0 module_ = - let world = extendWorldSelf module_ world0 - checkBoth upgradedPkgId upgradedPkg = do - case NM.lookup (NM.name module_) (LF.packageModules upgradedPkg) of - Nothing -> pure () - Just pastModule -> do - let upgradingModule = Upgrading { _past = pastModule, _present = module_ } - equalDataTypes <- structurallyEqualDataTypes upgradingModule - checkModuleM equalDataTypes upgradedPkgId upgradingModule - checkSingle = do - checkNewInterfacesAreUnused module_ - checkNewInterfacesHaveNoTemplates module_ - in - checkBothAndSingle world checkBoth checkSingle +checkModule world0 module_ deps version upgradeInfo mbUpgradedPkg = + extractDiagnostics version upgradeInfo $ + when (shouldTypecheck version upgradeInfo) $ do + let world = extendWorldSelf module_ world0 + case mbUpgradedPkg of + Nothing -> pure () + Just ((upgradedPkgIdRaw, upgradedPkg), upgradingDeps) -> do + let upgradedPkgId = UpgradedPackageId upgradedPkgIdRaw + deps <- checkUpgradeDependenciesM deps upgradingDeps -- TODO: Check if this causes quadratic blowup of dep checks + let upgradingWorld = Upgrading { _past = initWorldSelf [] upgradedPkg, _present = world } + withReaderT (\(version, upgradeInfo) -> UpgradingEnv (mkGamma version upgradeInfo <$> upgradingWorld) deps) $ + case NM.lookup (NM.name module_) (LF.packageModules upgradedPkg) of + Nothing -> pure () + Just pastModule -> do + let upgradingModule = Upgrading { _past = pastModule, _present = module_ } + equalDataTypes <- structurallyEqualDataTypes upgradingModule + checkModuleM equalDataTypes upgradedPkgId upgradingModule + withReaderT (\(version, upgradeInfo) -> mkGamma version upgradeInfo world) $ do + checkNewInterfacesAreUnused module_ + checkNewInterfacesHaveNoTemplates module_ checkUpgradeDependenciesM :: [LF.DalfPackage] -> [(LF.PackageId, LF.Package)] - -> TcMF (Upgrading Gamma) UpgradingDeps + -> TcMF (Version, UpgradeInfo) UpgradingDeps checkUpgradeDependenciesM presentDeps pastDeps = do initialUpgradeablePackageMap <- fmap (HMS.fromListWith (<>) . catMaybes) $ forM pastDeps $ \pastDep -> do - let (pkgId, pkg@LF.Package{packageMetadata = mbMeta}) = pastDep - if LF.pkgSupportsUpgrades pkg - then - case mbMeta of - Nothing -> do - diagnosticWithContextF present $ WErrorToWarning $ WEDependencyHasNoMetadataDespiteUpgradeability pkgId UpgradedPackage - pure Nothing - Just meta -> do - let LF.PackageMetadata {packageName, packageVersion} = meta - case splitPackageVersion id packageVersion of - Left version -> do - diagnosticWithContextF present $ WErrorToWarning $ WEDependencyHasUnparseableVersion packageName version UpgradedPackage + let (pkgId, pkg@LF.Package{packageMetadata = mbMeta}) = pastDep + withPkgAsGamma pkg $ do + if LF.pkgSupportsUpgrades pkg + then + case mbMeta of + Nothing -> do + diagnosticWithContext $ WErrorToWarning $ WEDependencyHasNoMetadataDespiteUpgradeability pkgId UpgradedPackage pure Nothing - Right rawVersion -> - pure $ Just (packageName, [(rawVersion, pkgId, pkg)]) - else pure Nothing + Just meta -> do + let LF.PackageMetadata {packageName, packageVersion} = meta + case splitPackageVersion id packageVersion of + Left version -> do + diagnosticWithContext $ WErrorToWarning $ WEDependencyHasUnparseableVersion packageName version UpgradedPackage + pure Nothing + Right rawVersion -> + pure $ Just (packageName, [(rawVersion, pkgId, pkg)]) + else pure Nothing - upgradeablePackageMapToDeps <$> checkAllDeps initialUpgradeablePackageMap presentDeps + upgradeablePackageMap <- checkAllDeps initialUpgradeablePackageMap presentDeps + pure $ upgradeablePackageMapToDeps upgradeablePackageMap where + withPkgAsGamma pkg action = + withReaderT (\(version, _) -> emptyGamma (initWorldSelf [] pkg) version) action + upgradeablePackageMapToDeps :: HMS.HashMap LF.PackageName [(LF.RawPackageVersion, LF.PackageId, LF.Package)] -> UpgradingDeps upgradeablePackageMapToDeps upgradeablePackageMap = HMS.fromList @@ -170,23 +192,30 @@ checkUpgradeDependenciesM presentDeps pastDeps = do , (pkgVersion, pkgId, _) <- versions ] + addDep + :: (LF.PackageName, (LF.RawPackageVersion, LF.PackageId, LF.Package)) + -> HMS.HashMap LF.PackageName [(LF.RawPackageVersion, LF.PackageId, LF.Package)] + -> HMS.HashMap LF.PackageName [(LF.RawPackageVersion, LF.PackageId, LF.Package)] + addDep (name, pkgVersionIdAndAst) upgradeablePackageMap = + HMS.insertWith (<>) name [pkgVersionIdAndAst] upgradeablePackageMap + checkAllDeps :: HMS.HashMap LF.PackageName [(LF.RawPackageVersion, LF.PackageId, LF.Package)] -> [LF.DalfPackage] - -> TcMF (Upgrading Gamma) (HMS.HashMap LF.PackageName [(LF.RawPackageVersion, LF.PackageId, LF.Package)]) + -> TcMF (Version, UpgradeInfo) (HMS.HashMap LF.PackageName [(LF.RawPackageVersion, LF.PackageId, LF.Package)]) checkAllDeps upgradeablePackageMap [] = pure upgradeablePackageMap checkAllDeps upgradeablePackageMap (pkg:rest) = do mbNewDep <- checkOneDep upgradeablePackageMap pkg let newUpgradeablePackageMap = case mbNewDep of Nothing -> upgradeablePackageMap - Just (name, pkgVersionIdAndAst) -> HMS.insertWith (<>) name [pkgVersionIdAndAst] upgradeablePackageMap + Just res -> addDep res upgradeablePackageMap checkAllDeps newUpgradeablePackageMap rest checkOneDep :: HMS.HashMap LF.PackageName [(LF.RawPackageVersion, LF.PackageId, LF.Package)] -> LF.DalfPackage - -> TcMF (Upgrading Gamma) (Maybe (LF.PackageName, (LF.RawPackageVersion, LF.PackageId, LF.Package))) + -> TcMF (Version, UpgradeInfo) (Maybe (LF.PackageName, (LF.RawPackageVersion, LF.PackageId, LF.Package))) checkOneDep upgradeablePackageMap dalfPkg = do let LF.DalfPackage{dalfPackagePkg,dalfPackageId=presentPkgId} = dalfPkg presentPkg = extPackagePkg dalfPackagePkg @@ -197,14 +226,16 @@ checkUpgradeDependenciesM presentDeps pastDeps = do Just meta -> let PackageMetadata {packageName, packageVersion} = meta in - case HMS.lookup packageName upgradeablePackageMap of - Nothing -> pure Nothing - Just upgradedPkgs -> do - case splitPackageVersion id packageVersion of - Left version -> do - diagnosticWithContextF present $ WErrorToWarning $ WEDependencyHasUnparseableVersion packageName version UpgradedPackage - pure Nothing - Right presentVersion -> do + case splitPackageVersion id packageVersion of + Left version -> do + withPkgAsGamma presentPkg $ + diagnosticWithContext $ WErrorToWarning $ WEDependencyHasUnparseableVersion packageName version UpgradedPackage + pure Nothing + Right presentVersion -> do + let result = (packageName, (presentVersion, presentPkgId, presentPkg)) + case HMS.lookup packageName upgradeablePackageMap of + Nothing -> pure () + Just upgradedPkgs -> do let equivalent = filter (\(pastVersion, pastPkgId, _) -> pastVersion == presentVersion && pastPkgId /= presentPkgId) upgradedPkgs ordFst = compare `on` (\(v,_,_) -> v) closestGreater = minimumByMay ordFst $ filter (\(pastVersion, _, _) -> pastVersion > presentVersion) upgradedPkgs @@ -212,28 +243,37 @@ checkUpgradeDependenciesM presentDeps pastDeps = do if not (null equivalent) then error "two upgradeable packages with same name and version" else do - withReaderT (\gamma -> UpgradingEnv gamma (upgradeablePackageMapToDeps upgradeablePackageMap)) $ do - case closestGreater of - Just (greaterPkgVersion, greaterPkgId, greaterPkg) -> - withContextF present' (ContextDefUpgrading packageName (Upgrading greaterPkgVersion presentVersion) ContextNone True) $ - check (presentPkgId, presentPkg) (greaterPkgId, greaterPkg) - Nothing -> - pure () - case closestLesser of - Just (lesserPkgVersion, lesserPkgId, lesserPkg) -> - withContextF present' (ContextDefUpgrading packageName (Upgrading lesserPkgVersion presentVersion) ContextNone True) $ - check (lesserPkgId, lesserPkg) (presentPkgId, presentPkg) - Nothing -> - pure () - pure $ Just (packageName, (presentVersion, presentPkgId, presentPkg)) + let otherDepsWithSelf = upgradeablePackageMapToDeps $ addDep result upgradeablePackageMap + case closestGreater of + Just (greaterPkgVersion, _greaterPkgId, greaterPkg) -> do + let context = ContextDefUpgrading packageName (Upgrading greaterPkgVersion presentVersion) ContextNone True + checkUpgradeBoth + (Just context) + greaterPkg + ((presentPkgId, presentPkg), otherDepsWithSelf) + checkUpgradeSingle + (Just context) + presentPkg + Nothing -> + pure () + case closestLesser of + Just (lesserPkgVersion, lesserPkgId, lesserPkg) -> do + let context = ContextDefUpgrading packageName (Upgrading lesserPkgVersion presentVersion) ContextNone True + checkUpgradeBoth + (Just context) + presentPkg + ((lesserPkgId, lesserPkg), otherDepsWithSelf) + checkUpgradeSingle + (Just context) + presentPkg + Nothing -> + pure () + pure (Just result) Nothing -> do - diagnosticWithContextF present $ WErrorToWarning $ WEDependencyHasNoMetadataDespiteUpgradeability presentPkgId UpgradingPackage + withPkgAsGamma presentPkg $ + diagnosticWithContext $ WErrorToWarning $ WEDependencyHasNoMetadataDespiteUpgradeability presentPkgId UpgradingPackage pure Nothing - check :: (LF.PackageId, LF.Package) -> (LF.PackageId, LF.Package) -> TcUpgradeM () - check (pastPkgId, pastPkg) (_presentPkgId, presentPkg) = - checkUpgradeM (UpgradedPackageId pastPkgId) (Upgrading pastPkg presentPkg) - checkUpgradeM :: LF.UpgradedPackageId -> Upgrading LF.Package -> TcUpgradeM () checkUpgradeM upgradedPackageId package = do (upgradedModules, _new) <- checkDeleted (EUpgradeMissingModule . NM.name) $ NM.toHashMap . packageModules <$> package From 2b395f6d1fbb4bcb326afb989ef26a46c1301a95 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Tue, 20 Aug 2024 17:12:24 +0100 Subject: [PATCH 14/31] Lint --- .../daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs index 58c8429884d6..6aac7f2e953e 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs @@ -117,10 +117,7 @@ checkUpgradeSingle :: Maybe Context -> LF.Package -> TcMF (Version, UpgradeInfo) checkUpgradeSingle mbContext pkg = let presentWorld = initWorldSelf [] pkg withMbContext :: TcM () -> TcM () - withMbContext = - case mbContext of - Nothing -> id - Just context -> withContext context + withMbContext = maybe id withContext context in withReaderT (\(version, upgradeInfo) -> mkGamma version upgradeInfo presentWorld) $ withMbContext $ do From 831542ec29d67e71d127f5762e9412090402ea50 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Tue, 20 Aug 2024 17:26:52 +0100 Subject: [PATCH 15/31] Fix lint --- .../daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs index 6aac7f2e953e..81e91851e8ea 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs @@ -117,7 +117,7 @@ checkUpgradeSingle :: Maybe Context -> LF.Package -> TcMF (Version, UpgradeInfo) checkUpgradeSingle mbContext pkg = let presentWorld = initWorldSelf [] pkg withMbContext :: TcM () -> TcM () - withMbContext = maybe id withContext context + withMbContext = maybe id withContext mbContext in withReaderT (\(version, upgradeInfo) -> mkGamma version upgradeInfo presentWorld) $ withMbContext $ do From 463ebfea28f6440408b8d750caa77b97933ce1d3 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Fri, 23 Aug 2024 16:39:18 +0100 Subject: [PATCH 16/31] Let template key be an upgradeable type instead of structurally equal --- .../daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs | 4 ++-- sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs index 81e91851e8ea..44aeb8a931b8 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs @@ -537,7 +537,7 @@ instantiatedIfaces modules = foldl' (HMS.unionWith (<>)) HMS.empty $ (map . fmap ] checkTemplate :: [LF.TypeConName] -> Upgrading Module -> Upgrading LF.Template -> TcUpgradeM () -checkTemplate equalDataTypes module_ template = do +checkTemplate _equalDataTypes module_ template = do -- Check that no choices have been removed (existingChoices, _existingNew) <- checkDeleted (EUpgradeMissingChoice . NM.name) $ NM.toHashMap . tplChoices <$> template forM_ existingChoices $ \choice -> do @@ -594,7 +594,7 @@ checkTemplate equalDataTypes module_ template = do let tplKey = Upgrading pastKey presentKey -- Key type musn't change - iset <- isStructurallyEquivalentType initialAlphaEnv equalDataTypes (fmap tplKeyType tplKey) + iset <- isUpgradedType (fmap tplKeyType tplKey) when (not iset) $ diagnosticWithContextF present' (EUpgradeTemplateChangedKeyType (NM.name (_present template))) diff --git a/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs b/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs index af56796248b5..2e895c0daf23 100644 --- a/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs +++ b/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs @@ -371,7 +371,7 @@ tests damlc = setUpgradeField , test "TemplateChangedKeyType2" - (FailWithError "\ESC\\[0;91merror type checking template Main.T key:\n The upgraded template T cannot change its key type.") + Succeed versionDefault NoDependencies False From 64d3535d11b4df78e5729ccecd47f35fb5a93164 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Wed, 28 Aug 2024 09:41:15 +0100 Subject: [PATCH 17/31] Change ContextDefUpgrading to named fields --- .../src/DA/Daml/LF/TypeChecker/Env.hs | 4 +-- .../src/DA/Daml/LF/TypeChecker/Error.hs | 29 +++++++++++-------- .../src/DA/Daml/LF/TypeChecker/Upgrade.hs | 4 +-- 3 files changed, 21 insertions(+), 16 deletions(-) diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Env.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Env.hs index af8435952b84..c08215035edc 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Env.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Env.hs @@ -184,8 +184,8 @@ withContextF setter newCtx = local (over (setter . locCtx) setCtx) setCtx :: Context -> Context setCtx oldCtx = case (oldCtx, newCtx) of - (ContextDefUpgrading _ _ _ _, ContextDefUpgrading _ _ _ _) -> newCtx - (ContextDefUpgrading name version _ isUpgrading, _) -> ContextDefUpgrading name version newCtx isUpgrading + (ContextDefUpgrading {}, ContextDefUpgrading {}) -> newCtx + (ContextDefUpgrading { cduPkgName, cduPkgVersion, cduIsDependency }, _) -> ContextDefUpgrading cduPkgName cduPkgVersion newCtx cduIsDependency (_, _) -> newCtx instance SomeErrorOrWarning UnwarnableError where diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs index c7787932affb..c1e6fb2636f8 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs @@ -40,7 +40,12 @@ data Context | ContextDefValue !Module !DefValue | ContextDefException !Module !DefException | ContextDefInterface !Module !DefInterface !InterfacePart - | ContextDefUpgrading !PackageName !(Upgrading RawPackageVersion) !Context !Bool + | ContextDefUpgrading + { cduPkgName :: !PackageName -- Name of package being checked for upgrade validity + , cduPkgVersion :: !(Upgrading RawPackageVersion) -- Prior (upgradee) and current (upgrader) version of dep package + , cduSubContext :: !Context -- Context within the package of the error + , cduIsDependency :: !Bool -- Is the package a dependency package or is it the main package? + } data TemplatePart = TPWhole @@ -271,7 +276,7 @@ contextLocation = \case ContextDefValue _ v -> dvalLocation v ContextDefException _ e -> exnLocation e ContextDefInterface _ i ip -> interfaceLocation i ip <|> intLocation i -- Fallback to interface header location if other locations are missing - ContextDefUpgrading _ _ _ _ -> Nothing + ContextDefUpgrading {} -> Nothing templateLocation :: Template -> TemplatePart -> Maybe SourceLoc templateLocation t = \case @@ -322,13 +327,13 @@ instance Show Context where "exception " <> show (moduleName m) <> "." <> show (exnName e) ContextDefInterface m i p -> "interface " <> show (moduleName m) <> "." <> show (intName i) <> " " <> show p - ContextDefUpgrading pkgName pkgVersion subContext isDependency -> + ContextDefUpgrading { cduPkgName, cduPkgVersion, cduSubContext, cduIsDependency } -> let prettyPkgName = - if isDependency - then "dependency " <> T.unpack (unPackageName pkgName) - else T.unpack (unPackageName pkgName) + if cduIsDependency + then "dependency " <> T.unpack (unPackageName cduPkgName) + else T.unpack (unPackageName cduPkgName) in - "upgrading " <> prettyPkgName <> " " <> show (_present pkgVersion) <> ", " <> show subContext + "upgrading " <> prettyPkgName <> " " <> show (_present cduPkgVersion) <> ", " <> show cduSubContext instance Show TemplatePart where show = \case @@ -713,14 +718,14 @@ prettyWithContext ctx warningOrErr = header $ hsep [ "exception", pretty (moduleName m) <> "." <> pretty (exnName e) ] ContextDefInterface m i p -> header $ hsep [ "interface", pretty (moduleName m) <> "." <> pretty (intName i), string (show p)] - ContextDefUpgrading pkgName pkgVersion subContext isDependency -> - let prettyPkgName = if isDependency then hsep ["dependency", pretty pkgName] else pretty pkgName - upgradeOrDowngrade = if _present pkgVersion > _past pkgVersion then "upgrade" else "downgrade" + ContextDefUpgrading { cduPkgName, cduPkgVersion, cduSubContext, cduIsDependency } -> + let prettyPkgName = if cduIsDependency then hsep ["dependency", pretty cduPkgName] else pretty cduPkgName + upgradeOrDowngrade = if _present cduPkgVersion > _past cduPkgVersion then "upgrade" else "downgrade" in vcat - [ hsep [ "error while validating that", prettyPkgName, "version", string (show (_present pkgVersion)), "is a valid", upgradeOrDowngrade, "of version", string (show (_past pkgVersion)) ] + [ hsep [ "error while validating that", prettyPkgName, "version", string (show (_present cduPkgVersion)), "is a valid", upgradeOrDowngrade, "of version", string (show (_past cduPkgVersion)) ] , nest 2 $ - prettyWithContext subContext warningOrErr + prettyWithContext cduSubContext warningOrErr ] class ToDiagnostic a where diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs index 44aeb8a931b8..13341d3a714c 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs @@ -243,7 +243,7 @@ checkUpgradeDependenciesM presentDeps pastDeps = do let otherDepsWithSelf = upgradeablePackageMapToDeps $ addDep result upgradeablePackageMap case closestGreater of Just (greaterPkgVersion, _greaterPkgId, greaterPkg) -> do - let context = ContextDefUpgrading packageName (Upgrading greaterPkgVersion presentVersion) ContextNone True + let context = ContextDefUpgrading { cduPkgName = packageName, cduPkgVersion = Upgrading greaterPkgVersion presentVersion, cduSubContext = ContextNone, cduIsDependency = True } checkUpgradeBoth (Just context) greaterPkg @@ -255,7 +255,7 @@ checkUpgradeDependenciesM presentDeps pastDeps = do pure () case closestLesser of Just (lesserPkgVersion, lesserPkgId, lesserPkg) -> do - let context = ContextDefUpgrading packageName (Upgrading lesserPkgVersion presentVersion) ContextNone True + let context = ContextDefUpgrading { cduPkgName = packageName, cduPkgVersion = Upgrading lesserPkgVersion presentVersion, cduSubContext = ContextNone, cduIsDependency = True } checkUpgradeBoth (Just context) presentPkg From 55b26b690921016bd5f7c72866890db85151188b Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Wed, 28 Aug 2024 10:08:28 +0100 Subject: [PATCH 18/31] Drop unused EUpgradeDependencyHasLowerVersionDespiteUpgrade --- .../daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs index c1e6fb2636f8..2058e3f57c70 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs @@ -211,7 +211,6 @@ data UnwarnableError | EUpgradeTemplateAddedKey !TypeConName !TemplateKey | EUpgradeTriedToUpgradeIface !TypeConName | EUpgradeMissingImplementation !TypeConName !TypeConName - | EUpgradeDependencyHasLowerVersionDespiteUpgrade !PackageName !PackageVersion !PackageVersion deriving (Show) data WarnableError @@ -676,11 +675,6 @@ instance Pretty UnwarnableError where EUpgradeTemplateAddedKey template _key -> "The upgraded template " <> pPrint template <> " cannot add a key where it didn't have one previously." EUpgradeTriedToUpgradeIface iface -> "Tried to upgrade interface " <> pPrint iface <> ", but interfaces cannot be upgraded. They should be removed in any upgrading package." EUpgradeMissingImplementation tpl iface -> "Implementation of interface " <> pPrint iface <> " by template " <> pPrint tpl <> " appears in package that is being upgraded, but does not appear in this package." - EUpgradeDependencyHasLowerVersionDespiteUpgrade pkgName presentVersion pastVersion -> - vcat - [ "Dependency " <> pPrint pkgName <> " has version " <> pPrint presentVersion <> " on the upgrading package, which is older than version " <> pPrint pastVersion <> " on the upgraded package." - , "Dependency versions of upgrading packages must always be greater or equal to the dependency versions on upgraded packages." - ] instance Pretty UpgradedRecordOrigin where From 4fa4c33734a093d7867233efd9ffae06180c0573 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Thu, 29 Aug 2024 13:58:36 +0100 Subject: [PATCH 19/31] Replace TCMF (Version, UpgradeInfo) with synonym TcPreUpgradeM --- .../src/DA/Daml/LF/TypeChecker/Upgrade.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs index 13341d3a714c..3bdac345407b 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs @@ -33,6 +33,7 @@ import Data.Function (on) -- Allows us to split the world into upgraded and non-upgraded type TcUpgradeM = TcMF UpgradingEnv +type TcPreUpgradeM = TcMF (Version, UpgradeInfo) type UpgradingDeps = HMS.HashMap LF.PackageId (LF.PackageName, RawPackageVersion) @@ -55,7 +56,7 @@ runGammaUnderUpgrades Upgrading{ _past = pastAction, _present = presentAction } shouldTypecheck :: Version -> UpgradeInfo -> Bool shouldTypecheck version upgradeInfo = version `LF.supports` LF.featurePackageUpgrades && uiTypecheckUpgrades upgradeInfo -shouldTypecheckM :: TcMF (Version, UpgradeInfo) Bool +shouldTypecheckM :: TcPreUpgradeM Bool shouldTypecheckM = asks (uncurry shouldTypecheck) mkGamma :: Version -> UpgradeInfo -> World -> Gamma @@ -73,10 +74,10 @@ mkGamma version upgradeInfo world = in addBadIfaceSwapIndicator $ emptyGamma world version -gammaM :: World -> TcMF (Version, UpgradeInfo) Gamma +gammaM :: World -> TcPreUpgradeM Gamma gammaM world = asks (flip (uncurry mkGamma) world) -extractDiagnostics :: Version -> UpgradeInfo -> TcMF (Version, UpgradeInfo) () -> [Diagnostic] +extractDiagnostics :: Version -> UpgradeInfo -> TcPreUpgradeM () -> [Diagnostic] extractDiagnostics version upgradeInfo action = case runGammaF (version, upgradeInfo) action of Left err -> [toDiagnostic err] @@ -98,7 +99,7 @@ checkUpgrade pkg deps version upgradeInfo mbUpgradedPkg = checkUpgradeBoth Nothing pkg (upgradedPkg, deps) checkUpgradeSingle Nothing pkg -checkUpgradeBoth :: Maybe Context -> LF.Package -> ((LF.PackageId, LF.Package), UpgradingDeps) -> TcMF (Version, UpgradeInfo) () +checkUpgradeBoth :: Maybe Context -> LF.Package -> ((LF.PackageId, LF.Package), UpgradingDeps) -> TcPreUpgradeM () checkUpgradeBoth mbContext pkg ((upgradedPkgId, upgradedPkg), upgradingDeps) = let presentWorld = initWorldSelf [] pkg pastWorld = initWorldSelf [] upgradedPkg @@ -113,7 +114,7 @@ checkUpgradeBoth mbContext pkg ((upgradedPkgId, upgradedPkg), upgradingDeps) = withMbContext $ checkUpgradeM (UpgradedPackageId upgradedPkgId) (Upgrading upgradedPkg pkg) -checkUpgradeSingle :: Maybe Context -> LF.Package -> TcMF (Version, UpgradeInfo) () +checkUpgradeSingle :: Maybe Context -> LF.Package -> TcPreUpgradeM () checkUpgradeSingle mbContext pkg = let presentWorld = initWorldSelf [] pkg withMbContext :: TcM () -> TcM () @@ -153,7 +154,7 @@ checkModule world0 module_ deps version upgradeInfo mbUpgradedPkg = checkUpgradeDependenciesM :: [LF.DalfPackage] -> [(LF.PackageId, LF.Package)] - -> TcMF (Version, UpgradeInfo) UpgradingDeps + -> TcPreUpgradeM UpgradingDeps checkUpgradeDependenciesM presentDeps pastDeps = do initialUpgradeablePackageMap <- fmap (HMS.fromListWith (<>) . catMaybes) $ forM pastDeps $ \pastDep -> do @@ -199,7 +200,7 @@ checkUpgradeDependenciesM presentDeps pastDeps = do checkAllDeps :: HMS.HashMap LF.PackageName [(LF.RawPackageVersion, LF.PackageId, LF.Package)] -> [LF.DalfPackage] - -> TcMF (Version, UpgradeInfo) (HMS.HashMap LF.PackageName [(LF.RawPackageVersion, LF.PackageId, LF.Package)]) + -> TcPreUpgradeM (HMS.HashMap LF.PackageName [(LF.RawPackageVersion, LF.PackageId, LF.Package)]) checkAllDeps upgradeablePackageMap [] = pure upgradeablePackageMap checkAllDeps upgradeablePackageMap (pkg:rest) = do mbNewDep <- checkOneDep upgradeablePackageMap pkg @@ -212,7 +213,7 @@ checkUpgradeDependenciesM presentDeps pastDeps = do checkOneDep :: HMS.HashMap LF.PackageName [(LF.RawPackageVersion, LF.PackageId, LF.Package)] -> LF.DalfPackage - -> TcMF (Version, UpgradeInfo) (Maybe (LF.PackageName, (LF.RawPackageVersion, LF.PackageId, LF.Package))) + -> TcPreUpgradeM (Maybe (LF.PackageName, (LF.RawPackageVersion, LF.PackageId, LF.Package))) checkOneDep upgradeablePackageMap dalfPkg = do let LF.DalfPackage{dalfPackagePkg,dalfPackageId=presentPkgId} = dalfPkg presentPkg = extPackagePkg dalfPackagePkg From 0f5ccef4bc7439c89b12f309589f0aec6d6afcb3 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Thu, 29 Aug 2024 13:58:50 +0100 Subject: [PATCH 20/31] Remove equality checker --- .../src/DA/Daml/LF/TypeChecker/Upgrade.hs | 77 ++----------------- 1 file changed, 8 insertions(+), 69 deletions(-) diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs index 3bdac345407b..2c5ad8dc76c1 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs @@ -9,12 +9,11 @@ module DA.Daml.LF.TypeChecker.Upgrade ( ) where import Control.Monad (unless, forM, forM_, when) -import Control.Monad.Extra (allM, filterM) import Control.Monad.Reader (withReaderT) import Control.Monad.Reader.Class (asks) import Control.Lens hiding (Context) import DA.Daml.LF.Ast as LF -import DA.Daml.LF.Ast.Alpha (alphaExpr, AlphaEnv(..), initialAlphaEnv, alphaType', alphaTypeCon, bindTypeVar) +import DA.Daml.LF.Ast.Alpha (alphaExpr, AlphaEnv(..), initialAlphaEnv, alphaType', alphaTypeCon) import DA.Daml.LF.TypeChecker.Check (expandTypeSynonyms) import DA.Daml.LF.TypeChecker.Env import DA.Daml.LF.TypeChecker.Error @@ -145,8 +144,7 @@ checkModule world0 module_ deps version upgradeInfo mbUpgradedPkg = Nothing -> pure () Just pastModule -> do let upgradingModule = Upgrading { _past = pastModule, _present = module_ } - equalDataTypes <- structurallyEqualDataTypes upgradingModule - checkModuleM equalDataTypes upgradedPkgId upgradingModule + checkModuleM upgradedPkgId upgradingModule withReaderT (\(version, upgradeInfo) -> mkGamma version upgradeInfo world) $ do checkNewInterfacesAreUnused module_ checkNewInterfacesHaveNoTemplates module_ @@ -275,8 +273,7 @@ checkUpgradeDependenciesM presentDeps pastDeps = do checkUpgradeM :: LF.UpgradedPackageId -> Upgrading LF.Package -> TcUpgradeM () checkUpgradeM upgradedPackageId package = do (upgradedModules, _new) <- checkDeleted (EUpgradeMissingModule . NM.name) $ NM.toHashMap . packageModules <$> package - equalDataTypes <- structurallyEqualDataTypes package - forM_ upgradedModules $ checkModuleM equalDataTypes upgradedPackageId + forM_ upgradedModules $ checkModuleM upgradedPackageId extractDelExistNew :: (Eq k, Hashable k) @@ -331,14 +328,14 @@ throwIfNonEmpty handleError hm = ctxHandler $ diagnosticWithContextF present' err _ -> pure () -checkModuleM :: [LF.TypeConName] -> LF.UpgradedPackageId -> Upgrading LF.Module -> TcUpgradeM () -checkModuleM equalDataTypes upgradedPackageId module_ = do +checkModuleM :: LF.UpgradedPackageId -> Upgrading LF.Module -> TcUpgradeM () +checkModuleM upgradedPackageId module_ = do (existingTemplates, _new) <- checkDeleted (EUpgradeMissingTemplate . NM.name) $ NM.toHashMap . moduleTemplates <$> module_ forM_ existingTemplates $ \template -> withContextF present' (ContextTemplate (_present module_) (_present template) TPWhole) - (checkTemplate equalDataTypes module_ template) + (checkTemplate module_ template) -- For a datatype, derive its context let deriveChoiceInfo :: LF.Module -> HMS.HashMap LF.TypeConName (LF.Template, LF.TemplateChoice) @@ -537,8 +534,8 @@ instantiatedIfaces modules = foldl' (HMS.unionWith (<>)) HMS.empty $ (map . fmap , template <- NM.elems (moduleTemplates module_) ] -checkTemplate :: [LF.TypeConName] -> Upgrading Module -> Upgrading LF.Template -> TcUpgradeM () -checkTemplate _equalDataTypes module_ template = do +checkTemplate :: Upgrading Module -> Upgrading LF.Template -> TcUpgradeM () +checkTemplate module_ template = do -- Check that no choices have been removed (existingChoices, _existingNew) <- checkDeleted (EUpgradeMissingChoice . NM.name) $ NM.toHashMap . tplChoices <$> template forM_ existingChoices $ \choice -> do @@ -783,63 +780,5 @@ isUpgradedType type_ = do tconCheck pastT presentT = checkSelf pastT presentT || checkImport pastT presentT pure $ foldU (alphaType' initialAlphaEnv { tconEquivalence = tconCheck }) expandedTypes -isStructurallyEquivalentType :: AlphaEnv -> [TypeConName] -> Upgrading Type -> TcUpgradeM Bool -isStructurallyEquivalentType alphaEnv identicalCons type_ = do - expandedTypes <- runGammaUnderUpgrades (expandTypeSynonyms <$> type_) - let checkSelf t1 t2 = - and - [ qualPackage t1 == PRSelf - , qualPackage t2 == PRSelf - , qualObject t2 `elem` identicalCons - , alphaTypeCon t1 t2 - ] - checkImport t1 t2 = - qualPackage t1 /= PRSelf - && qualPackage t2 /= PRSelf - && alphaTypeCon t1 t2 - tconCheck t1 t2 = checkSelf t1 t2 || checkImport t1 t2 - pure $ foldU (alphaType' alphaEnv { tconEquivalence = tconCheck }) expandedTypes - removePkgId :: Qualified a -> Qualified a removePkgId a = a { qualPackage = PRSelf } - -isStructurallyEquivalentDatatype :: [TypeConName] -> Upgrading DefDataType -> TcUpgradeM Bool -isStructurallyEquivalentDatatype identicalCons datatype = - let params = dataParams <$> datatype - allKindsMatch = foldU (==) (map snd <$> params) - paramNames = unsafeZipUpgrading (map fst <$> params) - in - if not allKindsMatch - then pure False - else - let env = foldl' (flip (foldU bindTypeVar)) initialAlphaEnv paramNames - in - case fmap dataCons datatype of - Upgrading { _past = DataRecord _past, _present = DataRecord _present } -> do - let allFieldsMatch = map fst _past == map fst _present - let types = zipWith Upgrading (map snd _past) (map snd _present) - allTypesMatch <- allM (isStructurallyEquivalentType env identicalCons) types - pure (allFieldsMatch && allTypesMatch) - Upgrading { _past = DataVariant _past, _present = DataVariant _present } -> do - let allConNamesMatch = map fst _past == map fst _present - let types = zipWith Upgrading (map snd _past) (map snd _present) - allTypesMatch <- allM (isStructurallyEquivalentType env identicalCons) types - pure (allConNamesMatch && allTypesMatch) - Upgrading { _past = DataEnum _past, _present = DataEnum _present } -> do - pure $ _past == _present - _ -> - pure False - -structurallyEqualDataTypes :: HasModules a => Upgrading a -> TcUpgradeM [TypeConName] -structurallyEqualDataTypes hasModules = - let module_ = NM.toHashMap . getModules <$> hasModules - (_, existingModules, _) = extractDelExistNew module_ - (_, existingDatatypes, _) = foldMap (extractDelExistNew . fmap (NM.toHashMap . moduleDataTypes)) (HMS.elems existingModules) - in - go (HMS.toList existingDatatypes) - where - go :: [(TypeConName, Upgrading DefDataType)] -> TcUpgradeM [TypeConName] - go list = do - let names = map fst list - list' <- filterM (isStructurallyEquivalentDatatype names . snd) list - if names /= map fst list' then go list' else pure names From b4951cd7e9be999a98064000747241e2ff4725b7 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Thu, 29 Aug 2024 14:00:02 +0100 Subject: [PATCH 21/31] fix comment on key type --- .../daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs index 2c5ad8dc76c1..c74d50b9ef6f 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs @@ -591,7 +591,7 @@ checkTemplate module_ template = do Upgrading { _past = Just pastKey, _present = Just presentKey } -> do let tplKey = Upgrading pastKey presentKey - -- Key type musn't change + -- Key type must be a valid upgrade iset <- isUpgradedType (fmap tplKeyType tplKey) when (not iset) $ diagnosticWithContextF present' (EUpgradeTemplateChangedKeyType (NM.name (_present template))) From 86072a1081c72fdb13e2c4f3c6a1032dd64c5635 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Thu, 29 Aug 2024 17:44:16 +0100 Subject: [PATCH 22/31] Topologically sort packages for upgrade checks --- .../daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs | 19 +++++++++++++++++++ .../src/DA/Daml/LF/TypeChecker/Upgrade.hs | 11 +++++++++-- 2 files changed, 28 insertions(+), 2 deletions(-) diff --git a/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs b/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs index 4a1f2301e53d..59f88b078a6c 100644 --- a/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs +++ b/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs @@ -38,6 +38,25 @@ dvalType = snd . dvalBinder chcArgType :: TemplateChoice -> Type chcArgType = snd . chcArgBinder +-- Return topologically sorted packages, with the most recent package first +topoSortPackages :: [(PackageId, a, Package)] -> Either [(PackageId, a, Package)] [(PackageId, a, Package)] +topoSortPackages pkgs = + let toPkgNode x@(pkgId, _, pkg) = + ( x + , pkgId + , toListOf (packageRefs . _PRImport) pkg + ) + fromPkgNode (x, _pkgId, _deps) = x + sccs = G.stronglyConnCompR (map toPkgNode pkgs) + isAcyclic = \case + G.AcyclicSCC pkg -> Right pkg + -- A package referencing itself shouldn't happen, but is not an actually + -- problematic cycle and won't trip up the engine + G.CyclicSCC [pkg] -> Right pkg + G.CyclicSCC pkgCycle -> Left (map fromPkgNode pkgCycle) + in + map fromPkgNode <$> traverse isAcyclic sccs + topoSortPackage :: Package -> Either [ModuleName] Package topoSortPackage pkg@Package{packageModules = mods} = do let isLocal (pkgRef, modName) = case pkgRef of diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs index c74d50b9ef6f..66aa86ba5cad 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs @@ -174,8 +174,15 @@ checkUpgradeDependenciesM presentDeps pastDeps = do pure $ Just (packageName, [(rawVersion, pkgId, pkg)]) else pure Nothing - upgradeablePackageMap <- checkAllDeps initialUpgradeablePackageMap presentDeps - pure $ upgradeablePackageMapToDeps upgradeablePackageMap + let withIdAndPkg dalfPkg = (dalfPackageId dalfPkg, dalfPkg, extPackagePkg (dalfPackagePkg dalfPkg)) + withoutIdAndPkg (_, dalfPkg, _) = dalfPkg + case topoSortPackages (map withIdAndPkg presentDeps) of + Left _badTrace -> do + error "deps have a cycle" + Right sortedPresentDeps -> do + let dependenciesFirst = reverse (map withoutIdAndPkg sortedPresentDeps) + upgradeablePackageMap <- checkAllDeps initialUpgradeablePackageMap dependenciesFirst + pure $ upgradeablePackageMapToDeps upgradeablePackageMap where withPkgAsGamma pkg action = withReaderT (\(version, _) -> emptyGamma (initWorldSelf [] pkg) version) action From 5d05baf000fd6d39e4b0f5dcc799a87d9a496e94 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Thu, 29 Aug 2024 17:44:51 +0100 Subject: [PATCH 23/31] Add upgradedPkg to upgradingDeps --- .../daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs index 66aa86ba5cad..907d51a56991 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs @@ -94,7 +94,7 @@ checkUpgrade pkg deps version upgradeInfo mbUpgradedPkg = case mbUpgradedPkg of Nothing -> pure () Just (upgradedPkg, upgradingDeps) -> do - deps <- checkUpgradeDependenciesM deps upgradingDeps + deps <- checkUpgradeDependenciesM deps (upgradedPkg : upgradingDeps) checkUpgradeBoth Nothing pkg (upgradedPkg, deps) checkUpgradeSingle Nothing pkg @@ -135,9 +135,9 @@ checkModule world0 module_ deps version upgradeInfo mbUpgradedPkg = let world = extendWorldSelf module_ world0 case mbUpgradedPkg of Nothing -> pure () - Just ((upgradedPkgIdRaw, upgradedPkg), upgradingDeps) -> do + Just (upgradedPkgWithId@(upgradedPkgIdRaw, upgradedPkg), upgradingDeps) -> do let upgradedPkgId = UpgradedPackageId upgradedPkgIdRaw - deps <- checkUpgradeDependenciesM deps upgradingDeps -- TODO: Check if this causes quadratic blowup of dep checks + deps <- checkUpgradeDependenciesM deps (upgradedPkgWithId : upgradingDeps) -- TODO: Check if this causes quadratic blowup of dep checks let upgradingWorld = Upgrading { _past = initWorldSelf [] upgradedPkg, _present = world } withReaderT (\(version, upgradeInfo) -> UpgradingEnv (mkGamma version upgradeInfo <$> upgradingWorld) deps) $ case NM.lookup (NM.name module_) (LF.packageModules upgradedPkg) of From c719893a79bfb4e4f26be01d2542de6a38c18f1b Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Thu, 29 Aug 2024 17:47:40 +0100 Subject: [PATCH 24/31] Improve comment on topoSortPackages --- sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs b/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs index 59f88b078a6c..92cb028ab798 100644 --- a/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs +++ b/sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs @@ -38,7 +38,7 @@ dvalType = snd . dvalBinder chcArgType :: TemplateChoice -> Type chcArgType = snd . chcArgBinder --- Return topologically sorted packages, with the most recent package first +-- Return topologically sorted packages, with the top-level parent package first topoSortPackages :: [(PackageId, a, Package)] -> Either [(PackageId, a, Package)] [(PackageId, a, Package)] topoSortPackages pkgs = let toPkgNode x@(pkgId, _, pkg) = From 857a3046582c7c8cdb69b52c3cac2b1bbbabdec6 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Thu, 29 Aug 2024 18:00:29 +0100 Subject: [PATCH 25/31] Refer to performance issue on github --- .../daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs index 907d51a56991..942378b511f0 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs @@ -137,7 +137,8 @@ checkModule world0 module_ deps version upgradeInfo mbUpgradedPkg = Nothing -> pure () Just (upgradedPkgWithId@(upgradedPkgIdRaw, upgradedPkg), upgradingDeps) -> do let upgradedPkgId = UpgradedPackageId upgradedPkgIdRaw - deps <- checkUpgradeDependenciesM deps (upgradedPkgWithId : upgradingDeps) -- TODO: Check if this causes quadratic blowup of dep checks + -- TODO: https://github.com/digital-asset/daml/issues/19859 + deps <- checkUpgradeDependenciesM deps (upgradedPkgWithId : upgradingDeps) let upgradingWorld = Upgrading { _past = initWorldSelf [] upgradedPkg, _present = world } withReaderT (\(version, upgradeInfo) -> UpgradingEnv (mkGamma version upgradeInfo <$> upgradingWorld) deps) $ case NM.lookup (NM.name module_) (LF.packageModules upgradedPkg) of @@ -176,6 +177,8 @@ checkUpgradeDependenciesM presentDeps pastDeps = do let withIdAndPkg dalfPkg = (dalfPackageId dalfPkg, dalfPkg, extPackagePkg (dalfPackagePkg dalfPkg)) withoutIdAndPkg (_, dalfPkg, _) = dalfPkg + + -- TODO: https://github.com/digital-asset/daml/issues/19859 case topoSortPackages (map withIdAndPkg presentDeps) of Left _badTrace -> do error "deps have a cycle" From 73547e8a841322f541ce282f6b513f0499597671 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Thu, 29 Aug 2024 18:15:09 +0100 Subject: [PATCH 26/31] Add EUpgradeDependenciesFormACycle error --- .../daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs | 9 +++++++++ .../daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs | 7 +++++-- 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs index 2058e3f57c70..5d4e2514cf0a 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs @@ -211,6 +211,7 @@ data UnwarnableError | EUpgradeTemplateAddedKey !TypeConName !TemplateKey | EUpgradeTriedToUpgradeIface !TypeConName | EUpgradeMissingImplementation !TypeConName !TypeConName + | EUpgradeDependenciesFormACycle ![(PackageId, Maybe PackageMetadata)] deriving (Show) data WarnableError @@ -675,6 +676,14 @@ instance Pretty UnwarnableError where EUpgradeTemplateAddedKey template _key -> "The upgraded template " <> pPrint template <> " cannot add a key where it didn't have one previously." EUpgradeTriedToUpgradeIface iface -> "Tried to upgrade interface " <> pPrint iface <> ", but interfaces cannot be upgraded. They should be removed in any upgrading package." EUpgradeMissingImplementation tpl iface -> "Implementation of interface " <> pPrint iface <> " by template " <> pPrint tpl <> " appears in package that is being upgraded, but does not appear in this package." + EUpgradeDependenciesFormACycle deps -> + vcat + [ "Dependencies from the `upgrades:` field and dependencies defined on the current package form a cycle:" + , nest 2 $ vcat $ map pprintDep deps + ] + where + pprintDep (pkgId, Just meta) = pPrint pkgId <> "(" <> pPrint (packageName meta) <> ", " <> pPrint (packageVersion meta) <> ")" + pprintDep (pkgId, Nothing) = pPrint pkgId instance Pretty UpgradedRecordOrigin where diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs index 942378b511f0..b47095b3e5d2 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs @@ -180,8 +180,11 @@ checkUpgradeDependenciesM presentDeps pastDeps = do -- TODO: https://github.com/digital-asset/daml/issues/19859 case topoSortPackages (map withIdAndPkg presentDeps) of - Left _badTrace -> do - error "deps have a cycle" + Left badTrace -> do + let placeholderPkg = let (_, _, pkg) = head badTrace in pkg + getPkgIdAndMetadata (pkgId, _, pkg) = (pkgId, packageMetadata pkg) + withPkgAsGamma placeholderPkg $ + throwWithContext $ EUpgradeDependenciesFormACycle $ map getPkgIdAndMetadata badTrace Right sortedPresentDeps -> do let dependenciesFirst = reverse (map withoutIdAndPkg sortedPresentDeps) upgradeablePackageMap <- checkAllDeps initialUpgradeablePackageMap dependenciesFirst From b9b0b114ada0e3a657d459097a1800e30f2c75e4 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Fri, 30 Aug 2024 13:01:11 +0100 Subject: [PATCH 27/31] Track and run additional upgrade deps tests from participant on compiler --- sdk/compiler/damlc/tests/BUILD.bazel | 6 ++ .../damlc/tests/src/DA/Test/DamlcUpgrades.hs | 74 +++++++++++++++---- 2 files changed, 64 insertions(+), 16 deletions(-) diff --git a/sdk/compiler/damlc/tests/BUILD.bazel b/sdk/compiler/damlc/tests/BUILD.bazel index 5016f43408d8..05d421566229 100644 --- a/sdk/compiler/damlc/tests/BUILD.bazel +++ b/sdk/compiler/damlc/tests/BUILD.bazel @@ -508,6 +508,12 @@ da_haskell_test( "//test-common:upgrades-WarnsWhenTemplateChangesKeyMaintainers-files", "//test-common:upgrades-WarnsWhenTemplateChangesObservers-files", "//test-common:upgrades-WarnsWhenTemplateChangesSignatories-files", + "//test-common:upgrades-FailsWhenUpgradedFieldPackagesAreNotUpgradable-files", + "//test-common:upgrades-FailsWhenUpgradedFieldFromDifferentPackageName-files", + "//test-common:upgrades-SucceedsWhenATopLevelRecordAddsAnOptionalFieldAtTheEnd-v2.dar", + "//test-common:upgrades-SucceedsWhenATopLevelRecordAddsAnOptionalFieldAtTheEnd-v1.dar", + "//test-common:upgrades-FailsWhenUpgradedFieldFromDifferentPackageName-dep-name1.dar", + "//test-common:upgrades-FailsWhenUpgradedFieldFromDifferentPackageName-dep-name2.dar", ], hackage_deps = [ "base", diff --git a/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs b/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs index 2e895c0daf23..258cc51d1933 100644 --- a/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs +++ b/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs @@ -19,7 +19,7 @@ import SdkVersion (SdkVersioned, sdkVersion, withSdkVersions) import DA.Daml.LF.Ast.Version import Text.Regex.TDFA import qualified Data.Text as T -import Safe (fromJustNote) +import Data.Maybe (maybeToList) main :: IO () main = withSdkVersions $ do @@ -439,6 +439,24 @@ tests damlc = (SeparateDeps False) False setUpgradeField + , testWithAdditionalDars + "FailsWhenUpgradedFieldPackagesAreNotUpgradable" + (FailWithError "\ESC\\[0;91merror type checking data type ProjectMain.T:\n The upgraded data type T has changed the types of some of its original fields.") + versionDefault + NoDependencies + False + setUpgradeField + ["upgrades-SucceedsWhenATopLevelRecordAddsAnOptionalFieldAtTheEnd-v2.dar"] -- Note that dependencies are in different order + ["upgrades-SucceedsWhenATopLevelRecordAddsAnOptionalFieldAtTheEnd-v1.dar"] + , testWithAdditionalDars + "FailsWhenUpgradedFieldFromDifferentPackageName" + (FailWithError "\ESC\\[0;91merror type checking data type Main.A:\n The upgraded data type A has changed the types of some of its original fields.") + versionDefault + NoDependencies + False + setUpgradeField + ["upgrades-FailsWhenUpgradedFieldFromDifferentPackageName-dep-name1.dar"] + ["upgrades-FailsWhenUpgradedFieldFromDifferentPackageName-dep-name2.dar"] ] | setUpgradeField <- [True, False] ] ++ @@ -452,6 +470,8 @@ tests damlc = warnBadInterfaceInstances True doTypecheck + [] + [] , testGeneral (prefix <> "WhenAnInterfaceIsUsedInThePackageThatItsDefinedIn") "WarnsWhenAnInterfaceIsUsedInThePackageThatItsDefinedIn" @@ -461,6 +481,8 @@ tests damlc = warnBadInterfaceInstances True doTypecheck + [] + [] , testGeneral (prefix <> "WhenAnInterfaceIsDefinedAndThenUsedInAPackageThatUpgradesIt") "WarnsWhenAnInterfaceIsDefinedAndThenUsedInAPackageThatUpgradesIt" @@ -470,6 +492,8 @@ tests damlc = warnBadInterfaceInstances True doTypecheck + [] + [] ] | warnBadInterfaceInstances <- [True, False] , let prefix = if warnBadInterfaceInstances then "Warns" else "Fail" @@ -481,12 +505,9 @@ tests damlc = ] ) where + -- TODO: https://github.com/digital-asset/daml/issues/19862 versionDefault :: LF.Version - versionDefault = - maxMinorVersion LF.versionDefault $ LF.versionMinor $ - fromJustNote - "Expected at least one LF 1.x version to support package upgrades." - (LF.featureMinVersion LF.featurePackageUpgrades LF.V1) + versionDefault = version1_dev test :: String @@ -497,7 +518,19 @@ tests damlc = -> Bool -> TestTree test name expectation lfVersion sharedDep warnBadInterfaceInstances setUpgradeField = - testGeneral name name expectation lfVersion sharedDep warnBadInterfaceInstances setUpgradeField True + testGeneral name name expectation lfVersion sharedDep warnBadInterfaceInstances setUpgradeField True [] [] + + testWithAdditionalDars + :: String + -> Expectation + -> LF.Version + -> Dependency + -> Bool + -> Bool + -> [String] -> [String] + -> TestTree + testWithAdditionalDars name expectation lfVersion sharedDep warnBadInterfaceInstances setUpgradeField additionalDarsV1 additionalDarsV2 = + testGeneral name name expectation lfVersion sharedDep warnBadInterfaceInstances setUpgradeField True additionalDarsV1 additionalDarsV2 testGeneral :: String @@ -508,12 +541,13 @@ tests damlc = -> Bool -> Bool -> Bool + -> [String] -> [String] -> TestTree - testGeneral name location expectation lfVersion sharedDep warnBadInterfaceInstances setUpgradeField doTypecheck = + testGeneral name location expectation lfVersion sharedDep warnBadInterfaceInstances setUpgradeField doTypecheck additionalDarsV1 additionalDarsV2 = let upgradeFieldTrailer = if not setUpgradeField then " (no upgrades field)" else "" doTypecheckTrailer = if not doTypecheck then " (disable typechecking)" else "" in - testCase (name <> upgradeFieldTrailer <> doTypecheckTrailer) $ + testCase (name <> upgradeFieldTrailer <> doTypecheckTrailer) $ do withTempDir $ \dir -> do let newDir = dir "newVersion" let oldDir = dir "oldVersion" @@ -521,6 +555,7 @@ tests damlc = let oldDar = oldDir "old.dar" let testRunfile path = locateRunfiles (mainWorkspace "test-common/src/main/daml/upgrades" path) + let testAdditionaDarRunfile darName = locateRunfiles (mainWorkspace "test-common" darName) v1FilePaths <- listDirectory =<< testRunfile (location "v1") let oldVersion = flip map v1FilePaths $ \path -> @@ -542,7 +577,7 @@ tests damlc = ) let sharedDir = dir "shared" let sharedDar = sharedDir "out.dar" - writeFiles sharedDir (projectFile "0.0.1" ("upgrades-example-" <> location <> "-dep") Nothing Nothing : sharedDepFiles) + writeFiles sharedDir (projectFile "0.0.1" ("upgrades-example-" <> location <> "-dep") Nothing Nothing [] : sharedDepFiles) callProcessSilent damlc ["build", "--project-root", sharedDir, "-o", sharedDar] pure (Just sharedDar, Just sharedDar) SeparateDeps { shouldSwap } -> do @@ -553,7 +588,7 @@ tests damlc = ) let depV1Dir = dir "shared-v1" let depV1Dar = depV1Dir "out.dar" - writeFiles depV1Dir (projectFile "0.0.1" ("upgrades-example-" <> location <> "-dep") Nothing Nothing : depV1Files) + writeFiles depV1Dir (projectFile "0.0.1" ("upgrades-example-" <> location <> "-dep") Nothing Nothing [] : depV1Files) callProcessSilent damlc ["build", "--project-root", depV1Dir, "-o", depV1Dar] depV2FilePaths <- listDirectory =<< testRunfile (location "dep-v2") @@ -563,7 +598,7 @@ tests damlc = ) let depV2Dir = dir "shared-v2" let depV2Dar = depV2Dir "out.dar" - writeFiles depV2Dir (projectFile "0.0.2" ("upgrades-example-" <> location <> "-dep") Nothing Nothing : depV2Files) + writeFiles depV2Dir (projectFile "0.0.2" ("upgrades-example-" <> location <> "-dep") Nothing Nothing [] : depV2Files) callProcessSilent damlc ["build", "--project-root", depV2Dir, "-o", depV2Dar] if shouldSwap @@ -574,10 +609,12 @@ tests damlc = _ -> pure (Nothing, Nothing) - writeFiles oldDir (projectFile "0.0.1" ("upgrades-example-" <> location) Nothing depV1Dar : oldVersion) + v1AdditionalDarsRunFiles <- traverse testAdditionaDarRunfile additionalDarsV1 + writeFiles oldDir (projectFile "0.0.1" ("upgrades-example-" <> location) Nothing depV1Dar v1AdditionalDarsRunFiles : oldVersion) callProcessSilent damlc ["build", "--project-root", oldDir, "-o", oldDar] - writeFiles newDir (projectFile "0.0.2" ("upgrades-example-" <> location) (if setUpgradeField then Just oldDar else Nothing) depV2Dar : newVersion) + v2AdditionalDarsRunFiles <- traverse testAdditionaDarRunfile additionalDarsV2 + writeFiles newDir (projectFile "0.0.2" ("upgrades-example-" <> location) (if setUpgradeField then Just oldDar else Nothing) depV2Dar v2AdditionalDarsRunFiles : newVersion) case expectation of Succeed -> @@ -602,7 +639,7 @@ tests damlc = else when (matchTest compiledRegex stderr) $ assertFailure ("`daml build` succeeded, did not `upgrade:` field set, should NOT give a warning matching '" <> show regexWithSeverity <> "':\n" <> show stderr) where - projectFile version name upgradedFile mbDep = + projectFile version name upgradedFile mbDep darDeps = ( "daml.yaml" , pure $ unlines $ [ "sdk-version: " <> sdkVersion @@ -618,9 +655,14 @@ tests damlc = ++ [" - --typecheck-upgrades=no" | not doTypecheck] ++ [" - --warn-bad-interface-instances=yes" | warnBadInterfaceInstances ] ++ ["upgrades: '" <> path <> "'" | Just path <- pure upgradedFile] - ++ ["data-dependencies:\n - '" <> path <> "'" | Just path <- pure mbDep] + ++ renderDataDeps (maybeToList mbDep ++ darDeps) ) + renderDataDeps :: [String] -> [String] + renderDataDeps [] = [] + renderDataDeps paths = + ["data-dependencies:"] ++ [" - '" <> path <> "'" | path <- paths] + writeFiles dir fs = for_ fs $ \(file, ioContent) -> do content <- ioContent From 7bfdc37d6f6bbde8e3cf88d9d08f7aca427bf981 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Fri, 30 Aug 2024 13:02:27 +0100 Subject: [PATCH 28/31] lint --- sdk/compiler/damlc/tests/BUILD.bazel | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/sdk/compiler/damlc/tests/BUILD.bazel b/sdk/compiler/damlc/tests/BUILD.bazel index 05d421566229..eb88f754f5ce 100644 --- a/sdk/compiler/damlc/tests/BUILD.bazel +++ b/sdk/compiler/damlc/tests/BUILD.bazel @@ -471,6 +471,10 @@ da_haskell_test( "//test-common:upgrades-FailsWhenTemplateChoiceChangesItsReturnType-files", "//test-common:upgrades-FailsWhenTemplateRemovesKeyType-files", "//test-common:upgrades-FailsWhenTwoDeeplyNestedTypeSynonymsResolveToDifferentDatatypes-files", + "//test-common:upgrades-FailsWhenUpgradedFieldFromDifferentPackageName-dep-name1.dar", + "//test-common:upgrades-FailsWhenUpgradedFieldFromDifferentPackageName-dep-name2.dar", + "//test-common:upgrades-FailsWhenUpgradedFieldFromDifferentPackageName-files", + "//test-common:upgrades-FailsWhenUpgradedFieldPackagesAreNotUpgradable-files", "//test-common:upgrades-FailsWithSynonymReturnTypeChange-files", "//test-common:upgrades-FailsWithSynonymReturnTypeChangeInSeparatePackage-files", "//test-common:upgrades-MissingChoice-files", @@ -481,6 +485,8 @@ da_haskell_test( "//test-common:upgrades-SucceedWhenATopLevelEnumAddsAField-files", "//test-common:upgrades-SucceedsWhenATopLevelEnumChanges-files", "//test-common:upgrades-SucceedsWhenATopLevelRecordAddsAnOptionalFieldAtTheEnd-files", + "//test-common:upgrades-SucceedsWhenATopLevelRecordAddsAnOptionalFieldAtTheEnd-v1.dar", + "//test-common:upgrades-SucceedsWhenATopLevelRecordAddsAnOptionalFieldAtTheEnd-v2.dar", "//test-common:upgrades-SucceedsWhenATopLevelTypeSynonymChanges-files", "//test-common:upgrades-SucceedsWhenATopLevelVariantAddsAVariant-files", "//test-common:upgrades-SucceedsWhenATopLevelVariantAddsAnOptionalFieldToAVariantsType-files", @@ -508,12 +514,6 @@ da_haskell_test( "//test-common:upgrades-WarnsWhenTemplateChangesKeyMaintainers-files", "//test-common:upgrades-WarnsWhenTemplateChangesObservers-files", "//test-common:upgrades-WarnsWhenTemplateChangesSignatories-files", - "//test-common:upgrades-FailsWhenUpgradedFieldPackagesAreNotUpgradable-files", - "//test-common:upgrades-FailsWhenUpgradedFieldFromDifferentPackageName-files", - "//test-common:upgrades-SucceedsWhenATopLevelRecordAddsAnOptionalFieldAtTheEnd-v2.dar", - "//test-common:upgrades-SucceedsWhenATopLevelRecordAddsAnOptionalFieldAtTheEnd-v1.dar", - "//test-common:upgrades-FailsWhenUpgradedFieldFromDifferentPackageName-dep-name1.dar", - "//test-common:upgrades-FailsWhenUpgradedFieldFromDifferentPackageName-dep-name2.dar", ], hackage_deps = [ "base", From 937214318e5f3c18d4e7002f1fee9f7f6357b66f Mon Sep 17 00:00:00 2001 From: Paul Brauner <141240651+paulbrauner-da@users.noreply.github.com> Date: Mon, 26 Aug 2024 12:33:15 +0200 Subject: [PATCH 29/31] Forbid adding new interface instances to the upgraded version of a template (#19817) * Forbid adding new interface instances to the upgraded version of a template * allow adding new instances to new templates --- sdk/compiler/damlc/tests/BUILD.bazel | 4 +- .../damlc/tests/src/DA/Test/DamlcUpgrades.hs | 4 +- sdk/daml-lf/validation/BUILD.bazel | 14 ++++--- .../daml/lf/validation/Upgrading.scala | 39 +++++++++++++----- .../validation/upgrade/UpgradesSpecBase.scala | 40 +++++++++++++++---- sdk/test-common/BUILD.bazel | 25 +++++++++--- .../dep/Dep.daml | 0 .../v1/Main.daml | 0 .../v2/Main.daml | 0 .../v1/Main.daml | 0 .../v2/Main.daml | 2 +- .../dep/Dep.daml | 9 +++++ .../v1/Main.daml | 7 ++++ .../v2/Main.daml | 14 +++++++ .../v1/Main.daml | 7 ++++ .../v2/Main.daml | 21 ++++++++++ 16 files changed, 152 insertions(+), 34 deletions(-) rename sdk/test-common/src/main/daml/upgrades/{SucceedsWhenAnInstanceIsAddedSeparateDep => FailsWhenAnInstanceIsAddedSeparateDep}/dep/Dep.daml (100%) rename sdk/test-common/src/main/daml/upgrades/{SucceedsWhenAnInstanceIsAddedSeparateDep => FailsWhenAnInstanceIsAddedSeparateDep}/v1/Main.daml (100%) rename sdk/test-common/src/main/daml/upgrades/{SucceedsWhenAnInstanceIsAddedSeparateDep => FailsWhenAnInstanceIsAddedSeparateDep}/v2/Main.daml (100%) rename sdk/test-common/src/main/daml/upgrades/{SucceedsWhenAnInstanceIsAddedUpgradedPackage => FailsWhenAnInstanceIsAddedUpgradedPackage}/v1/Main.daml (100%) rename sdk/test-common/src/main/daml/upgrades/{SucceedsWhenAnInstanceIsAddedUpgradedPackage => FailsWhenAnInstanceIsAddedUpgradedPackage}/v2/Main.daml (78%) create mode 100644 sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep/dep/Dep.daml create mode 100644 sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep/v1/Main.daml create mode 100644 sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep/v2/Main.daml create mode 100644 sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedToNewTemplateUpgradedPackage/v1/Main.daml create mode 100644 sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedToNewTemplateUpgradedPackage/v2/Main.daml diff --git a/sdk/compiler/damlc/tests/BUILD.bazel b/sdk/compiler/damlc/tests/BUILD.bazel index eb88f754f5ce..ee029e46c291 100644 --- a/sdk/compiler/damlc/tests/BUILD.bazel +++ b/sdk/compiler/damlc/tests/BUILD.bazel @@ -455,6 +455,8 @@ da_haskell_test( "//test-common:upgrades-FailsWhenATopLevelVariantAddsAFieldToAVariantsType-files", "//test-common:upgrades-FailsWhenATopLevelVariantAddsAVariant-files", "//test-common:upgrades-FailsWhenATopLevelVariantRemovesAVariant-files", + "//test-common:upgrades-FailsWhenAnInstanceIsAddedSeparateDep-files", + "//test-common:upgrades-FailsWhenAnInstanceIsAddedUpgradedPackage-files", "//test-common:upgrades-FailsWhenAnInstanceIsDropped-files", "//test-common:upgrades-FailsWhenAnInterfaceIsDefinedInAnUpgradingPackageWhenItWasAlreadyInThePriorPackage-files", "//test-common:upgrades-FailsWhenDatatypeChangesVariety-files", @@ -490,8 +492,6 @@ da_haskell_test( "//test-common:upgrades-SucceedsWhenATopLevelTypeSynonymChanges-files", "//test-common:upgrades-SucceedsWhenATopLevelVariantAddsAVariant-files", "//test-common:upgrades-SucceedsWhenATopLevelVariantAddsAnOptionalFieldToAVariantsType-files", - "//test-common:upgrades-SucceedsWhenAnInstanceIsAddedSeparateDep-files", - "//test-common:upgrades-SucceedsWhenAnInstanceIsAddedUpgradedPackage-files", "//test-common:upgrades-SucceedsWhenAnInterfaceIsOnlyDefinedInTheInitialPackage-files", "//test-common:upgrades-SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes-files", "//test-common:upgrades-SucceedsWhenNewFieldWithOptionalTypeIsAddedToTemplate-files", diff --git a/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs b/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs index 258cc51d1933..c99d9b284ad0 100644 --- a/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs +++ b/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs @@ -314,14 +314,14 @@ tests damlc = False setUpgradeField , test - "SucceedsWhenAnInstanceIsAddedSeparateDep" + "FailsWhenAnInstanceIsAddedSeparateDep" Succeed versionDefault SeparateDep False setUpgradeField , test - "SucceedsWhenAnInstanceIsAddedUpgradedPackage" + "FailsWhenAnInstanceIsAddedUpgradedPackage" Succeed versionDefault DependOnV1 diff --git a/sdk/daml-lf/validation/BUILD.bazel b/sdk/daml-lf/validation/BUILD.bazel index c0b23f3bdf3e..db018d1aac5b 100644 --- a/sdk/daml-lf/validation/BUILD.bazel +++ b/sdk/daml-lf/validation/BUILD.bazel @@ -259,11 +259,15 @@ da_scala_test_suite( "//test-common:upgrades-FailsWhenAnInstanceIsDropped-v2.dar", "//test-common:upgrades-FailsWhenAnInterfaceIsDefinedInAnUpgradingPackageWhenItWasAlreadyInThePriorPackage-v1.dar", "//test-common:upgrades-FailsWhenAnInterfaceIsDefinedInAnUpgradingPackageWhenItWasAlreadyInThePriorPackage-v2.dar", - "//test-common:upgrades-SucceedsWhenAnInstanceIsAddedSeparateDep-dep.dar", - "//test-common:upgrades-SucceedsWhenAnInstanceIsAddedSeparateDep-v1.dar", - "//test-common:upgrades-SucceedsWhenAnInstanceIsAddedSeparateDep-v2.dar", - "//test-common:upgrades-SucceedsWhenAnInstanceIsAddedUpgradedPackage-v1.dar", - "//test-common:upgrades-SucceedsWhenAnInstanceIsAddedUpgradedPackage-v2.dar", + "//test-common:upgrades-FailsWhenAnInstanceIsAddedSeparateDep-dep.dar", + "//test-common:upgrades-FailsWhenAnInstanceIsAddedSeparateDep-v1.dar", + "//test-common:upgrades-FailsWhenAnInstanceIsAddedSeparateDep-v2.dar", + "//test-common:upgrades-FailsWhenAnInstanceIsAddedUpgradedPackage-v1.dar", + "//test-common:upgrades-FailsWhenAnInstanceIsAddedUpgradedPackage-v2.dar", + "//test-common:upgrades-SucceedsWhenAnInstanceIsAddedToNewTemplateUpgradedPackage-v1.dar", + "//test-common:upgrades-SucceedsWhenAnInstanceIsAddedToNewTemplateUpgradedPackage-v2.dar", + "//test-common:upgrades-SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep-v1.dar", + "//test-common:upgrades-SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep-v2.dar", "//test-common:upgrades-SucceedsWhenATopLevelVariantAddsAVariant-v1.dar", "//test-common:upgrades-SucceedsWhenATopLevelVariantAddsAVariant-v2.dar", "//test-common:upgrades-FailsWhenDatatypeChangesVariety-v1.dar", diff --git a/sdk/daml-lf/validation/src/main/scala/com/digitalasset/daml/lf/validation/Upgrading.scala b/sdk/daml-lf/validation/src/main/scala/com/digitalasset/daml/lf/validation/Upgrading.scala index 0f7f6eae21e1..83fd0b06108a 100644 --- a/sdk/daml-lf/validation/src/main/scala/com/digitalasset/daml/lf/validation/Upgrading.scala +++ b/sdk/daml-lf/validation/src/main/scala/com/digitalasset/daml/lf/validation/Upgrading.scala @@ -196,6 +196,11 @@ object UpgradeError { override def message: String = s"Implementation of interface $iface by template $tpl appears in package that is being upgraded, but does not appear in this package." } + + final case class ForbiddenNewInstance(tpl: Ref.DottedName, iface: Ref.TypeConName) extends Error { + override def message: String = + s"Implementation of interface $iface by template $tpl appears in this package, but does not appear in package that is being upgraded." + } } sealed abstract class UpgradedRecordOrigin @@ -604,7 +609,7 @@ case class TypecheckUpgrades( val moduleWithMetadata = module.map(ModuleWithMetadata) for { - (existingTemplates, _new) <- checkDeleted( + (existingTemplates, newTemplates) <- checkDeleted( module.map(_.templates), (name: Ref.DottedName, _: Ast.Template) => UpgradeError.MissingTemplate(name), ) @@ -613,15 +618,13 @@ case class TypecheckUpgrades( (_ifaceDel, ifaceExisting, _ifaceNew) = extractDelExistNew(ifaceDts) _ <- checkContinuedIfaces(ifaceExisting) - (_instanceExisting, _instanceNew) <- - checkDeleted( - module.map(flattenInstances(_)), - (tplImpl: (Ref.DottedName, Ref.TypeConName), _: (Ast.Template, Ast.TemplateImplements)) => - { - val (tpl, impl) = tplImpl - UpgradeError.MissingImplementation(tpl, impl) - }, - ) + (instanceDel, _instanceExisting, instanceNew) = extractDelExistNew( + module.map(flattenInstances) + ) + _ <- checkDeletedInstances(instanceDel) + _ <- checkAddedInstances(instanceNew.view.filterKeys { case (tyCon, _) => + !newTemplates.contains(tyCon) + }.toMap) (existingDatatypes, _new) <- checkDeleted( unownedDts, @@ -643,6 +646,22 @@ case class TypecheckUpgrades( ).map(_ => ()) } + private def checkDeletedInstances( + deletedInstances: Map[(Ref.DottedName, TypeConName), (Ast.Template, Ast.TemplateImplements)] + ): Try[Unit] = + deletedInstances.headOption match { + case Some(((tpl, iface), _)) => fail(UpgradeError.MissingImplementation(tpl, iface)) + case None => Success(()) + } + + private def checkAddedInstances( + newInstances: Map[(Ref.DottedName, TypeConName), (Ast.Template, Ast.TemplateImplements)] + ): Try[Unit] = + newInstances.headOption match { + case Some(((tpl, iface), _)) => fail(UpgradeError.ForbiddenNewInstance(tpl, iface)) + case None => Success(()) + } + private def checkTemplate( templateAndName: (Ref.DottedName, Upgrading[Ast.Template]) ): Try[Unit] = { diff --git a/sdk/daml-lf/validation/src/test/scala/com/digitalasset/daml/lf/validation/upgrade/UpgradesSpecBase.scala b/sdk/daml-lf/validation/src/test/scala/com/digitalasset/daml/lf/validation/upgrade/UpgradesSpecBase.scala index a442736ec9f0..405e131fd92a 100644 --- a/sdk/daml-lf/validation/src/test/scala/com/digitalasset/daml/lf/validation/upgrade/UpgradesSpecBase.scala +++ b/sdk/daml-lf/validation/src/test/scala/com/digitalasset/daml/lf/validation/upgrade/UpgradesSpecBase.scala @@ -719,23 +719,47 @@ trait LongTests { this: UpgradesSpec => } yield result } - "Succeeds when an instance is added (separate dep)." in { + "Fails when an instance is added (separate dep)." in { for { - _ <- uploadPackage("test-common/upgrades-SucceedsWhenAnInstanceIsAddedSeparateDep-dep.dar") + _ <- uploadPackage("test-common/upgrades-FailsWhenAnInstanceIsAddedSeparateDep-dep.dar") result <- testPackagePair( - "test-common/upgrades-SucceedsWhenAnInstanceIsAddedSeparateDep-v1.dar", - "test-common/upgrades-SucceedsWhenAnInstanceIsAddedSeparateDep-v2.dar", + "test-common/upgrades-FailsWhenAnInstanceIsAddedSeparateDep-v1.dar", + "test-common/upgrades-FailsWhenAnInstanceIsAddedSeparateDep-v2.dar", assertPackageUpgradeCheck( - None + Some( + "Implementation of interface .*:Dep:I by template T appears in this package, but does not appear in package that is being upgraded." + ) ), ) } yield result } - "Succeeds when an instance is added (upgraded package)." in { + "Fails when an instance is added (upgraded package)." in { + testPackagePair( + "test-common/upgrades-FailsWhenAnInstanceIsAddedUpgradedPackage-v1.dar", + "test-common/upgrades-FailsWhenAnInstanceIsAddedUpgradedPackage-v2.dar", + assertPackageUpgradeCheck( + Some( + "Implementation of interface .*:Main:I by template T appears in this package, but does not appear in package that is being upgraded." + ) + ), + ) + } + + "Succeeds when an instance is added to a new template (upgraded package)." in { + testPackagePair( + "test-common/upgrades-SucceedsWhenAnInstanceIsAddedToNewTemplateUpgradedPackage-v1.dar", + "test-common/upgrades-SucceedsWhenAnInstanceIsAddedToNewTemplateUpgradedPackage-v2.dar", + assertPackageUpgradeCheck( + None + ), + ) + } + + "Succeeds when an instance is added to a new template (separate dep)." in { testPackagePair( - "test-common/upgrades-SucceedsWhenAnInstanceIsAddedUpgradedPackage-v1.dar", - "test-common/upgrades-SucceedsWhenAnInstanceIsAddedUpgradedPackage-v2.dar", + "test-common/upgrades-SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep-v1.dar", + "test-common/upgrades-SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep-v2.dar", assertPackageUpgradeCheck( None ), diff --git a/sdk/test-common/BUILD.bazel b/sdk/test-common/BUILD.bazel index f7d5a35ed894..0b23501aeb07 100644 --- a/sdk/test-common/BUILD.bazel +++ b/sdk/test-common/BUILD.bazel @@ -218,7 +218,8 @@ da_scala_dar_resources_library( for identifier in [ # More more more tests ported from DamlcUpgrades.hs "FailsWhenAnInstanceIsDropped", - "SucceedsWhenAnInstanceIsAddedSeparateDep", + "FailsWhenAnInstanceIsAddedSeparateDep", + "SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep", ] ] @@ -442,12 +443,24 @@ da_scala_dar_resources_library( ("FailsWhenAnInterfaceIsDefinedInAnUpgradingPackageWhenItWasAlreadyInThePriorPackage", {}, {}), ("SucceedsWhenAnInterfaceIsOnlyDefinedInTheInitialPackage", {}, {}), ( - "SucceedsWhenAnInstanceIsAddedUpgradedPackage", + "FailsWhenAnInstanceIsAddedUpgradedPackage", {}, {"data_dependencies": [ - "//test-common:upgrades-SucceedsWhenAnInstanceIsAddedUpgradedPackage-v1.dar", + "//test-common:upgrades-FailsWhenAnInstanceIsAddedUpgradedPackage-v1.dar", ]}, ), + ( + "SucceedsWhenAnInstanceIsAddedToNewTemplateUpgradedPackage", + {}, + {"data_dependencies": [ + "//test-common:upgrades-SucceedsWhenAnInstanceIsAddedToNewTemplateUpgradedPackage-v1.dar", + ]}, + ), + ( + "SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep", + {"data_dependencies": ["//test-common:upgrades-SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep-dep.dar"]}, + {"data_dependencies": ["//test-common:upgrades-SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep-dep.dar"]}, + ), ( "WarnsWhenAnInterfaceIsDefinedAndThenUsedInAPackageThatUpgradesIt", {}, @@ -461,9 +474,9 @@ da_scala_dar_resources_library( {"data_dependencies": ["//test-common:upgrades-FailsWhenAnInstanceIsDropped-dep.dar"]}, ), ( - "SucceedsWhenAnInstanceIsAddedSeparateDep", - {"data_dependencies": ["//test-common:upgrades-SucceedsWhenAnInstanceIsAddedSeparateDep-dep.dar"]}, - {"data_dependencies": ["//test-common:upgrades-SucceedsWhenAnInstanceIsAddedSeparateDep-dep.dar"]}, + "FailsWhenAnInstanceIsAddedSeparateDep", + {"data_dependencies": ["//test-common:upgrades-FailsWhenAnInstanceIsAddedSeparateDep-dep.dar"]}, + {"data_dependencies": ["//test-common:upgrades-FailsWhenAnInstanceIsAddedSeparateDep-dep.dar"]}, ), ("FailsOnlyInModuleNotInReexports", {}, {}), ("FailsWithSynonymReturnTypeChange", {}, {}), diff --git a/sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedSeparateDep/dep/Dep.daml b/sdk/test-common/src/main/daml/upgrades/FailsWhenAnInstanceIsAddedSeparateDep/dep/Dep.daml similarity index 100% rename from sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedSeparateDep/dep/Dep.daml rename to sdk/test-common/src/main/daml/upgrades/FailsWhenAnInstanceIsAddedSeparateDep/dep/Dep.daml diff --git a/sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedSeparateDep/v1/Main.daml b/sdk/test-common/src/main/daml/upgrades/FailsWhenAnInstanceIsAddedSeparateDep/v1/Main.daml similarity index 100% rename from sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedSeparateDep/v1/Main.daml rename to sdk/test-common/src/main/daml/upgrades/FailsWhenAnInstanceIsAddedSeparateDep/v1/Main.daml diff --git a/sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedSeparateDep/v2/Main.daml b/sdk/test-common/src/main/daml/upgrades/FailsWhenAnInstanceIsAddedSeparateDep/v2/Main.daml similarity index 100% rename from sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedSeparateDep/v2/Main.daml rename to sdk/test-common/src/main/daml/upgrades/FailsWhenAnInstanceIsAddedSeparateDep/v2/Main.daml diff --git a/sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedUpgradedPackage/v1/Main.daml b/sdk/test-common/src/main/daml/upgrades/FailsWhenAnInstanceIsAddedUpgradedPackage/v1/Main.daml similarity index 100% rename from sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedUpgradedPackage/v1/Main.daml rename to sdk/test-common/src/main/daml/upgrades/FailsWhenAnInstanceIsAddedUpgradedPackage/v1/Main.daml diff --git a/sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedUpgradedPackage/v2/Main.daml b/sdk/test-common/src/main/daml/upgrades/FailsWhenAnInstanceIsAddedUpgradedPackage/v2/Main.daml similarity index 78% rename from sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedUpgradedPackage/v2/Main.daml rename to sdk/test-common/src/main/daml/upgrades/FailsWhenAnInstanceIsAddedUpgradedPackage/v2/Main.daml index 64b9290843a6..19deb58e7247 100644 --- a/sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedUpgradedPackage/v2/Main.daml +++ b/sdk/test-common/src/main/daml/upgrades/FailsWhenAnInstanceIsAddedUpgradedPackage/v2/Main.daml @@ -2,7 +2,7 @@ -- SPDX-License-Identifier: Apache-2.0 module Main where -import qualified "upgrades-example-SucceedsWhenAnInstanceIsAddedUpgradedPackage" Main as V1 +import qualified "upgrades-example-FailsWhenAnInstanceIsAddedUpgradedPackage" Main as V1 template T with p: Party where diff --git a/sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep/dep/Dep.daml b/sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep/dep/Dep.daml new file mode 100644 index 000000000000..2c284d1f67e9 --- /dev/null +++ b/sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep/dep/Dep.daml @@ -0,0 +1,9 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Dep where +data IView = IView { i : Text } +interface I where + viewtype IView + method1 : Int + diff --git a/sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep/v1/Main.daml b/sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep/v1/Main.daml new file mode 100644 index 000000000000..fe1679ab0670 --- /dev/null +++ b/sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep/v1/Main.daml @@ -0,0 +1,7 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Main where + +-- We need a dummy datatype for the package to have a name +data Dummy = Dummy {} \ No newline at end of file diff --git a/sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep/v2/Main.daml b/sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep/v2/Main.daml new file mode 100644 index 000000000000..7bfad20cc2e6 --- /dev/null +++ b/sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep/v2/Main.daml @@ -0,0 +1,14 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Main where +import Dep +template T with + p: Party + where + signatory p + interface instance I for T where + view = IView "hi" + method1 = 2 + +data Dummy = Dummy {} \ No newline at end of file diff --git a/sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedToNewTemplateUpgradedPackage/v1/Main.daml b/sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedToNewTemplateUpgradedPackage/v1/Main.daml new file mode 100644 index 000000000000..fe1679ab0670 --- /dev/null +++ b/sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedToNewTemplateUpgradedPackage/v1/Main.daml @@ -0,0 +1,7 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Main where + +-- We need a dummy datatype for the package to have a name +data Dummy = Dummy {} \ No newline at end of file diff --git a/sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedToNewTemplateUpgradedPackage/v2/Main.daml b/sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedToNewTemplateUpgradedPackage/v2/Main.daml new file mode 100644 index 000000000000..5315b04884cf --- /dev/null +++ b/sdk/test-common/src/main/daml/upgrades/SucceedsWhenAnInstanceIsAddedToNewTemplateUpgradedPackage/v2/Main.daml @@ -0,0 +1,21 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Main where +import qualified "upgrades-example-SucceedsWhenAnInstanceIsAddedToNewTemplateUpgradedPackage" Main as V1 + +data Dummy = Dummy {} + +template T with + p: Party + where + signatory p + interface instance I for T where + view = IView "hi" + method1 = 1 + +data IView = IView { i : Text } + +interface I where + viewtype IView + method1 : Int From a817a6beb35b699e8cdf8cbff7a91d25af921f2b Mon Sep 17 00:00:00 2001 From: Paul Brauner <141240651+paulbrauner-da@users.noreply.github.com> Date: Mon, 26 Aug 2024 16:03:25 +0200 Subject: [PATCH 30/31] [compiler] forbid adding new interface instances to the upgraded version of a template (#19820) * [compiler] forbid adding new interface instances to the upgraded version of a template * allow adding new instances to new templates * add two more tests --- .../src/DA/Daml/LF/TypeChecker/Error.hs | 3 +- .../src/DA/Daml/LF/TypeChecker/Upgrade.hs | 40 +++++++++++++++---- sdk/compiler/damlc/tests/BUILD.bazel | 3 +- .../damlc/tests/src/DA/Test/DamlcUpgrades.hs | 16 +++++++- sdk/test-common/BUILD.bazel | 7 ---- .../v1/Main.daml | 9 ----- .../v2/Main.daml | 14 ------- 7 files changed, 51 insertions(+), 41 deletions(-) delete mode 100644 sdk/test-common/src/main/daml/upgrades/WarnsWhenAnInterfaceIsDefinedAndThenUsedInAPackageThatUpgradesIt/v1/Main.daml delete mode 100644 sdk/test-common/src/main/daml/upgrades/WarnsWhenAnInterfaceIsDefinedAndThenUsedInAPackageThatUpgradesIt/v2/Main.daml diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs index 5d4e2514cf0a..391082529f4f 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs @@ -211,6 +211,7 @@ data UnwarnableError | EUpgradeTemplateAddedKey !TypeConName !TemplateKey | EUpgradeTriedToUpgradeIface !TypeConName | EUpgradeMissingImplementation !TypeConName !TypeConName + | EForbiddenNewImplementation !TypeConName !TypeConName | EUpgradeDependenciesFormACycle ![(PackageId, Maybe PackageMetadata)] deriving (Show) @@ -676,6 +677,7 @@ instance Pretty UnwarnableError where EUpgradeTemplateAddedKey template _key -> "The upgraded template " <> pPrint template <> " cannot add a key where it didn't have one previously." EUpgradeTriedToUpgradeIface iface -> "Tried to upgrade interface " <> pPrint iface <> ", but interfaces cannot be upgraded. They should be removed in any upgrading package." EUpgradeMissingImplementation tpl iface -> "Implementation of interface " <> pPrint iface <> " by template " <> pPrint tpl <> " appears in package that is being upgraded, but does not appear in this package." + EForbiddenNewImplementation tpl iface -> "Implementation of interface " <> pPrint iface <> " by template " <> pPrint tpl <> " appears in this package, but does not appear in package that is being upgraded." EUpgradeDependenciesFormACycle deps -> vcat [ "Dependencies from the `upgrades:` field and dependencies defined on the current package form a cycle:" @@ -685,7 +687,6 @@ instance Pretty UnwarnableError where pprintDep (pkgId, Just meta) = pPrint pkgId <> "(" <> pPrint (packageName meta) <> ", " <> pPrint (packageVersion meta) <> ")" pprintDep (pkgId, Nothing) = pPrint pkgId - instance Pretty UpgradedRecordOrigin where pPrint = \case TemplateBody tpl -> "template " <> pPrint tpl diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs index b47095b3e5d2..0386a68a1b67 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs @@ -343,7 +343,7 @@ throwIfNonEmpty handleError hm = checkModuleM :: LF.UpgradedPackageId -> Upgrading LF.Module -> TcUpgradeM () checkModuleM upgradedPackageId module_ = do - (existingTemplates, _new) <- checkDeleted (EUpgradeMissingTemplate . NM.name) $ NM.toHashMap . moduleTemplates <$> module_ + (existingTemplates, newTemplates) <- checkDeleted (EUpgradeMissingTemplate . NM.name) $ NM.toHashMap . moduleTemplates <$> module_ forM_ existingTemplates $ \template -> withContextF present' @@ -431,13 +431,11 @@ checkModuleM upgradedPackageId module_ = do | template <- NM.elems (moduleTemplates module_) , implementation <- NM.elems (tplImplements template) ] - (_instanceExisting, instanceNew) <- - checkDeletedWithContext - (\(tpl, impl) -> - ( ContextTemplate (_present module_) tpl TPWhole - , EUpgradeMissingImplementation (NM.name tpl) (LF.qualObject (NM.name impl)) - )) - (flattenInstances <$> module_) + let (instanceDel, _instanceExisting, instanceNew) = extractDelExistNew (flattenInstances <$> module_) + let notANewTemplate (tyCon, _) _ = not (HMS.member tyCon newTemplates) + checkDeletedInstances (_present module_) instanceDel + checkAddedInstances (_present module_) (HMS.filterWithKey notANewTemplate instanceNew) + checkUpgradedInterfacesAreUnused upgradedPackageId (_present module_) instanceNew -- checkDeleted should only trigger on datatypes not belonging to templates or choices or interfaces, which we checked above @@ -455,6 +453,32 @@ checkModuleM upgradedPackageId module_ = do let (presentOrigin, context) = _present origin withContextF present' context $ checkDefDataType presentOrigin dt +checkDeletedInstances :: + Module -> + HMS.HashMap (TypeConName, Qualified TypeConName) (Template, TemplateImplements) -> + TcUpgradeM () +checkDeletedInstances module_ instances = throwIfNonEmpty handleError instances + where + handleError :: + (Template, TemplateImplements) -> (Maybe Context, UnwarnableError) + handleError (tpl, impl) = + ( Just (ContextTemplate module_ tpl TPWhole) + , EUpgradeMissingImplementation (NM.name tpl) (LF.qualObject (NM.name impl)) + ) + +checkAddedInstances :: + Module -> + HMS.HashMap (TypeConName, Qualified TypeConName) (Template, TemplateImplements) -> + TcUpgradeM () +checkAddedInstances module_ instances = throwIfNonEmpty handleError instances + where + handleError :: + (Template, TemplateImplements) -> (Maybe Context, UnwarnableError) + handleError (tpl, impl) = + ( Just (ContextTemplate module_ tpl TPWhole) + , EForbiddenNewImplementation (NM.name tpl) (LF.qualObject (NM.name impl)) + ) + -- It is always invalid to keep an interface in an upgrade checkContinuedIfaces :: Upgrading Module diff --git a/sdk/compiler/damlc/tests/BUILD.bazel b/sdk/compiler/damlc/tests/BUILD.bazel index ee029e46c291..536d0840d28e 100644 --- a/sdk/compiler/damlc/tests/BUILD.bazel +++ b/sdk/compiler/damlc/tests/BUILD.bazel @@ -492,6 +492,8 @@ da_haskell_test( "//test-common:upgrades-SucceedsWhenATopLevelTypeSynonymChanges-files", "//test-common:upgrades-SucceedsWhenATopLevelVariantAddsAVariant-files", "//test-common:upgrades-SucceedsWhenATopLevelVariantAddsAnOptionalFieldToAVariantsType-files", + "//test-common:upgrades-SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep-files", + "//test-common:upgrades-SucceedsWhenAnInstanceIsAddedToNewTemplateUpgradedPackage-files", "//test-common:upgrades-SucceedsWhenAnInterfaceIsOnlyDefinedInTheInitialPackage-files", "//test-common:upgrades-SucceedsWhenDepsDowngradeVersionsWithoutUsingDatatypes-files", "//test-common:upgrades-SucceedsWhenNewFieldWithOptionalTypeIsAddedToTemplate-files", @@ -504,7 +506,6 @@ da_haskell_test( "//test-common:upgrades-TemplateChangedKeyType2-files", "//test-common:upgrades-ValidUpgrade-files", "//test-common:upgrades-WarnsWhenAnInterfaceAndATemplateAreDefinedInTheSamePackage-files", - "//test-common:upgrades-WarnsWhenAnInterfaceIsDefinedAndThenUsedInAPackageThatUpgradesIt-files", "//test-common:upgrades-WarnsWhenAnInterfaceIsUsedInThePackageThatItsDefinedIn-files", "//test-common:upgrades-WarnsWhenControllersOfTemplateChoiceAreChanged-files", "//test-common:upgrades-WarnsWhenObserversOfTemplateChoiceAreChanged-files", diff --git a/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs b/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs index c99d9b284ad0..6604ea7ca752 100644 --- a/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs +++ b/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs @@ -315,13 +315,27 @@ tests damlc = setUpgradeField , test "FailsWhenAnInstanceIsAddedSeparateDep" - Succeed + (FailWithError "\ESC\\[0;91merror type checking template Main.T :\n Implementation of interface I by template T appears in this package, but does not appear in package that is being upgraded.") versionDefault SeparateDep False setUpgradeField , test "FailsWhenAnInstanceIsAddedUpgradedPackage" + (FailWithError "\ESC\\[0;91merror type checking template Main.T :\n Implementation of interface I by template T appears in this package, but does not appear in package that is being upgraded.") + versionDefault + DependOnV1 + True + setUpgradeField + , test + "SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep" + Succeed + versionDefault + SeparateDep + False + setUpgradeField + , test + "SucceedsWhenAnInstanceIsAddedToNewTemplateUpgradedPackage" Succeed versionDefault DependOnV1 diff --git a/sdk/test-common/BUILD.bazel b/sdk/test-common/BUILD.bazel index 0b23501aeb07..e728ad3f04a8 100644 --- a/sdk/test-common/BUILD.bazel +++ b/sdk/test-common/BUILD.bazel @@ -461,13 +461,6 @@ da_scala_dar_resources_library( {"data_dependencies": ["//test-common:upgrades-SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep-dep.dar"]}, {"data_dependencies": ["//test-common:upgrades-SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep-dep.dar"]}, ), - ( - "WarnsWhenAnInterfaceIsDefinedAndThenUsedInAPackageThatUpgradesIt", - {}, - {"data_dependencies": [ - "//test-common:upgrades-WarnsWhenAnInterfaceIsDefinedAndThenUsedInAPackageThatUpgradesIt-v1.dar", - ]}, - ), ( "FailsWhenAnInstanceIsDropped", {"data_dependencies": ["//test-common:upgrades-FailsWhenAnInstanceIsDropped-dep.dar"]}, diff --git a/sdk/test-common/src/main/daml/upgrades/WarnsWhenAnInterfaceIsDefinedAndThenUsedInAPackageThatUpgradesIt/v1/Main.daml b/sdk/test-common/src/main/daml/upgrades/WarnsWhenAnInterfaceIsDefinedAndThenUsedInAPackageThatUpgradesIt/v1/Main.daml deleted file mode 100644 index 2a757470c530..000000000000 --- a/sdk/test-common/src/main/daml/upgrades/WarnsWhenAnInterfaceIsDefinedAndThenUsedInAPackageThatUpgradesIt/v1/Main.daml +++ /dev/null @@ -1,9 +0,0 @@ --- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -module Main where -data IView = IView { i : Text } -interface I where - viewtype IView - method1 : Int - diff --git a/sdk/test-common/src/main/daml/upgrades/WarnsWhenAnInterfaceIsDefinedAndThenUsedInAPackageThatUpgradesIt/v2/Main.daml b/sdk/test-common/src/main/daml/upgrades/WarnsWhenAnInterfaceIsDefinedAndThenUsedInAPackageThatUpgradesIt/v2/Main.daml deleted file mode 100644 index 1cdbcf1688e8..000000000000 --- a/sdk/test-common/src/main/daml/upgrades/WarnsWhenAnInterfaceIsDefinedAndThenUsedInAPackageThatUpgradesIt/v2/Main.daml +++ /dev/null @@ -1,14 +0,0 @@ --- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -module Main where -import qualified "upgrades-example-WarnsWhenAnInterfaceIsDefinedAndThenUsedInAPackageThatUpgradesIt" Main as V1 -data IView = IView { i : Text } -template T with - p: Party - where - signatory p - interface instance V1.I for T where - view = V1.IView "hi" - method1 = 2 - From 917420e1a96ef692d3630c2502385977ac52bba9 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Mon, 2 Sep 2024 10:42:28 +0100 Subject: [PATCH 31/31] Drop test that Paul removed and I accidentally added back --- sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs b/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs index 6604ea7ca752..7c7ff29fa60b 100644 --- a/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs +++ b/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs @@ -497,17 +497,6 @@ tests damlc = doTypecheck [] [] - , testGeneral - (prefix <> "WhenAnInterfaceIsDefinedAndThenUsedInAPackageThatUpgradesIt") - "WarnsWhenAnInterfaceIsDefinedAndThenUsedInAPackageThatUpgradesIt" - (expectation "type checking template Main.T interface instance [0-9a-f]+:Main:I for Main:T:\n The template T has implemented interface I, which is defined in a previous version of this package.") - versionDefault - DependOnV1 - warnBadInterfaceInstances - True - doTypecheck - [] - [] ] | warnBadInterfaceInstances <- [True, False] , let prefix = if warnBadInterfaceInstances then "Warns" else "Fail"