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

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

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.
+instance ActionState s (State s) where
---
+  get = State (\s -> (s, s))
--- >>> runState (do x <- get; modify (+1); pure x) 0
+  put s = State (\_ -> ((), s))
--- (0, 1)
+  modify f = State (\s -> ((), f s))
-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))

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

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

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

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

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
+  , updateState : ACS -> Message -> TriggerStateA s ()
-  -- ^ Update the user-defined state based on the ACS and a transaction or
+  -- ^ Update the user-defined state based on the ACS and a transaction
-  -- completion message.
+  -- 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

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]

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)
+  where ((a, s'), (cmds, _)) = runState (foldFree sim (runStateT (runTriggerRule rule) s)) ([], 0)
-        sim : TriggerF x -> State.State ([Commands], Int) x
+        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)

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

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

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

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
+        | Failed {} <- c.status -> modify (subtract 1)
-      _ -> allowedFail
+      _ -> pure ()
   , rule = retryRule
   , registeredTemplates = AllInDar
   , heartbeat = None

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

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

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
+        | Failed {} <- c.status -> modify (subtract 1)
-      _ -> allowedFail
+      _ -> pure ()
   , rule = retryRule
   , registeredTemplates = AllInDar
   , heartbeat = None

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

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