Moving and renaming various things.

marlowe-dashboard-client/src/Contract/View.purs

@@ -12,7 +12,7 @@ import Data.Map as Map
 import Data.Maybe (Maybe(..))
 import Halogen.HTML (HTML, button, div, div_, h2_, text)
 import Halogen.HTML.Events (onClick)
-import MainFrame.Types (ContractStatus)
+import Play.Types (ContractStatus)
 import Marlowe.Execution (ExecutionStep, NamedAction(..))
 import Marlowe.Semantics (Accounts, ChoiceId(..), Input(..), Party, TransactionInput(..), _accounts)
 

marlowe-dashboard-client/src/MainFrame/Lenses.purs

@@ -3,27 +3,23 @@ module MainFrame.Lenses
   , _newWalletNicknameKey
   , _templates
   , _subState
+  , _webSocketStatus
   , _pickupState
-  , _walletState
+  , _playState
   , _screen
   , _card
-  , _wallet
-  , _menuOpen
-  , _webSocketStatus
-  , _templateState
-  , _contractState
   ) where
 
 import Prelude
-import Contract.Types (State) as Contract
 import Data.Either (Either)
 import Data.Lens (Lens', Traversal')
 import Data.Lens.Prism.Either (_Left, _Right)
 import Data.Lens.Record (prop)
 import Data.Symbol (SProxy(..))
-import MainFrame.Types (PickupState, State, WalletState, WebSocketStatus)
-import Marlowe.Semantics (PubKey)
-import Template.Types (State, Template) as Template
+import MainFrame.Types (State, WebSocketStatus)
+import Play.Types (State) as Play
+import Pickup.Types (State) as Pickup
+import Template.Types (Template) as Template
 import WalletData.Types (WalletLibrary, WalletNicknameKey)
 
 _wallets :: Lens' State WalletLibrary
@@ -35,35 +31,22 @@ _newWalletNicknameKey = prop (SProxy :: SProxy "newWalletNicknameKey")
 _templates :: Lens' State (Array Template.Template)
 _templates = prop (SProxy :: SProxy "templates")
 
-_subState :: Lens' State (Either PickupState WalletState)
+_subState :: Lens' State (Either Pickup.State Play.State)
 _subState = prop (SProxy :: SProxy "subState")
 
 _webSocketStatus :: Lens' State WebSocketStatus
 _webSocketStatus = prop (SProxy :: SProxy "webSocketStatus")
 
 ------------------------------------------------------------
-_pickupState :: Traversal' State PickupState
+_pickupState :: Traversal' State Pickup.State
 _pickupState = _subState <<< _Left
 
-_walletState :: Traversal' State WalletState
-_walletState = _subState <<< _Right
+_playState :: Traversal' State Play.State
+_playState = _subState <<< _Right
 
 ------------------------------------------------------------
 _screen :: forall s b. Lens' { screen :: s | b } s
 _screen = prop (SProxy :: SProxy "screen")
 
 _card :: forall c b. Lens' { card :: c | b } c
 _card = prop (SProxy :: SProxy "card")
-
-------------------------------------------------------------
-_wallet :: Lens' WalletState PubKey
-_wallet = prop (SProxy :: SProxy "wallet")
-
-_menuOpen :: Lens' WalletState Boolean
-_menuOpen = prop (SProxy :: SProxy "menuOpen")
-
-_templateState :: Lens' WalletState Template.State
-_templateState = prop (SProxy :: SProxy "templateState")
-
-_contractState :: Lens' WalletState Contract.State
-_contractState = prop (SProxy :: SProxy "contractState")

marlowe-dashboard-client/src/MainFrame/State.purs

@@ -1,13 +1,10 @@
 module MainFrame.State (mkMainFrame) where
 
 import Prelude
-import Contract.State (handleAction, defaultState) as Contract
-import Contract.Types (_executionState)
 import Control.Monad.Except (runExcept)
 import Data.Either (Either(..))
 import Data.Foldable (for_)
-import Data.Lens (Traversal', assign, modifying, over, set, use, view)
-import Data.Lens.Extra (peruse)
+import Data.Lens (assign, over, set, use)
 import Data.Map (empty, insert, member)
 import Data.Map.Extra (findIndex)
 import Data.Maybe (Maybe(..))
@@ -16,21 +13,18 @@ import Effect.Aff.Class (class MonadAff)
 import Effect.Random (random)
 import Foreign.Generic (decodeJSON, encodeJSON)
 import Halogen (Component, HalogenM, liftEffect, mkComponent, mkEval, modify_)
-import Halogen.Extra (mapMaybeSubmodule)
 import Halogen.HTML (HTML)
 import LocalStorage (getItem, removeItem, setItem)
-import MainFrame.Lenses (_card, _contractState, _menuOpen, _newWalletNicknameKey, _pickupState, _screen, _templateState, _subState, _templates, _walletState, _wallets, _webSocketStatus)
-import MainFrame.Types (Action(..), Card(..), ChildSlots, ContractStatus(..), Msg, PickupCard(..), PickupScreen(..), PickupState, Query(..), Screen(..), State, WalletState, WebSocketStatus(..))
+import MainFrame.Lenses (_card, _newWalletNicknameKey, _pickupState, _subState, _templates, _playState, _wallets, _webSocketStatus)
+import MainFrame.Types (Action(..), ChildSlots, Msg, Query(..), State, WebSocketStatus(..))
 import MainFrame.View (render)
-import Marlowe.Execution (_contract)
-import Marlowe.Extended (fillTemplate, toCore)
-import Marlowe.Semantics (PubKey)
+import Pickup.State (handleAction, initialState) as Pickup
+import Pickup.Types (Action(..), Card(..)) as Pickup
+import Play.State (handleAction, mkInitialState) as Play
+import Play.Types (Action(..)) as Play
 import Plutus.PAB.Webserver.Types (StreamToClient(..))
 import StaticData (walletLocalStorageKey, walletsLocalStorageKey)
-import Template.Lenses (_extendedContract, _template, _templateContent)
 import Template.Library (templates)
-import Template.State (defaultState, handleAction, mkInitialState) as Template
-import Template.Types (ContractSetupScreen(..))
 import WalletData.Lenses (_key, _nickname)
 import WalletData.Types (WalletDetails)
 import WebSocket.Support as WS
@@ -55,26 +49,10 @@ initialState =
   { wallets: empty
   , newWalletNicknameKey: mempty
   , templates: mempty
-  , subState: Left initialPickupState
+  , subState: Left Pickup.initialState
   , webSocketStatus: WebSocketClosed Nothing
   }
 
-initialPickupState :: PickupState
-initialPickupState =
-  { screen: GenerateWalletScreen
-  , card: Nothing
-  }
-
-mkWalletState :: PubKey -> WalletState
-mkWalletState pubKeyHash =
-  { wallet: pubKeyHash
-  , menuOpen: false
-  , screen: ContractsScreen Running
-  , card: Nothing
-  , templateState: Template.defaultState
-  , contractState: Contract.defaultState
-  }
-
 defaultWalletDetails :: WalletDetails
 defaultWalletDetails = { userHasPickedUp: false }
 
@@ -94,6 +72,15 @@ handleQuery (ReceiveWebSocketMessage msg next) = do
       (ErrorResponse error) -> pure unit
   pure $ Just next
 
+-- Note [State]: Some actions belong logically in one part of the state, but
+-- from the user's point of view in another. For example, the action of picking
+-- up a wallet belongs logically in the MainFrame state (because it modifies
+-- that state), but from the user's point of view it belongs in the Pickup
+-- state (because that's the state the app is in when you perform it). To work
+-- around this, we can either make our `handleAction` functions a bit awkward,
+-- or our `render` functions a bit awkward. I prefer the former. Hence some
+-- submodule actions (triggered straightforwardly in the submodule's `render`
+-- functions) are handled by their parent module's `handleAction` function.
 handleAction :: forall m. MonadAff m => Action -> HalogenM State Action ChildSlots Msg m Unit
 handleAction Init = do
   mCachedWalletsJson <- liftEffect $ getItem walletsLocalStorageKey
@@ -103,126 +90,70 @@ handleAction Init = do
   mCachedWalletJson <- liftEffect $ getItem walletLocalStorageKey
   for_ mCachedWalletJson \json ->
     for_ (runExcept $ decodeJSON json) \cachedWallet ->
-      assign _subState $ Right $ mkWalletState cachedWallet
+      assign _subState $ Right $ Play.mkInitialState cachedWallet
   -- TODO: fetch contract templates from the library ??
   assign _templates templates
 
--- pickup actions
-handleAction (SetPickupCard pickupCard) = assign (_pickupState <<< _card) pickupCard
+handleAction (SetNewWalletNickname nickname) = assign (_newWalletNicknameKey <<< _nickname) nickname
+
+handleAction AddNewWallet = do
+  oldWallets <- use _wallets
+  newWalletNicknameKey <- use _newWalletNicknameKey
+  when (not $ member newWalletNicknameKey oldWallets) do
+    modify_
+      $ (over _wallets) (insert newWalletNicknameKey defaultWalletDetails)
+      <<< (set _newWalletNicknameKey) mempty
+      <<< (_playState <<< set _card) Nothing
+    newWallets <- use _wallets
+    liftEffect $ setItem walletsLocalStorageKey $ encodeJSON newWallets
+
+-- pickup actions that need to be handled here
+handleAction (PickupAction (Pickup.SetNewWalletNickname nickname)) = handleAction $ SetNewWalletNickname nickname
+
+handleAction (PickupAction Pickup.PickupNewWallet) = do
+  newPubKey <- use (_newWalletNicknameKey <<< _key)
+  handleAction AddNewWallet
+  handleAction $ PickupAction $ Pickup.PickupWallet newPubKey
+
+handleAction (PickupAction (Pickup.PickupWallet pubKey)) = do
+  modify_
+    $ (set _subState) (Right $ Play.mkInitialState pubKey)
+    <<< (_pickupState <<< set _card) Nothing
+  liftEffect $ setItem walletLocalStorageKey $ encodeJSON pubKey
 
 -- TODO: generate wallet on the backend; for now just create a random number
-handleAction GenerateNewWallet = do
+handleAction (PickupAction Pickup.GenerateNewWallet) = do
   randomNumber <- liftEffect random
   let
     key = show $ randomNumber
   modify_
     $ (_newWalletNicknameKey <<< set _key) key
-    <<< (_pickupState <<< set _card) (Just PickupNewWalletCard)
+    <<< (_pickupState <<< set _card) (Just Pickup.PickupNewWalletCard)
 
-handleAction PickupNewWallet = do
-  newPubKey <- use (_newWalletNicknameKey <<< _key)
-  handleAction AddNewWallet
-  handleAction $ PickupWallet newPubKey
-
-handleAction (LookupWallet string) = do
+handleAction (PickupAction (Pickup.LookupWallet string)) = do
   wallets <- use _wallets
   -- check for a matching nickname in the wallet library first
   case findIndex (\key -> fst key == string) wallets of
-    Just key -> assign (_pickupState <<< _card) $ Just $ PickupWalletCard key
+    Just key -> assign (_pickupState <<< _card) $ Just $ Pickup.PickupWalletCard key
     -- failing that, check for a matching pubkey in the wallet library
     Nothing -> case findIndex (\key -> snd key == string) wallets of
-      Just key -> assign (_pickupState <<< _card) $ Just $ PickupWalletCard key
+      Just key -> assign (_pickupState <<< _card) $ Just $ Pickup.PickupWalletCard key
       -- TODO: lookup pubkey on the blockchain
       Nothing -> pure unit
 
-handleAction (PickupWallet pubKeyHash) = do
-  modify_
-    $ (set _subState) (Right $ mkWalletState pubKeyHash)
-    <<< (_pickupState <<< set _card) Nothing
-  liftEffect $ setItem walletLocalStorageKey $ encodeJSON pubKeyHash
+-- other pickup actions
+handleAction (PickupAction pickupAction) = Pickup.handleAction pickupAction
 
--- wallet actions
-handleAction PutdownWallet = do
-  assign _subState $ Left initialPickupState
+-- play actions that need to be handled here
+handleAction (PlayAction Play.PutdownWallet) = do
+  assign _subState $ Left Pickup.initialState
   liftEffect $ removeItem walletLocalStorageKey
 
-handleAction ToggleMenu = modifying (_walletState <<< _menuOpen) not
+handleAction (PlayAction (Play.SetNewWalletNickname nickname)) = handleAction $ SetNewWalletNickname nickname
 
-handleAction (SetScreen screen) =
-  modify_
-    $ (_walletState <<< set _menuOpen) false
-    <<< (_walletState <<< set _card) Nothing
-    <<< (_walletState <<< set _screen) screen
-
-handleAction (SetCard card) = do
-  previousCard <- peruse (_walletState <<< _card)
-  assign (_walletState <<< _card) card
-  for_ previousCard $ const $ assign (_walletState <<< _menuOpen) false
-
-handleAction (ToggleCard card) = do
-  mCurrentCard <- peruse (_walletState <<< _card)
-  case mCurrentCard of
-    Just currentCard
-      | currentCard == Just card -> handleAction $ SetCard Nothing
-    _ -> handleAction $ SetCard $ Just card
+handleAction (PlayAction (Play.SetNewWalletKey key)) = assign (_newWalletNicknameKey <<< _key) key
 
-handleAction (SetNewWalletNickname nickname) = assign (_newWalletNicknameKey <<< _nickname) nickname
-
-handleAction (SetNewWalletKey key) = assign (_newWalletNicknameKey <<< _key) key
+handleAction (PlayAction Play.AddNewWallet) = handleAction AddNewWallet
 
-handleAction AddNewWallet = do
-  oldWallets <- use _wallets
-  newWalletNicknameKey <- use _newWalletNicknameKey
-  when (not $ member newWalletNicknameKey oldWallets) do
-    modify_
-      $ (over _wallets) (insert newWalletNicknameKey defaultWalletDetails)
-      <<< (set _newWalletNicknameKey) mempty
-      <<< (_walletState <<< set _card) Nothing
-    newWallets <- use _wallets
-    liftEffect $ setItem walletsLocalStorageKey $ encodeJSON newWallets
-
--- template actions
-handleAction (SetTemplate template) = do
-  mCurrentTemplate <- peruse (_walletState <<< _templateState <<< _template)
-  when (mCurrentTemplate /= Just template) $ assign (_walletState <<< _templateState) $ Template.mkInitialState template
-  handleAction $ SetScreen $ ContractSetupScreen ContractRolesScreen
-
-handleAction (TemplateAction templateAction) = Template.handleAction templateAction
-
--- contract actions
-handleAction StartContract = do
-  mTemplateState <- peruse (_walletState <<< _templateState)
-  for_ mTemplateState \templateState ->
-    let
-      extendedContract = view (_template <<< _extendedContract) templateState
-
-      templateContent = view _templateContent templateState
-
-      mContract = toCore $ fillTemplate templateContent extendedContract
-    in
-      for_ mContract \contract -> do
-        assign (_walletState <<< _contractState <<< _executionState <<< _contract) contract
-        handleAction $ SetScreen $ ContractsScreen Running
-        handleAction $ ToggleCard ContractCard
-
-handleAction (ContractAction contractAction) = handleSubAction (_walletState <<< _contractState) ContractAction Contract.defaultState (Contract.handleAction contractAction)
-
--- there must be a nicer way to get the current state than by manually
--- piecing together each of its properties, but I haven't found it :(
-handleSubAction ::
-  forall m state' action'.
-  MonadAff m =>
-  Traversal' State state' ->
-  (action' -> Action) ->
-  state' ->
-  HalogenM state' action' ChildSlots Msg m Unit ->
-  HalogenM State Action ChildSlots Msg m Unit
-handleSubAction traversal wrapper submoduleInitialState submoduleHandleAction = do
-  wallets <- use _wallets
-  newWalletNicknameKey <- use _newWalletNicknameKey
-  templates <- use _templates
-  subState <- use _subState
-  webSocketStatus <- use _webSocketStatus
-  let
-    state = { wallets, newWalletNicknameKey, templates, subState, webSocketStatus }
-  mapMaybeSubmodule state traversal wrapper submoduleInitialState submoduleHandleAction
+-- other play actions
+handleAction (PlayAction playAction) = Play.handleAction playAction