Skip to content
Permalink
Browse files

WIP: Playground: Multiple simulations.

  • Loading branch information...
krisajenkins committed Mar 14, 2019
1 parent 43f92f7 commit c9b639b0b269da424c804f0895cd11bef9d39637
@@ -4,6 +4,7 @@ module Action

import Bootstrap (badge, badgePrimary, btn, btnDanger, btnInfo, btnLink, btnPrimary, btnSecondary, btnSuccess, btnWarning, card, cardBody_, col10_, col2_, col4_, col_, formControl, formGroup_, invalidFeedback_, nbsp, pullRight, row, row_, validFeedback_)
import Control.Monad.Aff.Class (class MonadAff)
import Cursor (Cursor, current)
import Data.Array (mapWithIndex)
import Data.Array as Array
import Data.Int as Int
@@ -14,7 +15,7 @@ import Data.Tuple.Nested ((/\))
import Halogen (HTML)
import Halogen.Component (ParentHTML)
import Halogen.ECharts (EChartsEffects)
import Halogen.HTML (ClassName(ClassName), br_, button, code_, div, div_, form, h2_, h3_, input, label, p_, small_, text)
import Halogen.HTML (ClassName(ClassName), br_, button, code_, div, div_, form, h2_, h3_, input, label, p_, small_, strong_, text)
import Halogen.HTML.Elements.Keyed as Keyed
import Halogen.HTML.Events (input_, onClick, onValueInput)
import Halogen.HTML.Events as HE
@@ -31,15 +32,23 @@ import Wallet (walletIdPane, walletsPane)
simulationPane ::
forall m aff.
MonadAff (EChartsEffects aff) m
=> Simulation
=> Cursor Simulation
-> WebData EvaluationResult
-> ParentHTML Query ChildQuery ChildSlot m
simulationPane (Simulation simulation) evaluationResult =
div_
[ walletsPane simulation.signatures simulation.wallets
, br_
, actionsPane simulation.actions (view _resultBlockchain <$> evaluationResult)
]
simulationPane simulations evaluationResult =
case current simulations of
Just (Simulation simulation) ->
div_
[ walletsPane simulation.signatures simulation.wallets
, br_
, actionsPane simulation.actions (view _resultBlockchain <$> evaluationResult)
]
Nothing ->
div_
[ text "Click the "
, strong_ [ text "Editor" ]
, text " tab above and compile a contract to get started."
]

actionsPane :: forall p. Array Action -> WebData Blockchain -> HTML p Query
actionsPane actions evaluationResult =
@@ -0,0 +1,99 @@
-- | A cursor is an Array with a pointer to the 'current' item, plus
-- some guarantees* that you cannot get into an invalid state.
--
-- * Mostly guaranteed by using smart constructors and judicious exports.
module Cursor
( Cursor
, current
, empty
, singleton
, fromArray
, null
, length
, _current
, setIndex
, left
, right
)
where

import Control.Monad.Gen.Class (chooseInt)
import Data.Array as Array
import Data.Generic (class Generic)
import Data.Lens (Traversal', wander)
import Data.Lens.Index (class Index)
import Data.Maybe (Maybe, fromMaybe, maybe)
import Prelude (class Eq, class Functor, class Ord, class Show, bind, map, max, min, pure, show, (#), ($), (+), (-), (<<<), (<>), (>>>))
import Test.QuickCheck.Arbitrary (class Arbitrary, arbitrary)
import Test.QuickCheck.Gen (arrayOf)

data Cursor a = Cursor Int (Array a)

derive instance eqCursor :: Eq a => Eq (Cursor a)
derive instance ordCursor :: Ord a => Ord (Cursor a)
derive instance functorCursor :: Functor Cursor
derive instance genericCursor :: Generic a => Generic (Cursor a)

instance showCursor :: Show a => Show (Cursor a) where
show (Cursor index xs) = "Cursor " <> show index <> " " <> show xs

instance arbitraryCursor :: Arbitrary a => Arbitrary (Cursor a) where
arbitrary = do
xs <- arrayOf arbitrary
index <- chooseInt 0 (Array.length xs - 1)
pure $ clamp $ Cursor index xs

instance indexCursor :: Index (Cursor a) Int a where
ix n = wander \coalg (Cursor index xs) ->
Array.index xs n
# maybe
(pure xs)
(let f x = fromMaybe xs $ Array.updateAt n x xs
in coalg >>> map f)
# map (Cursor index)

_current :: forall a. Traversal' (Cursor a) a
_current =
wander \coalg (Cursor index xs) ->
Array.index xs index
# maybe
(pure xs)
(let f x = fromMaybe xs $ Array.updateAt index x xs
in coalg >>> map f)
# map (Cursor index)

clamp :: forall a. Cursor a -> Cursor a
clamp (Cursor index xs) =
Cursor
(min (max 0 index) (Array.length xs - 1))
xs

empty :: forall a. Cursor a
empty = fromArray []

singleton :: forall a. a -> Cursor a
singleton = fromArray <<< Array.singleton

fromArray :: forall a. Array a -> Cursor a
fromArray xs = Cursor 0 xs

null :: forall a. Cursor a -> Boolean
null (Cursor _ xs) = Array.null xs

length :: forall a. Cursor a -> Int
length (Cursor _ xs) = Array.length xs

current :: forall a. Cursor a -> Maybe a
current (Cursor index xs) = Array.index xs index

getIndex :: forall a. Cursor a -> Int
getIndex (Cursor index xs) = index

setIndex :: forall a. Int -> Cursor a -> Cursor a
setIndex newIndex (Cursor _ xs) = clamp $ Cursor newIndex xs

left :: forall a. Cursor a -> Cursor a
left (Cursor index xs) = clamp $ Cursor (index - 1) xs

right :: forall a. Cursor a -> Cursor a
right (Cursor index xs) = clamp $ Cursor (index + 1) xs
@@ -0,0 +1,17 @@
module Data.Lens.Extra
(peruse) where

import Control.Category ((<<<))
import Control.Monad.State.Class (class MonadState, gets)
import Data.Lens.Fold (Fold, preview)
import Data.Maybe (Maybe)
import Data.Maybe.First (First)

-- | Extract a `Maybe` in the context of `MonadState`.
-- ie. `preview` on a `use`.
--
-- By happy coincidence, the English language has a word that's spelt
-- like a portmanteau of 'preview+use' and means, "to look at
-- something in a relaxed way."
peruse :: forall m s t a b. MonadState s m => Fold (First a) s t a b -> m (Maybe a)
peruse = gets <<< preview
@@ -11,6 +11,7 @@ import AjaxUtils (getEncodeJson, showAjaxError)
import Auth (AuthRole(..), AuthStatus, authStatusAuthRole)
import Bootstrap (btn, btnBlock, btnDanger, btnInfo, btnPrimary, btnSecondary, nbsp)
import Control.Monad.Reader.Trans (class MonadAsk)
import Cursor (Cursor)
import DOM.HTML.Indexed.InputType (InputType(..))
import Data.Argonaut.Core (stringify)
import Data.Array (catMaybes)
@@ -128,13 +129,13 @@ mkNewGist ::
forall m params.
MonadAsk (SPSettings_ params) m
=> { source :: Maybe SourceCode
, simulation :: Maybe Simulation
, simulations :: Cursor Simulation
}
-> m (Maybe NewGist)
mkNewGist { source, simulation } = do
mkNewGist { source, simulations } = do
encodeJson <- getEncodeJson
let gistFiles = catMaybes [ mkNewGistFile gistSourceFilename <<< unwrap <$> source
, mkNewGistFile gistSimulationFilename <<< stringify <<< encodeJson <$> simulation
, Just (mkNewGistFile gistSimulationFilename $ stringify $ encodeJson simulations)
]
pure $ if Array.null gistFiles
then Nothing
@@ -22,12 +22,15 @@ import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT)
import Control.Monad.Reader.Class (class MonadAsk)
import Control.Monad.State (class MonadState)
import Control.Monad.Trans.Class (lift)
import Cursor (_current)
import Cursor as Cursor
import Data.Argonaut.Parser (jsonParser)
import Data.Array (catMaybes, (..))
import Data.Array as Array
import Data.Either (Either(..), note)
import Data.Generic (gEq)
import Data.Lens (_1, _2, _Just, _Right, assign, modifying, over, set, traversed, use, view)
import Data.Lens.Extra (peruse)
import Data.Lens.Fold (findOf, maximumOf, preview)
import Data.Lens.Index (ix)
import Data.Map as Map
@@ -74,7 +77,7 @@ initialState :: State
initialState = State
{ currentView: Editor
, compilationResult: NotAsked
, simulation: Nothing
, simulations: Cursor.empty
, evaluationResult: NotAsked
, authStatus: NotAsked
, createGistResult: NotAsked
@@ -183,8 +186,8 @@ eval (CheckAuthStatus next) = do

eval (PublishGist next) = do
mContents <- editorGetContents
simulation <- use _simulation
mNewGist <- mkNewGist { source: mContents, simulation }
simulations <- use _simulations
mNewGist <- mkNewGist { source: mContents, simulations }
case mNewGist of
Nothing -> pure next
Just newGist ->
@@ -224,7 +227,7 @@ eval (LoadGist next) = do
Nothing -> pure unit
Just content -> do editorSetContents content (Just 1)
saveBuffer content
assign _simulation Nothing
assign _simulations Cursor.empty
assign _evaluationResult NotAsked

-- Load the simulation, if available.
@@ -235,9 +238,9 @@ eval (LoadGist next) = do
Just simulationString -> do
case (decodeJson =<< jsonParser simulationString) of
Left err -> pure unit
Right simulation -> do
assign _simulation $ Just simulation
assign _evaluationResult NotAsked
Right simulations -> do
assign _simulations simulations
assign _evaluationResult NotAsked

_ -> pure unit

@@ -282,12 +285,12 @@ eval (CompileProgram next) = do
-- change means we'll have to clear out the existing simulation.
case preview (_Success <<< _Right <<< _CompilationResult <<< _functionSchema) result of
Just newSignatures -> do
oldSignatures <- use (_simulation <<< _Just <<< _signatures)
oldSignatures <- use (_simulations <<< _current <<< _signatures)
unless (oldSignatures `gEq` newSignatures)
(assign _simulation $ Just $ Simulation { signatures: newSignatures
, actions: []
, wallets: mkSimulatorWallet <$> 1..2
})
(assign _simulations $ Cursor.singleton $ Simulation { signatures: newSignatures
, actions: []
, wallets: mkSimulatorWallet <$> 1..2
})
_ -> pure unit

pure next
@@ -297,14 +300,14 @@ eval (ScrollTo {row, column} next) = do
pure next

eval (ModifyActions actionEvent next) = do
modifying (_simulation <<< _Just <<< _actions) (evalActionEvent actionEvent)
modifying (_simulations <<< _current <<< _actions) (evalActionEvent actionEvent)
pure next

eval (EvaluateActions next) = do
_ <- runMaybeT $
do evaluation <- MaybeT do
contents <- editorGetContents
simulation <- use _simulation
simulation <- peruse (_simulations <<< _current)
pure $ join $ toEvaluation <$> contents <*> simulation

result <- lift $ postEvaluation evaluation
@@ -318,29 +321,29 @@ eval (EvaluateActions next) = do
pure next

eval (AddWallet next) = do
modifying (_simulation <<< _Just <<< _wallets)
modifying (_simulations <<< _current <<< _wallets)
(\wallets -> let maxWalletId = fromMaybe 0 $ maximumOf (traversed <<< _simulatorWalletWallet <<< _walletId) wallets
newWallet = mkSimulatorWallet (maxWalletId + 1)
in Array.snoc wallets newWallet)

pure next

eval (RemoveWallet index next) = do
modifying (_simulation <<< _Just <<< _wallets) (fromMaybe <*> Array.deleteAt index)
assign (_simulation <<< _Just <<< _actions) []
modifying (_simulations <<< _current <<< _wallets) (fromMaybe <*> Array.deleteAt index)
assign (_simulations <<< _current <<< _actions) []
pure next

eval (SetBalance wallet newBalance next) = do
modifying (_simulation <<< _Just <<< _wallets <<< traversed)
modifying (_simulations <<< _current <<< _wallets <<< traversed)
(\simulatorWallet -> if view _simulatorWalletWallet simulatorWallet == wallet
then set _simulatorWalletBalance newBalance simulatorWallet
else simulatorWallet)
pure next

eval (PopulateAction n l event) = do
modifying
(_simulation
<<< _Just
(_simulations
<<< _current
<<< _actions
<<< ix n
<<< _Action
@@ -435,20 +438,13 @@ render state@(State {currentView}) =
_ -> empty
]
, viewContainer currentView Simulations $
case view _simulation state of
Just simulation ->
[ simulationPane
simulation
(view _simulations state)
(view _evaluationResult state)
, case (view _evaluationResult state) of
Failure error -> ajaxErrorPane error
_ -> empty
]
Nothing ->
[ text "Click the "
, strong_ [ text "Editor" ]
, text " tab above and compile a contract to get started."
]
, viewContainer currentView Transactions $
case view _evaluationResult state of
Success evaluation ->
@@ -6,6 +6,7 @@ import Ace.Halogen.Component (AceMessage, AceQuery)
import Auth (AuthStatus)
import Control.Comonad (class Comonad, extract)
import Control.Extend (class Extend, extend)
import Cursor (Cursor)
import DOM.HTML.Event.Types (DragEvent)
import Data.Argonaut.Core (Json)
import Data.Argonaut.Core as Json
@@ -244,7 +245,7 @@ type WebData = RemoteData AjaxError
newtype State = State
{ currentView :: View
, compilationResult :: WebData (Either (Array CompilationError) CompilationResult)
, simulation :: Maybe Simulation
, simulations :: Cursor Simulation
, evaluationResult :: WebData EvaluationResult
, authStatus :: WebData AuthStatus
, createGistResult :: WebData Gist
@@ -256,8 +257,8 @@ derive instance newtypeState :: Newtype State _
_currentView :: Lens' State View
_currentView = _Newtype <<< prop (SProxy :: SProxy "currentView")

_simulation :: Lens' State (Maybe Simulation)
_simulation = _Newtype <<< prop (SProxy :: SProxy "simulation")
_simulations :: Lens' State (Cursor Simulation)
_simulations = _Newtype <<< prop (SProxy :: SProxy "simulations")

_signatures :: Lens' Simulation Signatures
_signatures = _Newtype <<< prop (SProxy :: SProxy "signatures")
Oops, something went wrong.

0 comments on commit c9b639b

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