Skip to content
Permalink
Browse files

remove old parser and use new pretty printer

  • Loading branch information...
David Smith
David Smith committed Mar 15, 2019
1 parent e21b880 commit e56f420bf8bb6ffffef9c55fb19f391e8ca2bb18
Showing with 10 additions and 254 deletions.
  1. +7 −5 meadow-client/src/MainFrame.purs
  2. +3 −249 meadow-client/src/Semantics.purs
@@ -49,13 +49,15 @@ import Halogen.Query (HalogenM)
import Language.Haskell.Interpreter (CompilationError(CompilationError, RawError))
import LocalStorage (LOCALSTORAGE)
import LocalStorage as LocalStorage
import Marlowe.Parser (contract)
import Marlowe.Parser as Parser
import Marlowe.Pretty (pretty)
import Marlowe.Types (BlockNumber, Choice, Person, Contract(..), WIdChoice(..), IdChoice(..), IdOracle(..))
import Meadow (SPParams_, getOauthStatus, patchGistsByGistId, postGists, postContractHaskell)
import Network.HTTP.Affjax (AJAX)
import Network.RemoteData (RemoteData(Success, NotAsked), _Success)
import Prelude (type (~>), Unit, Void, bind, const, discard, id, pure, show, unit, void, ($), (+), (-), (<$>), (<<<), (<>), (==))
import Semantics (ErrorResult(..), IdInput(..), MApplicationResult(..), State(..), applyTransaction, collectNeededInputsFromContract, emptyState, peopleFromStateAndContract, readContract, reduce, scoutPrimitives)
import Semantics (ErrorResult(..), IdInput(..), MApplicationResult(..), State(..), applyTransaction, collectNeededInputsFromContract, emptyState, peopleFromStateAndContract, reduce, scoutPrimitives)
import Servant.PureScript.Settings (SPSettings_)
import Simulation (simulationPane)
import StaticData (bufferLocalStorageKey, marloweBufferLocalStorageKey)
@@ -300,9 +302,9 @@ updateState oldState = actState
updateContractInState :: String -> MarloweState -> MarloweState
updateContractInState text state = updateState newState
where
con = case readContract text of
Just pcon -> pcon
Nothing -> Null
con = case parse contract text of
Right pcon -> pcon
Left _ -> Null
newState = set (_contract) con state

evalF ::
@@ -402,7 +404,7 @@ evalF (SetSignature { person, isChecked } next) = do
evalF (ApplyTransaction next) = do
modifying (_marloweState) applyTransactionM
currContract <- use (_marloweState <<< _contract)
void $ withMarloweEditor $ Editor.setValue (show currContract) (Just 1)
void $ withMarloweEditor $ Editor.setValue (show $ pretty currContract) (Just 1)
modifying (_marloweState) updateState
pure next

@@ -2,269 +2,23 @@ module Semantics where

import Control.Monad

import Data.BigInteger (BigInteger, fromInt, fromString)
import Data.Either (Either(..))
import Data.BigInteger (BigInteger, fromInt)
import Data.Eq (class Eq, (/=), (==))
import Data.EuclideanRing (div, mod)
import Data.FoldableWithIndex (foldrWithIndexDefault)
import Data.HeytingAlgebra (not, (&&), (||))
import Data.List (List(..), concat, foldl, foldr, fromFoldable, reverse)
import Data.List (List(Nil, Cons), concat, foldl, foldr)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (unwrap)
import Data.Ord (class Ord, max, (<), (<=), (>), (>=))
import Data.Ring (negate, (*), (+), (-))
import Data.String.Regex (split, regex)
import Data.String.Regex.Flags (RegexFlags(..))
import Data.Tuple (Tuple(..))
import Marlowe.Types (BlockNumber, Choice, Contract(..), IdAction, IdChoice(..), IdCommit, IdOracle, Observation(..), Person, Timeout, Value(..), WIdChoice(..), LetLabel)
import Marlowe.Types (BlockNumber, Choice, Contract(Use, Let, Scale, While, When, Choice, Both, Pay, Commit, Null), IdAction, IdChoice, IdCommit, IdOracle, LetLabel, Observation(FalseObs, TrueObs, ValueEQ, ValueLE, ValueLT, ValueGT, ValueGE, ChoseSomething, ChoseThis, NotObs, OrObs, AndObs, BelowTimeout), Person, Timeout, Value(ValueFromOracle, ValueFromChoice, ModValue, DivValue, MulValue, SubValue, AddValue, NegValue, Constant, Committed, CurrentBlock), WIdChoice(WIdChoice))

import Data.Foldable as F
import Data.Map as M
import Data.Set as S

newtype Parser a
= Parser {runParser :: List String -> Maybe (Tuple a (List String))}

instance functorParser :: Functor Parser where
map :: forall a b. (a -> b) -> Parser a -> Parser b
map x (Parser y) = Parser { runParser: (\z ->
case y.runParser z of
Nothing -> Nothing
Just (Tuple q1 q2) -> Just (Tuple (x q1) q2))
}

instance applyParser :: Apply Parser where
apply ::
forall a b.
Parser (a -> b) ->
Parser a ->
Parser b
apply (Parser p) (Parser a) = Parser { runParser: (\y ->
case a.runParser y of
Nothing -> Nothing
Just (Tuple z1 z2) -> (case p.runParser z2 of
Nothing -> Nothing
Just (Tuple p1 p2) -> Just (Tuple (p1 z1) p2)))
}

instance applicativeParser :: Applicative Parser where
pure :: forall a. a -> Parser a
pure x = Parser { runParser: (\y -> Just (Tuple x y)) }

instance bindParser :: Bind Parser where
bind :: forall a b. Parser a -> (a -> Parser b) -> Parser b
bind (Parser a) fb = Parser { runParser: (\y ->
case a.runParser y of
Nothing -> Nothing
Just (Tuple z1 z2) -> let Parser b = fb z1
in b.runParser z2)
}

instance monadParser :: Monad Parser

getToken :: Parser String
getToken = Parser { runParser: (\x ->
case x of
Nil -> Nothing
(Cons y z) -> Just (Tuple y z))
}

wrongParse :: forall a. Parser a
wrongParse = Parser { runParser: (\y -> Nothing) }

runParser :: forall a. List String -> Parser a -> Maybe a
runParser l (Parser p) = case p.runParser l of
Just (Tuple x Nil) -> Just x
_ -> Nothing

bigIntParser :: Parser BigInteger
bigIntParser = do
tok <- getToken
case fromString tok of
Just v -> pure v
Nothing -> wrongParse

valueParser :: Parser Value
valueParser = do
tok <- getToken
case tok of
"CurrentBlock" -> pure CurrentBlock
"Committed" -> do
idCommit <- bigIntParser
pure (Committed idCommit)
"Constant" -> do
bigInteger <- bigIntParser
pure (Constant bigInteger)
"NegValue" -> do
value <- valueParser
pure (NegValue value)
"AddValue" -> do
value1 <- valueParser
value2 <- valueParser
pure (AddValue value1 value2)
"SubValue" -> do
value1 <- valueParser
value2 <- valueParser
pure (SubValue value1 value2)
"MulValue" -> do
value1 <- valueParser
value2 <- valueParser
pure (MulValue value1 value2)
"DivValue" -> do
value1 <- valueParser
value2 <- valueParser
value3 <- valueParser
pure (DivValue value1 value2 value3)
"ModValue" -> do
value1 <- valueParser
value2 <- valueParser
value3 <- valueParser
pure (ModValue value1 value2 value3)
"ValueFromChoice" -> do
choice <- bigIntParser
person <- bigIntParser
value <- valueParser
pure (ValueFromChoice (IdChoice { choice, person }) value)
"ValueFromOracle" -> do
idOracle <- bigIntParser
value <- valueParser
pure (ValueFromOracle idOracle value)
_ -> wrongParse

observationParser :: Parser Observation
observationParser = do
tok <- getToken
case tok of
"BelowTimeout" -> do
timeout <- bigIntParser
pure (BelowTimeout timeout)
"AndObs" -> do
observation1 <- observationParser
observation2 <- observationParser
pure (AndObs observation1 observation2)
"OrObs" -> do
observation1 <- observationParser
observation2 <- observationParser
pure (OrObs observation1 observation2)
"NotObs" -> do
observation <- observationParser
pure (NotObs observation)
"ChoseThis" -> do
choice <- bigIntParser
person <- bigIntParser
choice2 <- bigIntParser
pure (ChoseThis (IdChoice { choice, person }) choice2)
"ChoseSomething" -> do
choice <- bigIntParser
person <- bigIntParser
pure (ChoseSomething (IdChoice { choice, person }))
"ValueGE" -> do
value1 <- valueParser
value2 <- valueParser
pure (ValueGE value1 value2)
"ValueGT" -> do
value1 <- valueParser
value2 <- valueParser
pure (ValueGT value1 value2)
"ValueLT" -> do
value1 <- valueParser
value2 <- valueParser
pure (ValueLT value1 value2)
"ValueLE" -> do
value1 <- valueParser
value2 <- valueParser
pure (ValueLE value1 value2)
"ValueEQ" -> do
value1 <- valueParser
value2 <- valueParser
pure (ValueEQ value1 value2)
"TrueObs" -> pure TrueObs
"FalseObs" -> pure FalseObs
_ -> wrongParse

contractParser :: Parser Contract
contractParser = do
tok <- getToken
case tok of
"Null" -> pure Null
"Commit" -> do
idAction <- bigIntParser
idCommit <- bigIntParser
person <- bigIntParser
value <- valueParser
timeout1 <- bigIntParser
timeout2 <- bigIntParser
contract1 <- contractParser
contract2 <- contractParser
pure (Commit idAction idCommit person value timeout1 timeout2 contract1 contract2)
"Pay" -> do
idAction <- bigIntParser
idCommit <- bigIntParser
person <- bigIntParser
value <- valueParser
timeout <- bigIntParser
contract1 <- contractParser
contract2 <- contractParser
pure (Pay idAction idCommit person value timeout contract1 contract2)
"Both" -> do
contract1 <- contractParser
contract2 <- contractParser
pure (Both contract1 contract2)
"Choice" -> do
observation <- observationParser
contract1 <- contractParser
contract2 <- contractParser
pure (Choice observation contract1 contract2)
"When" -> do
observation <- observationParser
timeout <- bigIntParser
contract1 <- contractParser
contract2 <- contractParser
pure (When observation timeout contract1 contract2)
"While" -> do
observation <- observationParser
timeout <- bigIntParser
contract1 <- contractParser
contract2 <- contractParser
pure (While observation timeout contract1 contract2)
"Scale" -> do
value1 <- valueParser
value2 <- valueParser
value3 <- valueParser
contract <- contractParser
pure (Scale value1 value2 value3 contract)
"Let" -> do
letLabel <- bigIntParser
contract1 <- contractParser
contract2 <- contractParser
pure (Let letLabel contract1 contract2)
"Use" -> do
letLabel <- bigIntParser
pure (Use letLabel)
_ -> wrongParse

alternateRemove :: forall a. Boolean -> List a -> List a -> List a
alternateRemove _ Nil x = reverse x

alternateRemove true (Cons x y) l = alternateRemove false y (Cons x l)

alternateRemove false (Cons _ x) l = alternateRemove true x l

removeOdd :: forall a. List a -> List a
removeOdd x = alternateRemove false x Nil

readContract :: String -> Maybe Contract
readContract x = case mr of
Left _ -> Nothing
Right re -> runParser (removeOdd (fromFoldable (split re x))) contractParser
where
mr = regex ("([a-zA-Z]+|-?[0-9]+)") (RegexFlags { global: true
, ignoreCase: false
, multiline: true
, sticky: false
, unicode: true
})

-- Data type for Inputs with their information
data Input
= IChoice IdChoice Choice

0 comments on commit e56f420

Please sign in to comment.
You can’t perform that action at this time.