View on GitHub
File Changes
module Marlowe.Holes where

                      
import Prelude
-

                      
import Data.Array (foldMap, foldl, mapWithIndex)
import Data.BigInteger (BigInteger)
import Data.Foldable (intercalate)
instance actionMarloweType :: IsMarloweType Action where
  marloweType _ = ActionType

                      
-
instance actionHasMarloweHoles :: HasMarloweHoles Action where
-
  getHoles (Deposit a b c d) m = getHoles a m <> insertHole b m <> getHoles c m <> getHoles d m
-
  getHoles (Choice a bs) m = getHoles a m <> getHoles bs m
-
  getHoles (Notify a) m = getHoles a m
-

                      
data Payee
  = Account (Term AccountId)
  | Party (Term Party)
instance valueIsMarloweType :: IsMarloweType Value where
  marloweType _ = ValueType

                      
-
instance valueHasMarloweHoles :: HasMarloweHoles Value where
-
  getHoles (AvailableMoney a b) m = getHoles a m <> getHoles b m
-
  getHoles (Constant a) m = insertHole a m
-
  getHoles (NegValue a) m = getHoles a m
-
  getHoles (AddValue a b) m = getHoles a m <> getHoles b m
-
  getHoles (SubValue a b) m = getHoles a m <> getHoles b m
-
  getHoles (ChoiceValue a b) m = getHoles a m <> getHoles b m
-
  getHoles SlotIntervalStart m = mempty
-
  getHoles SlotIntervalEnd m = mempty
-
  getHoles (UseValue a) m = getHoles a m
-

                      
data Input
  = IDeposit (Term AccountId) (Term Party) (Term Money)
  | IChoice (Term ChoiceId) (Term ChosenNum)
instance observationIsMarloweType :: IsMarloweType Observation where
  marloweType _ = ObservationType

                      
-
instance observationHasMarloweHoles :: HasMarloweHoles Observation where
-
  getHoles (AndObs a b) m = getHoles a m <> getHoles b m
-
  getHoles (OrObs a b) m = getHoles a m <> getHoles b m
-
  getHoles (NotObs a) m = getHoles a m
-
  getHoles (ChoseSomething a) m = getHoles a m
-
  getHoles (ValueGE a b) m = getHoles a m <> getHoles b m
-
  getHoles (ValueGT a b) m = getHoles a m <> getHoles b m
-
  getHoles (ValueLT a b) m = getHoles a m <> getHoles b m
-
  getHoles (ValueLE a b) m = getHoles a m <> getHoles b m
-
  getHoles (ValueEQ a b) m = getHoles a m <> getHoles b m
-
  getHoles TrueObs m = mempty
-
  getHoles FalseObs m = mempty
-

                      
data Contract
  = Close
  | Pay (Term AccountId) (Term Payee) (Term Token) (Term Value) (Term Contract)
  , _negativeDeposits
  , _negativePayments
  , _timeoutNotIncreasing
+
  , _uninitializedUse
+
  , _shadowedLet
+
  , _trueObservation
+
  , _falseObservation
  ) where

                      
import Prelude
-
import Data.Array (catMaybes, fold, foldMap, (:))
+
import Data.Array (catMaybes, cons, fold, foldMap, (:))
import Data.BigInteger (BigInteger)
-
import Data.Lens (Lens', over, set, view)
+
import Data.Lens (Lens', over, view)
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record (prop)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype)
+
import Data.Set (Set)
+
import Data.Set as Set
import Data.Symbol (SProxy(..))
import Data.Tuple.Nested (type (/\), (/\))
-
import Marlowe.Holes (Action(..), Case(..), Contract(..), Holes, Term(..), Value(..), getHoles, insertHole)
+
import Marlowe.Holes (Action(..), Case(..), Contract(..), Holes, Observation(..), Term(..), Value(..), ValueId, getHoles, insertHole)
import Marlowe.Semantics (Timeout)
import Text.Parsing.StringParser (Pos)

                      
  , negativeDeposits :: Array Position
  , maxTimeout :: Timeout
  , timeoutNotIncreasing :: Array Position
+
  , letBindings :: Set ValueId
+
  , uninitializedUse :: Array Position
+
  , shadowedLet :: Array Position
+
  , trueObservation :: Array Position
+
  , falseObservation :: Array Position
  }

                      
derive instance newtypeState :: Newtype State _
      , negativeDeposits: s1.negativeDeposits <> s2.negativeDeposits
      , maxTimeout: max s1.maxTimeout s2.maxTimeout
      , timeoutNotIncreasing: s1.timeoutNotIncreasing <> s2.timeoutNotIncreasing
+
      , letBindings: s1.letBindings <> s2.letBindings
+
      , uninitializedUse: s1.uninitializedUse <> s2.uninitializedUse
+
      , shadowedLet: s1.shadowedLet <> s2.shadowedLet
+
      , trueObservation: s1.trueObservation <> s2.trueObservation
+
      , falseObservation: s1.falseObservation <> s2.falseObservation
      }

                      
instance monoidState :: Monoid State where
      , negativeDeposits: mempty
      , maxTimeout: zero
      , timeoutNotIncreasing: mempty
+
      , letBindings: mempty
+
      , uninitializedUse: mempty
+
      , shadowedLet: mempty
+
      , trueObservation: mempty
+
      , falseObservation: mempty
      }

                      
_holes :: Lens' State Holes
_timeoutNotIncreasing :: Lens' State (Array Position)
_timeoutNotIncreasing = _Newtype <<< prop (SProxy :: SProxy "timeoutNotIncreasing")

                      
+
_letBindings :: Lens' State (Set ValueId)
+
_letBindings = _Newtype <<< prop (SProxy :: SProxy "letBindings")
+

                      
+
_uninitializedUse :: Lens' State (Array Position)
+
_uninitializedUse = _Newtype <<< prop (SProxy :: SProxy "uninitializedUse")
+

                      
+
_shadowedLet :: Lens' State (Array Position)
+
_shadowedLet = _Newtype <<< prop (SProxy :: SProxy "shadowedLet")
+

                      
+
_trueObservation :: Lens' State (Array Position)
+
_trueObservation = _Newtype <<< prop (SProxy :: SProxy "trueObservation")
+

                      
+
_falseObservation :: Lens' State (Array Position)
+
_falseObservation = _Newtype <<< prop (SProxy :: SProxy "falseObservation")
+

                      
-- | We go through a contract term collecting all warnings and holes etc so that we can display them in the editor
-- | The aim here is to only traverse the contract once since we are concerned about performance with the linting
lint :: Term Contract -> State

                      
  go state (Term (Pay acc payee token payment contract) start end) =
    let
-
      gatherHoles = getHoles acc <> getHoles payee <> getHoles token <> getHoles payment
+
      gatherHoles = getHoles acc <> getHoles payee <> getHoles token

                      
      newState =
        state
          # over _holes gatherHoles
          # over _negativePayments (maybeCons (negativeValue payment))
    in
-
      go newState contract
-

                      
-
  go state (Term (If obs c1 c2) _ _) =
-
    let
-
      gatherHoles = getHoles obs
+
      go newState contract <> lintValue newState payment

                      
-
      newState = over _holes gatherHoles state
-
    in
-
      go newState c1 <> go newState c2
+
  go state (Term (If obs c1 c2) _ _) = go state c1 <> go state c2 <> lintObservation state obs

                      
  go state (Term (When cases timeoutTerm contract) _ _) =
    let
-
      hs = view _holes state
-

                      
-
      (holes /\ negatives /\ contracts) = collectFromTuples (map (contractFromCase hs) cases)
+
      (states /\ contracts) = collectFromTuples (map (lintCase state) cases)

                      
      newState = case timeoutTerm of
        (Term timeout start end) ->
          let
            timeoutNotIncreasing = if timeout > (view _maxTimeout state) then [] else [ { start, end } ]
          in
-
            state
-
              # over _negativeDeposits (append (catMaybes negatives))
-
              # set _holes (insertHole timeoutTerm (fold holes))
+
            (fold states)
+
              # over _holes (insertHole timeoutTerm)
              # over _maxTimeout (max timeout)
              # over _timeoutNotIncreasing (append timeoutNotIncreasing)
        _ ->
-
          state
-
            # over _negativeDeposits (append (catMaybes negatives))
-
            # set _holes (insertHole timeoutTerm (fold holes))
+
          (fold states)
+
            # over _holes (insertHole timeoutTerm)
    in
      foldMap (go newState) (contract : catMaybes contracts)

                      
-
  go state (Term (Let valueId value contract) _ _) =
+
  go state (Term (Let valueIdTerm value contract) _ _) =
    let
-
      gatherHoles = getHoles valueId <> getHoles value
+
      gatherHoles = getHoles valueIdTerm

                      
-
      newState =
-
        state
-
          # over _holes gatherHoles
-
          # over _negativePayments (maybeCons (negativeValue value))
+
      newState = case valueIdTerm of
+
        (Term valueId start end) ->
+
          let
+
            shadowedLet = if Set.member valueId (view _letBindings state) then [ { start, end } ] else []
+
          in
+
            state
+
              # over _holes gatherHoles
+
              # over _negativePayments (maybeCons (negativeValue value))
+
              # over _letBindings (Set.insert valueId)
+
              # over _shadowedLet (append shadowedLet)
+
        _ ->
+
          state
+
            # over _holes gatherHoles
+
            # over _negativePayments (maybeCons (negativeValue value))
    in
-
      go newState contract
+
      go newState contract <> lintValue newState value

                      
  go state [email protected](Hole _ _ _ _) = over _holes (insertHole hole) state

                      
+
lintObservation :: State -> Term Observation -> State
+
lintObservation state (Term (AndObs a b) _ _) = lintObservation state a <> lintObservation state b
+

                      
+
lintObservation state (Term (OrObs a b) _ _) = lintObservation state a <> lintObservation state b
+

                      
+
lintObservation state (Term (NotObs a) _ _) = lintObservation state a
+

                      
+
lintObservation state (Term (ChoseSomething choiceId) _ _) = over _holes (getHoles choiceId) state
+

                      
+
lintObservation state (Term (ValueGE a b) _ _) = lintValue state a <> lintValue state b
+

                      
+
lintObservation state (Term (ValueGT a b) _ _) = lintValue state a <> lintValue state b
+

                      
+
lintObservation state (Term (ValueLT a b) _ _) = lintValue state a <> lintValue state b
+

                      
+
lintObservation state (Term (ValueLE a b) _ _) = lintValue state a <> lintValue state b
+

                      
+
lintObservation state (Term (ValueEQ a b) _ _) = lintValue state a <> lintValue state b
+

                      
+
lintObservation state (Term TrueObs start end) = over _trueObservation (cons { start, end }) state
+

                      
+
lintObservation state (Term FalseObs start end) = over _falseObservation (cons { start, end }) state
+

                      
+
lintObservation state [email protected](Hole _ _ _ _) = over _holes (insertHole hole) state
+

                      
+
lintValue :: State -> Term Value -> State
+
lintValue state (Term (AvailableMoney acc token) _ _) =
+
  let
+
    gatherHoles = getHoles acc <> getHoles token
+
  in
+
    over _holes (gatherHoles) state
        map (warningToAnnotation text "The contract can make a negative payment here") (view L._negativePayments lintResult)
          <> map (warningToAnnotation text "The contract can make a negative deposit here") (view L._negativeDeposits lintResult)
          <> map (warningToAnnotation text "Timeouts should always increase in value") (view L._timeoutNotIncreasing lintResult)
+
          <> map (warningToAnnotation text "The contract tries to Use a ValueId that has not been defined in a Let") (view L._uninitializedUse lintResult)
+
          <> map (warningToAnnotation text "Let is redfining a ValueId that already exists") (view L._shadowedLet lintResult)
+
          <> map (warningToAnnotation text "This Observation will always evaluate to True") (view L._trueObservation lintResult)
+
          <> map (warningToAnnotation text "This Observation will always evaluate to False") (view L._falseObservation lintResult)

                      
      mContract = fromTerm parsedContract
    in
                                'src/**/*.purs',
                                'generated/**/*.purs',
                                '.spago/*/*/src/**/*.purs',
+
                                '../playground-common/src/**/*.purs',
                                '../web-common/src/**/*.purs'
                            ],
                            psc: null,