View on GitHub
File Changes
  marloweType _ = BigIntegerType

                      
-- a Monoid for collecting Holes
-
data Holes
+
newtype Holes
  = Holes (Map String (Set MarloweHole))

                      
derive instance genericHoles :: Generic Holes _

                      
-
instance showHoles :: Show Holes where
-
  show = genericShow
+
derive instance newtypeHoles :: Newtype Holes _
+

                      
+
derive newtype instance showHoles :: Show Holes

                      
instance semigroupHoles :: Semigroup Holes where
  append (Holes a) (Holes b) = Holes (Map.unionWith append a b)

                      
-
instance monoidHoles :: Monoid Holes where
-
  mempty = Holes mempty
+
derive newtype instance monoidHoles :: Monoid Holes

                      
insertHole :: forall a. IsMarloweType a => Term a -> Holes -> Holes
insertHole (Term _ _ _) m = m
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)
  ( lint
  , State(..)
  , Position
+
  , MaxTimeout
  , _holes
  , _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)

                      
type Position
  = { start :: Pos, end :: Pos }

                      
+
newtype MaxTimeout
+
  = MaxTimeout Timeout
+

                      
+
derive instance newtypeMaxTimeout :: Newtype MaxTimeout _
+

                      
+
derive newtype instance eqMaxTimeout :: Eq MaxTimeout
+

                      
+
derive newtype instance ordMaxTimeout :: Ord MaxTimeout
+

                      
+
instance semigroupMax :: Semigroup MaxTimeout where
+
  append a b = max a b
+

                      
+
instance monoidMaxTimeout :: Monoid MaxTimeout where
+
  mempty = MaxTimeout zero
+

                      
newtype State
  = State
  { holes :: Holes
  , negativePayments :: Array Position
  , negativeDeposits :: Array Position
+
  , maxTimeout :: MaxTimeout
+
  , timeoutNotIncreasing :: Array Position
+
  , letBindings :: Set ValueId
+
  , uninitializedUse :: Array Position
+
  , shadowedLet :: Array Position
+
  , trueObservation :: Array Position
+
  , falseObservation :: Array Position
  }

                      
derive instance newtypeState :: Newtype State _

                      
-
instance semigroupState :: Semigroup State where
-
  append (State s1) (State s2) =
-
    State
-
      { holes: s1.holes <> s2.holes
-
      , negativePayments: s1.negativePayments <> s2.negativePayments
-
      , negativeDeposits: s1.negativeDeposits <> s2.negativeDeposits
-
      }
-

                      
-
instance monoidState :: Monoid State where
-
  mempty =
-
    State
-
      { holes: mempty
-
      , negativePayments: mempty
-
      , negativeDeposits: mempty
-
      }
+
derive newtype instance semigroupState :: Semigroup State
+

                      
+
derive newtype instance monoidState :: Monoid State

                      
_holes :: Lens' State Holes
_holes = _Newtype <<< prop (SProxy :: SProxy "holes")
_negativeDeposits :: Lens' State (Array Position)
_negativeDeposits = _Newtype <<< prop (SProxy :: SProxy "negativeDeposits")

                      
-
lint :: Term Contract -> State
-
lint = traverseContract mempty
+
_maxTimeout :: Lens' State Timeout
+
_maxTimeout = _Newtype <<< prop (SProxy :: SProxy "maxTimeout") <<< _Newtype
+

                      
+
_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
-
traverseContract :: State -> Term Contract -> State
-
traverseContract state (Term Close _ _) = state
+
-- | The aim here is to only traverse the contract once since we are concerned about performance with the linting
+
lint :: Term Contract -> State
+
lint = go mempty
+
  where
+
  go :: State -> Term Contract -> State
+
  go state (Term Close _ _) = state

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

                      
-
    newState =
-
      over _holes gatherHoles
-
        <<< over _negativePayments (maybeCons (negativeValue payment))
-
        $ state
-
  in
-
    traverseContract newState contract
+
      newState =
+
        state
+
          # over _holes gatherHoles
+
          # over _negativePayments (maybeCons (negativeValue payment))
+
    in
+
      go newState contract <> lintValue newState payment

                      
-
traverseContract state (Term (If obs c1 c2) _ _) =
-
  let
-
    gatherHoles = getHoles obs
+
  go state (Term (If obs c1 c2) _ _) = go state c1 <> go state c2 <> lintObservation state obs

                      
-
    newState = over _holes gatherHoles state
-
  in
-
    traverseContract newState c1 <> traverseContract newState c2
+
  go state (Term (When cases timeoutTerm contract) _ _) =
+
    let
+
      (states /\ contracts) = collectFromTuples (map (lintCase state) cases)

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

                      
-
    (holes /\ mnds /\ contracts) = collectFromTuples (map (contractFromCase hs) cases)
+
  go state (Term (Let valueIdTerm value contract) _ _) =
+
    let
+
      gatherHoles = getHoles valueIdTerm

                      
-
    nds = catMaybes mnds
+
      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 <> lintValue newState value

                      
-
    newState =

                      
updateContractInStateP :: String -> MarloweState -> MarloweState
updateContractInStateP text state = case runParser' (parseTerm contract) text of
-
  Right pcon ->
+
  Right parsedContract ->
    let
-
      lintResult = lint pcon
-

                      
-
      lintHoles = view L._holes lintResult
-

                      
-
      (Holes holes) = lintHoles
+
      lintResult = lint parsedContract

                      
      warnings =
        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 redefining 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 pcon
+
      mContract = fromTerm parsedContract
    in
      case mContract of
        Just contract -> do
          set _editorErrors warnings <<< set _contract (Just contract) $ state
        Nothing -> do
          let
-
            holes' = fold $ fromFoldable $ Map.values holes
-

                      
-
            holesm = lintHoles
+
            (Holes holes) = view L._holes lintResult

                      
-
            holes'' = fold $ fromFoldable $ Map.values holes
+
            holesArray = Set.toUnfoldable $ fold $ Map.values holes

                      
-
            errors = warnings <> map (holeToAnnotation text) (Set.toUnfoldable holes')
-
          (set _editorErrors errors <<< set _holes holesm) state
+
            errors = warnings <> map (holeToAnnotation text) holesArray
+
          (set _editorErrors errors <<< set _holes (Holes holes)) state
  Left error -> (set _editorErrors [ errorToAnnotation text error ] <<< set _holes mempty) state

                      
warningToAnnotation :: String -> String -> Position -> Annotation
  let
    kvs = Map.toUnfoldable holes

                      
+
    sortHoles = compare `on` (head <<< Set.toUnfoldable <<< snd)
+

                      
    ordered = sortBy sortHoles kvs

                      
    holesGroup = map (\(Tuple k v) -> displayHole selectedHole k v) ordered
          ]
          holesGroup
      ]
-
  where
-
  sortHoles = compare `on` (head <<< Set.toUnfoldable <<< snd)

                      
displayHole :: forall p. Maybe String -> String -> Set MarloweHole -> HTML p HAction
displayHole selectedHole name holes =
                                'src/**/*.purs',
                                'generated/**/*.purs',
                                '.spago/*/*/src/**/*.purs',
+
                                '../playground-common/src/**/*.purs',
                                '../web-common/src/**/*.purs'
                            ],
                            psc: null,