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

Compiler: Clean compiler from from Exercise's actors (#8076)

Browse Source 
This is the Haskell counterpart of #8071.
This advances the state of #7155.

CHANGELOG_BEGIN
CHANGELOG_END
This commit is contained in:
Remy 2020-11-26 15:38:30 +01:00 committed by GitHub
parent de498e4b0c
commit 174ba1de30
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
13 changed files with 21 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Alpha.hs
View File

@ -29,13 +29,6 @@ data AlphaEnv = AlphaEnv
-- the depth of the binder which introduced them.
}
onMaybe :: (a -> a -> Bool) -> Maybe a -> Maybe a -> Bool
onMaybe f me1 me2 = case (me1, me2) of
(Nothing, Nothing) -> True
(Nothing, Just _) -> False
(Just _, Nothing) -> False
(Just e1, Just e2) -> f e1 e2
onList :: (a -> a -> Bool) -> [a] -> [a] -> Bool
onList f xs ys = length xs == length ys
&& and (zipWith f xs ys)
@ -265,12 +258,11 @@ alphaUpdate env = \case
UCreate t2 e2 -> alphaTypeCon t1 t2
&& alphaExpr' env e1 e2
_ -> False
UExercise t1 c1 e1a e1b e1c -> \case
UExercise t2 c2 e2a e2b e2c -> alphaTypeCon t1 t2
UExercise t1 c1 e1a e1b -> \case
UExercise t2 c2 e2a e2b -> alphaTypeCon t1 t2
&& c1 == c2
&& alphaExpr' env e1a e2a
&& onMaybe (alphaExpr' env) e1b e2b
&& alphaExpr' env e1c e2c
&& alphaExpr' env e1b e2b
_ -> False
UExerciseByKey t1 c1 e1a e1b -> \case
UExerciseByKey t2 c2 e2a e2b -> alphaTypeCon t1 t2

2
compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Base.hs
View File

@ -589,8 +589,6 @@ data Update
-- ^ Choice to exercise.
, exeContractId :: !Expr
-- ^ Contract id of the contract template instance to exercise choice on.
, exeActors :: !(Maybe Expr)
-- ^ Parties exercising the choice.
, exeArg :: !Expr
-- ^ Argument for the choice.
}

3
compiler/daml-lf-ast/src/DA/Daml/LF/Ast/FreeVars.hs
View File

@ -25,7 +25,6 @@ import DA.Daml.LF.Ast.Recursive
import qualified DA.Daml.LF.Ast.Type as Type
import Data.Functor.Foldable (cata)
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set
import qualified Data.Text as T
import Safe (findJust)
@ -129,7 +128,7 @@ freeVarsStep = \case
UPureF t e -> freeVarsInType t <> e
UBindF b e -> goBinding b e
UCreateF _ e -> e
UExerciseF _ _ e1 e2M e3 -> e1 <> fromMaybe mempty e2M <> e3
UExerciseF _ _ e1 e2 -> e1 <> e2
UExerciseByKeyF _ _ e1 e2 -> e1 <> e2
UFetchF _ e -> e
UGetTimeF -> mempty

6
compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Pretty.hs
View File

@ -377,14 +377,10 @@ instance Pretty Update where
$$ keyword_ "in" <-> pPrintPrec lvl precELam body
UCreate tpl arg ->
pPrintAppKeyword lvl prec "create" [tplArg tpl, TmArg arg]
UExercise tpl choice cid Nothing arg ->
UExercise tpl choice cid arg ->
-- NOTE(MH): Converting the choice name into a variable is a bit of a hack.
pPrintAppKeyword lvl prec "exercise"
[tplArg tpl, TmArg (EVar (ExprVarName (unChoiceName choice))), TmArg cid, TmArg arg]
UExercise tpl choice cid (Just actor) arg ->
-- NOTE(MH): Converting the choice name into a variable is a bit of a hack.
pPrintAppKeyword lvl prec "exercise_with_actors"
[tplArg tpl, TmArg (EVar (ExprVarName (unChoiceName choice))), TmArg cid, TmArg actor, TmArg arg]
UExerciseByKey tpl choice key arg ->
pPrintAppKeyword lvl prec "exercise_by_key"
[tplArg tpl, TmArg (EVar (ExprVarName (unChoiceName choice))), TmArg key, TmArg arg]

6
compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Recursive.hs
View File

@ -55,7 +55,7 @@ data UpdateF expr
= UPureF !Type !expr
| UBindF !(BindingF expr) !expr
| UCreateF !(Qualified TypeConName) !expr
| UExerciseF !(Qualified TypeConName) !ChoiceName !expr !(Maybe expr) !expr
| UExerciseF !(Qualified TypeConName) !ChoiceName !expr !expr
| UExerciseByKeyF !(Qualified TypeConName) !ChoiceName !expr !expr
| UFetchF !(Qualified TypeConName) !expr
| UGetTimeF
@ -100,7 +100,7 @@ projectUpdate = \case
UPure a b -> UPureF a b
UBind a b -> UBindF (projectBinding a) b
UCreate a b -> UCreateF a b
UExercise a b c d e -> UExerciseF a b c d e
UExercise a b c d -> UExerciseF a b c d
UExerciseByKey a b c d -> UExerciseByKeyF a b c d
UFetch a b -> UFetchF a b
UGetTime -> UGetTimeF
@ -116,7 +116,7 @@ embedUpdate = \case
UPureF a b -> UPure a b
UBindF a b -> UBind (embedBinding a) b
UCreateF a b -> UCreate a b
UExerciseF a b c d e -> UExercise a b c d e
UExerciseF a b c d -> UExercise a b c d
UExerciseByKeyF a b c d -> UExerciseByKey a b c d
UFetchF a b -> UFetch a b
UGetTimeF -> UGetTime

5
compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Subst.hs
View File

@ -226,12 +226,11 @@ applySubstInUpdate subst = \case
UCreate templateName e -> UCreate
templateName
(applySubstInExpr subst e)
UExercise templateName choiceName e1 e2M e3 -> UExercise
UExercise templateName choiceName e1 e2 -> UExercise
templateName
choiceName
(applySubstInExpr subst e1)
(applySubstInExpr subst <$> e2M)
(applySubstInExpr subst e3)
(applySubstInExpr subst e2)
UExerciseByKey templateName choiceName e1 e2 -> UExerciseByKey
templateName
choiceName

1
compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/DecodeV1.hs
View File

@ -594,7 +594,6 @@ decodeUpdate LF1.Update{..} = mayDecode "updateSum" updateSum $ \case
<$> mayDecode "update_ExerciseTemplate" update_ExerciseTemplate decodeTypeConName
<*> decodeName ChoiceName update_ExerciseChoice
<*> mayDecode "update_ExerciseCid" update_ExerciseCid decodeExpr
<*> traverse decodeExpr update_ExerciseActor
<*> mayDecode "update_ExerciseArg" update_ExerciseArg decodeExpr
LF1.UpdateSumExerciseByKey LF1.Update_ExerciseByKey{..} ->
fmap EUpdate $ UExerciseByKey

2
compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/EncodeV1.hs
View File

@ -669,9 +669,9 @@ encodeUpdate = fmap (P.Update . Just) . \case
update_ExerciseTemplate <- encodeQualTypeConName exeTemplate
update_ExerciseChoice <- encodeName unChoiceName exeChoice
update_ExerciseCid <- encodeExpr exeContractId
update_ExerciseActor <- traverse encodeExpr' exeActors
update_ExerciseArg <- encodeExpr exeArg
pure $ P.UpdateSumExercise P.Update_Exercise{..}
where update_ExerciseActor = Nothing
UExerciseByKey{..} -> do
update_ExerciseByKeyTemplate <- encodeQualTypeConName exeTemplate
update_ExerciseByKeyChoiceInternedStr <-

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

@ -565,11 +565,10 @@ checkCreate tpl arg = do
checkExpr arg (TCon tpl)
typeOfExercise :: MonadGamma m =>
Qualified TypeConName -> ChoiceName -> Expr -> Maybe Expr -> Expr -> m Type
typeOfExercise tpl chName cid mbActors arg = do
Qualified TypeConName -> ChoiceName -> Expr -> Expr -> m Type
typeOfExercise tpl chName cid arg = do
choice <- inWorld (lookupChoice (tpl, chName))
checkExpr cid (TContractId (TCon tpl))
whenJust mbActors $ \actors -> checkExpr actors (TList TParty)
checkExpr arg (chcArgType choice)
pure (TUpdate (chcReturnType choice))
@ -605,7 +604,7 @@ typeOfUpdate = \case
UPure typ expr -> checkPure typ expr $> TUpdate typ
UBind binding body -> typeOfBind binding body
UCreate tpl arg -> checkCreate tpl arg $> TUpdate (TContractId (TCon tpl))
UExercise tpl choice cid actors arg -> typeOfExercise tpl choice cid actors arg
UExercise tpl choice cid arg -> typeOfExercise tpl choice cid arg
UExerciseByKey tpl choice key arg -> typeOfExerciseByKey tpl choice key arg
UFetch tpl cid -> checkFetch tpl cid $> TUpdate (TCon tpl)
UGetTime -> pure (TUpdate TTimestamp)

10
compiler/daml-lf-verify/src/DA/Daml/LF/Verify/Generate.hs
View File

@ -262,7 +262,7 @@ genUpdate = \case
let out' = updateOutExpr (EUpdate $ UPure typ (_oExpr out)) out
return (out', Just typ, Nothing)
UCreate tem arg -> genForCreate tem arg
UExercise tem ch cid par arg -> genForExercise tem ch cid par arg
UExercise tem ch cid arg -> genForExercise tem ch cid arg
UGetTime -> return (emptyOut (EUpdate UGetTime), Just $ TBuiltin BTTimestamp, Nothing)
-- TODO: This can be extended with missing cases later on.
u -> error ("Update not implemented yet: " ++ show u)
@ -450,13 +450,11 @@ genForExercise :: (GenPhase ph, MonadEnv m ph)
-> ChoiceName
-- ^ The choice which is being exercised.
-> Expr
-- ^ The contract id on which the choice is being exercised.
-> Maybe Expr
-- ^ The party which exercises the choice.
-> Expr
-- ^ The arguments with which the choice is being exercised.
-> m (Output ph, Maybe Type, Maybe Expr)
genForExercise tem ch cid par arg = do
genForExercise tem ch cid arg = do
cidOut <- genExpr True cid
arout <- genExpr True arg
lookupChoice tem ch >>= \case
@ -466,12 +464,12 @@ genForExercise tem ch cid par arg = do
updSet = if containsChoiceRefs updSet_refs
then addChoice emptyUpdateSet tem ch
else updSet_refs
return ( Output (EUpdate (UExercise tem ch (_oExpr cidOut) par (_oExpr arout))) updSet
return ( Output (EUpdate (UExercise tem ch (_oExpr cidOut) (_oExpr arout))) updSet
, Just resType
, Nothing )
Nothing -> do
let updSet = addChoice emptyUpdateSet tem ch
return ( Output (EUpdate (UExercise tem ch (_oExpr cidOut) par (_oExpr arout))) updSet
return ( Output (EUpdate (UExercise tem ch (_oExpr cidOut) (_oExpr arout))) updSet
, Nothing
, Nothing )

2
compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/Primitives.hs
View File

@ -291,7 +291,7 @@ convertPrim _ "UExercise"
(TContractId (TCon template) :-> TCon choice :-> TUpdate _returnTy) =
ETmLam (mkVar "this", TContractId (TCon template)) $
ETmLam (mkVar "arg", TCon choice) $
EUpdate $ UExercise template choiceName (EVar (mkVar "this")) Nothing (EVar (mkVar "arg"))
EUpdate $ UExercise template choiceName (EVar (mkVar "this")) (EVar (mkVar "arg"))
where
choiceName = ChoiceName (T.intercalate "." $ unTypeConName $ qualObject choice)

2
compiler/damlc/daml-visual/src/DA/Daml/Visual.hs
View File

@ -136,7 +136,7 @@ startFromUpdate seen world update = case update of
LF.UGetTime -> Set.empty
LF.UEmbedExpr _ upEx -> startFromExpr seen world upEx
LF.UCreate tpl _ -> Set.singleton (ACreate tpl)
LF.UExercise tpl choice _ _ _ -> Set.singleton (AExercise tpl choice)
LF.UExercise tpl choice _ _ -> Set.singleton (AExercise tpl choice)
LF.UExerciseByKey tpl choice _ _ -> Set.singleton (AExercise tpl choice)
LF.UFetch{} -> Set.empty
LF.ULookupByKey{} -> Set.empty

2
daml-lf/engine/src/test/scala/com/digitalasset/daml/lf/engine/ContractDiscriminatorFreshnessCheckSpec.scala
View File

@ -208,7 +208,7 @@ class ContractDiscriminatorFreshnessCheckSpec
}
"fails when a local conflicts with a local contract previously fetched" in {
"fails when a local conflicts with a local contract previously fetched" in {
val conflictingCid = {
val createNodeSeed = crypto.Hash.deriveNodeSeed(transactionSeed, 1)