digital-asset/daml
1
1
Fork 0
mirror of https://github.com/digital-asset/daml.git synced 2024-09-19 08:48:21 +03:00
Code Issues Projects Releases Wiki Activity

Upgrade validation warnings to errors flag (#19259)

Browse Source 
* Split errors into errors that can turn into warnings (or vice versa)

* Add warn-bad-interface-instances flag

* fix compilation errors, finish implementation of swap

* Add tests for warn-bad-interface-instances flag

* Bump - try to rebuild?

run-all-tests: true

* Don't do single-package checks if typecheck-upgrades: true

* Fix tests that break on warn-bad-interface-instances

* Lint

* Move WEWarningToError to Error type, remove commented code

Also:
- Mark integration tests as flaky again
- Whitespace

* Check errors & warns aren't emitted when upgrades/typechecking disabled

* Update error message & expected error message
This commit is contained in:
dylant-da 2024-07-10 15:44:29 +01:00 committed by GitHub
parent 34034d3d0e
commit 069f1c060a
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
17 changed files with 765 additions and 476 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
sdk/compiler/daml-lf-tools/BUILD.bazel
View File

@ -28,6 +28,7 @@ da_haskell_library(
deps = [
"//compiler/daml-lf-ast",
"//compiler/damlc/daml-lf-util",
"//compiler/damlc/daml-opts:daml-opts-types",
"//libs-haskell/da-hs-base",
],
)

8
sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Check.hs
View File

@ -64,7 +64,7 @@ import DA.Daml.LF.TypeChecker.Error
-- | Check that a list does /not/ contain duplicate elements.
checkUnique :: (MonadGamma m, Eq a, Hashable a) => (a -> Error) -> [a] -> m ()
checkUnique :: (MonadGamma m, Eq a, Hashable a) => (a -> UnwarnableError) -> [a] -> m ()
checkUnique mkDuplicateError xs = void (foldlM step HS.empty xs)
where
step acc x
@ -338,7 +338,7 @@ typeOfRecUpd typ0 field record update = do
fieldType <- match _Just (EUnknownField field typ1) (lookup field recordType)
checkExpr record typ1
catchAndRethrow
(\case
(overUnwarnable $ \case
ETypeMismatch { foundType, expectedType, expr } ->
EFieldTypeMismatch
{ targetRecord = typ1
@ -1019,7 +1019,7 @@ checkInterfaceInstance tmplParam iiHead iiBody = do
Nothing -> throwWithContext (EUnknownMethodInInterfaceInstance iiInterface iiTemplate iiMethodName)
Just InterfaceMethod{ifmType} ->
catchAndRethrow
(\case
(overUnwarnable $ \case
ETypeMismatch { foundType, expectedType, expr } ->
EMethodTypeMismatch
{ emtmIfaceName = iiInterface
@ -1034,7 +1034,7 @@ checkInterfaceInstance tmplParam iiHead iiBody = do
-- check view result type matches interface result type
catchAndRethrow
(\case
(overUnwarnable $ \case
ETypeMismatch { foundType, expectedType, expr } ->
EViewTypeMismatch
{ evtmIfaceName = iiInterface

88
sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Env.hs
View File

@ -15,6 +15,7 @@ module DA.Daml.LF.TypeChecker.Env(
TcMF,
throwWithContext, throwWithContextF,
warnWithContext, warnWithContextF,
diagnosticWithContext,
catchAndRethrow,
inWorld,
match,
@ -27,8 +28,11 @@ module DA.Daml.LF.TypeChecker.Env(
getLfVersion,
getWorld,
runGamma, runGammaF,
Gamma,
emptyGamma
Gamma(..),
emptyGamma,
SomeErrorOrWarning(..),
addDiagnosticSwapIndicator,
withDiagnosticSwapIndicatorF,
) where
import Control.Lens hiding (Context)
@ -52,13 +56,36 @@ data Gamma = Gamma
-- ^ The packages in scope.
, _lfVersion :: Version
-- ^ The Daml-LF version of the package being type checked.
, _diagnosticSwapIndicator :: Either WarnableError Warning -> Bool
-- ^ Function for relaxing errors into warnings and strictifying warnings into errors
}
makeLenses ''Gamma
class SomeErrorOrWarning d where
diagnosticWithContextF :: forall m gamma. MonadGammaF gamma m => Getter gamma Gamma -> d -> m ()
getLfVersion :: MonadGamma m => m Version
getLfVersion = view lfVersion
getDiagnosticSwapIndicatorF :: forall m gamma. MonadGammaF gamma m => Getter gamma Gamma -> m (Either WarnableError Warning -> Bool)
getDiagnosticSwapIndicatorF getter = view (getter . diagnosticSwapIndicator)
addDiagnosticSwapIndicator
:: (Either WarnableError Warning -> Maybe Bool)
-> Gamma -> Gamma
addDiagnosticSwapIndicator newIndicator =
diagnosticSwapIndicator %~ \oldIndicator err ->
case newIndicator err of
Nothing -> oldIndicator err
Just verdict -> verdict
withDiagnosticSwapIndicatorF
:: MonadGammaF gamma m
=> Setter' gamma Gamma -> (Either WarnableError Warning -> Maybe Bool) -> m () -> m ()
withDiagnosticSwapIndicatorF setter newIndicator =
locally setter (addDiagnosticSwapIndicator newIndicator)
getWorld :: MonadGamma m => m World
getWorld = view world
@ -84,13 +111,13 @@ runGammaF gamma act = runStateT (runReaderT act gamma) []
-- | Helper function which tries to match on a prism and fails with a provided
-- error in case is does not match.
match :: MonadGamma m => Prism' a b -> Error -> a -> m b
match :: MonadGamma m => Prism' a b -> UnwarnableError -> a -> m b
match p e x = either (const (throwWithContext e)) pure (matching p x)
-- | Environment containing only the packages in scope but no type or term
-- variables.
emptyGamma :: World -> Version -> Gamma
emptyGamma = Gamma ContextNone mempty mempty
emptyGamma world version = Gamma ContextNone mempty mempty world version (const False)
-- | Run a computation in the current environment extended by a new type
-- variable/kind binding. Does not fail on shadowing.
@ -125,31 +152,54 @@ inWorld look = do
Left e -> throwWithContext (EUnknownDefinition e)
Right x -> pure x
throwWithContext :: MonadGamma m => Error -> m a
throwWithContext err = do
ctx <- view locCtx
throwError $ EContext ctx err
diagnosticWithContext :: (SomeErrorOrWarning d, MonadGamma m) => d -> m ()
diagnosticWithContext = diagnosticWithContextF id
throwWithContext :: MonadGamma m => UnwarnableError -> m a
throwWithContext = throwWithContextF id
warnWithContext :: MonadGamma m => Warning -> m ()
warnWithContext warning = do
ctx <- view locCtx
modify' (WContext ctx warning :)
warnWithContext = warnWithContextF id
withContext :: MonadGamma m => Context -> m b -> m b
withContext ctx = local (set locCtx ctx)
withContext = withContextF id
catchAndRethrow :: MonadGamma m => (Error -> Error) -> m b -> m b
catchAndRethrow handler mb = catchError mb $ throwWithContext . handler
catchAndRethrow handler mb = catchError mb $ throwWithContextFRaw id . handler
throwWithContextF :: MonadGammaF gamma m => Getter gamma Gamma -> Error -> m a
throwWithContextF getter err = do
throwWithContextF :: forall m gamma a. MonadGammaF gamma m => Getter gamma Gamma -> UnwarnableError -> m a
throwWithContextF getter err = throwWithContextFRaw getter (EUnwarnableError err)
throwWithContextFRaw :: forall m gamma a. MonadGammaF gamma m => Getter gamma Gamma -> Error -> m a
throwWithContextFRaw getter err = do
ctx <- view $ getter . locCtx
throwError $ EContext ctx err
warnWithContextF :: MonadGammaF gamma m => Getter gamma Gamma -> Warning -> m ()
warnWithContextF getter warning = do
ctx <- view $ getter . locCtx
modify' (WContext ctx warning :)
warnWithContextF :: forall m gamma. MonadGammaF gamma m => Getter gamma Gamma -> Warning -> m ()
warnWithContextF = diagnosticWithContextF
withContextF :: MonadGammaF gamma m => Setter' gamma Gamma -> Context -> m b -> m b
withContextF setter ctx = local (set (setter . locCtx) ctx)
instance SomeErrorOrWarning UnwarnableError where
diagnosticWithContextF = throwWithContextF
instance SomeErrorOrWarning WarnableError where
diagnosticWithContextF getter err = do
shouldSwap <- getDiagnosticSwapIndicatorF getter
if shouldSwap (Left err)
then do
ctx <- view $ getter . locCtx
modify' (WContext ctx (WErrorToWarning err) :)
else do
throwWithContextFRaw getter (EWarnableError err)
instance SomeErrorOrWarning Warning where
diagnosticWithContextF getter warning = do
shouldSwap <- getDiagnosticSwapIndicatorF getter
if shouldSwap (Right warning)
then do
throwWithContextFRaw getter (EWarningToError warning)
else do
ctx <- view $ getter . locCtx
modify' (WContext ctx warning :)

189
sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs
View File

@ -4,7 +4,9 @@
module DA.Daml.LF.TypeChecker.Error(
Context(..),
Error(..),
UpgradeError(..),
overUnwarnable,
UnwarnableError(..),
WarnableError(..),
TemplatePart(..),
InterfacePart(..),
UnserializabilityReason(..),
@ -61,6 +63,7 @@ data SerializabilityRequirement
| SRDataType
| SRExceptionArg
| SRView
deriving (Show)
-- | Reason why a type is not serializable.
data UnserializabilityReason
@ -90,8 +93,20 @@ data UnserializabilityReason
| URTypeSyn -- ^ It contains a type synonym.
| URExperimental -- ^ It contains a experimental type
| URInterface -- ^ It constains an interface
deriving (Show)
data Error
= EUnwarnableError !UnwarnableError
| EWarnableError !WarnableError
| EWarningToError !Warning
| EContext !Context !Error
deriving (Show)
overUnwarnable :: (UnwarnableError -> UnwarnableError) -> Error -> Error
overUnwarnable f (EUnwarnableError e) = EUnwarnableError (f e)
overUnwarnable _ x = x
data UnwarnableError
= EUnknownTypeVar !TypeVarName
| EUnknownExprVar !ExprVarName
| EUnknownDefinition !LookupError
@ -143,7 +158,6 @@ data Error
| EDataTypeCycle ![TypeConName] -- TODO: implement check for this error
| EValueCycle ![ExprValName]
| EImpredicativePolymorphism !Type
| EContext !Context !Error
| EKeyOperationOnTemplateWithNoKey !(Qualified TypeConName)
| EUnsupportedFeature !Feature
| EForbiddenNameCollision !T.Text ![T.Text]
@ -163,35 +177,62 @@ data Error
| EMissingMethodInInterfaceInstance !MethodName
| EUnknownMethodInInterfaceInstance { eumiiIface :: !(Qualified TypeConName), eumiiTpl :: !(Qualified TypeConName), eumiiMethodName :: !MethodName }
| EWrongInterfaceRequirement !(Qualified TypeConName) !(Qualified TypeConName)
| EUpgradeError !UpgradeError
| EUnknownExperimental !T.Text !Type
| EUpgradeMissingModule !ModuleName
| EUpgradeMissingTemplate !TypeConName
| EUpgradeMissingChoice !ChoiceName
| EUpgradeMissingDataCon !TypeConName
| EUpgradeMismatchDataConsVariety !TypeConName
| EUpgradeRecordFieldsMissing !UpgradedRecordOrigin
| EUpgradeRecordFieldsExistingChanged !UpgradedRecordOrigin
| EUpgradeRecordFieldsNewNonOptional !UpgradedRecordOrigin
| EUpgradeRecordFieldsOrderChanged !UpgradedRecordOrigin
| EUpgradeVariantAddedVariant !UpgradedRecordOrigin
| EUpgradeVariantRemovedVariant !UpgradedRecordOrigin
| EUpgradeVariantChangedVariantType !UpgradedRecordOrigin
| EUpgradeVariantAddedVariantField !UpgradedRecordOrigin
| EUpgradeVariantVariantsOrderChanged !UpgradedRecordOrigin
| EUpgradeEnumAddedVariant !UpgradedRecordOrigin
| EUpgradeEnumRemovedVariant !UpgradedRecordOrigin
| EUpgradeEnumVariantsOrderChanged !UpgradedRecordOrigin
| EUpgradeRecordChangedOrigin !TypeConName !UpgradedRecordOrigin !UpgradedRecordOrigin
| EUpgradeTemplateChangedKeyType !TypeConName
| EUpgradeChoiceChangedReturnType !ChoiceName
| EUpgradeTemplateRemovedKey !TypeConName !TemplateKey
| EUpgradeTemplateAddedKey !TypeConName !TemplateKey
| EUpgradeTriedToUpgradeIface !TypeConName
| EUpgradeMissingImplementation !TypeConName !TypeConName
deriving (Show)
data UpgradeError
= MissingModule !ModuleName
| MissingTemplate !TypeConName
| MissingChoice !ChoiceName
| MissingDataCon !TypeConName
| MismatchDataConsVariety !TypeConName
| RecordFieldsMissing !UpgradedRecordOrigin
| RecordFieldsExistingChanged !UpgradedRecordOrigin
| RecordFieldsNewNonOptional !UpgradedRecordOrigin
| RecordFieldsOrderChanged !UpgradedRecordOrigin
| VariantAddedVariant !UpgradedRecordOrigin
| VariantRemovedVariant !UpgradedRecordOrigin
| VariantChangedVariantType !UpgradedRecordOrigin
| VariantAddedVariantField !UpgradedRecordOrigin
| VariantVariantsOrderChanged !UpgradedRecordOrigin
| EnumAddedVariant !UpgradedRecordOrigin
| EnumRemovedVariant !UpgradedRecordOrigin
| EnumVariantsOrderChanged !UpgradedRecordOrigin
| RecordChangedOrigin !TypeConName !UpgradedRecordOrigin !UpgradedRecordOrigin
| TemplateChangedKeyType !TypeConName
| ChoiceChangedReturnType !ChoiceName
| TemplateRemovedKey !TypeConName !TemplateKey
| TemplateAddedKey !TypeConName !TemplateKey
| TriedToUpgradeIface !TypeConName
| MissingImplementation !TypeConName !TypeConName
deriving (Eq, Ord, Show)
data WarnableError
= WEUpgradeShouldDefineIfacesAndTemplatesSeparately
| WEUpgradeShouldDefineIfaceWithoutImplementation !TypeConName ![TypeConName]
| WEUpgradeShouldDefineTplInSeparatePackage !TypeConName !TypeConName
deriving (Show)
instance Pretty WarnableError where
pPrint = \case
WEUpgradeShouldDefineIfacesAndTemplatesSeparately ->
vsep
[ "This package defines both interfaces and templates. This may make this package and its dependents not upgradeable."
, "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."
]
WEUpgradeShouldDefineIfaceWithoutImplementation iface implementingTemplates ->
vsep $ concat
[ [ "The interface " <> pPrint iface <> " was defined in this package and implemented in this package by the following templates:" ]
, map (quotes . pPrint) implementingTemplates
, [ "This may make this package and its dependents not upgradeable." ]
, [ "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." ]
]
WEUpgradeShouldDefineTplInSeparatePackage tpl iface ->
vsep
[ "The template " <> pPrint tpl <> " has implemented interface " <> pPrint iface <> ", which is defined in a previous version of this package."
, "This may make this package and its dependents not upgradeable."
, "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."
]
data UpgradedRecordOrigin
= TemplateBody TypeConName
@ -318,12 +359,17 @@ instance Pretty UnserializabilityReason where
instance Pretty Error where
pPrint = \case
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)
]
instance Pretty UnwarnableError where
pPrint = \case
EUnknownTypeVar v -> "unknown type variable: " <> pretty v
EUnknownExprVar v -> "unknown expr variable: " <> pretty v
EUnknownDefinition e -> pretty e
@ -565,36 +611,32 @@ instance Pretty Error where
text "Tried to implement method " <> quotes (pretty eumiiMethodName) <> text ", but interface " <> pretty eumiiIface <> text " does not have a method with that name."
EWrongInterfaceRequirement requiringIface requiredIface ->
"Interface " <> pretty requiringIface <> " does not require interface " <> pretty requiredIface
EUpgradeError upgradeError -> pPrint upgradeError
EUnknownExperimental name ty ->
"Unknown experimental primitive " <> string (show name) <> " : " <> pretty ty
instance Pretty UpgradeError where
pPrint = \case
MissingModule moduleName -> "Module " <> pPrint moduleName <> " appears in package that is being upgraded, but does not appear in this package."
MissingTemplate templateName -> "Template " <> pPrint templateName <> " appears in package that is being upgraded, but does not appear in this package."
MissingChoice templateName -> "Choice " <> pPrint templateName <> " appears in package that is being upgraded, but does not appear in this package."
MissingDataCon dataConName -> "Data type " <> pPrint dataConName <> " appears in package that is being upgraded, but does not appear in this package."
MismatchDataConsVariety dataConName -> "EUpgradeMismatchDataConsVariety " <> pretty dataConName
RecordFieldsMissing origin -> "The upgraded " <> pPrint origin <> " is missing some of its original fields."
RecordFieldsExistingChanged origin -> "The upgraded " <> pPrint origin <> " has changed the types of some of its original fields."
RecordFieldsNewNonOptional origin -> "The upgraded " <> pPrint origin <> " has added new fields, but those fields are not Optional."
RecordFieldsOrderChanged origin -> "The upgraded " <> pPrint origin <> " has changed the order of its fields - any new fields must be added at the end of the record."
VariantAddedVariant origin -> "The upgraded " <> pPrint origin <> " has added a new variant."
VariantRemovedVariant origin -> "The upgraded " <> pPrint origin <> " has removed an existing variant."
VariantChangedVariantType origin -> "The upgraded " <> pPrint origin <> " has changed the type of a variant."
VariantAddedVariantField origin -> "The upgraded " <> pPrint origin <> " has added a field."
VariantVariantsOrderChanged origin -> "The upgraded " <> pPrint origin <> " has changed the order of its variants - any new variant must be added at the end of the variant."
EnumAddedVariant origin -> "The upgraded " <> pPrint origin <> " has added a new variant."
EnumRemovedVariant origin -> "The upgraded " <> pPrint origin <> " has removed an existing variant."
EnumVariantsOrderChanged origin -> "The upgraded " <> pPrint origin <> " has changed the order of its variants - any new variant must be added at the end of the enum."
RecordChangedOrigin dataConName past present -> "The record " <> pPrint dataConName <> " has changed origin from " <> pPrint past <> " to " <> pPrint present
ChoiceChangedReturnType choice -> "The upgraded choice " <> pPrint choice <> " cannot change its return type."
TemplateChangedKeyType templateName -> "The upgraded template " <> pPrint templateName <> " cannot change its key type."
TemplateRemovedKey templateName _key -> "The upgraded template " <> pPrint templateName <> " cannot remove its key."
TemplateAddedKey template _key -> "The upgraded template " <> pPrint template <> " cannot add a key where it didn't have one previously."
TriedToUpgradeIface iface -> "Tried to upgrade interface " <> pPrint iface <> ", but interfaces cannot be upgraded. They should be removed in any upgrading package."
MissingImplementation 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."
EUpgradeMissingModule moduleName -> "Module " <> pPrint moduleName <> " appears in package that is being upgraded, but does not appear in this package."
EUpgradeMissingTemplate templateName -> "Template " <> pPrint templateName <> " appears in package that is being upgraded, but does not appear in this package."
EUpgradeMissingChoice templateName -> "Choice " <> pPrint templateName <> " appears in package that is being upgraded, but does not appear in this package."
EUpgradeMissingDataCon dataConName -> "Data type " <> pPrint dataConName <> " appears in package that is being upgraded, but does not appear in this package."
EUpgradeMismatchDataConsVariety dataConName -> "EUpgradeMismatchDataConsVariety " <> pretty dataConName
EUpgradeRecordFieldsMissing origin -> "The upgraded " <> pPrint origin <> " is missing some of its original fields."
EUpgradeRecordFieldsExistingChanged origin -> "The upgraded " <> pPrint origin <> " has changed the types of some of its original fields."
EUpgradeRecordFieldsNewNonOptional origin -> "The upgraded " <> pPrint origin <> " has added new fields, but those fields are not Optional."
EUpgradeRecordFieldsOrderChanged origin -> "The upgraded " <> pPrint origin <> " has changed the order of its fields - any new fields must be added at the end of the record."
EUpgradeVariantAddedVariant origin -> "The upgraded " <> pPrint origin <> " has added a new variant."
EUpgradeVariantRemovedVariant origin -> "The upgraded " <> pPrint origin <> " has removed an existing variant."
EUpgradeVariantChangedVariantType origin -> "The upgraded " <> pPrint origin <> " has changed the type of a variant."
EUpgradeVariantAddedVariantField origin -> "The upgraded " <> pPrint origin <> " has added a field."
EUpgradeVariantVariantsOrderChanged origin -> "The upgraded " <> pPrint origin <> " has changed the order of its variants - any new variant must be added at the end of the variant."
EUpgradeEnumAddedVariant origin -> "The upgraded " <> pPrint origin <> " has added a new variant."
EUpgradeEnumRemovedVariant origin -> "The upgraded " <> pPrint origin <> " has removed an existing variant."
EUpgradeEnumVariantsOrderChanged origin -> "The upgraded " <> pPrint origin <> " has changed the order of its variants - any new variant must be added at the end of the enum."
EUpgradeRecordChangedOrigin dataConName past present -> "The record " <> pPrint dataConName <> " has changed origin from " <> pPrint past <> " to " <> pPrint present
EUpgradeChoiceChangedReturnType choice -> "The upgraded choice " <> pPrint choice <> " cannot change its return type."
EUpgradeTemplateChangedKeyType templateName -> "The upgraded template " <> pPrint templateName <> " cannot change its key type."
EUpgradeTemplateRemovedKey templateName _key -> "The upgraded template " <> pPrint templateName <> " cannot remove its key."
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."
instance Pretty UpgradedRecordOrigin where
pPrint = \case
@ -637,6 +679,17 @@ instance ToDiagnostic Error where
, _relatedInformation = Nothing
}
instance ToDiagnostic UnwarnableError where
toDiagnostic err = Diagnostic
{ _range = maybe noRange sourceLocToRange (errorLocation (EUnwarnableError err))
, _severity = Just DsError
, _code = Nothing
, _tags = Nothing
, _source = Just "Daml-LF typechecker"
, _message = renderPretty err
, _relatedInformation = Nothing
}
data Warning
= WContext !Context !Warning
| WTemplateChangedPrecondition !TypeConName
@ -651,9 +704,7 @@ data Warning
-- ^ When upgrading, we extract relevant expressions for things like
-- signatories. If the expression changes shape so that we can't get the
-- underlying expression that has changed, this warning is emitted.
| WShouldDefineIfacesAndTemplatesSeparately
| WShouldDefineIfaceWithoutImplementation !TypeConName ![TypeConName]
| WShouldDefineTplInSeparatePackage !TypeConName !TypeConName
| WErrorToWarning !WarnableError
deriving (Show)
warningLocation :: Warning -> Maybe SourceLoc
@ -677,23 +728,7 @@ instance Pretty Warning where
WTemplateChangedKeyExpression template -> "The upgraded template " <> pPrint template <> " has changed the expression for computing its key."
WTemplateChangedKeyMaintainers template -> "The upgraded template " <> pPrint template <> " has changed the maintainers for its key."
WCouldNotExtractForUpgradeChecking attribute mbExtra -> "Could not check if the upgrade of " <> text attribute <> " is valid because its expression is the not the right shape." <> foldMap (const " Extra context: " <> text) mbExtra
WShouldDefineIfacesAndTemplatesSeparately ->
vsep
[ "This package defines both interfaces and templates."
, "This is not recommended - templates are upgradeable, but interfaces are not, which means that this version of the package and its templates can never be uninstalled."
, "It is recommended that interfaces are defined in their own package separate from their implementations."
]
WShouldDefineIfaceWithoutImplementation iface implementingTemplates ->
vsep $ concat
[ [ "The interface " <> pPrint iface <> " was defined in this package and implemented in this package by the following templates:" ]
, map (quotes . pPrint) implementingTemplates
, [ "However, it is recommended that interfaces are defined in their own package separate from their implementations." ]
]
WShouldDefineTplInSeparatePackage tpl iface ->
vsep
[ "The template " <> pPrint tpl <> " has implemented interface " <> pPrint iface <> ", which is defined in a previous version of this package."
, "However, it is recommended that interfaces are defined in their own package separate from their implementations."
]
WErrorToWarning err -> pPrint err
instance ToDiagnostic Warning where
toDiagnostic warning = Diagnostic

11
sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/NameCollision.hs
View File

@ -143,22 +143,21 @@ initialState :: NCState
initialState = NCState M.empty
-- | Monad in which to run the name collision check.
type NCMonad t = RWS () [Diagnostic] NCState t
type NCMonad t = RWS () [Error] NCState t
-- | Run the name collision with a blank initial state.
runNameCollision :: NCMonad t -> [Diagnostic]
runNameCollision m = snd (evalRWS m () initialState)
runNameCollision m = map toDiagnostic $ snd (evalRWS m () initialState)
-- | Try to add a name to the NCState. Returns Error only
-- if the name results in a forbidden name collision.
addName :: Name -> NCState -> Either Diagnostic NCState
addName :: Name -> NCState -> Either Error NCState
addName name (NCState nameMap)
| null badNames =
Right . NCState $ M.insert frName (name : oldNames) nameMap
| otherwise =
let err = EForbiddenNameCollision (displayName name) (map displayName badNames)
diag = toDiagnostic err
in Left diag
let err = EUnwarnableError $ EForbiddenNameCollision (displayName name) (map displayName badNames)
in Left err
where
frName = fullyResolve name
oldNames = fromMaybe [] (M.lookup frName nameMap)

6
sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Recursion.hs
View File

@ -77,8 +77,8 @@ checkModule mod0 = do
-- | Check whether a directed graph given by its adjacency list is acyclic. If
-- it is not, throw an error.
checkAcyclic
:: (Ord k, MonadGamma m)
=> ([k] -> Error) -- ^ Make an error from the names of nodes forming a cycle.
:: (Ord k, MonadGamma m, SomeErrorOrWarning e)
=> ([k] -> e) -- ^ Make an error from the names of nodes forming a cycle.
-> (a -> k) -- ^ Map a node to its name.
-> (a -> [k]) -- ^ Map a node to the names of its adjacent nodes.
-> [a] -- ^ Nodes of the graph.
@ -87,4 +87,4 @@ checkAcyclic mkError name adjacent objs = do
let graph = map (\obj -> (obj, name obj, nubOrd (adjacent obj))) objs
for_ (G.stronglyConnComp graph) $ \case
G.AcyclicSCC _ -> pure ()
G.CyclicSCC cycle -> throwWithContext (mkError (map name cycle))
G.CyclicSCC cycle -> diagnosticWithContext (mkError (map name cycle))

103
sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs
View File

@ -10,13 +10,14 @@ module DA.Daml.LF.TypeChecker.Upgrade (
import Control.DeepSeq
import Control.Monad (unless, forM_, when)
import Control.Monad.Reader (withReaderT)
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.TypeChecker.Check (expandTypeSynonyms)
import DA.Daml.LF.TypeChecker.Env
import DA.Daml.LF.TypeChecker.Error
import DA.Daml.Options.Types (WarnBadInterfaceInstances(..))
import Data.Bifunctor (first)
import Data.Data
import Data.Either (partitionEithers)
@ -61,16 +62,28 @@ runGammaUnderUpgrades Upgrading{ _past = pastAction, _present = presentAction }
presentResult <- withReaderT _present presentAction
pure Upgrading { _past = pastResult, _present = presentResult }
checkUpgrade :: Version -> Bool -> LF.Package -> Maybe (LF.PackageId, LF.Package) -> [Diagnostic]
checkUpgrade version shouldTypecheckUpgrades presentPkg mbUpgradedPackage =
let bothPkgDiagnostics :: Either Error ((), [Warning])
checkUpgrade :: Version -> Bool -> WarnBadInterfaceInstances -> LF.Package -> Maybe (LF.PackageId, LF.Package) -> [Diagnostic]
checkUpgrade version shouldTypecheckUpgrades warnBadInterfaceInstances presentPkg mbUpgradedPackage =
let addBadIfaceSwapIndicator :: Gamma -> Gamma
addBadIfaceSwapIndicator =
if getWarnBadInterfaceInstances warnBadInterfaceInstances
then
addDiagnosticSwapIndicator (\case
Left WEUpgradeShouldDefineIfaceWithoutImplementation {} -> Just True
Left WEUpgradeShouldDefineTplInSeparatePackage {} -> Just True
Left WEUpgradeShouldDefineIfacesAndTemplatesSeparately {} -> Just True
_ -> Nothing)
else id
bothPkgDiagnostics :: Either Error ((), [Warning])
bothPkgDiagnostics =
case mbUpgradedPackage of
Nothing ->
Right ((), [])
Just (_, pastPkg) ->
let package = Upgrading { _past = pastPkg, _present = presentPkg }
upgradingWorld = fmap (\package -> emptyGamma (initWorldSelf [] package) version) package
initWorldFromPackage package =
addBadIfaceSwapIndicator $ emptyGamma (initWorldSelf [] package) version
upgradingWorld = fmap initWorldFromPackage package
in
runGammaF upgradingWorld $ do
when shouldTypecheckUpgrades (checkUpgradeM package)
@ -79,9 +92,11 @@ checkUpgrade version shouldTypecheckUpgrades presentPkg mbUpgradedPackage =
singlePkgDiagnostics =
let world = initWorldSelf [] presentPkg
in
runGamma world version $ do
checkNewInterfacesHaveNoTemplates presentPkg
checkNewInterfacesAreUnused presentPkg
runGamma world version $
local addBadIfaceSwapIndicator $
when shouldTypecheckUpgrades $ do
checkNewInterfacesAreUnused presentPkg
checkNewInterfacesHaveNoTemplates presentPkg
extractDiagnostics :: Either Error ((), [Warning]) -> [Diagnostic]
extractDiagnostics result =
@ -93,7 +108,7 @@ checkUpgrade version shouldTypecheckUpgrades presentPkg mbUpgradedPackage =
checkUpgradeM :: Upgrading LF.Package -> TcUpgradeM ()
checkUpgradeM package = do
(upgradedModules, _new) <- checkDeleted (EUpgradeError . MissingModule . NM.name) $ NM.toHashMap . packageModules <$> package
(upgradedModules, _new) <- checkDeleted (EUpgradeMissingModule . NM.name) $ NM.toHashMap . packageModules <$> package
forM_ upgradedModules $ \module_ -> checkModule package module_
extractDelExistNew
@ -107,24 +122,24 @@ extractDelExistNew Upgrading{..} =
)
checkDeleted
:: (Eq k, Hashable k)
=> (a -> Error)
:: (Eq k, Hashable k, SomeErrorOrWarning e)
=> (a -> e)
-> Upgrading (HMS.HashMap k a)
-> TcUpgradeM (HMS.HashMap k (Upgrading a), HMS.HashMap k a)
checkDeleted handleError upgrade =
checkDeletedG ((Nothing,) . handleError) upgrade
checkDeletedWithContext
:: (Eq k, Hashable k)
=> (a -> (Context, Error))
:: (Eq k, Hashable k, SomeErrorOrWarning e)
=> (a -> (Context, e))
-> Upgrading (HMS.HashMap k a)
-> TcUpgradeM (HMS.HashMap k (Upgrading a), HMS.HashMap k a)
checkDeletedWithContext handleError upgrade =
checkDeletedG (first Just . handleError) upgrade
checkDeletedG
:: (Eq k, Hashable k)
=> (a -> (Maybe Context, Error))
:: (Eq k, Hashable k, SomeErrorOrWarning e)
=> (a -> (Maybe Context, e))
-> Upgrading (HMS.HashMap k a)
-> TcUpgradeM (HMS.HashMap k (Upgrading a), HMS.HashMap k a)
checkDeletedG handleError upgrade = do
@ -133,8 +148,8 @@ checkDeletedG handleError upgrade = do
pure (existing, new)
throwIfNonEmpty
:: (Eq k, Hashable k)
=> (a -> (Maybe Context, Error))
:: (Eq k, Hashable k, SomeErrorOrWarning e)
=> (a -> (Maybe Context, e))
-> HMS.HashMap k a
-> TcUpgradeM ()
throwIfNonEmpty handleError hm =
@ -146,12 +161,12 @@ throwIfNonEmpty handleError hm =
Nothing -> id
Just ctx -> withContextF present ctx
in
ctxHandler $ throwWithContextF present err
ctxHandler $ diagnosticWithContextF present err
_ -> pure ()
checkModule :: Upgrading LF.Package -> Upgrading LF.Module -> TcUpgradeM ()
checkModule package module_ = do
(existingTemplates, _new) <- checkDeleted (EUpgradeError . MissingTemplate . NM.name) $ NM.toHashMap . moduleTemplates <$> module_
(existingTemplates, _new) <- checkDeleted (EUpgradeMissingTemplate . NM.name) $ NM.toHashMap . moduleTemplates <$> module_
forM_ existingTemplates $ \template ->
withContextF
present
@ -243,13 +258,13 @@ checkModule package module_ = do
checkDeletedWithContext
(\(tpl, impl) ->
( ContextTemplate (_present module_) tpl TPWhole
, EUpgradeError (MissingImplementation (NM.name tpl) (LF.qualObject (NM.name impl)))
, EUpgradeMissingImplementation (NM.name tpl) (LF.qualObject (NM.name impl))
))
(flattenInstances <$> module_)
checkUpgradedInterfacesAreUnused (_present package) (_present module_) instanceNew
-- checkDeleted should only trigger on datatypes not belonging to templates or choices or interfaces, which we checked above
(dtExisting, _dtNew) <- checkDeleted (EUpgradeError . MissingDataCon . NM.name) unownedDts
(dtExisting, _dtNew) <- checkDeleted (EUpgradeMissingDataCon . NM.name) unownedDts
forM_ dtExisting $ \dt ->
-- Get origin/context for each datatype in both _past and _present
@ -258,7 +273,7 @@ checkModule package module_ = do
-- If origins don't match, record has changed origin
if foldU (/=) (fst <$> origin) then
withContextF present (ContextDefDataType (_present module_) (_present dt)) $
throwWithContextF present (EUpgradeError (RecordChangedOrigin (dataTypeCon (_present dt)) (fst (_past origin)) (fst (_present origin))))
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
@ -273,7 +288,7 @@ checkContinuedIfaces module_ ifaces =
let (_dt, iface) = _present upgradedDtIface
in
withContextF present (ContextDefInterface (_present module_) iface IPWhole) $
throwWithContextF present $ EUpgradeError $ TriedToUpgradeIface (NM.name iface)
throwWithContextF present $ EUpgradeTriedToUpgradeIface (NM.name iface)
-- This warning should run even when no upgrade target is set
checkNewInterfacesHaveNoTemplates :: LF.Package -> TcM ()
@ -286,14 +301,14 @@ checkNewInterfacesHaveNoTemplates presentPkg =
in
forM_ (HMS.toList templateAndInterfaceDefined) $ \(_, (module_, _)) ->
withContext (ContextDefModule module_) $
warnWithContext WShouldDefineIfacesAndTemplatesSeparately
diagnosticWithContext WEUpgradeShouldDefineIfacesAndTemplatesSeparately
-- This warning should run even when no upgrade target is set
checkNewInterfacesAreUnused :: LF.Package -> TcM ()
checkNewInterfacesAreUnused presentPkg =
forM_ definedAndInstantiated $ \((module_, iface), implementations) ->
withContext (ContextDefInterface module_ iface IPWhole) $
warnWithContext $ WShouldDefineIfaceWithoutImplementation (NM.name iface) ((\(_,a,_) -> NM.name a) <$> implementations)
diagnosticWithContext $ WEUpgradeShouldDefineIfaceWithoutImplementation (NM.name iface) ((\(_,a,_) -> NM.name a) <$> implementations)
where
definedIfaces :: HMS.HashMap (LF.Qualified LF.TypeConName) (Module, DefInterface)
definedIfaces = HMS.unions
@ -321,7 +336,7 @@ checkUpgradedInterfacesAreUnused package module_ newInstances = do
ifaceInstanceHead = InterfaceInstanceHead ifaceName qualifiedTplName
in
withContextF present (ContextTemplate module_ tpl (TPInterfaceInstance ifaceInstanceHead Nothing)) $
warnWithContextF present $ WShouldDefineTplInSeparatePackage (NM.name tpl) (LF.qualObject (NM.name implementation))
diagnosticWithContextF present $ WEUpgradeShouldDefineTplInSeparatePackage (NM.name tpl) (LF.qualObject (NM.name implementation))
where
fromUpgradedPackage :: forall a. LF.Qualified a -> Bool
fromUpgradedPackage identifier =
@ -339,11 +354,11 @@ instantiatedIfaces pkg = foldl' (HMS.unionWith (<>)) HMS.empty $ (map . fmap) pu
checkTemplate :: Upgrading Module -> Upgrading LF.Template -> TcUpgradeM ()
checkTemplate module_ template = do
-- Check that no choices have been removed
(existingChoices, _existingNew) <- checkDeleted (EUpgradeError . MissingChoice . NM.name) $ NM.toHashMap . tplChoices <$> template
(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)
(EUpgradeError (ChoiceChangedReturnType (NM.name (_present choice))))
(EUpgradeChoiceChangedReturnType (NM.name (_present choice)))
whenDifferent "controllers" (extractFuncFromFuncThisArg . chcControllers) choice $
warnWithContextF present $ WChoiceChangedControllers $ NM.name $ _present choice
@ -392,7 +407,7 @@ checkTemplate module_ template = do
-- Key type musn't change
checkUpgradeType (fmap tplKeyType tplKey)
(EUpgradeError (TemplateChangedKeyType (NM.name (_present template))))
(EUpgradeTemplateChangedKeyType (NM.name (_present template)))
-- But expression for computing it may
whenDifferent "key expression"
@ -402,9 +417,9 @@ checkTemplate module_ template = do
(extractFuncFromTyAppNil . tplKeyMaintainers) tplKey
(warnWithContextF present $ WTemplateChangedKeyMaintainers $ NM.name $ _present template)
Upgrading { _past = Just pastKey, _present = Nothing } ->
throwWithContextF present $ EUpgradeError $ TemplateRemovedKey (NM.name (_present template)) pastKey
throwWithContextF present $ EUpgradeTemplateRemovedKey (NM.name (_present template)) pastKey
Upgrading { _past = Nothing, _present = Just presentKey } ->
throwWithContextF present $ EUpgradeError $ TemplateAddedKey (NM.name (_present template)) presentKey
throwWithContextF present $ EUpgradeTemplateAddedKey (NM.name (_present template)) presentKey
-- TODO: Check that return type of a choice is compatible
pure ()
@ -511,24 +526,24 @@ checkDefDataType origin datatype = do
checkFields origin (Upgrading {..})
Upgrading { _past = DataVariant _past, _present = DataVariant _present } -> do
let upgrade = Upgrading{..}
(existing, _new) <- checkDeleted (\_ -> EUpgradeError (VariantRemovedVariant origin)) (fmap HMS.fromList upgrade)
(existing, _new) <- checkDeleted (\_ -> EUpgradeVariantRemovedVariant origin) (fmap HMS.fromList upgrade)
when (not $ and $ foldU (zipWith (==)) $ fmap (map fst) upgrade) $
throwWithContextF present (EUpgradeError (VariantVariantsOrderChanged origin))
throwWithContextF present (EUpgradeVariantVariantsOrderChanged origin)
different <- filterHashMapM (fmap not . isSameType) existing
when (not (null different)) $
throwWithContextF present $ EUpgradeError (VariantChangedVariantType origin)
throwWithContextF present $ EUpgradeVariantChangedVariantType origin
Upgrading { _past = DataEnum _past, _present = DataEnum _present } -> do
let upgrade = Upgrading{..}
(_, _new) <-
checkDeleted
(\_ -> EUpgradeError (EnumRemovedVariant origin))
(\_ -> EUpgradeEnumRemovedVariant origin)
(fmap (HMS.fromList . map (,())) upgrade)
when (not $ and $ foldU (zipWith (==)) upgrade) $
throwWithContextF present (EUpgradeError (EnumVariantsOrderChanged origin))
throwWithContextF present (EUpgradeEnumVariantsOrderChanged origin)
Upgrading { _past = DataInterface {}, _present = DataInterface {} } ->
pure ()
_ ->
throwWithContextF present (EUpgradeError (MismatchDataConsVariety (dataTypeCon (_past datatype))))
throwWithContextF present (EUpgradeMismatchDataConsVariety (dataTypeCon (_past datatype)))
filterHashMapM :: (Applicative m) => (a -> m Bool) -> HMS.HashMap k a -> m (HMS.HashMap k a)
filterHashMapM pred t =
@ -536,30 +551,30 @@ filterHashMapM pred t =
checkFields :: UpgradedRecordOrigin -> Upgrading [(FieldName, Type)] -> TcUpgradeM ()
checkFields origin fields = do
(existing, new) <- checkDeleted (\_ -> EUpgradeError (RecordFieldsMissing origin)) (fmap HMS.fromList fields)
(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
when (not (HMS.null different)) $
throwWithContextF present (EUpgradeError (RecordFieldsExistingChanged origin))
throwWithContextF present (EUpgradeRecordFieldsExistingChanged origin)
when (not (all newFieldOptionalType new)) $
case origin of
VariantConstructor{} ->
throwWithContextF present (EUpgradeError (VariantAddedVariantField origin))
throwWithContextF present (EUpgradeVariantAddedVariantField origin)
_ ->
throwWithContextF present (EUpgradeError (RecordFieldsNewNonOptional 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 (EUpgradeError (RecordFieldsOrderChanged origin))
throwWithContextF present (EUpgradeRecordFieldsOrderChanged origin)
where
newFieldOptionalType (TOptional _) = True
newFieldOptionalType _ = False
-- Check type upgradability
checkUpgradeType :: Upgrading Type -> Error -> TcUpgradeM ()
checkUpgradeType :: SomeErrorOrWarning e => Upgrading Type -> e -> TcUpgradeM ()
checkUpgradeType type_ err = do
sameType <- isSameType type_
unless sameType $ throwWithContextF present err
unless sameType $ diagnosticWithContextF present err
isSameType :: Upgrading Type -> TcUpgradeM Bool
isSameType type_ = do

5
sdk/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Dar.hs
View File

@ -112,8 +112,9 @@ buildDar ::
-> PackageConfigFields
-> NormalizedFilePath
-> FromDalf
-> WarnBadInterfaceInstances
-> IO (Maybe (Zip.ZipArchive (), Maybe LF.PackageId))
buildDar service PackageConfigFields {..} ifDir dalfInput = do
buildDar service PackageConfigFields {..} ifDir dalfInput warnBadInterfaceInstances = do
liftIO $
IdeLogger.logDebug (ideLogger service) $
"Creating dar: " <> T.pack pSrc
@ -152,7 +153,7 @@ buildDar service PackageConfigFields {..} ifDir dalfInput = do
MaybeT $
runDiagnosticCheck $ diagsToIdeResult (toNormalizedFilePath' pSrc) $
TypeChecker.Upgrade.checkUpgrade lfVersion pTypecheckUpgrades pkg mbUpgradedPackage
TypeChecker.Upgrade.checkUpgrade lfVersion pTypecheckUpgrades warnBadInterfaceInstances pkg mbUpgradedPackage
MaybeT $ finalPackageCheck (toNormalizedFilePath' pSrc) pkg
let pkgModuleNames = map (Ghc.mkModuleName . T.unpack) $ LF.packageModuleNames pkg

7
sdk/compiler/damlc/daml-opts/daml-opts-types/DA/Daml/Options/Types.hs
View File

@ -10,6 +10,7 @@ module DA.Daml.Options.Types
, EnableScenarios(..)
, EnableInterfaces(..)
, AllowLargeTuples(..)
, WarnBadInterfaceInstances(..)
, StudioAutorunAllScenarios(..)
, SkipScenarioValidation(..)
, DlintRulesFile(..)
@ -127,6 +128,8 @@ data Options = Options
-- packages from remote ledgers.
, optAllowLargeTuples :: AllowLargeTuples
-- ^ Do not warn when tuples of size > 5 are used
, optWarnBadInterfaceInstances :: WarnBadInterfaceInstances
-- ^ Warn for bad interface instances instead of erroring out
}
newtype IncrementalBuild = IncrementalBuild { getIncrementalBuild :: Bool }
@ -187,6 +190,9 @@ newtype EnableScenarios = EnableScenarios { getEnableScenarios :: Bool }
newtype AllowLargeTuples = AllowLargeTuples { getAllowLargeTuples :: Bool }
deriving Show
newtype WarnBadInterfaceInstances = WarnBadInterfaceInstances { getWarnBadInterfaceInstances :: Bool }
deriving Show
newtype StudioAutorunAllScenarios = StudioAutorunAllScenarios { getStudioAutorunAllScenarios :: Bool }
deriving Show
@ -271,6 +277,7 @@ defaultOptions mbVersion =
, optEnableOfInterestRule = False
, optAccessTokenPath = Nothing
, optAllowLargeTuples = AllowLargeTuples False
, optWarnBadInterfaceInstances = WarnBadInterfaceInstances False
}
pkgNameVersion :: LF.PackageName -> Maybe LF.PackageVersion -> UnitId

3
sdk/compiler/damlc/lib/DA/Cli/Damlc.hs
View File

@ -137,6 +137,7 @@ import DA.Daml.Options.Types (EnableScenarioService(..),
optScenarioService,
optSkipScenarioValidation,
optThreads,
optWarnBadInterfaceInstances,
pkgNameVersion,
projectPackageDatabase)
import DA.Daml.Package.Config (MultiPackageConfigFields(..),
@ -981,6 +982,7 @@ buildEffect relativize pkgConfig@PackageConfigFields{..} opts mbOutFile incremen
pkgConfig
(toNormalizedFilePath' $ fromMaybe ifaceDir $ optIfaceDir opts)
(FromDalf False)
(optWarnBadInterfaceInstances opts)
(dar, mPkgId) <- mbErr "ERROR: Creation of DAR file failed." mbDar
fp <- targetFilePath relativize $ unitIdString (pkgNameVersion pName pVersion)
createDarFile loggerH fp dar
@ -1338,6 +1340,7 @@ execPackage projectOpts filePath opts mbOutFile dalfInput =
}
(toNormalizedFilePath' $ fromMaybe ifaceDir $ optIfaceDir opts)
dalfInput
(optWarnBadInterfaceInstances opts)
case mbDar of
Nothing -> do
hPutStrLn stderr "ERROR: Creation of DAR file failed."

10
sdk/compiler/damlc/lib/DA/Cli/Options.hs
View File

@ -446,6 +446,7 @@ optionsParser numProcessors enableScenarioService parsePkgName parseDlintUsage =
optEnableInterfaces <- enableInterfacesOpt
optAllowLargeTuples <- allowLargeTuplesOpt
optTestFilter <- compilePatternExpr <$> optTestPattern
optWarnBadInterfaceInstances <- warnBadInterfaceInstancesOpt
return Options{..}
where
@ -572,6 +573,15 @@ optionsParser numProcessors enableScenarioService parsePkgName parseDlintUsage =
<> help "Set path to CPP."
<> internal
warnBadInterfaceInstancesOpt :: Parser WarnBadInterfaceInstances
warnBadInterfaceInstancesOpt =
WarnBadInterfaceInstances <$>
flagYesNoAuto
"warn-bad-interface-instances"
False
"Convert errors about bad, non-upgradeable interface instances into warnings."
idm
optGhcCustomOptions :: Parser [String]
optGhcCustomOptions =
fmap concat $ many $

788
sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs
View File

@ -34,282 +34,414 @@ tests :: SdkVersioned => FilePath -> TestTree
tests damlc =
testGroup
"Upgrade"
[ test
"WarnsWhenTemplateChangesSignatories"
(SucceedWithWarning "\ESC\\[0;93mwarning while type checking template Main.A signatories:\n The upgraded template A has changed the definition of its signatories.")
LF.versionDefault
NoDependencies
, test
"WarnsWhenTemplateChangesObservers"
(SucceedWithWarning "\ESC\\[0;93mwarning while type checking template Main.A observers:\n The upgraded template A has changed the definition of its observers.")
LF.versionDefault
NoDependencies
, test
"SucceedsWhenATopLevelEnumChanges"
Succeed
LF.versionDefault
NoDependencies
, test
"WarnsWhenTemplateChangesEnsure"
(SucceedWithWarning "\ESC\\[0;93mwarning while type checking template Main.A precondition:\n The upgraded template A has changed the definition of its precondition.")
LF.versionDefault
NoDependencies
, test
"WarnsWhenTemplateChangesKeyExpression"
(SucceedWithWarning "\ESC\\[0;93mwarning while type checking template Main.A key:\n The upgraded template A has changed the expression for computing its key.")
contractKeysMinVersion
NoDependencies
, test
"WarnsWhenTemplateChangesKeyMaintainers"
(SucceedWithWarning "\ESC\\[0;93mwarning while type checking template Main.A key:\n The upgraded template A has changed the maintainers for its key.")
contractKeysMinVersion
NoDependencies
, test
"FailsWhenTemplateChangesKeyType"
(FailWithError "\ESC\\[0;91merror type checking template Main.A key:\n The upgraded template A cannot change its key type.")
contractKeysMinVersion
NoDependencies
, test
"FailsWhenTemplateRemovesKeyType"
(FailWithError "\ESC\\[0;91merror type checking template Main.A key:\n The upgraded template A cannot remove its key.")
contractKeysMinVersion
NoDependencies
, test
"FailsWhenTemplateAddsKeyType"
(FailWithError "\ESC\\[0;91merror type checking template Main.A key:\n The upgraded template A cannot add a key where it didn't have one previously.")
contractKeysMinVersion
NoDependencies
, test
"FailsWhenNewFieldIsAddedToTemplateWithoutOptionalType"
(FailWithError "\ESC\\[0;91merror type checking template Main.A :\n The upgraded template A has added new fields, but those fields are not Optional.")
LF.versionDefault
NoDependencies
, test
"FailsWhenOldFieldIsDeletedFromTemplate"
(FailWithError "\ESC\\[0;91merror type checking template Main.A :\n The upgraded template A is missing some of its original fields.")
LF.versionDefault
NoDependencies
, test
"FailsWhenExistingFieldInTemplateIsChanged"
(FailWithError "\ESC\\[0;91merror type checking template Main.A :\n The upgraded template A has changed the types of some of its original fields.")
LF.versionDefault
NoDependencies
, test
"SucceedsWhenNewFieldWithOptionalTypeIsAddedToTemplate"
Succeed
LF.versionDefault
NoDependencies
, test
"FailsWhenNewFieldIsAddedToTemplateChoiceWithoutOptionalType"
(FailWithError "\ESC\\[0;91merror type checking template Main.A choice C:\n The upgraded input type of choice C on template A has added new fields, but those fields are not Optional.")
LF.versionDefault
NoDependencies
, test
"FailsWhenOldFieldIsDeletedFromTemplateChoice"
(FailWithError "\ESC\\[0;91merror type checking template Main.A choice C:\n The upgraded input type of choice C on template A is missing some of its original fields.")
LF.versionDefault
NoDependencies
, test
"FailsWhenExistingFieldInTemplateChoiceIsChanged"
(FailWithError "\ESC\\[0;91merror type checking template Main.A choice C:\n The upgraded input type of choice C on template A has changed the types of some of its original fields.")
LF.versionDefault
NoDependencies
, test
"WarnsWhenControllersOfTemplateChoiceAreChanged"
(SucceedWithWarning "\ESC\\[0;93mwarning while type checking template Main.A choice C:\n The upgraded choice C has changed the definition of controllers.")
LF.versionDefault
NoDependencies
, test
"WarnsWhenObserversOfTemplateChoiceAreChanged"
(SucceedWithWarning "\ESC\\[0;93mwarning while type checking template Main.A choice C:\n The upgraded choice C has changed the definition of observers.")
LF.versionDefault
NoDependencies
, test
"FailsWhenTemplateChoiceChangesItsReturnType"
(FailWithError "\ESC\\[0;91merror type checking template Main.A choice C:\n The upgraded choice C cannot change its return type.")
LF.versionDefault
NoDependencies
, test
"SucceedsWhenTemplateChoiceReturnsATemplateWhichHasChanged"
Succeed
LF.versionDefault
NoDependencies
, test
"SucceedsWhenTemplateChoiceInputArgumentHasChanged"
Succeed
LF.versionDefault
NoDependencies
, test
"SucceedsWhenNewFieldWithOptionalTypeIsAddedToTemplateChoice"
Succeed
LF.versionDefault
NoDependencies
, test
"FailsWhenATopLevelRecordAddsANonOptionalField"
(FailWithError "\ESC\\[0;91merror type checking data type Main.A:\n The upgraded data type A has added new fields, but those fields are not Optional.")
LF.versionDefault
NoDependencies
, test
"SucceedsWhenATopLevelRecordAddsAnOptionalFieldAtTheEnd"
Succeed
LF.versionDefault
NoDependencies
, test
"FailsWhenATopLevelRecordAddsAnOptionalFieldBeforeTheEnd"
(FailWithError "\ESC\\[0;91merror type checking data type Main.A:\n The upgraded data type A has changed the order of its fields - any new fields must be added at the end of the record.")
LF.versionDefault
NoDependencies
, test
"SucceedsWhenATopLevelVariantAddsAVariant"
Succeed
LF.versionDefault
NoDependencies
, test
"FailsWhenATopLevelVariantRemovesAVariant"
(FailWithError "\ESC\\[0;91merror type checking <none>:\n Data type A.Z appears in package that is being upgraded, but does not appear in this package.")
LF.versionDefault
NoDependencies
, test
"FailWhenATopLevelVariantChangesChangesTheOrderOfItsVariants"
(FailWithError "\ESC\\[0;91merror type checking data type Main.A:\n The upgraded data type A has changed the order of its variants - any new variant must be added at the end of the variant.")
LF.versionDefault
NoDependencies
, test
"FailsWhenATopLevelVariantAddsAFieldToAVariantsType"
(FailWithError "\ESC\\[0;91merror type checking data type Main.A:\n The upgraded variant constructor Y from variant A has added a field.")
LF.versionDefault
NoDependencies
, test
"SucceedsWhenATopLevelVariantAddsAnOptionalFieldToAVariantsType"
Succeed
LF.versionDefault
NoDependencies
, test
"SucceedWhenATopLevelEnumAddsAField"
Succeed
LF.versionDefault
NoDependencies
, test
"FailWhenATopLevelEnumChangesChangesTheOrderOfItsVariants"
(FailWithError "\ESC\\[0;91merror type checking data type Main.A:\n The upgraded data type A has changed the order of its variants - any new variant must be added at the end of the enum.")
LF.versionDefault
NoDependencies
, test
"SucceedsWhenATopLevelTypeSynonymChanges"
Succeed
LF.versionDefault
NoDependencies
, test
"SucceedsWhenTwoDeeplyNestedTypeSynonymsResolveToTheSameDatatypes"
Succeed
LF.versionDefault
NoDependencies
, test
"FailsWhenTwoDeeplyNestedTypeSynonymsResolveToDifferentDatatypes"
(FailWithError "\ESC\\[0;91merror type checking template Main.A :\n The upgraded template A has changed the types of some of its original fields.")
LF.versionDefault
NoDependencies
, test
"SucceedsWhenAnInterfaceIsOnlyDefinedInTheInitialPackage"
Succeed
LF.versionDefault
NoDependencies
, test
"FailsWhenAnInterfaceIsDefinedInAnUpgradingPackageWhenItWasAlreadyInThePriorPackage"
(FailWithError "\ESC\\[0;91merror type checking interface Main.I :\n Tried to upgrade interface I, but interfaces cannot be upgraded. They should be removed in any upgrading package.")
LF.versionDefault
NoDependencies
, test
"WarnsWhenAnInterfaceAndATemplateAreDefinedInTheSamePackage"
(SucceedWithWarning "\ESC\\[0;93mwarning while type checking module Main:\n This package defines both interfaces and templates.\n \n This is not recommended - templates are upgradeable, but interfaces are not, which means that this version of the package and its templates can never be uninstalled.\n \n It is recommended that interfaces are defined in their own package separate from their implementations.")
LF.versionDefault
NoDependencies
, test
"WarnsWhenAnInterfaceIsUsedInThePackageThatItsDefinedIn"
(SucceedWithWarning "\ESC\\[0;93mwarning while type checking interface Main.I :\n The interface I was defined in this package and implemented in this package by the following templates:\n \n 'T'\n \n However, it is recommended that interfaces are defined in their own package separate from their implementations.")
LF.versionDefault
NoDependencies
, test
"WarnsWhenAnInterfaceIsDefinedAndThenUsedInAPackageThatUpgradesIt"
(SucceedWithWarning "\ESC\\[0;93mwarning while 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.")
LF.versionDefault
DependOnV1
, test
"FailsWhenAnInstanceIsDropped"
(FailWithError "\ESC\\[0;91merror type checking template Main.T :\n Implementation of interface I by template T appears in package that is being upgraded, but does not appear in this package.")
LF.versionDefault
SeparateDep
, test
"SucceedsWhenAnInstanceIsAddedSeparateDep"
Succeed
LF.versionDefault
SeparateDep
, test
"SucceedsWhenAnInstanceIsAddedUpgradedPackage"
Succeed
LF.versionDefault
DependOnV1
, test
"CannotUpgradeView"
(FailWithError ".*Tried to implement a view of type (‘|\915\199\255)IView(’|\915\199\214) on interface (‘|\915\199\255)V1.I(’|\915\199\214), but the definition of interface (‘|\915\199\255)V1.I(’|\915\199\214) requires a view of type (‘|\915\199\255)V1.IView(’|\915\199\214)")
LF.versionDefault
DependOnV1
, test
"ValidUpgrade"
Succeed
contractKeysMinVersion
NoDependencies
, test
"MissingModule"
(FailWithError "\ESC\\[0;91merror type checking <none>:\n Module Other appears in package that is being upgraded, but does not appear in this package.")
LF.versionDefault
NoDependencies
, test
"MissingTemplate"
(FailWithError "\ESC\\[0;91merror type checking <none>:\n Template U appears in package that is being upgraded, but does not appear in this package.")
LF.versionDefault
NoDependencies
, test
"MissingDataCon"
(FailWithError "\ESC\\[0;91merror type checking <none>:\n Data type U appears in package that is being upgraded, but does not appear in this package.")
LF.versionDefault
NoDependencies
, test
"MissingChoice"
(FailWithError "\ESC\\[0;91merror type checking template Main.T :\n Choice C2 appears in package that is being upgraded, but does not appear in this package.")
LF.versionDefault
NoDependencies
, test
"TemplateChangedKeyType"
(FailWithError "\ESC\\[0;91merror type checking template Main.T key:\n The upgraded template T cannot change its key type.")
contractKeysMinVersion
NoDependencies
, 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.")
LF.versionDefault
NoDependencies
, test
"FailsWithSynonymReturnTypeChange"
(FailWithError "\ESC\\[0;91merror type checking template Main.T choice C:\n The upgraded choice C cannot change its return type.")
LF.versionDefault
NoDependencies
, test
"FailsWithSynonymReturnTypeChangeInSeparatePackage"
(FailWithError "\ESC\\[0;91merror type checking template Main.T choice C:\n The upgraded choice C cannot change its return type.")
LF.versionDefault
SeparateDeps
, test
"SucceedsWhenUpgradingADependency"
Succeed
LF.versionDefault
SeparateDeps
, test
"FailsOnlyInModuleNotInReexports"
(FailWithError "\ESC\\[0;91merror type checking data type Other.A:\n The upgraded data type A has added new fields, but those fields are not Optional.")
LF.versionDefault
NoDependencies
]
(
[ test
"CannotUpgradeView"
(FailWithError ".*Tried to implement a view of type (‘|\915\199\255)IView(’|\915\199\214) on interface (‘|\915\199\255)V1.I(’|\915\199\214), but the definition of interface (‘|\915\199\255)V1.I(’|\915\199\214) requires a view of type (‘|\915\199\255)V1.IView(’|\915\199\214)")
LF.versionDefault
DependOnV1
True
True
] ++
concat [
[ test
"WarnsWhenTemplateChangesSignatories"
(SucceedWithWarning "\ESC\\[0;93mwarning while type checking template Main.A signatories:\n The upgraded template A has changed the definition of its signatories.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"WarnsWhenTemplateChangesObservers"
(SucceedWithWarning "\ESC\\[0;93mwarning while type checking template Main.A observers:\n The upgraded template A has changed the definition of its observers.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"SucceedsWhenATopLevelEnumChanges"
Succeed
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"WarnsWhenTemplateChangesEnsure"
(SucceedWithWarning "\ESC\\[0;93mwarning while type checking template Main.A precondition:\n The upgraded template A has changed the definition of its precondition.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"WarnsWhenTemplateChangesKeyExpression"
(SucceedWithWarning "\ESC\\[0;93mwarning while type checking template Main.A key:\n The upgraded template A has changed the expression for computing its key.")
contractKeysMinVersion
NoDependencies
False
setUpgradeField
, test
"WarnsWhenTemplateChangesKeyMaintainers"
(SucceedWithWarning "\ESC\\[0;93mwarning while type checking template Main.A key:\n The upgraded template A has changed the maintainers for its key.")
contractKeysMinVersion
NoDependencies
False
setUpgradeField
, test
"FailsWhenTemplateChangesKeyType"
(FailWithError "\ESC\\[0;91merror type checking template Main.A key:\n The upgraded template A cannot change its key type.")
contractKeysMinVersion
NoDependencies
False
setUpgradeField
, test
"FailsWhenTemplateRemovesKeyType"
(FailWithError "\ESC\\[0;91merror type checking template Main.A key:\n The upgraded template A cannot remove its key.")
contractKeysMinVersion
NoDependencies
False
setUpgradeField
, test
"FailsWhenTemplateAddsKeyType"
(FailWithError "\ESC\\[0;91merror type checking template Main.A key:\n The upgraded template A cannot add a key where it didn't have one previously.")
contractKeysMinVersion
NoDependencies
False
setUpgradeField
, test
"FailsWhenNewFieldIsAddedToTemplateWithoutOptionalType"
(FailWithError "\ESC\\[0;91merror type checking template Main.A :\n The upgraded template A has added new fields, but those fields are not Optional.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"FailsWhenOldFieldIsDeletedFromTemplate"
(FailWithError "\ESC\\[0;91merror type checking template Main.A :\n The upgraded template A is missing some of its original fields.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"FailsWhenExistingFieldInTemplateIsChanged"
(FailWithError "\ESC\\[0;91merror type checking template Main.A :\n The upgraded template A has changed the types of some of its original fields.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"SucceedsWhenNewFieldWithOptionalTypeIsAddedToTemplate"
Succeed
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"FailsWhenNewFieldIsAddedToTemplateChoiceWithoutOptionalType"
(FailWithError "\ESC\\[0;91merror type checking template Main.A choice C:\n The upgraded input type of choice C on template A has added new fields, but those fields are not Optional.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"FailsWhenOldFieldIsDeletedFromTemplateChoice"
(FailWithError "\ESC\\[0;91merror type checking template Main.A choice C:\n The upgraded input type of choice C on template A is missing some of its original fields.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"FailsWhenExistingFieldInTemplateChoiceIsChanged"
(FailWithError "\ESC\\[0;91merror type checking template Main.A choice C:\n The upgraded input type of choice C on template A has changed the types of some of its original fields.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"WarnsWhenControllersOfTemplateChoiceAreChanged"
(SucceedWithWarning "\ESC\\[0;93mwarning while type checking template Main.A choice C:\n The upgraded choice C has changed the definition of controllers.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"WarnsWhenObserversOfTemplateChoiceAreChanged"
(SucceedWithWarning "\ESC\\[0;93mwarning while type checking template Main.A choice C:\n The upgraded choice C has changed the definition of observers.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"FailsWhenTemplateChoiceChangesItsReturnType"
(FailWithError "\ESC\\[0;91merror type checking template Main.A choice C:\n The upgraded choice C cannot change its return type.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"SucceedsWhenTemplateChoiceReturnsATemplateWhichHasChanged"
Succeed
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"SucceedsWhenTemplateChoiceInputArgumentHasChanged"
Succeed
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"SucceedsWhenNewFieldWithOptionalTypeIsAddedToTemplateChoice"
Succeed
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"FailsWhenATopLevelRecordAddsANonOptionalField"
(FailWithError "\ESC\\[0;91merror type checking data type Main.A:\n The upgraded data type A has added new fields, but those fields are not Optional.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"SucceedsWhenATopLevelRecordAddsAnOptionalFieldAtTheEnd"
Succeed
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"FailsWhenATopLevelRecordAddsAnOptionalFieldBeforeTheEnd"
(FailWithError "\ESC\\[0;91merror type checking data type Main.A:\n The upgraded data type A has changed the order of its fields - any new fields must be added at the end of the record.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"SucceedsWhenATopLevelVariantAddsAVariant"
Succeed
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"FailsWhenATopLevelVariantRemovesAVariant"
(FailWithError "\ESC\\[0;91merror type checking <none>:\n Data type A.Z appears in package that is being upgraded, but does not appear in this package.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"FailWhenATopLevelVariantChangesChangesTheOrderOfItsVariants"
(FailWithError "\ESC\\[0;91merror type checking data type Main.A:\n The upgraded data type A has changed the order of its variants - any new variant must be added at the end of the variant.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"FailsWhenATopLevelVariantAddsAFieldToAVariantsType"
(FailWithError "\ESC\\[0;91merror type checking data type Main.A:\n The upgraded variant constructor Y from variant A has added a field.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"SucceedsWhenATopLevelVariantAddsAnOptionalFieldToAVariantsType"
Succeed
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"SucceedWhenATopLevelEnumAddsAField"
Succeed
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"FailWhenATopLevelEnumChangesChangesTheOrderOfItsVariants"
(FailWithError "\ESC\\[0;91merror type checking data type Main.A:\n The upgraded data type A has changed the order of its variants - any new variant must be added at the end of the enum.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"SucceedsWhenATopLevelTypeSynonymChanges"
Succeed
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"SucceedsWhenTwoDeeplyNestedTypeSynonymsResolveToTheSameDatatypes"
Succeed
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"FailsWhenTwoDeeplyNestedTypeSynonymsResolveToDifferentDatatypes"
(FailWithError "\ESC\\[0;91merror type checking template Main.A :\n The upgraded template A has changed the types of some of its original fields.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"SucceedsWhenAnInterfaceIsOnlyDefinedInTheInitialPackage"
Succeed
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"FailsWhenAnInterfaceIsDefinedInAnUpgradingPackageWhenItWasAlreadyInThePriorPackage"
(FailWithError "\ESC\\[0;91merror type checking interface Main.I :\n Tried to upgrade interface I, but interfaces cannot be upgraded. They should be removed in any upgrading package.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"FailsWhenAnInstanceIsDropped"
(FailWithError "\ESC\\[0;91merror type checking template Main.T :\n Implementation of interface I by template T appears in package that is being upgraded, but does not appear in this package.")
LF.versionDefault
SeparateDep
False
setUpgradeField
, test
"SucceedsWhenAnInstanceIsAddedSeparateDep"
Succeed
LF.versionDefault
SeparateDep
False
setUpgradeField
, test
"SucceedsWhenAnInstanceIsAddedUpgradedPackage"
Succeed
LF.versionDefault
DependOnV1
True
setUpgradeField
, test
"ValidUpgrade"
Succeed
contractKeysMinVersion
NoDependencies
False
setUpgradeField
, test
"MissingModule"
(FailWithError "\ESC\\[0;91merror type checking <none>:\n Module Other appears in package that is being upgraded, but does not appear in this package.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"MissingTemplate"
(FailWithError "\ESC\\[0;91merror type checking <none>:\n Template U appears in package that is being upgraded, but does not appear in this package.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"MissingDataCon"
(FailWithError "\ESC\\[0;91merror type checking <none>:\n Data type U appears in package that is being upgraded, but does not appear in this package.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"MissingChoice"
(FailWithError "\ESC\\[0;91merror type checking template Main.T :\n Choice C2 appears in package that is being upgraded, but does not appear in this package.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"TemplateChangedKeyType"
(FailWithError "\ESC\\[0;91merror type checking template Main.T key:\n The upgraded template T cannot change its key type.")
contractKeysMinVersion
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.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"FailsWithSynonymReturnTypeChange"
(FailWithError "\ESC\\[0;91merror type checking template Main.T choice C:\n The upgraded choice C cannot change its return type.")
LF.versionDefault
NoDependencies
False
setUpgradeField
, test
"FailsWithSynonymReturnTypeChangeInSeparatePackage"
(FailWithError "\ESC\\[0;91merror type checking template Main.T choice C:\n The upgraded choice C cannot change its return type.")
LF.versionDefault
SeparateDeps
False
setUpgradeField
, test
"SucceedsWhenUpgradingADependency"
Succeed
LF.versionDefault
SeparateDeps
False
setUpgradeField
, test
"FailsOnlyInModuleNotInReexports"
(FailWithError "\ESC\\[0;91merror type checking data type Other.A:\n The upgraded data type A has added new fields, but those fields are not Optional.")
LF.versionDefault
NoDependencies
False
setUpgradeField
]
| setUpgradeField <- [True, False]
] ++
concat [
[ testGeneral
(prefix <> "WhenAnInterfaceAndATemplateAreDefinedInTheSamePackage")
"WarnsWhenAnInterfaceAndATemplateAreDefinedInTheSamePackage"
(expectation "type checking module Main:\n This package defines both interfaces and templates.")
LF.versionDefault
NoDependencies
warnBadInterfaceInstances
True
doTypecheck
, testGeneral
(prefix <> "WhenAnInterfaceIsUsedInThePackageThatItsDefinedIn")
"WarnsWhenAnInterfaceIsUsedInThePackageThatItsDefinedIn"
(expectation "type checking interface Main.I :\n The interface I was defined in this package and implemented in this package by the following templates:")
LF.versionDefault
NoDependencies
warnBadInterfaceInstances
True
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.")
LF.versionDefault
DependOnV1
warnBadInterfaceInstances
True
doTypecheck
]
| warnBadInterfaceInstances <- [True, False]
, let prefix = if warnBadInterfaceInstances then "Warns" else "Fail"
, let expectation msg =
if warnBadInterfaceInstances
then SucceedWithWarning ("\ESC\\[0;93mwarning while " <> msg)
else FailWithError ("\ESC\\[0;91merror " <> msg)
, doTypecheck <- [True, False]
]
)
where
contractKeysMinVersion :: LF.Version
contractKeysMinVersion =
@ -317,14 +449,32 @@ tests damlc =
"Expected at least one LF 2.x version to support contract keys."
(LF.featureMinVersion LF.featureContractKeys LF.V2)
test ::
String
test
:: String
-> Expectation
-> LF.Version
-> Dependency
-> Bool
-> Bool
-> TestTree
test name expectation lfVersion sharedDep =
testCase name $
test name expectation lfVersion sharedDep warnBadInterfaceInstances setUpgradeField =
testGeneral name name expectation lfVersion sharedDep warnBadInterfaceInstances setUpgradeField True
testGeneral
:: String
-> String
-> Expectation
-> LF.Version
-> Dependency
-> Bool
-> Bool
-> Bool
-> TestTree
testGeneral name location expectation lfVersion sharedDep warnBadInterfaceInstances setUpgradeField doTypecheck =
let upgradeFieldTrailer = if not setUpgradeField then " (no upgrades field)" else ""
doTypecheckTrailer = if not doTypecheck then " (disable typechecking)" else ""
in
testCase (name <> upgradeFieldTrailer <> doTypecheckTrailer) $
withTempDir $ \dir -> do
let newDir = dir </> "newVersion"
let oldDir = dir </> "oldVersion"
@ -333,48 +483,48 @@ tests damlc =
let testRunfile path = locateRunfiles (mainWorkspace </> "test-common/src/main/daml/upgrades" </> path)
v1FilePaths <- listDirectory =<< testRunfile (name </> "v1")
v1FilePaths <- listDirectory =<< testRunfile (location </> "v1")
let oldVersion = flip map v1FilePaths $ \path ->
( "daml" </> path
, readFile =<< testRunfile (name </> "v1" </> path)
, readFile =<< testRunfile (location </> "v1" </> path)
)
v2FilePaths <- listDirectory =<< testRunfile (name </> "v2")
v2FilePaths <- listDirectory =<< testRunfile (location </> "v2")
let newVersion = flip map v2FilePaths $ \path ->
( "daml" </> path
, readFile =<< testRunfile (name </> "v2" </> path)
, readFile =<< testRunfile (location </> "v2" </> path)
)
(depV1Dar, depV2Dar) <- case sharedDep of
SeparateDep -> do
depFilePaths <- listDirectory =<< testRunfile (name </> "dep")
depFilePaths <- listDirectory =<< testRunfile (location </> "dep")
let sharedDepFiles = flip map depFilePaths $ \path ->
( "daml" </> path
, readFile =<< testRunfile (name </> "dep" </> path)
, readFile =<< testRunfile (location </> "dep" </> path)
)
let sharedDir = dir </> "shared"
let sharedDar = sharedDir </> "out.dar"
writeFiles sharedDir (projectFile lfVersion ("upgrades-example-" <> name <> "-dep") Nothing Nothing : sharedDepFiles)
writeFiles sharedDir (projectFile ("upgrades-example-" <> location <> "-dep") Nothing Nothing : sharedDepFiles)
callProcessSilent damlc ["build", "--project-root", sharedDir, "-o", sharedDar]
pure (Just sharedDar, Just sharedDar)
SeparateDeps -> do
depV1FilePaths <- listDirectory =<< testRunfile (name </> "dep-v1")
depV1FilePaths <- listDirectory =<< testRunfile (location </> "dep-v1")
let depV1Files = flip map depV1FilePaths $ \path ->
( "daml" </> path
, readFile =<< testRunfile (name </> "dep-v1" </> path)
, readFile =<< testRunfile (location </> "dep-v1" </> path)
)
let depV1Dir = dir </> "shared-v1"
let depV1Dar = depV1Dir </> "out.dar"
writeFiles depV1Dir (projectFile lfVersion ("upgrades-example-" <> name <> "-dep-v1") Nothing Nothing : depV1Files)
writeFiles depV1Dir (projectFile ("upgrades-example-" <> location <> "-dep-v1") Nothing Nothing : depV1Files)
callProcessSilent damlc ["build", "--project-root", depV1Dir, "-o", depV1Dar]
depV2FilePaths <- listDirectory =<< testRunfile (name </> "dep-v2")
depV2FilePaths <- listDirectory =<< testRunfile (location </> "dep-v2")
let depV2Files = flip map depV2FilePaths $ \path ->
( "daml" </> path
, readFile =<< testRunfile (name </> "dep-v2" </> path)
, readFile =<< testRunfile (location </> "dep-v2" </> path)
)
let depV2Dir = dir </> "shared-v2"
let depV2Dar = depV2Dir </> "out.dar"
writeFiles depV2Dir (projectFile lfVersion ("upgrades-example-" <> name <> "-dep-v2") Nothing Nothing : depV2Files)
writeFiles depV2Dir (projectFile ("upgrades-example-" <> location <> "-dep-v2") Nothing Nothing : depV2Files)
callProcessSilent damlc ["build", "--project-root", depV2Dir, "-o", depV2Dar]
pure (Just depV1Dar, Just depV2Dar)
@ -383,13 +533,16 @@ tests damlc =
_ ->
pure (Nothing, Nothing)
writeFiles oldDir (projectFile lfVersion ("upgrades-example-" <> name) Nothing depV1Dar : oldVersion)
writeFiles oldDir (projectFile ("upgrades-example-" <> location) Nothing depV1Dar : oldVersion)
callProcessSilent damlc ["build", "--project-root", oldDir, "-o", oldDar]
writeFiles newDir (projectFile lfVersion ("upgrades-example-" <> name <> "-v2") (Just oldDar) depV2Dar : newVersion)
writeFiles newDir (projectFile ("upgrades-example-" <> location <> "-v2") (if setUpgradeField then Just oldDar else Nothing) depV2Dar : newVersion)
case expectation of
Succeed ->
callProcessSilent damlc ["build", "--project-root", newDir, "-o", newDar]
FailWithError _ | not (doTypecheck && setUpgradeField) ->
callProcessSilent damlc ["build", "--project-root", newDir, "-o", newDar]
FailWithError regex -> do
stderr <- callProcessForStderr damlc ["build", "--project-root", newDir, "-o", newDar]
let regexWithSeverity = "Severity: DsError\nMessage: \n" <> regex
@ -402,8 +555,31 @@ tests damlc =
let regexWithSeverity = "Severity: DsWarning\nMessage: \n" <> regex
let compiledRegex :: Regex
compiledRegex = makeRegexOpts defaultCompOpt { multiline = False } defaultExecOpt regexWithSeverity
unless (matchTest compiledRegex stderr) $
assertFailure ("`daml build` succeeded, but did not give a warning matching '" <> show regexWithSeverity <> "':\n" <> show stderr)
if setUpgradeField && doTypecheck
then unless (matchTest compiledRegex stderr) $
assertFailure ("`daml build` succeeded, but did not give a warning matching '" <> show regexWithSeverity <> "':\n" <> show stderr)
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 =
( "daml.yaml"
, unlines $
[ "sdk-version: " <> sdkVersion
, "name: " <> name
, "source: daml"
, "version: 0.0.1"
, "dependencies:"
, " - daml-prim"
, " - daml-stdlib"
, "build-options:"
, " - --target=" <> LF.renderVersion lfVersion
, " - --enable-interfaces=yes"
]
++ [" - --warn-bad-interface-instances=yes" | warnBadInterfaceInstances ]
++ ["upgrades: '" <> path <> "'" | Just path <- pure upgradedFile]
++ ["data-dependencies:\n - '" <> path <> "'" | Just path <- pure mbDep]
++ ["typecheck-upgrades: False" | not doTypecheck]
)
writeFiles dir fs =
for_ fs $ \(file, ioContent) -> do
@ -411,24 +587,6 @@ tests damlc =
createDirectoryIfMissing True (takeDirectory $ dir </> file)
writeFileUTF8 (dir </> file) content
projectFile lfVersion name upgradedFile mbDep =
( "daml.yaml"
, unlines $
[ "sdk-version: " <> sdkVersion
, "name: " <> name
, "source: daml"
, "version: 0.0.1"
, "dependencies:"
, " - daml-prim"
, " - daml-stdlib"
, "typecheck-upgrades: true"
, "build-options:"
, " - --target=" <> LF.renderVersion lfVersion
, " - --enable-interfaces=yes"
] ++ ["upgrades: '" <> path <> "'" | Just path <- pure upgradedFile]
++ ["data-dependencies:\n - '" <> path <> "'" | Just path <- pure mbDep]
)
data Expectation
= Succeed
| FailWithError T.Text

1
sdk/compiler/damlc/tests/src/DA/Test/DataDependencies.hs
View File

@ -2707,6 +2707,7 @@ tests TestArgs{..} =
{ buildOptions =
[ "--target=" <> LF.renderVersion targetDevVersion
, "--enable-interfaces=yes"
, "--warn-bad-interface-instances=yes"
]
, extraDeps = []
}

8
sdk/compiler/damlc/tests/src/DamlcTest.hs
View File

@ -103,7 +103,9 @@ testsForDamlcValidate damlc = testGroup "damlc validate-dar"
, "version: 0.0.1"
, "source: ."
, "dependencies: [daml-prim, daml-stdlib]"
, "build-options: [--enable-interfaces=yes]"
, "build-options:"
, "- --enable-interfaces=yes"
, "- --warn-bad-interface-instances=yes"
]
writeFileUTF8 (projDir </> "Good.daml") $ unlines
[ "module Good where"
@ -129,7 +131,9 @@ testsForDamlcValidate damlc = testGroup "damlc validate-dar"
, "version: 0.0.1"
, "source: ."
, "dependencies: [daml-prim, daml-stdlib]"
, "build-options: [--enable-interfaces=yes]"
, "build-options:"
, "- --enable-interfaces=yes"
, "- --warn-bad-interface-instances=yes"
]
writeFileUTF8 (projDir </> "Interface.daml") $ unlines
[ "module Interface where"

11
sdk/daml-assistant/integration-tests/src/DA/Daml/Assistant/IntegrationTests.hs
View File

@ -102,7 +102,7 @@ damlStart tmpDir disableUpgradeValidation = do
createDirectoryIfMissing True (projDir </> "daml")
let scriptOutputFile = "script-output.json"
writeFileUTF8 (projDir </> "daml.yaml") $
unlines
unlines $
[ "sdk-version: " <> sdkVersion
, "name: assistant-integration-tests"
, "version: \"1.0\""
@ -112,7 +112,6 @@ damlStart tmpDir disableUpgradeValidation = do
, " - daml-stdlib"
, " - daml3-script"
-- TODO(#14706): remove build-options once the default major version is 2
, "build-options: [--target=2.1]"
, "init-script: Main:init"
, "script-options:"
, " - --output-file"
@ -123,7 +122,9 @@ damlStart tmpDir disableUpgradeValidation = do
, " npm-scope: daml.js"
, " java:"
, " output-directory: ui/java"
]
, "build-options:"
, "- --target=2.1"
] ++ [ "- --warn-bad-interface-instances=yes" | disableUpgradeValidation ]
writeFileUTF8 (projDir </> "daml/Main.daml") $
unlines
[ "module Main where"
@ -535,7 +536,9 @@ cantonTests = testGroup "daml sandbox"
let outputLines = lines output
-- NOTE (Sofia): We use `isInfixOf` extensively because
-- the REPL output is full of color codes.
Just res0 <- pure (find (isInfixOf "res0") outputLines)
res0 <- case find (isInfixOf "res0") outputLines of
Just res0 -> pure res0
_ -> fail output
assertBool "sandbox participant is not running" ("true" `isInfixOf` res0)
Just res1 <- pure (find (isInfixOf "res1") outputLines)
assertBool "local domain is not running" ("true" `isInfixOf` res1)

1
sdk/daml-script/test/BUILD.bazel
View File

@ -72,6 +72,7 @@ dependencies:
build-options:
- --target={target}
- --enable-interfaces=yes
typecheck-upgrades: false
EOF
$(location //compiler/damlc) build --project-root=$$TMP_DIR --ghc-option=-Werror -o $$PWD/$(location script{scriptVersion}-test-v{name}.dar)
rm -rf $$TMP_DIR

1
sdk/docs/source/daml-script/template-root/daml.yaml.template
View File

@ -6,6 +6,7 @@ version: 0.0.1
build-options:
- --target=2.1
- --enable-interfaces=yes
- --warn-bad-interface-instances=yes
# script-build-options-end
# script-dependencies-begin
dependencies: