mirror of
https://github.com/digital-asset/daml.git
synced 2024-09-19 00:37:23 +03:00
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 <https://github.com/digital-asset/daml/pull/7621>`__. CHANGELOG_END * some DAML docs for updateState and TriggerStateA
This commit is contained in:
parent
8b9c237031
commit
664a0c0076
@ -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
|
||||
|
@ -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
|
||||
instance ActionState s (State s) where
|
||||
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))
|
||||
|
35
compiler/damlc/daml-stdlib-src/DA/Action/State/Class.daml
Normal file
35
compiler/damlc/daml-stdlib-src/DA/Action/State/Class.daml
Normal file
@ -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
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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]
|
||||
|
@ -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)
|
||||
|
@ -8,7 +8,7 @@ import Daml.Trigger
|
||||
trigger : Trigger ()
|
||||
trigger = Trigger with
|
||||
initialize = \_ -> ()
|
||||
updateState = \_ _ _ -> ()
|
||||
updateState = \_ _ -> pure ()
|
||||
rule = triggerRule
|
||||
registeredTemplates = AllInDar
|
||||
heartbeat = None
|
||||
|
@ -25,7 +25,7 @@ template B
|
||||
trigger : Trigger ()
|
||||
trigger = Trigger with
|
||||
initialize = \_ -> ()
|
||||
updateState = \_ _ _ -> ()
|
||||
updateState = \_ _ -> pure ()
|
||||
rule = triggerRule
|
||||
registeredTemplates = AllInDar
|
||||
heartbeat = None
|
||||
|
@ -9,7 +9,7 @@ import Daml.Trigger
|
||||
createAndExerciseTrigger : Trigger ()
|
||||
createAndExerciseTrigger = Trigger
|
||||
{ initialize = \_ -> ()
|
||||
, updateState = \_ _ _ -> ()
|
||||
, updateState = \_ _ -> pure ()
|
||||
, rule = createAndExerciseRule
|
||||
, registeredTemplates = AllInDar
|
||||
, heartbeat = None
|
||||
|
@ -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
|
||||
|
@ -10,7 +10,7 @@ import Daml.Trigger
|
||||
maxInboundMessageSizeTrigger : Trigger ()
|
||||
maxInboundMessageSizeTrigger = Trigger
|
||||
{ initialize = \_ -> ()
|
||||
, updateState = \_ _ _ -> ()
|
||||
, updateState = \_ _ -> pure ()
|
||||
, rule = maxInboundMessageSizeRule
|
||||
, registeredTemplates = AllInDar
|
||||
, heartbeat = None
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user