Merge pull request #687 from input-output-hk/playground-selenium

Playground: Adding some HTML `id` attributes to make writing Selenium scripts easier.

plutus-playground-client/src/Action.purs

@@ -18,15 +18,15 @@ import Halogen.HTML (ClassName(ClassName), br_, button, code_, div, div_, form,
 import Halogen.HTML.Elements.Keyed as Keyed
 import Halogen.HTML.Events (input_, onClick, onValueInput)
 import Halogen.HTML.Events as HE
-import Halogen.HTML.Properties (InputType(InputText, InputNumber), class_, classes, disabled, for, placeholder, required, type_, value)
+import Halogen.HTML.Properties (InputType(InputText, InputNumber), class_, classes, disabled, for, id_, placeholder, required, type_, value)
 import Halogen.Query as HQ
 import Icons (Icon(..), icon)
 import Network.RemoteData (RemoteData(Loading, NotAsked, Failure, Success))
 import Playground.API (EvaluationResult, SimulatorWallet, _EvaluationResult, _Fn, _FunctionSchema)
 import Prelude (map, pure, show, ($), (+), (/=), (<$>), (<<<), (<>))
 import Servant.PureScript.Affjax (AjaxError)
 import Types (Action(..), ActionEvent(..), Blockchain, ChildQuery, ChildSlot, FormEvent(..), Query(..), SimpleArgument(..), Simulation, _argumentSchema, _functionName, _resultBlockchain, _simulatorWalletWallet)
-import Validation (ValidationError, WithPath, addPath, validate)
+import Validation (ValidationError, WithPath, joinPath, showPathValue, validate)
 import Wallet (walletIdPane, walletsPane)
 
 simulationPane ::
@@ -61,7 +61,7 @@ actionPane :: forall p. Int -> Action -> Tuple String (HTML p Query)
 actionPane index action =
   Tuple (show index) $
     col4_
-      [ div [ class_ $ ClassName "action" ]
+      [ div [ classes [ ClassName "action", ClassName ("action-" <> show index) ] ]
         [ div [ class_ card ]
           [ cardBody_
             [ div
@@ -90,6 +90,7 @@ actionPane index action =
                         , col_ [
                             input
                               [ type_ InputNumber
+                              , classes [ formControl, ClassName $ "action-argument-0-blocks" ]
                               , value $ show blocks
                               , placeholder "Int"
                               , onValueInput $ map (HQ.action <<< ModifyActions <<< SetWaitTime index) <<< Int.fromString
@@ -110,49 +111,55 @@ validationClasses ::
 validationClasses arg Nothing = [ ClassName "error" ]
 validationClasses arg (Just _) = []
 
+actionArgumentClass :: Array String -> Array ClassName
+actionArgumentClass ancestors =
+  [ ClassName "action-argument"
+  , ClassName $ "action-argument-" <> Array.intercalate "-" ancestors
+  ]
+
 actionArgumentForm :: forall p. Int -> Array SimpleArgument -> HTML p Query
 actionArgumentForm index arguments =
   form [ class_ $ ClassName "was-validated" ]
     (Array.mapWithIndex
-       (\i argument -> PopulateAction index i <$> actionArgumentField ("Field " <> show i) false argument)
+       (\i argument -> PopulateAction index i <$> actionArgumentField [ show i ] false argument)
        arguments)
 
 actionArgumentField ::
   forall p. Warn "We're still not handling the Unknowable case."
-  => String
+  => Array String
   -> Boolean
   -> SimpleArgument
   -> HTML p FormEvent
-actionArgumentField context _ arg@(SimpleInt n) =
+actionArgumentField ancestors _ arg@(SimpleInt n) =
   div_ [
     input
       [ type_ InputNumber
-      , class_ formControl
+      , classes (Array.cons formControl (actionArgumentClass ancestors))
       , value $ maybe "" show n
       , required true
       , placeholder "Int"
       , onValueInput $ (Just <<< HQ.action <<< SetIntField <<< Int.fromString)
       ]
-    , validationFeedback (addPath context <$> validate arg)
+    , validationFeedback (joinPath ancestors <$> validate arg)
   ]
-actionArgumentField context _ arg@(SimpleString s) =
+actionArgumentField ancestors _ arg@(SimpleString s) =
   div_ [
     input
       [ type_ InputText
-      , class_ formControl
+      , classes (Array.cons formControl (actionArgumentClass ancestors))
       , value $ fromMaybe "" s
       , required true
       , placeholder "String"
       , onValueInput $ HE.input SetStringField
       ]
-    , validationFeedback (addPath context <$> validate arg)
+    , validationFeedback (joinPath ancestors <$> validate arg)
   ]
-actionArgumentField context nested (SimpleTuple (subFieldA /\subFieldB)) =
+actionArgumentField ancestors nested (SimpleTuple (subFieldA /\subFieldB)) =
   row_
-    [ col_ [ SetSubField 1 <$> actionArgumentField "_1" true subFieldA ]
-    , col_ [ SetSubField 2 <$> actionArgumentField "_2" true subFieldB ]
+    [ col_ [ SetSubField 1 <$> actionArgumentField (Array.snoc ancestors "_1") true subFieldA ]
+    , col_ [ SetSubField 2 <$> actionArgumentField (Array.snoc ancestors "_2") true subFieldB ]
     ]
-actionArgumentField context nested (SimpleArray schema subFields) =
+actionArgumentField ancestors nested (SimpleArray schema subFields) =
     div_ [(if nested
            then Keyed.div [ classes [  ClassName "nested" ] ]
            else Keyed.div_) (mapWithIndex subFormContainer subFields)
@@ -169,7 +176,7 @@ actionArgumentField context nested (SimpleArray schema subFields) =
       formGroup_ [
         row_
           [ col10_
-              [ SetSubField i <$> actionArgumentField (show i) true field ]
+              [ SetSubField i <$> actionArgumentField (Array.snoc ancestors (show i)) true field ]
           , col2_
             [ button
               [ classes [ btn, btnLink ]
@@ -180,27 +187,27 @@ actionArgumentField context nested (SimpleArray schema subFields) =
           ]
         ]
 
-actionArgumentField context nested (SimpleObject _ subFields) =
+actionArgumentField ancestors nested (SimpleObject _ subFields) =
     (if nested
        then div [ classes [  ClassName "nested" ] ]
        else div_) $ mapWithIndex (\i field -> map (SetSubField i) (subForm field)) subFields
   where
     subForm (name /\ arg) =
       (formGroup_
          [ label [ for name ] [ text name ]
-         , actionArgumentField name true arg
+         , actionArgumentField (Array.snoc ancestors name) true arg
          ]
       )
 actionArgumentField _ _ (Unknowable { context, description }) =
-  div_ [ text $ "Unsupported: " <> context
+  div_ [ text $ "Unsupported: " <>  context
        , code_ [ text description ]
        ]
 
 validationFeedback :: forall p i. Array (WithPath ValidationError) -> HTML p i
 validationFeedback [] =
   validFeedback_ [ nbsp ]
 validationFeedback errors =
-  invalidFeedback_ (div_ <<< pure <<< text <<< show <$> errors)
+  invalidFeedback_ (div_ <<< pure <<< text <<< showPathValue <$> errors)
 
 addWaitActionPane :: forall p. Tuple String (HTML p Query)
 addWaitActionPane =
@@ -223,7 +230,8 @@ evaluateActionsPane :: forall p. RemoteData AjaxError Blockchain -> Array Action
 evaluateActionsPane evaluationResult actions =
   col_
     [ button
-      [ classes [ btn, btnClass evaluationResult hasErrors ]
+      [ id_ "evaluate"
+      , classes [ btn, btnClass evaluationResult hasErrors ]
       , disabled hasErrors
       , onClick $ input_ EvaluateActions
       ]

plutus-playground-client/src/Editor.purs

@@ -23,7 +23,7 @@ import Halogen (HTML, action)
 import Halogen.Component (ParentHTML)
 import Halogen.HTML (ClassName(ClassName), br_, button, code_, div, div_, h3_, pre_, slot', small, strong_, text)
 import Halogen.HTML.Events (input, input_, onClick, onDragOver, onDrop)
-import Halogen.HTML.Properties (class_, classes, disabled)
+import Halogen.HTML.Properties (class_, classes, disabled, id_)
 import Icons (Icon(..), icon)
 import Language.Haskell.Interpreter (CompilationError(CompilationError, RawError))
 import LocalStorage (LOCALSTORAGE)
@@ -62,7 +62,8 @@ editorPane state =
   div_
     [ demoScriptsPane
     , div
-        [ onDragOver $ Just <<< action <<< HandleDragEvent
+        [ id_ "editor"
+        , onDragOver $ Just <<< action <<< HandleDragEvent
         , onDrop $ Just <<< action <<< HandleDropEvent
         ]
         [ slot' cpEditor EditorSlot
@@ -76,7 +77,8 @@ editorPane state =
             [ gistControls (view _authStatus state) (view _createGistResult state) ]
         , div_
             [ button
-                [ classes [ btn, btnClass ]
+                [ id_ "compile"
+                , classes [ btn, btnClass ]
                 , onClick $ input_ CompileProgram
                 , disabled (isLoading state.compilationResult)
                 ]
@@ -117,7 +119,7 @@ editorPane state =
 
 demoScriptsPane :: forall p. HTML p Query
 demoScriptsPane =
-  div [ class_ $ ClassName "demos" ]
+  div [ id_ "demos" ]
    (Array.cons
       (strong_ [ text "Demos: " ])
       (demoScriptButton <$> Array.fromFoldable (Map.keys StaticData.demoFiles)))

plutus-playground-client/src/Gists.purs

@@ -14,10 +14,10 @@ import Data.Maybe (Maybe(..))
 import Gist (Gist, NewGist(NewGist), NewGistFile(NewGistFile), gistHtmlUrl)
 import Halogen.HTML (ClassName(ClassName), HTML, a, br_, div, div_, text)
 import Halogen.HTML.Events (input_, onClick)
-import Halogen.HTML.Properties (class_, classes, href, target)
+import Halogen.HTML.Properties (class_, classes, href, id_, target)
 import Icons (Icon(..), icon)
 import Network.RemoteData (RemoteData(NotAsked, Loading, Failure, Success))
-import Prelude (Unit, ($), (<$>))
+import Prelude (Unit, ($), (<$>), (<>))
 import Servant.PureScript.Affjax (AjaxError)
 import Types (Query(..))
 
@@ -28,7 +28,8 @@ gistControls ::
   -> HTML p (Query Unit)
 gistControls authStatus createGistResult =
   div_
-    [ a publishAttributes publishContent
+    [ a ([ id_ "publish-gist" ] <> publishAttributes)
+        publishContent
     , br_
     , div_
         [ case createGistResult of

plutus-playground-client/src/MainFrame.purs

@@ -45,7 +45,7 @@ import Halogen.ECharts (EChartsEffects)
 import Halogen.ECharts as EC
 import Halogen.HTML (ClassName(ClassName), HTML, a, div, div_, h1, strong_, text)
 import Halogen.HTML.Events (onClick)
-import Halogen.HTML.Properties (class_, classes, href)
+import Halogen.HTML.Properties (class_, classes, href, id_)
 import Halogen.Query (HalogenM)
 import Icons (Icon(..), icon)
 import Language.Haskell.Interpreter (CompilationError(CompilationError, RawError))
@@ -472,10 +472,13 @@ mainTabBar activeView =
            , Simulation /\ "Simulation"
            , Transactions /\ "Transactions"
            ]
-    mkTab (link /\ title ) =
+
+    mkTab :: Tuple View String -> HTML p (Query Unit)
+    mkTab (link /\ title) =
       navItem_ [
         a
-          [ classes $ [ navLink ] <> activeClass
+          [ id_ $ "tab-" <> String.toLower (show link)
+          , classes $ [ navLink ] <> activeClass
           , onClick $ const $ Just $ action $ ChangeView link
           ]
           [ text title ]

plutus-playground-client/src/Types.purs

@@ -269,7 +269,9 @@ derive instance eqView :: Eq View
 derive instance genericView :: Generic View
 
 instance showView :: Show View where
-  show = gShow
+  show Editor = "Editor"
+  show Simulation = "Simulation"
+  show Transactions = "Transactions"
 
 ------------------------------------------------------------
 

plutus-playground-client/src/Validation.purs

@@ -2,10 +2,9 @@ module Validation where
 
 import Prelude
 
+import Data.Array as Array
 import Data.Foldable (class Foldable)
 import Data.Generic (class Generic)
-import Data.List (List(..))
-import Data.List as List
 
 class Validation a where
   validate ::  a -> Array (WithPath ValidationError)
@@ -23,20 +22,26 @@ instance showValidationError :: Show ValidationError where
 
 ------------------------------------------------------------
 
-newtype WithPath a = WithPath { path :: List String, value :: a }
+newtype WithPath a = WithPath { path :: Array String, value :: a }
 
 derive instance eqWithPath :: Eq a => Eq (WithPath a)
 
 derive instance functorWithPath :: Functor WithPath
 
 instance showWithPath :: Show a => Show (WithPath a) where
-  show (WithPath { path, value }) = List.intercalate "." path <> ": " <> show value
+  show (WithPath { path, value }) = Array.intercalate "." path <> ": " <> show value
+
+showPathValue :: forall a. Show a => WithPath a -> String
+showPathValue (WithPath {value}) = show value
 
 noPath :: forall a. a -> WithPath a
-noPath value = WithPath { path: Nil, value }
+noPath value = WithPath { path: [], value }
 
 withPath :: forall a f. Foldable f => f String -> a -> WithPath a
-withPath path value = WithPath { path: List.fromFoldable path, value }
+withPath path value = WithPath { path: Array.fromFoldable path, value }
 
 addPath :: forall a. String -> WithPath a -> WithPath a
-addPath parent (WithPath {path, value}) = WithPath { path: Cons parent path, value }
+addPath parent (WithPath {path, value}) = WithPath { path: Array.cons parent path, value }
+
+joinPath :: forall a. Array String -> WithPath a -> WithPath a
+joinPath ancestors (WithPath {path, value}) = WithPath { path: ancestors <> path, value }

plutus-playground-client/src/Wallet.purs

@@ -2,7 +2,7 @@ module Wallet where
 
 import Types
 
-import Bootstrap (btn, btnSecondary, btnSmall, card, cardBody_, cardTitle_, card_, col4_, col_, pullRight, row, row_)
+import Bootstrap (btn, btnSecondary, btnSmall, card, cardBody_, cardTitle_, card_, col4_, col_, formControl, pullRight, row, row_)
 import Data.Array (mapWithIndex)
 import Data.Array as Array
 import Data.Int as Int
@@ -18,7 +18,7 @@ import Halogen.Query as HQ
 import Icons (Icon(..), icon)
 import Ledger.Ada.TH (Ada(..))
 import Playground.API (FunctionSchema, SimulatorWallet, SimpleArgumentSchema, _Fn, _FunctionSchema)
-import Prelude (map, show, ($), (<$>), (<<<))
+import Prelude (map, show, ($), (<$>), (<<<), (<>))
 import Wallet.Emulator.Types (Wallet)
 
 walletsPane ::
@@ -44,8 +44,7 @@ walletPane ::
 walletPane signatures index simulatorWallet =
   Tuple (show index) $
     col4_
-      [ div
-          [class_ $ ClassName "wallet"]
+      [ div [ classes [ ClassName "wallet", ClassName ("wallet-" <> show index) ] ]
           [ card_
               [ cardBody_
                   [ button
@@ -59,6 +58,7 @@ walletPane signatures index simulatorWallet =
                       , col_ [
                           input
                             [ type_ InputNumber
+                            , class_ formControl
                             , value $ show $ view (_simulatorWalletBalance <<< _ada) simulatorWallet
                             , placeholder "Int"
                             , onValueInput $ map (HQ.action <<< SetBalance (view _simulatorWalletWallet simulatorWallet) <<< \v -> Ada {getAda: v}) <<< Int.fromString

plutus-playground-client/static/main.scss

@@ -72,7 +72,7 @@ h2 {
     }
 }
 
-.demos {
+#demos {
     text-align: right;
     padding: 5px 0;
 }