diff --git a/sdk/compiler/daml-lf-tools/BUILD.bazel b/sdk/compiler/daml-lf-tools/BUILD.bazel index 014ace6e60e..10f1a44f2ae 100644 --- a/sdk/compiler/daml-lf-tools/BUILD.bazel +++ b/sdk/compiler/daml-lf-tools/BUILD.bazel @@ -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", ], ) diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Check.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Check.hs index 7d20c9708a9..51a4e267488 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Check.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Check.hs @@ -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 diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Env.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Env.hs index 81400896a67..2dab97d87be 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Env.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Env.hs @@ -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 :) diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs index 442459fe367..3f3ec990389 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs @@ -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 diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/NameCollision.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/NameCollision.hs index 2a79d402e6c..766ac7a8dab 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/NameCollision.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/NameCollision.hs @@ -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) diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Recursion.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Recursion.hs index b993d5773f5..1cb625631a5 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Recursion.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Recursion.hs @@ -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)) diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs index dd84f969c90..aacff8cf44b 100644 --- a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs +++ b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs @@ -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 diff --git a/sdk/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Dar.hs b/sdk/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Dar.hs index ac839a5dd01..8d886a9ef6a 100644 --- a/sdk/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Dar.hs +++ b/sdk/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Dar.hs @@ -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 diff --git a/sdk/compiler/damlc/daml-opts/daml-opts-types/DA/Daml/Options/Types.hs b/sdk/compiler/damlc/daml-opts/daml-opts-types/DA/Daml/Options/Types.hs index 029c6a426ed..f7321386ef4 100644 --- a/sdk/compiler/damlc/daml-opts/daml-opts-types/DA/Daml/Options/Types.hs +++ b/sdk/compiler/damlc/daml-opts/daml-opts-types/DA/Daml/Options/Types.hs @@ -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 diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc.hs index abfbb25c529..36876f03094 100644 --- a/sdk/compiler/damlc/lib/DA/Cli/Damlc.hs +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc.hs @@ -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." diff --git a/sdk/compiler/damlc/lib/DA/Cli/Options.hs b/sdk/compiler/damlc/lib/DA/Cli/Options.hs index 4a119f4b9cf..3b4d355be93 100644 --- a/sdk/compiler/damlc/lib/DA/Cli/Options.hs +++ b/sdk/compiler/damlc/lib/DA/Cli/Options.hs @@ -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 $ diff --git a/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs b/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs index 026ef3ce698..656621ae62d 100644 --- a/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs +++ b/sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs @@ -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 :\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 :\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 :\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 :\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 :\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 :\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 :\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 :\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 diff --git a/sdk/compiler/damlc/tests/src/DA/Test/DataDependencies.hs b/sdk/compiler/damlc/tests/src/DA/Test/DataDependencies.hs index c5e333130f4..d08da12f49e 100644 --- a/sdk/compiler/damlc/tests/src/DA/Test/DataDependencies.hs +++ b/sdk/compiler/damlc/tests/src/DA/Test/DataDependencies.hs @@ -2707,6 +2707,7 @@ tests TestArgs{..} = { buildOptions = [ "--target=" <> LF.renderVersion targetDevVersion , "--enable-interfaces=yes" + , "--warn-bad-interface-instances=yes" ] , extraDeps = [] } diff --git a/sdk/compiler/damlc/tests/src/DamlcTest.hs b/sdk/compiler/damlc/tests/src/DamlcTest.hs index 069e99db2ee..e9582e97068 100644 --- a/sdk/compiler/damlc/tests/src/DamlcTest.hs +++ b/sdk/compiler/damlc/tests/src/DamlcTest.hs @@ -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" diff --git a/sdk/daml-assistant/integration-tests/src/DA/Daml/Assistant/IntegrationTests.hs b/sdk/daml-assistant/integration-tests/src/DA/Daml/Assistant/IntegrationTests.hs index bdb8b69917a..4dfe0ce8b54 100644 --- a/sdk/daml-assistant/integration-tests/src/DA/Daml/Assistant/IntegrationTests.hs +++ b/sdk/daml-assistant/integration-tests/src/DA/Daml/Assistant/IntegrationTests.hs @@ -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) diff --git a/sdk/daml-script/test/BUILD.bazel b/sdk/daml-script/test/BUILD.bazel index f7512d2d738..9e6fc296ce1 100644 --- a/sdk/daml-script/test/BUILD.bazel +++ b/sdk/daml-script/test/BUILD.bazel @@ -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 diff --git a/sdk/docs/source/daml-script/template-root/daml.yaml.template b/sdk/docs/source/daml-script/template-root/daml.yaml.template index 476ddde6d71..7076e0362a2 100644 --- a/sdk/docs/source/daml-script/template-root/daml.yaml.template +++ b/sdk/docs/source/daml-script/template-root/daml.yaml.template @@ -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: