Merge pull request #3969 from input-output-hk/anemish/marlowe-div

Add Marlowe DivValue (division)

doc/marlowe/tutorials/marlowe-data.rst

@@ -147,6 +147,7 @@ cases. First, looking at ``Value`` we have
               | AddValue Value Value
               | SubValue Value Value
               | MulValue Value Value
+              | DivValue Value Value
               | Scale Rational Value
               | ChoiceValue ChoiceId
               | SlotIntervalStart

marlowe-actus/src/Language/Marlowe/ACTUS/Ops.hs

@@ -5,7 +5,7 @@ module Language.Marlowe.ACTUS.Ops where
 
 import           Data.Time                                             (Day)
 import           Language.Marlowe                                      (Observation (ValueGT, ValueLT),
-                                                                        Value (AddValue, Cond, Constant, MulValue, Scale, SubValue),
+                                                                        Value (AddValue, Cond, Constant, DivValue, MulValue, Scale, SubValue),
                                                                         (%))
 import           Language.Marlowe.ACTUS.Definitions.ContractTerms      (CR, DCC)
 import           Language.Marlowe.ACTUS.Model.Utility.ContractRoleSign (contractRoleSign)
@@ -82,4 +82,4 @@ instance ActusNum (Value Observation) where
     (Constant 0) / (Constant 0) = Constant 0 -- by convention in finance
     (Constant x) / (Constant y) = Scale (marloweFixedPoint % 1) $ Constant $ div x y
     x / (Constant y)            = Scale (marloweFixedPoint % y) x
-    _ / _                       = undefined --division not supported in Marlowe yet
+    x / y                       = DivValue x y

marlowe-playground-client/grammar.ne

@@ -37,6 +37,7 @@ const lexer = moo.compile({
                     'AddValue',
                     'SubValue',
                     'MulValue',
+                    'DivValue',
                     'Scale',
                     'ChoiceValue',
                     'SlotIntervalStart',
@@ -195,6 +196,7 @@ value
     | lparen "AddValue" someWS value someWS value rparen {% ([start,{line,col},,v1,,v2,end]) => opts.mkTerm(opts.mkAddValue(v1)(v2))({startLineNumber: start.line, startColumn: start.col, endLineNumber: end.line, endColumn: end.col + 1}) %}
     | lparen "SubValue" someWS value someWS value rparen {% ([start,{line,col},,v1,,v2,end]) => opts.mkTerm(opts.mkSubValue(v1)(v2))({startLineNumber: start.line, startColumn: start.col, endLineNumber: end.line, endColumn: end.col + 1}) %}
     | lparen "MulValue" someWS value someWS value rparen {% ([start,{line,col},,v1,,v2,end]) => opts.mkTerm(opts.mkMulValue(v1)(v2))({startLineNumber: start.line, startColumn: start.col, endLineNumber: end.line, endColumn: end.col + 1}) %}
+    | lparen "DivValue" someWS value someWS value rparen {% ([start,{line,col},,v1,,v2,end]) => opts.mkTerm(opts.mkDivValue(v1)(v2))({startLineNumber: start.line, startColumn: start.col, endLineNumber: end.line, endColumn: end.col + 1}) %}
     | lparen "Scale" someWS lparen rational rparen someWS value rparen {% ([start,{line,col},,,ratio,,,v,end]) => opts.mkTerm(opts.mkScale(ratio)(v))({startLineNumber: start.line, startColumn: start.col, endLineNumber: end.line, endColumn: end.col + 1}) %}
     | lparen "ChoiceValue" someWS choiceId rparen {% ([start,{line,col},,choiceId,end]) => opts.mkTerm(opts.mkChoiceValue(choiceId))({startLineNumber: start.line, startColumn: start.col, endLineNumber: end.line, endColumn: end.col + 1}) %}
     | "SlotIntervalStart" {% ([{line,col}]) => opts.mkTerm(opts.mkSlotIntervalStart)({startLineNumber: line, startColumn: col, endLineNumber: line, endColumn: col + 17}) %}

marlowe-playground-client/src/JavascriptEditor/State.purs

@@ -200,7 +200,7 @@ decorationHeader :: String
 decorationHeader =
   """import {
     PK, Role, Account, Party, ada, AvailableMoney, Constant, ConstantParam,
-    NegValue, AddValue, SubValue, MulValue, Scale, ChoiceValue, SlotIntervalStart,
+    NegValue, AddValue, SubValue, MulValue, DivValue, Scale, ChoiceValue, SlotIntervalStart,
     SlotIntervalEnd, UseValue, Cond, AndObs, OrObs, NotObs, ChoseSomething,
     ValueGE, ValueGT, ValueLT, ValueLE, ValueEQ, TrueObs, FalseObs, Deposit,
     Choice, Notify, Close, Pay, If, When, Let, Assert, SomeNumber, AccountId,

marlowe-playground-client/src/Language/Javascript/MarloweJS.ts

@@ -82,6 +82,8 @@ type Value = { "amount_of_token": Token,
              , "minus": Value }
            | { "multiply": Value
              , "times": Value }
+           | { "divide": Value
+             , "by": Value }
            | { "multiply": Value
              , "times": bignumber.BigNumber
              , "divide_by": bignumber.BigNumber }
@@ -149,6 +151,12 @@ export const MulValue =
                  "times": coerceValue(rhs) };
     };
 
+export const DivValue =
+    function (lhs : EValue, rhs : EValue) : Value {
+        return { "divide": coerceValue(lhs),
+                 "by": coerceValue(rhs) };
+    };
+
 export const Scale =
     function (num : SomeNumber, den : SomeNumber, val : EValue) : Value {
         var cden = coerceNumber(den);

marlowe-playground-client/src/Marlowe/Blockly.purs

@@ -247,6 +247,7 @@ data ValueType
   | AddValueValueType
   | SubValueValueType
   | MulValueValueType
+  | DivValueValueType
   | ScaleValueType
   | ChoiceValueValueType
   | SlotIntervalStartValueType
@@ -911,6 +912,21 @@ toDefinition blockType@(ValueType MulValueValueType) =
         }
         defaultBlockDefinition
 
+toDefinition blockType@(ValueType DivValueValueType) =
+  BlockDefinition
+    $ merge
+        { type: show DivValueValueType
+        , message0: "%1 / %2"
+        , args0:
+            [ Value { name: "value1", check: "value", align: Right }
+            , Value { name: "value2", check: "value", align: Right }
+            ]
+        , colour: blockColour blockType
+        , output: Just "value"
+        , inputsInline: Just true
+        }
+        defaultBlockDefinition
+
 toDefinition blockType@(ValueType CondObservationValueValueType) =
   BlockDefinition
     $ merge
@@ -1342,6 +1358,10 @@ instance blockToTermValue :: BlockToTerm Value where
     value1 <- valueToTerm "value1" b
     value2 <- valueToTerm "value2" b
     pure $ Term (MulValue value1 value2) (BlockId id)
+  blockToTerm b@({ type: "DivValueValueType", id }) = do
+    value1 <- valueToTerm "value1" b
+    value2 <- valueToTerm "value2" b
+    pure $ Term (DivValue value1 value2) (BlockId id)
   blockToTerm b@({ type: "ScaleValueType", id }) = do
     numerator <- fieldAsBigInteger "numerator" b
     denominator <- fieldAsBigInteger "denominator" b
@@ -1729,6 +1749,11 @@ instance toBlocklyValue :: ToBlockly Value where
     connectToOutput block input
     inputToBlockly newBlock workspace block "value1" v1
     inputToBlockly newBlock workspace block "value2" v2
+  toBlockly newBlock workspace input (DivValue v1 v2) = do
+    block <- newBlock workspace (show DivValueValueType)
+    connectToOutput block input
+    inputToBlockly newBlock workspace block "value1" v1
+    inputToBlockly newBlock workspace block "value2" v2
   toBlockly newBlock workspace input (Scale (TermWrapper (Rational numerator denominator) _) value) = do
     block <- newBlock workspace (show ScaleValueType)
     connectToOutput block input

marlowe-playground-client/src/Marlowe/Gen.purs

@@ -225,6 +225,7 @@ genValue' size
             , AddValue <$> genNewValueIndexed 1 <*> genNewValueIndexed 2
             , SubValue <$> genNewValueIndexed 1 <*> genNewValueIndexed 2
             , MulValue <$> genNewValueIndexed 1 <*> genNewValueIndexed 2
+            , DivValue <$> genNewValueIndexed 1 <*> genNewValueIndexed 2
             , Scale <$> genTermWrapper genRational <*> genNewValue
             , ChoiceValue <$> genChoiceId
             , UseValue <$> genTermWrapper genValueId

marlowe-playground-client/src/Marlowe/Holes.purs

@@ -161,6 +161,7 @@ getMarloweConstructors ValueType =
     , (Tuple "AddValue" $ ArgumentArray [ DataArgIndexed 1 ValueType, DataArgIndexed 2 ValueType ])
     , (Tuple "SubValue" $ ArgumentArray [ DataArgIndexed 1 ValueType, DataArgIndexed 2 ValueType ])
     , (Tuple "MulValue" $ ArgumentArray [ DataArgIndexed 1 ValueType, DataArgIndexed 2 ValueType ])
+    , (Tuple "DivValue" $ ArgumentArray [ DataArgIndexed 1 ValueType, DataArgIndexed 2 ValueType ])
     , (Tuple "Scale" $ ArgumentArray [ DefaultRational (Rational one one), DataArg ValueType ])
     , (Tuple "ChoiceValue" $ ArgumentArray [ GenArg ChoiceIdType ])
     , (Tuple "SlotIntervalStart" $ ArgumentArray [])
@@ -817,6 +818,7 @@ data Value
   | AddValue (Term Value) (Term Value)
   | SubValue (Term Value) (Term Value)
   | MulValue (Term Value) (Term Value)
+  | DivValue (Term Value) (Term Value)
   | Scale (TermWrapper Rational) (Term Value)
   | ChoiceValue ChoiceId
   | SlotIntervalStart
@@ -848,6 +850,7 @@ instance templateValue :: Template Value Placeholders where
   getPlaceholderIds (AddValue lhs rhs) = getPlaceholderIds lhs <> getPlaceholderIds rhs
   getPlaceholderIds (SubValue lhs rhs) = getPlaceholderIds lhs <> getPlaceholderIds rhs
   getPlaceholderIds (MulValue lhs rhs) = getPlaceholderIds lhs <> getPlaceholderIds rhs
+  getPlaceholderIds (DivValue lhs rhs) = getPlaceholderIds lhs <> getPlaceholderIds rhs
   getPlaceholderIds (Scale _ v) = getPlaceholderIds v
   getPlaceholderIds (ChoiceValue _) = mempty
   getPlaceholderIds SlotIntervalStart = mempty
@@ -864,6 +867,7 @@ instance fillableValue :: Fillable Value TemplateContent where
     AddValue lhs rhs -> AddValue (go lhs) (go rhs)
     SubValue lhs rhs -> SubValue (go lhs) (go rhs)
     MulValue lhs rhs -> MulValue (go lhs) (go rhs)
+    DivValue lhs rhs -> DivValue (go lhs) (go rhs)
     Scale f v -> Scale f $ go v
     ChoiceValue _ -> val
     SlotIntervalStart -> val
@@ -882,6 +886,7 @@ instance valueFromTerm :: FromTerm Value EM.Value where
   fromTerm (AddValue a b) = EM.AddValue <$> fromTerm a <*> fromTerm b
   fromTerm (SubValue a b) = EM.SubValue <$> fromTerm a <*> fromTerm b
   fromTerm (MulValue a b) = EM.MulValue <$> fromTerm a <*> fromTerm b
+  fromTerm (DivValue a b) = EM.DivValue <$> fromTerm a <*> fromTerm b
   fromTerm (Scale a b) = EM.Scale <$> fromTerm a <*> fromTerm b
   fromTerm (ChoiceValue a) = EM.ChoiceValue <$> fromTerm a
   fromTerm SlotIntervalStart = pure EM.SlotIntervalStart
@@ -903,6 +908,7 @@ instance valueHasContractData :: HasContractData Value where
   gatherContractData (AddValue a b) s = gatherContractData a s <> gatherContractData b s
   gatherContractData (SubValue a b) s = gatherContractData a s <> gatherContractData b s
   gatherContractData (MulValue a b) s = gatherContractData a s <> gatherContractData b s
+  gatherContractData (DivValue a b) s = gatherContractData a s <> gatherContractData b s
   gatherContractData (Scale _ a) s = gatherContractData a s
   gatherContractData (ChoiceValue a) s = gatherContractData a s
   gatherContractData (Cond c a b) s = gatherContractData c s <> gatherContractData a s <> gatherContractData b s

marlowe-playground-client/src/Marlowe/Linter.purs

@@ -396,7 +396,7 @@ lintContract env t@(Term (Pay acc payee token payment cont) pos) = do
             Just (Just avMoney) /\ Just paidMoney -> Just (avMoney + paidMoney) -- We know exactly what is happening (everything is constant)
             Nothing /\ Just paidMoney -> Just paidMoney -- We still know what is happening (there was no money, now there is)
             _ -> Nothing -- Either we don't know how much money there was or how money we are adding or both (so we don't know how much there will be)
-      _ -> identity -- Either is not an account or we don't know so we do nothing     
+      _ -> identity -- Either is not an account or we don't know so we do nothing
 
     tmpEnv2 = over _deposits fixTargetAcc tmpEnv
   newEnv <- stepPrefixMapEnv_ tmpEnv2 PayContPath
@@ -637,6 +637,26 @@ lintValue env t@(Term (MulValue a b) pos) = do
       markSimplification constToVal SimplifiableValue b sb
       pure (ValueSimp pos false t)
 
+lintValue env t@(Term (DivValue a b) pos) = do
+  sa <- lintValue env a
+  sb <- lintValue env b
+  case sa /\ sb of
+    (ConstantSimp _ _ v1 /\ ConstantSimp _ _ v2) ->
+      let
+        evaluated = evalValue (makeEnvironment zero zero) (emptyState (Slot zero)) (S.DivValue (S.Constant v1) (S.Constant v2))
+      in
+        pure (ConstantSimp pos true evaluated)
+    (ConstantSimp _ _ v /\ _)
+      | v == zero -> pure (ConstantSimp pos true zero)
+    (_ /\ ConstantSimp _ _ v)
+      | v == zero -> pure (ConstantSimp pos true zero)
+    (_ /\ ConstantSimp _ _ v)
+      | v == one -> pure (simplifyTo sa pos)
+    _ -> do
+      markSimplification constToVal SimplifiableValue a sa
+      markSimplification constToVal SimplifiableValue b sb
+      pure (ValueSimp pos false t)
+
 lintValue env t@(Term (Scale (TermWrapper r@(Rational a b) pos2) c) pos) = do
   sc <- lintValue env c
   if (b == zero) then do

marlowe-playground-client/src/Marlowe/Monaco.ts

@@ -168,6 +168,7 @@ const marloweLexer = moo.compile({
         'AddValue',
         'SubValue',
         'MulValue',
+        'DivValue',
         'ChoiceValue',
         'SlotIntervalStart',
         'SlotIntervalEnd',

marlowe-playground-client/src/Marlowe/Parser.purs

@@ -61,6 +61,7 @@ type HelperFunctions a
     , mkAddValue :: Term Value -> Term Value -> Value
     , mkSubValue :: Term Value -> Term Value -> Value
     , mkMulValue :: Term Value -> Term Value -> Value
+    , mkDivValue :: Term Value -> Term Value -> Value
     , mkRational :: BigInteger -> BigInteger -> Rational
     , mkScale :: TermWrapper Rational -> Term Value -> Value
     , mkChoiceValue :: ChoiceId -> Value
@@ -125,6 +126,7 @@ helperFunctions =
   , mkAddValue: AddValue
   , mkSubValue: SubValue
   , mkMulValue: MulValue
+  , mkDivValue: DivValue
   , mkRational: Rational
   , mkScale: Scale
   , mkChoiceValue: ChoiceValue

marlowe-playground-client/test/BridgeTests.purs

@@ -65,7 +65,7 @@ serializationTest =
                   )
               , Case (Choice choiceId [ Bound (fromInt 0) (fromInt 1) ])
                   ( If (ChoseSomething choiceId `OrObs` (ChoiceValue choiceId `ValueEQ` Scale (Rational (fromInt 1) (fromInt 10)) const))
-                      (Pay alicePk (Account alicePk) token (AvailableMoney alicePk token) Close)
+                      (Pay alicePk (Account alicePk) token (DivValue (AvailableMoney alicePk token) const) Close)
                       Close
                   )
               , Case (Notify (AndObs (SlotIntervalStart `ValueLT` SlotIntervalEnd) TrueObs)) Close
@@ -92,10 +92,7 @@ serializationTest =
     let
       rx = unsafeRegex "\\s+" (RegexFlags { global: true, ignoreCase: true, multiline: true, sticky: false, unicode: true })
 
-      expected = replace rx "" expectedJson
-
       expectedState = replace rx "" expectedStateJson
-    equal expected json
     equal expectedState jsonState
     equal (Right contract) (runExcept $ decodeJSON json)
     equal (Right contract) (runExcept $ decodeJSON bridgedJson)

marlowe-playground-client/test/Marlowe/LintTests.purs

@@ -34,6 +34,9 @@ all = do
     test "in OrObs" orObsSimplifies
     test "of OrObs with False constant" orObsSimplifiesWithFalse
     test "of non-reduced Scale" nonReducedScaleSimplified
+    test "of DivValue 0 / _" divZeroSimplified
+    test "of DivValue by 0" divByZeroSimplified
+    test "of DivValue with constant" divConstantSimplified
     test "of Scale with constant" scaleConstantSimplified
     test "of Scale with constant expression" scaleConstantExpressionSimplified
     test "Invalid bound in Case" unreachableCaseInvalidBound
@@ -276,6 +279,33 @@ nonReducedScaleSimplified =
   in
     testValueSimplificationWarning letContract simplifiableExpression simplification
 
+divZeroSimplified :: Test
+divZeroSimplified =
+  let
+    simplifiableExpression = "(DivValue (Constant 0) (Constant 3))"
+
+    simplification = "(Constant 0)"
+  in
+    testValueSimplificationWarning letContract simplifiableExpression simplification
+
+divByZeroSimplified :: Test
+divByZeroSimplified =
+  let
+    simplifiableExpression = "(DivValue (Constant 42) (Constant 0))"
+
+    simplification = "(Constant 0)"
+  in
+    testValueSimplificationWarning letContract simplifiableExpression simplification
+
+divConstantSimplified :: Test
+divConstantSimplified =
+  let
+    simplifiableExpression = "(DivValue (Constant 7) (Constant -3))"
+
+    simplification = "(Constant -2)"
+  in
+    testValueSimplificationWarning letContract simplifiableExpression simplification
+
 scaleConstantSimplified :: Test
 scaleConstantSimplified =
   let