From 664a0c007651007b49c02e8c2312ec24577fdf53 Mon Sep 17 00:00:00 2001 From: Stephen Compall Date: Fri, 9 Oct 2020 13:56:24 -0400 Subject: [PATCH] add Action to high-level trigger updateState (#7621) * add ActionState to the standard library * use 1 ActionState, 1 get, 1 put in low-level trigger library * introduce TriggerStateA for updateState * fix tests and examples for new updateState signature CHANGELOG_BEGIN - [Triggers] The ``updateState`` function now returns a ``TriggerStateA``. This is an action like ``TriggerA``, but doesn't permit emitting commands. Instead of taking the state as an argument and returning a new state, you can manipulate the state with ``get``, ``put``, and ``modify``. Any existing ``updateState`` can be ported by replacing ``s -> expr`` in the lambda expression with ``-> modify $ \s ->``, and then made to look nicer from there as desired. See `issue #7621 `__. CHANGELOG_END * some DAML docs for updateState and TriggerStateA --- .../daml_trigger/example/src/CopyTrigger.daml | 2 +- .../daml-stdlib-src/DA/Action/State.daml | 35 ++++++++----------- .../DA/Action/State/Class.daml | 35 +++++++++++++++++++ docs/source/triggers/index.rst | 2 +- .../template-root/src/CopyTrigger.daml | 2 +- .../daml/UpgradeTrigger.daml | 2 +- triggers/daml/Daml/Trigger.daml | 19 ++++++---- triggers/daml/Daml/Trigger/Internal.daml | 10 ++++++ triggers/daml/Daml/Trigger/LowLevel.daml | 20 ++++------- triggers/service/test-model/ErrorTrigger.daml | 2 +- triggers/service/test-model/TestTrigger.daml | 2 +- triggers/tests/daml/CreateAndExercise.daml | 2 +- triggers/tests/daml/ExerciseByKey.daml | 6 ++-- .../tests/daml/MaxInboundMessageTest.daml | 2 +- triggers/tests/daml/PendingSet.daml | 2 +- triggers/tests/daml/Retry.daml | 6 ++-- triggers/tests/daml/TemplateIdFilter.daml | 2 +- triggers/tests/scenarios/Rule.daml | 2 +- 18 files changed, 97 insertions(+), 56 deletions(-) create mode 100644 compiler/damlc/daml-stdlib-src/DA/Action/State/Class.daml diff --git a/compatibility/bazel_tools/daml_trigger/example/src/CopyTrigger.daml b/compatibility/bazel_tools/daml_trigger/example/src/CopyTrigger.daml index 08cf532e941..e773fdb93f4 100755 --- a/compatibility/bazel_tools/daml_trigger/example/src/CopyTrigger.daml +++ b/compatibility/bazel_tools/daml_trigger/example/src/CopyTrigger.daml @@ -51,7 +51,7 @@ deriving instance Ord Copy copyTrigger : Trigger () copyTrigger = Trigger { initialize = \_acs -> () - , updateState = \_acs _message () -> () + , updateState = \_acs _message -> pure () , rule = copyRule , registeredTemplates = AllInDar , heartbeat = None diff --git a/compiler/damlc/daml-stdlib-src/DA/Action/State.daml b/compiler/damlc/daml-stdlib-src/DA/Action/State.daml index 9ed626c058e..ca42439dce2 100644 --- a/compiler/damlc/daml-stdlib-src/DA/Action/State.daml +++ b/compiler/damlc/daml-stdlib-src/DA/Action/State.daml @@ -11,6 +11,8 @@ module DA.Action.State , modify ) where +import DA.Action.State.Class + -- | A value of type `State s a` represents a computation that has access to a state variable -- of type `s` and produces a value of type `a`. -- @@ -23,6 +25,15 @@ module DA.Action.State -- >>> execState (modify (+1)) 0 -- 1 -- +-- >>> runState (do x <- get; modify (+1); pure x) 0 +-- (0, 1) +-- +-- >>> runState (put 1) 0 +-- ((), 1) +-- +-- >>> runState (modify (+1)) 0 +-- ((), 1) +-- -- Note that values of type `State s a` are not serializable. newtype State s a = State { runState : s -> (a, s) } deriving Functor @@ -47,23 +58,7 @@ evalState a s = fst (runState a s) execState : State s a -> s -> s execState a s = snd (runState a s) --- | Fetch the current value of the state variable. --- --- >>> runState (do x <- get; modify (+1); pure x) 0 --- (0, 1) -get : State s s -get = State (\s -> (s, s)) - --- | Set the value of the state variable. --- --- >>> runState (put 1) 0 --- ((), 1) -put : s -> State s () -put s = State (\_ -> ((), s)) - --- | Modify the state variable with the given function. --- --- >>> runState (modify (+1)) 0 --- ((), 1) -modify : (s -> s) -> State s () -modify f = State (\s -> ((), f s)) +instance ActionState s (State s) where + get = State (\s -> (s, s)) + put s = State (\_ -> ((), s)) + modify f = State (\s -> ((), f s)) diff --git a/compiler/damlc/daml-stdlib-src/DA/Action/State/Class.daml b/compiler/damlc/daml-stdlib-src/DA/Action/State/Class.daml new file mode 100644 index 00000000000..94e93d54458 --- /dev/null +++ b/compiler/damlc/daml-stdlib-src/DA/Action/State/Class.daml @@ -0,0 +1,35 @@ +-- Copyright (c) 2020 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE DefaultSignatures #-} + +-- | DA.Action.State.Class +module DA.Action.State.Class + ( ActionState(..) + ) where + +-- | Action `m` has a state variable of type `s`. +-- +-- Rules: +-- get *> ma = ma +-- ma <* get = ma +-- put a >>= get = put a $> a +-- put a *> put b = put b +-- (,) <$> get <*> get = get <&> \a -> (a, a) +-- +-- Informally, these rules mean it behaves like an ordinary assignable variable: +-- it doesn't magically change value by looking at it, if you put a value there +-- that's always the value you'll get if you read it, assigning a value but +-- never reading that value has no effect, and so on. +class ActionState s m | m -> s where + {-# MINIMAL get, (put | modify) #-} + -- | Fetch the current value of the state variable. + get : m s + + -- | Set the value of the state variable. + put : s -> m () + put = modify . const + + -- | Modify the state variable with the given function. + modify : (s -> s) -> m () + default modify : Action m => (s -> s) -> m () + modify f = put . f =<< get diff --git a/docs/source/triggers/index.rst b/docs/source/triggers/index.rst index 17709752c70..de0e560c9d1 100644 --- a/docs/source/triggers/index.rst +++ b/docs/source/triggers/index.rst @@ -102,7 +102,7 @@ To create a trigger you need to define a value of type ``Trigger s`` where ``s`` data Trigger s = Trigger { initialize : ACS -> s - , updateState : ACS -> Message -> s -> s + , updateState : ACS -> Message -> TriggerStateA s () , rule : Party -> ACS -> s -> TriggerA () , registeredTemplates : RegisteredTemplates , heartbeat : Optional RelTime diff --git a/docs/source/triggers/template-root/src/CopyTrigger.daml b/docs/source/triggers/template-root/src/CopyTrigger.daml index 5fc5c1a5b18..8522eb83376 100644 --- a/docs/source/triggers/template-root/src/CopyTrigger.daml +++ b/docs/source/triggers/template-root/src/CopyTrigger.daml @@ -51,7 +51,7 @@ deriving instance Ord Copy copyTrigger : Trigger () copyTrigger = Trigger { initialize = \_acs -> () - , updateState = \_acs _message () -> () + , updateState = \_acs _message -> pure () , rule = copyRule , registeredTemplates = AllInDar , heartbeat = None diff --git a/docs/source/upgrade/example/coin-upgrade-trigger/daml/UpgradeTrigger.daml b/docs/source/upgrade/example/coin-upgrade-trigger/daml/UpgradeTrigger.daml index 62243287d2d..a69311fba3b 100644 --- a/docs/source/upgrade/example/coin-upgrade-trigger/daml/UpgradeTrigger.daml +++ b/docs/source/upgrade/example/coin-upgrade-trigger/daml/UpgradeTrigger.daml @@ -18,7 +18,7 @@ import UpgradeFromCoinV1 upgradeTrigger : Trigger () upgradeTrigger = Trigger with initialize = \_acs -> () - updateState = \_acs _msg () -> () + updateState = \_acs _msg -> pure () registeredTemplates = AllInDar heartbeat = None rule = triggerRule diff --git a/triggers/daml/Daml/Trigger.daml b/triggers/daml/Daml/Trigger.daml index 6dff96e2b88..57bf38e506a 100644 --- a/triggers/daml/Daml/Trigger.daml +++ b/triggers/daml/Daml/Trigger.daml @@ -9,6 +9,10 @@ module Daml.Trigger , getTemplates , Trigger(..) , TriggerA + , TriggerStateA + , get + , put + , modify , emitCommands , runTrigger , CommandId @@ -35,6 +39,7 @@ module Daml.Trigger ) where import DA.Action +import DA.Action.State (execState) import DA.Functor ((<&>)) #ifdef DAML_GENMAP && DAML_GENERIC_COMPARISON import qualified DA.Map as GMap @@ -71,9 +76,10 @@ getContracts (ACS tpls pending) = mapOptional fromAny data Trigger s = Trigger { initialize : ACS -> s -- ^ Initialize the user-defined state based on the ACS. - , updateState : ACS -> Message -> s -> s - -- ^ Update the user-defined state based on the ACS and a transaction or - -- completion message. + , updateState : ACS -> Message -> TriggerStateA s () + -- ^ Update the user-defined state based on the ACS and a transaction + -- or completion message. It can manipulate the state with `get`, + -- `put`, and `modify`. , rule : Party -> ACS -> s -> TriggerA () -- ^ The rule defines the main logic of your trigger. It can send commands -- to the ledger using `emitCommands` to change the ACS. @@ -196,12 +202,13 @@ runTrigger userTrigger = LowLevel.Trigger userState = userTrigger.initialize acs state = TriggerState acs party userState Map.empty in TriggerSetup $ execStateT (runTriggerRule $ runRule userTrigger.rule) state + utUpdateState acs msg = execState $ runTriggerStateA $ userTrigger.updateState acs msg update msg = do time <- getTime state <- get case msg of MCompletion completion -> - let userState = userTrigger.updateState state.acs (MCompletion completion) state.userState + let userState = utUpdateState state.acs (MCompletion completion) state.userState in case completion.status of Succeeded {} -> -- We delete successful completions when we receive the corresponding transaction @@ -214,7 +221,7 @@ runTrigger userTrigger = LowLevel.Trigger runRule userTrigger.rule MTransaction transaction -> do let acs = applyTransaction transaction state.acs - userState = userTrigger.updateState acs (MTransaction transaction) state.userState + userState = utUpdateState acs (MTransaction transaction) state.userState -- See the comment above for why we delete this here instead of when we receive the completion. (acs', commandsInFlight) = case transaction.commandId of None -> (acs, state.commandsInFlight) @@ -222,6 +229,6 @@ runTrigger userTrigger = LowLevel.Trigger put $ state { acs = acs', userState, commandsInFlight } runRule userTrigger.rule MHeartbeat -> do - let userState = userTrigger.updateState state.acs MHeartbeat state.userState + let userState = utUpdateState state.acs MHeartbeat state.userState put $ state { userState } runRule userTrigger.rule diff --git a/triggers/daml/Daml/Trigger/Internal.daml b/triggers/daml/Daml/Trigger/Internal.daml index c6d1c645f8e..7550d9ead62 100644 --- a/triggers/daml/Daml/Trigger/Internal.daml +++ b/triggers/daml/Daml/Trigger/Internal.daml @@ -6,6 +6,7 @@ module Daml.Trigger.Internal ( ACS (..) , TriggerA (..) + , TriggerStateA (..) , addCommands , insertTpl , groupActiveContracts @@ -18,6 +19,7 @@ module Daml.Trigger.Internal , TriggerState (..) ) where +import DA.Action.State import DA.Next.Map (Map) import qualified DA.Next.Map as Map #ifdef DAML_GENMAP && DAML_GENERIC_COMPARISON @@ -50,6 +52,14 @@ data ACS = ACS newtype TriggerA a = TriggerA (TriggerRule TriggerAState a) deriving (Functor, Applicative, Action, HasTime) +-- | TriggerStateA is the type used in the `updateState` of a DAML +-- trigger. It has similar actions in common with `TriggerA`, but +-- cannot use `emitCommands` or `getTime`. +newtype TriggerStateA s a = TriggerStateA { runTriggerStateA : State s a } + deriving (Functor, Applicative, Action) + +deriving instance ActionState s (TriggerStateA s) + -- Internal API addCommands : Map CommandId [Command] -> Commands -> Map CommandId [Command] diff --git a/triggers/daml/Daml/Trigger/LowLevel.daml b/triggers/daml/Daml/Trigger/LowLevel.daml index 84a8f390842..807e1a6b18c 100644 --- a/triggers/daml/Daml/Trigger/LowLevel.daml +++ b/triggers/daml/Daml/Trigger/LowLevel.daml @@ -39,13 +39,13 @@ module Daml.Trigger.LowLevel , TriggerSetup(..) , TriggerRule(..) , ActionState(..) - , modify , zoom , submitCommands , simulateRule ) where -import qualified DA.Action.State as State +import DA.Action.State +import DA.Action.State.Class import DA.Functor ((<&>)) import DA.Next.Map (MapKey(..)) import DA.Time (RelTime(..)) @@ -272,16 +272,10 @@ instance Action m => Action (StateT s m) where (x', s') <- x s runStateT (f x') s' -class ActionState s m | m -> s where - get : m s - put : s -> m () - -modify : (Action m, ActionState s m) => (s -> s) -> m () -modify f = put . f =<< get - instance Applicative m => ActionState s (StateT s m) where get = StateT $ \s -> pure (s, s) put s = StateT $ const $ pure ((), s) + modify f = StateT $ \s -> pure ((), f s) execStateT : Functor m => StateT s m a -> s -> m s execStateT (StateT fa) = fmap snd . fa @@ -306,13 +300,13 @@ newtype TriggerRule s a = TriggerRule { runTriggerRule : StateT s (Free TriggerF -- meant for testing purposes only. simulateRule : TriggerRule s a -> Time -> s -> (s, [Commands], a) simulateRule rule time s = (s', reverse cmds, a) - where ((a, s'), (cmds, _)) = State.runState (foldFree sim (runStateT (runTriggerRule rule) s)) ([], 0) - sim : TriggerF x -> State.State ([Commands], Int) x + where ((a, s'), (cmds, _)) = runState (foldFree sim (runStateT (runTriggerRule rule) s)) ([], 0) + sim : TriggerF x -> State ([Commands], Int) x sim (GetTime f) = pure (f time) sim (Submit (cmds, f)) = do - (pastCmds, nextId) <- State.get + (pastCmds, nextId) <- get let nextIdShown = show nextId - State.put (Commands (CommandId nextIdShown) cmds :: pastCmds, nextId + 1) + put (Commands (CommandId nextIdShown) cmds :: pastCmds, nextId + 1) pure $ f nextIdShown deriving instance ActionState s (TriggerRule s) diff --git a/triggers/service/test-model/ErrorTrigger.daml b/triggers/service/test-model/ErrorTrigger.daml index f3e90286e66..5fb01254c55 100644 --- a/triggers/service/test-model/ErrorTrigger.daml +++ b/triggers/service/test-model/ErrorTrigger.daml @@ -8,7 +8,7 @@ import Daml.Trigger trigger : Trigger () trigger = Trigger with initialize = \_ -> () - updateState = \_ _ _ -> () + updateState = \_ _ -> pure () rule = triggerRule registeredTemplates = AllInDar heartbeat = None diff --git a/triggers/service/test-model/TestTrigger.daml b/triggers/service/test-model/TestTrigger.daml index 58de23ea262..04ff9429f04 100644 --- a/triggers/service/test-model/TestTrigger.daml +++ b/triggers/service/test-model/TestTrigger.daml @@ -25,7 +25,7 @@ template B trigger : Trigger () trigger = Trigger with initialize = \_ -> () - updateState = \_ _ _ -> () + updateState = \_ _ -> pure () rule = triggerRule registeredTemplates = AllInDar heartbeat = None diff --git a/triggers/tests/daml/CreateAndExercise.daml b/triggers/tests/daml/CreateAndExercise.daml index 59ec51951da..b8250149037 100644 --- a/triggers/tests/daml/CreateAndExercise.daml +++ b/triggers/tests/daml/CreateAndExercise.daml @@ -9,7 +9,7 @@ import Daml.Trigger createAndExerciseTrigger : Trigger () createAndExerciseTrigger = Trigger { initialize = \_ -> () - , updateState = \_ _ _ -> () + , updateState = \_ _ -> pure () , rule = createAndExerciseRule , registeredTemplates = AllInDar , heartbeat = None diff --git a/triggers/tests/daml/ExerciseByKey.daml b/triggers/tests/daml/ExerciseByKey.daml index 086b73be4e1..712e211b1e6 100644 --- a/triggers/tests/daml/ExerciseByKey.daml +++ b/triggers/tests/daml/ExerciseByKey.daml @@ -9,10 +9,10 @@ import Daml.Trigger exerciseByKeyTrigger : Trigger Int exerciseByKeyTrigger = Trigger { initialize = \_acs -> 3 - , updateState = \_acs msg allowedFail -> case msg of + , updateState = \_acs msg -> case msg of MCompletion c - | Failed {} <- c.status -> allowedFail - 1 - _ -> allowedFail + | Failed {} <- c.status -> modify (subtract 1) + _ -> pure () , rule = retryRule , registeredTemplates = AllInDar , heartbeat = None diff --git a/triggers/tests/daml/MaxInboundMessageTest.daml b/triggers/tests/daml/MaxInboundMessageTest.daml index a0226b322aa..5c236c54791 100644 --- a/triggers/tests/daml/MaxInboundMessageTest.daml +++ b/triggers/tests/daml/MaxInboundMessageTest.daml @@ -10,7 +10,7 @@ import Daml.Trigger maxInboundMessageSizeTrigger : Trigger () maxInboundMessageSizeTrigger = Trigger { initialize = \_ -> () - , updateState = \_ _ _ -> () + , updateState = \_ _ -> pure () , rule = maxInboundMessageSizeRule , registeredTemplates = AllInDar , heartbeat = None diff --git a/triggers/tests/daml/PendingSet.daml b/triggers/tests/daml/PendingSet.daml index 515382ff0bd..f3cf4d5de18 100644 --- a/triggers/tests/daml/PendingSet.daml +++ b/triggers/tests/daml/PendingSet.daml @@ -36,7 +36,7 @@ template Done booTrigger : Trigger () booTrigger = Trigger with initialize = \acs -> () - updateState = \acs _ s -> s + updateState = \acs _ -> pure () rule = booRule registeredTemplates = AllInDar heartbeat = None diff --git a/triggers/tests/daml/Retry.daml b/triggers/tests/daml/Retry.daml index 77592318ba0..0170a96ddee 100644 --- a/triggers/tests/daml/Retry.daml +++ b/triggers/tests/daml/Retry.daml @@ -9,10 +9,10 @@ import Daml.Trigger retryTrigger : Trigger Int retryTrigger = Trigger { initialize = \_acs -> 3 - , updateState = \_acs msg allowedFail -> case msg of + , updateState = \_acs msg -> case msg of MCompletion c - | Failed {} <- c.status -> allowedFail - 1 - _ -> allowedFail + | Failed {} <- c.status -> modify (subtract 1) + _ -> pure () , rule = retryRule , registeredTemplates = AllInDar , heartbeat = None diff --git a/triggers/tests/daml/TemplateIdFilter.daml b/triggers/tests/daml/TemplateIdFilter.daml index e79d8687739..45963db90a7 100644 --- a/triggers/tests/daml/TemplateIdFilter.daml +++ b/triggers/tests/daml/TemplateIdFilter.daml @@ -10,7 +10,7 @@ import Daml.Trigger test : RegisteredTemplates -> Trigger () test registered = Trigger { initialize = \_acs -> () - , updateState = \_acs _message () -> () + , updateState = \_acs _message -> pure () , registeredTemplates = registered , rule = \party acs () -> do let ones = getContracts @One acs diff --git a/triggers/tests/scenarios/Rule.daml b/triggers/tests/scenarios/Rule.daml index f4de3598fd4..41beffbcb4f 100644 --- a/triggers/tests/scenarios/Rule.daml +++ b/triggers/tests/scenarios/Rule.daml @@ -30,7 +30,7 @@ template T trigger : Trigger Int trigger = Trigger with initialize = const 0 - updateState = \acs _msg count -> length (getContracts @T acs) + updateState = \acs _msg -> put $ length (getContracts @T acs) rule = \party acs count -> do when (count == 1) do priorCIF <- getCommandsInFlight