mirror of
https://github.com/digital-asset/daml.git
synced 2024-09-20 01:07:18 +03:00
interfaces: fix mkMethod erasure (#12171)
We erase the call to `mkMethod` in `convertExpr` instead of pattern matching against the binding. This fixes a bug when the method body contained statements using typeclass dictionaries such as `do [2] === [2]`. CHANGELOG_BEGIN CHANGELOG_END
This commit is contained in:
parent
2940a7b5c2
commit
1ed02369eb
@ -558,7 +558,7 @@ convertModule envLfVersion envEnableScenarios envPkgMap envStablePackages envIsG
|
|||||||
envInterfaceMethodInstances = MS.fromListWith (++)
|
envInterfaceMethodInstances = MS.fromListWith (++)
|
||||||
[
|
[
|
||||||
( (mod, mkTypeCon [getOccText iface], mkTypeCon [getOccText tpl])
|
( (mod, mkTypeCon [getOccText iface], mkTypeCon [getOccText tpl])
|
||||||
, [(methodName, body)]
|
, [(methodName, untick val)]
|
||||||
)
|
)
|
||||||
| (name, val) <- binds
|
| (name, val) <- binds
|
||||||
, TypeCon methodNewtype
|
, TypeCon methodNewtype
|
||||||
@ -569,15 +569,6 @@ convertModule envLfVersion envEnableScenarios envPkgMap envStablePackages envIsG
|
|||||||
] <- [varType name]
|
] <- [varType name]
|
||||||
, NameIn DA_Internal_Desugar "Method" <- [methodNewtype]
|
, NameIn DA_Internal_Desugar "Method" <- [methodNewtype]
|
||||||
, Just mod <- [nameModule_maybe (getName iface)]
|
, Just mod <- [nameModule_maybe (getName iface)]
|
||||||
, Var (NameIn DA_Internal_Desugar "mkMethod")
|
|
||||||
`App` Type _tpl
|
|
||||||
`App` Type _iface
|
|
||||||
`App` Type _methodName
|
|
||||||
`App` Type _methodType
|
|
||||||
`App` _implDict
|
|
||||||
`App` _hasMethodDict
|
|
||||||
`App` body
|
|
||||||
<- [untick val]
|
|
||||||
]
|
]
|
||||||
envChoiceData = MS.fromListWith (++)
|
envChoiceData = MS.fromListWith (++)
|
||||||
[ (mkTypeCon [getOccText tplTy], [ChoiceData ty v])
|
[ (mkTypeCon [getOccText tplTy], [ChoiceData ty v])
|
||||||
@ -1220,6 +1211,9 @@ convertExpr env0 e = do
|
|||||||
pure $ ETmLam (v, TStruct fields) $ ERecCon tupleType $ zipWithFrom mkFieldProj (1 :: Int) fields
|
pure $ ETmLam (v, TStruct fields) $ ERecCon tupleType $ zipWithFrom mkFieldProj (1 :: Int) fields
|
||||||
go env (VarIn GHC_Types "primitive") (LType (isStrLitTy -> Just y) : LType t : args)
|
go env (VarIn GHC_Types "primitive") (LType (isStrLitTy -> Just y) : LType t : args)
|
||||||
= fmap (, args) $ convertPrim (envLfVersion env) (unpackFS y) <$> convertType env t
|
= fmap (, args) $ convertPrim (envLfVersion env) (unpackFS y) <$> convertType env t
|
||||||
|
-- erase mkMethod calls and leave only the body.
|
||||||
|
go env (VarIn DA_Internal_Desugar "mkMethod") (LType _tpl : LType _iface : LType _methodName : LType _methodTy : LExpr _implDict : LExpr _hasMethodDic : LExpr body : args)
|
||||||
|
= go env body args
|
||||||
go env (VarIn GHC_Types "primitiveInterface") (LType (isStrLitTy -> Just y) : LType t : args)
|
go env (VarIn GHC_Types "primitiveInterface") (LType (isStrLitTy -> Just y) : LType t : args)
|
||||||
= do
|
= do
|
||||||
ty <- convertType env t
|
ty <- convertType env t
|
||||||
|
@ -73,6 +73,7 @@ template Asset
|
|||||||
pure (toInterfaceContractId @Token cid)
|
pure (toInterfaceContractId @Token cid)
|
||||||
|
|
||||||
let noopImpl = \nothing -> do
|
let noopImpl = \nothing -> do
|
||||||
|
[1] === [1] -- make sure `mkMethod` calls are properly erased in the presence of polymorphism.
|
||||||
pure ()
|
pure ()
|
||||||
|
|
||||||
main = scenario do
|
main = scenario do
|
||||||
|
Loading…
Reference in New Issue
Block a user