Skip to content
Permalink
Browse files

Playground: Multiple simulations.

  • Loading branch information...
krisajenkins committed Mar 14, 2019
1 parent 43f92f7 commit b97c4db1ac517776b5c5f12848f21302bd656972
@@ -2,8 +2,10 @@ module Action
( simulationPane
) where

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 Bootstrap (badge, badgePrimary, btn, btnDanger, btnGroup, btnGroupSmall, 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 Cursor as Cursor
import Data.Array (mapWithIndex)
import Data.Array as Array
import Data.Int as Int
@@ -14,7 +16,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
@@ -23,23 +25,78 @@ import Halogen.Query as HQ
import Icons (Icon(..), icon)
import Network.RemoteData (RemoteData(Loading, NotAsked, Failure, Success))
import Playground.API (EvaluationResult, _Fn, _FunctionSchema)
import Prelude (map, pure, show, ($), (+), (/=), (<$>), (<<<), (<>))
import Types (Action(Wait, Action), ActionEvent(AddWaitAction, SetWaitTime, RemoveAction), Blockchain, ChildQuery, ChildSlot, FormEvent(SetSubField, AddSubField, RemoveSubField, SetStringField, SetIntField), Query(EvaluateActions, ModifyActions, PopulateAction), SimpleArgument(Unknowable, SimpleObject, SimpleArray, SimpleTuple, SimpleString, SimpleInt), Simulation(Simulation), WebData, _argumentSchema, _functionName, _resultBlockchain, _simulatorWalletWallet)
import Prelude (map, pure, show, (#), ($), (+), (/=), (<$>), (<<<), (<>), (==))
import Types (Action(Wait, Action), ActionEvent(AddWaitAction, SetWaitTime, RemoveAction), Blockchain, ChildQuery, ChildSlot, FormEvent(SetSubField, AddSubField, RemoveSubField, SetStringField, SetIntField), Query(..), SimpleArgument(Unknowable, SimpleObject, SimpleArray, SimpleTuple, SimpleString, SimpleInt), Simulation(Simulation), WebData, _argumentSchema, _functionName, _resultBlockchain, _simulatorWalletWallet)
import Validation (ValidationError, WithPath, joinPath, showPathValue, validate)
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_
[ simulationsNav simulations
, 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."
]

simulationsNav :: forall p . Cursor Simulation -> HTML p Query
simulationsNav simulations =
div
[ id_ "simulation-nav"
, classes [ btnGroup, btnGroupSmall ]
]
((simulations
# Cursor.mapWithIndex (simulationNavItem (Cursor.getIndex simulations))
# Cursor.toArray
# Array.concat
)
<>
[ addSimulationControl ]
)

simulationNavItem :: forall p. Int -> Int -> Simulation -> Array (HTML p Query)
simulationNavItem activeIndex index simulation =
[ button
[ id_ $ "simulation-nav-item-" <> show index
, buttonClasses
, onClick $ input_ $ SetSimulationSlot index
]
[ text $ "Simulation #" <> show (index + 1) ]
, button
[ id_ $ "simulation-nav-item-" <> show index <> "-remove"
, buttonClasses
, onClick $ input_ $ RemoveSimulationSlot index
]
[ icon Close ]
]
where
buttonClasses =
classes ([ btn, simulationNavItemClass ] <> if activeIndex == index then [ btnPrimary ] else [ btnInfo ])

simulationNavItemClass :: ClassName
simulationNavItemClass = ClassName "simulation-nav-item"

addSimulationControl :: forall p. HTML p Query
addSimulationControl =
button
[ id_ "simulation-nav-item-add"
, classes [ btn, btnInfo, simulationNavItemClass ]
, onClick $ input_ $ AddSimulationSlot
]
[ icon Plus ]

actionsPane :: forall p. Array Action -> WebData Blockchain -> HTML p Query
actionsPane actions evaluationResult =
@@ -139,6 +139,9 @@ btnBlock = ClassName "btn-block"
btnGroup :: ClassName
btnGroup = ClassName "btn-group"

btnGroupSmall :: ClassName
btnGroupSmall = ClassName "btn-group-sm"

btnGroup_ :: forall p i. Array (HTML p i) -> HTML p i
btnGroup_ = div [ class_ btnGroup ]

@@ -274,6 +277,9 @@ disabled = ClassName "disabled"
nav :: ClassName
nav = ClassName "nav"

navPills_ :: forall p i. Array (HTML p i) -> HTML p i
navPills_ = ul [ classes [ nav, ClassName "nav-pills" ] ]

navTabs_ :: forall p i. Array (HTML p i) -> HTML p i
navTabs_ = ul [ classes [ nav, ClassName "nav-tabs" ] ]

@@ -0,0 +1,131 @@
-- | 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
, first
, last
, empty
, singleton
, snoc
, deleteAt
, fromArray
, toArray
, mapWithIndex
, null
, length
, _current
, setIndex
, getIndex
, 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

snoc :: forall a. Cursor a -> a -> Cursor a
snoc (Cursor index xs) x = last $ Cursor index (Array.snoc xs x)

deleteAt :: forall a. Int -> Cursor a -> Cursor a
deleteAt n cursor@(Cursor index xs) = fromMaybe cursor do
let newIndex = if n > index
then index
else if n == index
then index
else index - 1
newXs <- Array.deleteAt n xs
pure $ clamp $ Cursor newIndex newXs

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

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

mapWithIndex :: forall b a. (Int -> a -> b) -> Cursor a -> Cursor b
mapWithIndex f (Cursor index xs) = Cursor index (Array.mapWithIndex f 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

first :: forall a. Cursor a -> Cursor a
first (Cursor _ xs) = clamp $ Cursor 0 xs

last :: forall a. Cursor a -> Cursor a
last (Cursor _ xs) = clamp $ Cursor (Array.length xs - 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
Oops, something went wrong.

0 comments on commit b97c4db

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