diff --git a/compatibility/bazel_tools/daml_trigger/example/src/CopyTrigger.daml b/compatibility/bazel_tools/daml_trigger/example/src/CopyTrigger.daml index 08cf532e94..e773fdb93f 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 9ed626c058..ca42439dce 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 0000000000..94e93d5445 --- /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 17709752c7..de0e560c9d 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 5fc5c1a5b1..8522eb8337 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 62243287d2..a69311fba3 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 6dff96e2b8..57bf38e506 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 c6d1c645f8..7550d9ead6 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 84a8f39084..807e1a6b18 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 f3e90286e6..5fb01254c5 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 58de23ea26..04ff9429f0 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 59ec51951d..b825014903 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 086b73be4e..712e211b1e 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 a0226b322a..5c236c5479 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 515382ff0b..f3cf4d5de1 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 77592318ba..0170a96dde 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 e79d868773..45963db90a 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 f4de3598fd..41beffbcb4 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