Check that keys are upgradeable (2.9.x) (#19666)

Structural equality was not implemented in the end because upgrade rules changed to allow keys to upgraded and because there were bugs in the structural equality implementation for per-module typechecking.

Also port Paul's #19817 and #19820

---------

Co-authored-by: Paul Brauner <[email protected]>

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,10 @@ 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)
+    -- ^ 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
@@ -77,7 +86,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 +484,7 @@ initialAlphaEnv = AlphaEnv
     , boundTypeVarsRhs = Map.empty
     , boundExprVarsLhs = Map.empty
     , boundExprVarsRhs = Map.empty
+    , tconEquivalence = alphaTypeCon
     }
 
 alphaType :: Type -> Type -> Bool

sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs

@@ -1,26 +1,33 @@
 -- 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)
 
 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
@@ -31,6 +38,25 @@ dvalType = snd . dvalBinder
 chcArgType :: TemplateChoice -> Type
 chcArgType = snd . chcArgBinder
 
+-- 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) =
+        ( 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
@@ -47,6 +73,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
@@ -327,3 +367,62 @@ 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 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 $ RawPackageVersion versions
+
+newtype RawPackageVersion = RawPackageVersion [Integer]
+
+padEquivalent :: RawPackageVersion -> RawPackageVersion -> ([Integer], [Integer])
+padEquivalent (RawPackageVersion v1Pieces) (RawPackageVersion v2Pieces) =
+  let pad xs target =
+        take
+          (length target `max` length xs)
+          (xs ++ repeat 0)
+  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
+
+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)

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 { cduPkgName, cduPkgVersion, cduIsDependency }, _) -> ContextDefUpgrading cduPkgName cduPkgVersion newCtx cduIsDependency
+        (_, _) -> newCtx
 
 instance SomeErrorOrWarning UnwarnableError where
   diagnosticWithContextF = throwWithContextF

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
@@ -39,6 +40,12 @@ data Context
   | ContextDefValue !Module !DefValue
   | ContextDefException !Module !DefException
   | ContextDefInterface !Module !DefInterface !InterfacePart
+  | 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
@@ -204,12 +211,16 @@ data UnwarnableError
   | EUpgradeTemplateAddedKey !TypeConName !TemplateKey
   | EUpgradeTriedToUpgradeIface !TypeConName
   | EUpgradeMissingImplementation !TypeConName !TypeConName
+  | EForbiddenNewImplementation !TypeConName !TypeConName
+  | EUpgradeDependenciesFormACycle ![(PackageId, Maybe PackageMetadata)]
   deriving (Show)
 
 data WarnableError
   = WEUpgradeShouldDefineIfacesAndTemplatesSeparately
   | WEUpgradeShouldDefineIfaceWithoutImplementation !TypeConName ![TypeConName]
   | WEUpgradeShouldDefineTplInSeparatePackage !TypeConName !TypeConName
+  | WEDependencyHasUnparseableVersion !PackageName !PackageVersion !PackageUpgradeOrigin
+  | WEDependencyHasNoMetadataDespiteUpgradeability !PackageId !PackageUpgradeOrigin
   deriving (Show)
 
 instance Pretty WarnableError where
@@ -235,6 +246,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."
         ]
+    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
@@ -254,6 +277,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
@@ -304,6 +328,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 { cduPkgName, cduPkgVersion, cduSubContext, cduIsDependency } ->
+      let prettyPkgName =
+            if cduIsDependency
+            then "dependency " <> T.unpack (unPackageName cduPkgName)
+            else T.unpack (unPackageName cduPkgName)
+      in
+      "upgrading " <> prettyPkgName <> " " <> show (_present cduPkgVersion) <> ", " <> show cduSubContext
 
 instance Show TemplatePart where
   show = \case
@@ -368,11 +399,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
@@ -650,6 +677,15 @@ 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:"
+        , 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
   pPrint = \case
@@ -659,24 +695,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 "<none>"
+      header $ string "<none>"
     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 { 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 cduPkgVersion)), "is a valid", upgradeOrDowngrade, "of version", string (show (_past cduPkgVersion)) ]
+      , nest 2 $
+        prettyWithContext cduSubContext warningOrErr
+      ]
 
 class ToDiagnostic a where
   toDiagnostic :: a -> Diagnostic
@@ -728,11 +782,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."