Skip to content

Commit 1283c80

Browse files
sjoerdvisschersjoerdvisscher
committed
studio: Working breadcrumb links. #381 
1 parent a442d24 commit 1283c80

File tree

6 files changed

+128
-127
lines changed

6 files changed

+128
-127
lines changed

‎halogen-tree-menu/src/TreeMenu.purs

Lines changed: 4 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -4,12 +4,10 @@ import Prelude hiding (div)
44
import Effect.Aff.Class (class MonadAff)
55
import Control.Comonad.Cofree
66
import Data.Foldable (null)
7-
import Data.FunctorWithIndex (class FunctorWithIndex, mapWithIndex)
8-
import Data.Maybe (Maybe(..), maybe, fromMaybe)
9-
import Data.Tuple.Nested (type (/\), (/\))
7+
import Data.Maybe (Maybe(..), maybe)
108
import Halogen as H
11-
import Halogen (Component, ComponentHTML, HalogenM, mkEval, defaultEval)
12-
import Halogen.HTML (HTML, a, b, details, div, li, nav, span, summary, text, ul)
9+
import Halogen (Component, ComponentHTML, HalogenM)
10+
import Halogen.HTML (HTML, a, b, details, li, nav, span, summary, text, ul)
1311
import Halogen.HTML.Core (ClassName(..), AttrName(..))
1412
import Halogen.HTML.Events (onClick)
1513
import Halogen.HTML.Properties (IProp, attr, classes, href)
@@ -20,6 +18,7 @@ import Web.UIEvent.MouseEvent (toEvent)
2018

2119
--------------------------------------------------------------------------------
2220

21+
componentCssClassNameStr :: String
2322
componentCssClassNameStr = "css-object-chooser"
2423

2524
--------------------------------------------------------------------------------

‎studio/src/View/Studio.purs

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -186,7 +186,9 @@ handleAction = case _ of
186186
type Affine s t a b = forall p. Strong p => Choice p => Optic p s t a b
187187
type Affine' s a = Affine s s a a
188188

189-
handleCRUDAction :: ∀ m s t a. MonadEffect m => MonadState s m => At t String a => Affine' s t -> CRUDAction a -> (String -> Maybe a -> m Unit) -> m Unit
189+
handleCRUDAction
190+
:: ∀ m s t a. MonadEffect m => MonadState s m => At t String a
191+
=> Affine' s t -> CRUDAction a -> (String -> Maybe a -> m Unit) -> m Unit
190192
handleCRUDAction l action eventHandler =
191193
case action of
192194
CreateAction a -> do

‎studio/src/View/Studio/Model.purs

Lines changed: 26 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,7 @@ module View.Studio.Model where
22

33
import Prelude
44
import Affjax (URL) -- TODO introduce URL alias in Client so we can abstract Affjax away
5-
import Data.Array (findIndex, modifyAt)
5+
import Data.Array (findIndex, modifyAt, fromFoldable, cons)
66
import Data.AdjacencySpace (AdjacencySpace)
77
import Data.Foldable (find)
88
import Data.Lens (Lens')
@@ -71,40 +71,41 @@ _projects = prop (SProxy :: SProxy "projects")
7171

7272
--------------------------------------------------------------------------------
7373

74-
type ResolvedRoute = ResolvedRouteF Project DiagramInfo NetInfoWithTypesAndRoles
74+
type ResolvedRoute = Array (ResolvedRouteF Project DiagramInfo NetInfoWithTypesAndRoles)
7575

76-
resolveRoute :: Route -> State -> Maybe ResolvedRoute
76+
resolveRoute :: Route -> State -> ResolvedRoute
7777
resolveRoute route state = case route of
78-
Home -> pure $ ResolvedHome state.projects
79-
TxHome _ -> pure $ ResolvedTxHome state.projects
80-
ProjectRoute projectId pr -> findProject state.projects projectId >>= resolveProjectRoute pr state
81-
ApiRoute x endpointUrl -> resolveApiRoute endpointUrl x state.hashSpace
82-
83-
resolveProjectRoute :: ProjectRoute -> State -> Project -> Maybe ResolvedRoute
84-
resolveProjectRoute route state project = case route of
85-
ProjectHome -> pure $ ResolvedProject project
86-
Types -> pure $ ResolvedTypes project
87-
Auths -> pure $ ResolvedAuths project
88-
Net name -> ResolvedNet <$> findNetInfoWithTypesAndRoles project name
89-
Diagram name nodeId -> do diagram <- findDiagramInfo project name
78+
Home -> [ ResolvedHome state.projects ]
79+
TxHome _ -> [ ResolvedTxHome state.projects ]
80+
ProjectRoute projectId pr -> ResolvedHome state.projects `cons` (fromFoldable (findProject state.projects projectId) >>= resolveProjectRoute pr state)
81+
ApiRoute x endpointUrl -> ResolvedTxHome state.projects `cons` resolveApiRoute endpointUrl x state.hashSpace
82+
83+
resolveProjectRoute :: ProjectRoute -> State -> Project -> ResolvedRoute
84+
resolveProjectRoute route state project = ResolvedProject project `cons` case route of
85+
ProjectHome -> []
86+
Types -> [ ResolvedTypes project ]
87+
Auths -> [ ResolvedAuths project ]
88+
Net name -> fromFoldable $ ResolvedNet <$> findNetInfoWithTypesAndRoles project name
89+
Diagram name nodeId -> fromFoldable do
90+
diagram <- findDiagramInfo project name
9091
let node = nodeId >>= case _ of
9192
DiagramNode dn -> DiagramNode <$> findDiagramInfo project dn
9293
NetNode nn -> NetNode <$> findNetInfoWithTypesAndRoles project nn
9394
pure $ ResolvedDiagram diagram node
94-
KDMonCatR str -> ResolvedKDMonCat <$> findKDMonCat project str
95-
96-
resolveApiRoute :: URL -> ApiRoute -> AdjacencySpace HashStr TxSum -> Maybe ResolvedRoute
97-
resolveApiRoute endpointUrl route hashSpace = case route of
98-
UberRootR -> pure $ ResolvedUberRoot endpointUrl
99-
NamespaceR hash -> pure $ ResolvedNamespace hash
100-
WiringR hash -> ResolvedWiring { hash, endpointUrl } <$> TxCache.findWiringTx hashSpace hash
101-
FiringR hash -> ResolvedFiring { hash, endpointUrl } <$> firingTxM <*> pure execTrace
95+
KDMonCatR str -> fromFoldable $ ResolvedKDMonCat <$> findKDMonCat project str
96+
97+
resolveApiRoute :: URL -> ApiRoute -> AdjacencySpace HashStr TxSum -> ResolvedRoute
98+
resolveApiRoute endpointUrl route hashSpace = ResolvedUberRoot endpointUrl `cons` case route of
99+
UberRootR -> []
100+
NamespaceR hash -> [ ResolvedNamespace hash ]
101+
WiringR hash -> fromFoldable $ ResolvedWiring { hash, endpointUrl } <$> TxCache.findWiringTx hashSpace hash
102+
FiringR hash -> fromFoldable $ ResolvedFiring { hash, endpointUrl } <$> firingTxM <*> pure execTrace
102103
where
103104
firingTxM = TxCache.findFiringTx hashSpace hash
104105
execTrace = TxCache.findExecutionTrace hashSpace hash execHash
105106
execHash = firingTxM >>= _.firing.execution # fromMaybe hash
106-
DiagramR wiringHash ix name -> (\d -> ResolvedDiagram d Nothing) <$> TxCache.findDiagramInfo hashSpace wiringHash ix
107-
NetR wiringHash ix name -> (\n -> ResolvedNet n) <$> TxCache.findNetInfo hashSpace wiringHash ix
107+
DiagramR wiringHash ix name -> fromFoldable $ (\d -> ResolvedDiagram d Nothing) <$> TxCache.findDiagramInfo hashSpace wiringHash ix
108+
NetR wiringHash ix name -> fromFoldable $ (\n -> ResolvedNet n) <$> TxCache.findNetInfo hashSpace wiringHash ix
108109

109110
--------------------------------------------------------------------------------
110111

‎studio/src/View/Studio/Model/Route.purs

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -7,15 +7,14 @@ import Data.Map (Map)
77
import Data.Maybe (Maybe)
88
import Data.Newtype
99
import Data.Lens.Iso.Newtype
10-
import Data.Tuple.Nested (type (/\))
1110
import Data.Generic.Rep
12-
import Routing.Duplex (RouteDuplex', path, root, segment, string, int, optional, param, params)
11+
import Routing.Duplex (RouteDuplex', path, root, segment, int, optional, param)
1312
import Routing.Duplex.Generic (sum, noArgs)
1413
import Routing.Duplex.Generic.Syntax
1514

1615
import View.KDMonCat.App (Input) as KDMonCat.App
1716
import Statebox.Core.Types (NetsAndDiagramsIndex)
18-
import Statebox.Core.Transaction (HashStr, Tx, TxSum(..), WiringTx, FiringTx, evalTxSum)
17+
import Statebox.Core.Transaction (HashStr, TxSum, WiringTx, FiringTx, evalTxSum)
1918
import View.Model (ProjectId)
2019
import View.Studio.Model.TxCache (ExecutionTrace)
2120

‎studio/src/View/Studio/View.purs

Lines changed: 91 additions & 92 deletions
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,7 @@ import Affjax (URL) -- TODO introduce URL alias in Client so we can abstract Aff
55
import Control.Comonad.Cofree ((:<))
66
import Data.AdjacencySpace as AdjacencySpace
77
import Data.AdjacencySpace (AdjacencySpace)
8-
import Data.Array (cons)
8+
import Data.Array (cons, last)
99
import Data.Foldable (foldMap, foldr, length)
1010
import Data.FoldableWithIndex (foldMapWithIndex)
1111
import Data.FunctorWithIndex (mapWithIndex)
@@ -80,112 +80,111 @@ render state =
8080
main =
8181
[ div []
8282
[ div [ classes $ ClassName <$> [ "container" ] <> guard showSidebar [ "is-fluid" ] ] $
83-
resolveRoute state.route state
84-
# maybe [ text "Couldn't find project/net/diagram." ] \resolved ->
85-
[ routeBreadcrumbs state.route resolved
86-
, contentView state.apiUrl resolved
87-
]
83+
resolveRoute state.route state # \resolved ->
84+
[ routeBreadcrumbs state.route resolved
85+
, contentView state.apiUrl resolved
86+
]
8887
]
8988
]
9089

9190
contentView :: ∀ m. MonadAff m => URL -> ResolvedRoute -> ComponentHTML Action ChildSlots m
92-
contentView apiUrl route = case route of
93-
ResolvedHome projects ->
94-
div []
95-
[ projectsDashboard projects
96-
]
91+
contentView apiUrl route = last route # maybe (text "Couldn't find project/net/diagram.") view
92+
where
93+
view = case _ of
94+
ResolvedHome projects ->
95+
div []
96+
[ projectsDashboard projects
97+
]
9798

98-
ResolvedTxHome projects ->
99-
div []
100-
[ homeForm apiUrl
101-
]
99+
ResolvedTxHome projects ->
100+
div []
101+
[ homeForm apiUrl
102+
]
102103

103-
ResolvedProject project ->
104-
div []
105-
[ p_ [ text $ "Project '" <> project.name <> "'" ]
106-
, p_ [ button [ onClick \_ -> Just $ CRUDKDMonCat $ CreateAction mempty ]
107-
[ text "Create new KDMonCat diagram" ]
108-
]
109-
]
104+
ResolvedProject project ->
105+
div []
106+
[ p_ [ text $ "Project '" <> project.name <> "'" ]
107+
, p_ [ button [ onClick \_ -> Just $ CRUDKDMonCat $ CreateAction mempty ]
108+
[ text "Create new KDMonCat diagram" ]
109+
]
110+
]
110111

111-
ResolvedTypes project ->
112-
TypedefsEditor.typedefsTreeView project.types
113-
114-
ResolvedAuths project ->
115-
RolesEditor.roleInfosHtml project.roleInfos
116-
117-
ResolvedNet netInfo ->
118-
slot _petrinetEditor unit (PetrinetEditor.ui (Just "main_net")) netInfo (Just <<< HandlePetrinetEditorMsg)
119-
120-
ResolvedDiagram diagramInfo nodeMaybe ->
121-
div [ classes [ ClassName "has-columns" ] ]
122-
[ div []
123-
[ slot _diagramEditor unit DiagramEditor.ui diagramInfo.ops (Just <<< HandleDiagramEditorMsg) ]
124-
, div []
125-
[ slot _kdmoncatBricks unit KDMonCat.Bricks.bricksView bricksInput (Just <<< HandleKDMonCatBricksMsg diagramInfo)
126-
, case nodeMaybe of
127-
Just (NetNode netInfo) -> slot _petrinetEditor unit (PetrinetEditor.ui (Just "diagram_node")) netInfo (Just <<< HandlePetrinetEditorMsg)
128-
Just (DiagramNode diagramInfo2) -> text "TODO viewing internal diagrams is not supported yet."
129-
Nothing -> text "Click a node to show the corresponding net or diagram."
130-
]
131-
]
132-
where
133-
bricksInput =
134-
(KDMonCat.App.toBricksInput (DiagramV2.fromOperators diagramInfo.ops) zero)
135-
{ renderBoxContent = \name bid ->
136-
(KDMonCat.Bricks.defaultRenderBoxContent name bid)
137-
{ className = if maybeSelectedBid == Just bid then "selected" else "" } }
138-
maybeSelectedBid = case nodeMaybe of
139-
Just (NetNode netInfo) -> DiagramV2.toPixel diagramInfo.ops (\{ identifier } -> netInfo.name == identifier)
140-
_ -> Nothing
112+
ResolvedTypes project ->
113+
TypedefsEditor.typedefsTreeView project.types
114+
115+
ResolvedAuths project ->
116+
RolesEditor.roleInfosHtml project.roleInfos
117+
118+
ResolvedNet netInfo ->
119+
slot _petrinetEditor unit (PetrinetEditor.ui (Just "main_net")) netInfo (Just <<< HandlePetrinetEditorMsg)
120+
121+
ResolvedDiagram diagramInfo nodeMaybe ->
122+
div [ classes [ ClassName "has-columns" ] ]
123+
[ div []
124+
[ slot _diagramEditor unit DiagramEditor.ui diagramInfo.ops (Just <<< HandleDiagramEditorMsg) ]
125+
, div []
126+
[ slot _kdmoncatBricks unit KDMonCat.Bricks.bricksView bricksInput (Just <<< HandleKDMonCatBricksMsg diagramInfo)
127+
, case nodeMaybe of
128+
Just (NetNode netInfo) -> slot _petrinetEditor unit (PetrinetEditor.ui (Just "diagram_node")) netInfo (Just <<< HandlePetrinetEditorMsg)
129+
Just (DiagramNode diagramInfo2) -> text "TODO viewing internal diagrams is not supported yet."
130+
Nothing -> text "Click a node to show the corresponding net or diagram."
131+
]
132+
]
133+
where
134+
bricksInput =
135+
(KDMonCat.App.toBricksInput (DiagramV2.fromOperators diagramInfo.ops) zero)
136+
{ renderBoxContent = \name bid ->
137+
(KDMonCat.Bricks.defaultRenderBoxContent name bid)
138+
{ className = if maybeSelectedBid == Just bid then "selected" else "" } }
139+
maybeSelectedBid = case nodeMaybe of
140+
Just (NetNode netInfo) -> DiagramV2.toPixel diagramInfo.ops (\{ identifier } -> netInfo.name == identifier)
141+
_ -> Nothing
141142

142-
ResolvedKDMonCat kdmoncatInput ->
143-
div [ classes [ ClassName "w-full", ClassName "pl-4" ] ]
144-
[ slot _kdmoncatApp unit KDMonCat.App.appView kdmoncatInput (Just <<< HandleKDMonCatAppMsg) ]
143+
ResolvedKDMonCat kdmoncatInput ->
144+
div [ classes [ ClassName "w-full", ClassName "pl-4" ] ]
145+
[ slot _kdmoncatApp unit KDMonCat.App.appView kdmoncatInput (Just <<< HandleKDMonCatAppMsg) ]
145146

146-
ResolvedUberRoot url ->
147-
text $ "Service über-root " <> url
147+
ResolvedUberRoot url ->
148+
text $ "Service über-root " <> url
148149

149-
ResolvedNamespace hash ->
150-
text $ "Namespace " <> hash
150+
ResolvedNamespace hash ->
151+
text $ "Namespace " <> hash
151152

152-
ResolvedWiring wfi wiringTx ->
153-
wiringTxView wfi wiringTx
153+
ResolvedWiring wfi wiringTx ->
154+
wiringTxView wfi wiringTx
154155

155-
ResolvedFiring wfi firingTx executionTraceE ->
156-
firingTxView wfi firingTx executionTraceE
156+
ResolvedFiring wfi firingTx executionTraceE ->
157+
firingTxView wfi firingTx executionTraceE
157158

158159
routeBreadcrumbs :: ∀ m. Route -> ResolvedRoute -> ComponentHTML Action ChildSlots m
159160
routeBreadcrumbs route resolvedRoute =
160161
nav [ classes [ ClassName "stbx-breadcrumbs" ] ]
161-
[ ol [] $
162-
crumb <$> case route /\ resolvedRoute of
163-
Home /\ _ -> [ "Home" ]
164-
TxHome _ /\ _ -> [ "Home" ]
165-
ProjectRoute _ pr /\ ResolvedProject project -> [ "Home", project.name ] <> projectRouteBreadcrumbs pr
166-
ApiRoute apiRoute endpointUrl /\ _ -> apiRouteBreadcrumbs endpointUrl apiRoute
167-
_ -> []
168-
]
162+
[ ol [] $ toBreadcrumb <$> resolvedRoute ]
169163
where
170-
crumb str = li [] [ a [ href "#" ] [ text str ] ]
171-
172-
projectRouteBreadcrumbs :: ProjectRoute -> Array _
173-
projectRouteBreadcrumbs = case _ of
174-
ProjectHome -> []
175-
Types -> [ "Types" ]
176-
Auths -> [ "Authorisation" ]
177-
Net name -> [ name ]
178-
Diagram name _ -> [ name ]
179-
KDMonCatR name -> [ name ]
180-
181-
apiRouteBreadcrumbs :: URL -> ApiRoute -> Array _
182-
apiRouteBreadcrumbs endpointUrl = case _ of
183-
UberRootR -> [ "über-namespace", endpointUrl ]
184-
NamespaceR hash -> [ "namespace", shortHash hash ]
185-
WiringR x -> [ endpointUrl, "wiring " <> shortHash x ]
186-
FiringR x -> [ endpointUrl, shortHash x ]
187-
DiagramR hash ix name -> [ shortHash hash, "diagram " <> show ix <> " " <> name ]
188-
NetR hash ix name -> [ shortHash hash, "net " <> show ix <> " " <> name ]
164+
crumb r str = li [] [ a [ onClick \_ -> Just (SelectRoute r) ] [ text str ] ]
165+
166+
sub = case route of
167+
Home -> Home
168+
TxHome h -> TxHome h
169+
ProjectRoute id _ -> ProjectRoute id ProjectHome
170+
ApiRoute _ url -> ApiRoute UberRootR url
171+
172+
toBreadcrumb = case _ of
173+
ResolvedHome _ -> crumb Home "Home"
174+
ResolvedTxHome _ -> crumb (TxHome Nothing) "Home"
175+
176+
ResolvedProject p -> crumb sub p.name
177+
ResolvedTypes p -> crumb route "Types"
178+
ResolvedAuths p -> crumb route "Authorisation"
179+
180+
ResolvedNet n -> crumb route n.name
181+
ResolvedDiagram d _ -> crumb route d.name
182+
ResolvedKDMonCat k -> crumb route "TODO"
183+
184+
ResolvedUberRoot u -> crumb sub u
185+
ResolvedNamespace h -> crumb route $ shortHash h
186+
ResolvedWiring w _ -> crumb route $ "wiring " <> shortHash w.hash
187+
ResolvedFiring f _ _ -> crumb route $ "firing " <> shortHash f.hash
189188

190189
navBar :: ∀ m. String -> Array (String /\ Maybe Route) -> ComponentHTML Action ChildSlots m
191190
navBar title menuItems =
@@ -283,7 +282,7 @@ projectsDashboard projects =
283282
[ ul [ classes [ ClassName "stbx-cards" ] ] $
284283
(projects # foldMapWithIndex mkProjectLink) <>
285284
[ li [ classes [ ClassName "stbx-add-card" ] ]
286-
[ button [ onClick \_ -> Just $ CRUDProject $ CreateAction $ emptyProject { name = "Untitled (TODO)" } ]
285+
[ button [ onClick $ Just <<< StopEvent (Just $ CRUDProject $ CreateAction $ emptyProject { name = "Untitled (TODO)" }) <<< toEvent ]
287286
[ text "Create new project" ]
288287
]
289288
]
@@ -300,7 +299,7 @@ projectsDashboard projects =
300299
]
301300
, div [ classes [ ClassName "hover-controls" ] ]
302301
[ button [ onClick $ Just <<< StopEvent (Just $ CRUDProject $ DeleteAction projectId) <<< toEvent ]
303-
[ text "Delete" ]
302+
[ text "Delete" ]
304303
]
305304
]
306305

‎tx-browser/src/Statebox/Browser/Main.purs

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,7 @@ import Routing.Hash as Routing
1616
import Routing.PushState (makeInterface, matchesWith)
1717

1818
import View.Studio as Studio
19-
import View.Studio (Query(LoadTransactionsThenView))
19+
import View.Studio (Query(..))
2020
import View.Studio.Model.Route
2121

2222
import ExampleData as Ex
@@ -34,6 +34,7 @@ main = runHalogenAff do
3434
{ path } <- liftEffect $ nav.locationState
3535
case parse codex path of
3636
Right Home -> do
37+
_ <- io.query $ H.tell (Navigate (TxHome Nothing))
3738
urlHash <- liftEffect $ Routing.getHash
3839
loadTransactionsThenView io Ex.endpointUrl urlHash
3940
Right (TxHome (Just hash)) -> loadTransactionsThenView io Ex.endpointUrl hash

0 commit comments

Comments
 (0)