Skip to content

Commit 3fbb57d

Browse files
epostepost
authored
Segregate Paths and Routes to API objects. #358 (#372)
* studio: Segregate Routes to stbx core/API things into separate ADT. #358 * studio: Use NetsAndDiagramsIndex nwetype in Routes. #358 * studio: put Studio tx cache model stuff in a separate model. #358
1 parent 90b7c3d commit 3fbb57d

File tree

6 files changed

+129
-77
lines changed

6 files changed

+129
-77
lines changed

‎stbx-core/src/Statebox/Core/Wiring.purs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -43,6 +43,10 @@ derive instance newtypeNetsAndDiagramsIndex :: Newtype NetsAndDiagramsIndex _
4343
instance showNetsAndDiagramsIndex :: Show NetsAndDiagramsIndex where
4444
show (NetsAndDiagramsIndex x) = show x
4545

46+
derive instance eqNetsAndDiagramsIndex :: Eq NetsAndDiagramsIndex
47+
48+
derive instance ordNetsAndDiagramsIndex :: Ord NetsAndDiagramsIndex
49+
4650
--------------------------------------------------------------------------------
4751

4852
-- TODO Occurrences of this outside of internal implementation should be the newtype GluedTransitionId instead.

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

Lines changed: 18 additions & 52 deletions
Original file line numberDiff line numberDiff line change
@@ -15,19 +15,17 @@ import Data.Tuple.Nested (type (/\), (/\))
1515
import Debug.Trace (spy)
1616
import Record as Record
1717

18-
import Data.Diagram.FromNLL as FromNLL
19-
import Data.Diagram.FromNLL (ErrDiagramEncoding)
20-
import Data.Petrinet.Representation.NLL as Net
2118
import Data.Petrinet.Representation.PNPRO as PNPRO
2219
import Data.Petrinet.Representation.PNPROtoDict as PNPRO
23-
import Statebox.Core.Types (Diagram, PathElem)
20+
import Statebox.Core.Types (Diagram)
2421
import Statebox.Core.Transaction (HashStr, TxSum, FiringTx, WiringTx)
2522
import Statebox.Core.Lenses (_wiringTx, _firingTx)
2623
import View.Diagram.Model (DiagramInfo)
2724
import View.Model (Project, ProjectName, NetInfoWithTypesAndRoles)
2825
import View.Petrinet.Model (NetInfo)
29-
import View.Petrinet.Model.NLL as NLL
30-
import View.Studio.Model.Route (Route, RouteF(..), ResolvedRouteF(..), NetName, DiagramName, NodeIdent(..), ExecutionTrace)
26+
import View.Studio.Model.Route (ApiRoute(..), Route, RouteF(..), ResolvedRouteF(..), NetName, DiagramName, NodeIdent(..))
27+
import View.Studio.Model.TxCache as TxCache
28+
import View.Studio.Model.TxCache (ExecutionTrace)
3129

3230
-- deps needed for Action, for now
3331
import View.Petrinet.Model as PetrinetEditor
@@ -59,29 +57,33 @@ type State =
5957
--------------------------------------------------------------------------------
6058

6159
resolveRoute :: RouteF ProjectName DiagramName NetName -> State -> Maybe (ResolvedRouteF Project DiagramInfo NetInfoWithTypesAndRoles)
62-
resolveRoute route {projects, hashSpace} = case route of
60+
resolveRoute route state = case route of
6361
Home -> pure ResolvedHome
64-
Types projectName -> ResolvedTypes <$> findProject projects projectName
65-
Auths projectName -> ResolvedAuths <$> findProject projects projectName
66-
Net projectName name -> do project <- findProject projects projectName
62+
Types projectName -> ResolvedTypes <$> findProject state.projects projectName
63+
Auths projectName -> ResolvedAuths <$> findProject state.projects projectName
64+
Net projectName name -> do project <- findProject state.projects projectName
6765
net <- findNetInfoWithTypesAndRoles project name
6866
pure $ ResolvedNet net
69-
Diagram projectName name nodeId -> do project <- findProject projects projectName
67+
Diagram projectName name nodeId -> do project <- findProject state.projects projectName
7068
diagram <- findDiagramInfo project name
7169
let node = nodeId >>= case _ of
7270
DiagramNode dn -> DiagramNode <$> findDiagramInfo project dn
7371
NetNode nn -> NetNode <$> findNetInfoWithTypesAndRoles project nn
7472
pure $ ResolvedDiagram diagram node
73+
ApiThing x -> resolveApiRoute x state.hashSpace
74+
75+
resolveApiRoute :: ApiRoute -> AdjacencySpace HashStr TxSum -> Maybe (ResolvedRouteF Project DiagramInfo NetInfoWithTypesAndRoles)
76+
resolveApiRoute route hashSpace = case route of
7577
UberRootR url -> pure $ ResolvedUberRoot url
7678
NamespaceR hash -> pure $ ResolvedNamespace hash
77-
WiringR x -> ResolvedWiring x <$> findWiringTx hashSpace x.hash
79+
WiringR x -> ResolvedWiring x <$> TxCache.findWiringTx hashSpace x.hash
7880
FiringR x -> ResolvedFiring x <$> firingTxM <*> pure execTrace
7981
where
80-
firingTxM = findFiringTx hashSpace x.hash
81-
execTrace = findExecutionTrace hashSpace x.hash execHash
82+
firingTxM = TxCache.findFiringTx hashSpace x.hash
83+
execTrace = TxCache.findExecutionTrace hashSpace x.hash execHash
8284
execHash = firingTxM >>= _.firing.execution # fromMaybe x.hash
83-
DiagramR wiringHash ix name -> (\d -> ResolvedDiagram d Nothing) <$> findDiagramInfoInWirings hashSpace wiringHash ix
84-
NetR wiringHash ix name -> (\n -> ResolvedNet n) <$> findNetInfoInWirings hashSpace wiringHash ix
85+
DiagramR wiringHash ix name -> (\d -> ResolvedDiagram d Nothing) <$> TxCache.findDiagramInfo hashSpace wiringHash ix
86+
NetR wiringHash ix name -> (\n -> ResolvedNet n) <$> TxCache.findNetInfo hashSpace wiringHash ix
8587

8688
findProject :: Array Project -> ProjectName -> Maybe Project
8789
findProject projects projectName = find (\p -> p.name == projectName) projects
@@ -106,42 +108,6 @@ modifyDiagramInfo diagramName fn diagrams = do
106108
ix <- findIndex (\d -> d.name == diagramName) diagrams
107109
modifyAt ix fn diagrams
108110

109-
findWiringTx :: AdjacencySpace HashStr TxSum -> HashStr -> Maybe WiringTx
110-
findWiringTx hashSpace wiringHash = preview _wiringTx =<< AdjacencySpace.lookup wiringHash hashSpace
111-
112-
findFiringTx :: AdjacencySpace HashStr TxSum -> HashStr -> Maybe FiringTx
113-
findFiringTx hashSpace firingHash = preview _firingTx =<< AdjacencySpace.lookup firingHash hashSpace
114-
115-
findNetInfoInWirings :: AdjacencySpace HashStr TxSum -> HashStr -> PathElem -> Maybe NetInfoWithTypesAndRoles
116-
findNetInfoInWirings hashSpace wiringHash ix = do
117-
wiring <- findWiringTx hashSpace wiringHash
118-
netW <- spy "findNetInfoInWirings: netW" $ wiring.wiring.nets `index` ix
119-
netTopo <- spy "findNetInfoInWirings: netTopo" $ Net.fromNLLMaybe 0 netW.partition
120-
let
121-
placeNames = NLL.defaultPlaceNames netTopo
122-
netInfo = spy "findNetInfoInWirings: netInfo" $ NLL.toNetInfoWithDefaults netTopo netW.name placeNames netW.names
123-
pure $ Record.merge { types: [], roleInfos: [] } netInfo
124-
125-
findDiagramInfoInWirings :: AdjacencySpace HashStr TxSum -> HashStr -> PathElem -> Maybe DiagramInfo
126-
findDiagramInfoInWirings hashSpace wiringHash ix =
127-
hush =<< diagramEitherMaybe
128-
where
129-
diagramEitherMaybe :: Maybe (ErrDiagramEncoding \/ DiagramInfo)
130-
diagramEitherMaybe = (\d -> FromNLL.fromNLL d.name (toNLL d)) <$> diagramMaybe
131-
132-
diagramMaybe :: Maybe Diagram
133-
diagramMaybe = (flip index ix <<< _.wiring.diagrams) =<< findWiringTx hashSpace wiringHash
134-
135-
toNLL d = [d.width] <> d.pixels
136-
137-
findExecutionTrace :: AdjacencySpace HashStr TxSum -> HashStr -> HashStr -> String \/ ExecutionTrace
138-
findExecutionTrace s firingHash executionHash =
139-
hashChainE # bimap (const "Failed to resolve execution trace, probably because a parent hash was missing from the space.")
140-
(map (\hash -> hash /\ AdjacencySpace.lookup hash s))
141-
where
142-
hashChainE :: Array HashStr \/ Array HashStr
143-
hashChainE = AdjacencySpace.unsafeAncestorsBetween s firingHash executionHash
144-
145111
--------------------------------------------------------------------------------
146112

147113
fromPNPROProject :: PNPRO.Project -> Project

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

Lines changed: 18 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -6,9 +6,11 @@ import Data.Either.Nested (type (\/))
66
import Data.Maybe (Maybe)
77
import Data.Tuple.Nested (type (/\))
88
import View.Model (ProjectName)
9-
import Statebox.Core.Types (PathElem)
9+
import Statebox.Core.Types (NetsAndDiagramsIndex)
1010
import Statebox.Core.Transaction (HashStr, Tx, TxSum(..), WiringTx, FiringTx, evalTxSum)
1111

12+
import View.Studio.Model.TxCache (ExecutionTrace)
13+
1214
type Route = RouteF ProjectName DiagramName NetName
1315

1416
-- | This can:
@@ -26,20 +28,29 @@ data RouteF p d n
2628
| Diagram p d (Maybe (NodeIdent d n)) -- ^ A diagram with maybe one of its 'child' nodes.
2729

2830
-- Statebox API-related constructors
29-
| UberRootR URL
31+
| ApiThing ApiRoute
32+
33+
derive instance eqRouteF :: (Eq p, Eq d, Eq n) => Eq (RouteF p d n)
34+
derive instance ordRouteF :: (Ord p, Ord d, Ord n) => Ord (RouteF p d n)
35+
36+
-- | Statebox Core/API-related routes
37+
data ApiRoute
38+
= UberRootR URL
3039
| NamespaceR HashStr
3140
| WiringR WiringFiringInfo
3241
| FiringR WiringFiringInfo
33-
| DiagramR HashStr PathElem String
34-
| NetR HashStr PathElem String
42+
| DiagramR HashStr NetsAndDiagramsIndex String
43+
| NetR HashStr NetsAndDiagramsIndex String
3544

36-
derive instance eqRouteF :: (Eq p, Eq d, Eq n) => Eq (RouteF p d n)
37-
derive instance ordRouteF :: (Ord p, Ord d, Ord n) => Ord (RouteF p d n)
45+
derive instance eqApiRoute :: Eq ApiRoute
46+
derive instance ordApiRoute :: Ord ApiRoute
3847

3948
type DiagramName = String
4049

4150
type NetName = String
4251

52+
--------------------------------------------------------------------------------
53+
4354
data ResolvedRouteF p d n
4455
= ResolvedHome
4556
| ResolvedTypes p
@@ -58,7 +69,7 @@ data ResolvedRouteF p d n
5869
--------------------------------------------------------------------------------
5970

6071
fromTxSum :: ∀ p d n. URL -> HashStr -> TxSum -> RouteF p d n
61-
fromTxSum endpointUrl hash tx = tx # evalTxSum
72+
fromTxSum endpointUrl hash tx = tx # ApiThing <<< evalTxSum
6273
(\x -> UberRootR endpointUrl)
6374
(\x -> NamespaceR x.root.message)
6475
(\w -> WiringR { name: hash, endpointUrl, hash })
@@ -83,6 +94,3 @@ type NamespaceInfo =
8394
{ name :: String
8495
, hash :: HashStr
8596
}
86-
87-
-- TODO we may want to change the name and the exact type a bit; this is a 1st version to get things going
88-
type ExecutionTrace = Array (HashStr /\ Maybe TxSum)

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

Lines changed: 68 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,68 @@
1+
module View.Studio.Model.TxCache where
2+
3+
import Prelude
4+
import Data.Array (index, findIndex, modifyAt)
5+
import Data.AdjacencySpace as AdjacencySpace
6+
import Data.AdjacencySpace (AdjacencySpace)
7+
import Data.Bifunctor (bimap)
8+
import Data.Either (hush)
9+
import Data.Either.Nested (type (\/))
10+
import Data.Foldable (find)
11+
import Data.Lens (preview)
12+
import Data.Maybe (Maybe(..), fromMaybe)
13+
import Data.Newtype (un)
14+
import Data.Tuple.Nested (type (/\), (/\))
15+
import Debug.Trace (spy)
16+
import Record as Record
17+
18+
import Data.Diagram.FromNLL as FromNLL
19+
import Data.Diagram.FromNLL (ErrDiagramEncoding)
20+
import Data.Petrinet.Representation.NLL as Net
21+
import Statebox.Core.Types (Diagram, NetsAndDiagramsIndex(..))
22+
import Statebox.Core.Transaction (HashStr, TxSum, FiringTx, WiringTx)
23+
import Statebox.Core.Lenses (_wiringTx, _firingTx)
24+
import View.Diagram.Model (DiagramInfo)
25+
import View.Model (NetInfoWithTypesAndRoles)
26+
import View.Petrinet.Model (NetInfo)
27+
import View.Petrinet.Model.NLL as NLL
28+
29+
findWiringTx :: AdjacencySpace HashStr TxSum -> HashStr -> Maybe WiringTx
30+
findWiringTx hashSpace wiringHash = preview _wiringTx =<< AdjacencySpace.lookup wiringHash hashSpace
31+
32+
findFiringTx :: AdjacencySpace HashStr TxSum -> HashStr -> Maybe FiringTx
33+
findFiringTx hashSpace firingHash = preview _firingTx =<< AdjacencySpace.lookup firingHash hashSpace
34+
35+
findNetInfo :: AdjacencySpace HashStr TxSum -> HashStr -> NetsAndDiagramsIndex -> Maybe NetInfoWithTypesAndRoles
36+
findNetInfo hashSpace wiringHash ix = do
37+
wiring <- findWiringTx hashSpace wiringHash
38+
netW <- spy "TxCache.findNetInfo: netW" $ wiring.wiring.nets `index` (un NetsAndDiagramsIndex ix)
39+
netTopo <- spy "TxCache.findNetInfo: netTopo" $ Net.fromNLLMaybe 0 netW.partition
40+
let
41+
placeNames = NLL.defaultPlaceNames netTopo
42+
netInfo = spy "TxCache.findNetInfo: netInfo" $ NLL.toNetInfoWithDefaults netTopo netW.name placeNames netW.names
43+
pure $ Record.merge { types: [], roleInfos: [] } netInfo
44+
45+
findDiagramInfo :: AdjacencySpace HashStr TxSum -> HashStr -> NetsAndDiagramsIndex -> Maybe DiagramInfo
46+
findDiagramInfo hashSpace wiringHash ix =
47+
hush =<< diagramEitherMaybe
48+
where
49+
diagramEitherMaybe :: Maybe (ErrDiagramEncoding \/ DiagramInfo)
50+
diagramEitherMaybe = (\d -> FromNLL.fromNLL d.name (toNLL d)) <$> diagramMaybe
51+
52+
diagramMaybe :: Maybe Diagram
53+
diagramMaybe = (flip index (un NetsAndDiagramsIndex ix) <<< _.wiring.diagrams) =<< findWiringTx hashSpace wiringHash
54+
55+
toNLL d = [d.width] <> d.pixels
56+
57+
--------------------------------------------------------------------------------
58+
59+
-- TODO we may want to change the name and the exact type a bit; this is a 1st version to get things going
60+
type ExecutionTrace = Array (HashStr /\ Maybe TxSum)
61+
62+
findExecutionTrace :: AdjacencySpace HashStr TxSum -> HashStr -> HashStr -> String \/ ExecutionTrace
63+
findExecutionTrace s firingHash executionHash =
64+
hashChainE # bimap (const "Failed to resolve execution trace, probably because a parent hash was missing from the space.")
65+
(map (\hash -> hash /\ AdjacencySpace.lookup hash s))
66+
where
67+
hashChainE :: Array HashStr \/ Array HashStr
68+
hashChainE = AdjacencySpace.unsafeAncestorsBetween s firingHash executionHash

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

Lines changed: 19 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@ import Language.Statebox.Wiring.Generator.DiagramV2.Operators (fromOperators, to
2525
import TreeMenu as TreeMenu
2626
import TreeMenu (mkItem, MenuTree, Item)
2727
import Statebox.Core.Transaction (HashStr, TxSum, evalTxSum, isExecutionTx)
28+
import Statebox.Core.Types (NetsAndDiagramsIndex(..))
2829
import View.Auth.RolesEditor as RolesEditor
2930
import View.Diagram.DiagramEditor as DiagramEditor
3031
import View.Diagram.Model (DiagramInfo)
@@ -35,7 +36,7 @@ import View.Model (Project, NetInfoWithTypesAndRoles)
3536
import View.Petrinet.PetrinetEditor as PetrinetEditor
3637
import View.Petrinet.Model as PetrinetEditor
3738
import View.Studio.Model (Action(..), State, resolveRoute)
38-
import View.Studio.Model.Route (Route, RouteF(..), ResolvedRouteF(..), NodeIdent(..))
39+
import View.Studio.Model.Route (ApiRoute(..), Route, RouteF(..), ResolvedRouteF(..), NodeIdent(..))
3940
import View.Transaction (firingTxView, wiringTxView)
4041
import View.Typedefs.TypedefsEditor as TypedefsEditor
4142

@@ -133,16 +134,20 @@ routeBreadcrumbs route =
133134
Auths projectName -> [ projectName, "Authorisation" ]
134135
Net projectName name -> [ projectName, name ]
135136
Diagram projectName name _ -> [ projectName, name ]
136-
UberRootR url -> [ "über-namespace", url ]
137-
NamespaceR hash -> [ "namespace", shortHash hash ]
138-
WiringR x -> [ x.endpointUrl, "wiring " <> shortHash x.hash ]
139-
FiringR x -> [ x.endpointUrl, shortHash x.hash ]
140-
DiagramR hash ix name -> [ shortHash hash, "diagram " <> show ix <> " " <> name ]
141-
NetR hash ix name -> [ shortHash hash, "net " <> show ix <> " " <> name ]
137+
ApiThing apiRoute -> apiRouteBreadcrumbs apiRoute
142138
]
143139
where
144140
crumb str = li [] [ a [ href "#" ] [ text str ] ]
145141

142+
apiRouteBreadcrumbs :: ∀ m. ApiRoute -> Array _
143+
apiRouteBreadcrumbs = case _ of
144+
UberRootR url -> [ "über-namespace", url ]
145+
NamespaceR hash -> [ "namespace", shortHash hash ]
146+
WiringR x -> [ x.endpointUrl, "wiring " <> shortHash x.hash ]
147+
FiringR x -> [ x.endpointUrl, shortHash x.hash ]
148+
DiagramR hash ix name -> [ shortHash hash, "diagram " <> show ix <> " " <> name ]
149+
NetR hash ix name -> [ shortHash hash, "net " <> show ix <> " " <> name ]
150+
146151
navBar :: ∀ m. String -> ComponentHTML Action ChildSlots m
147152
navBar title =
148153
nav [ classes [ ClassName "stbx-menu" ], tabIndex 0 ]
@@ -196,25 +201,25 @@ transactionMenu apiUrl t hash valueMaybe itemKids =
196201
mkItem2 :: HashStr -> TxSum -> Array (MenuTree Route) -> MenuTree Route
197202
mkItem2 hash tx itemKids = evalTxSum
198203
(\x -> mkItem ("☁️ " <> shortHash hash)
199-
(Just $ UberRootR apiUrl)
204+
(Just $ ApiThing $ UberRootR apiUrl)
200205
:< itemKids
201206
)
202207
(\x -> mkItem ("🌐 " <> shortHash hash)
203-
(Just $ NamespaceR x.root.message)
208+
(Just $ ApiThing $ NamespaceR x.root.message)
204209
:< itemKids
205210
)
206211
(\w -> mkItem ("🥨 " <> shortHash hash)
207-
(Just $ WiringR { name: hash, endpointUrl: apiUrl, hash: hash })
212+
(Just $ ApiThing $ WiringR { name: hash, endpointUrl: apiUrl, hash: hash })
208213
:< (fromNets w.wiring.nets <> fromDiagrams w.wiring.diagrams <> itemKids)
209214
)
210215
(\f -> mkItem ((if isExecutionTx f then "🔫 " else "🔥 ") <> shortHash hash)
211-
(Just $ FiringR { name: hash, endpointUrl: apiUrl, hash: hash })
216+
(Just $ ApiThing $ FiringR { name: hash, endpointUrl: apiUrl, hash: hash })
212217
:< (flattenTree =<< itemKids) -- for nested firings, just drop the 'flattenTree' part
213218
)
214219
tx
215220
where
216-
fromNets nets = mapWithIndex (\ix n -> mkItem ("🔗 " <> n.name) (Just $ NetR hash ix n.name) :< []) nets
217-
fromDiagrams diags = mapWithIndex (\ix d -> mkItem ("⛓ " <> d.name) (Just $ DiagramR hash ix d.name) :< []) diags
221+
fromNets nets = mapWithIndex (\ix n -> mkItem ("🔗 " <> n.name) (Just $ ApiThing $ NetR hash (NetsAndDiagramsIndex ix) n.name) :< []) nets
222+
fromDiagrams diags = mapWithIndex (\ix d -> mkItem ("⛓ " <> d.name) (Just $ ApiThing $ DiagramR hash (NetsAndDiagramsIndex ix) d.name) :< []) diags
218223

219224
flattenTree :: MenuTree Route -> Array (MenuTree Route)
220225
flattenTree = treeifyElems <<< flattenTree'
@@ -228,7 +233,7 @@ transactionMenu apiUrl t hash valueMaybe itemKids =
228233
mkUnloadedItem :: Array (MenuTree Route) -> MenuTree Route
229234
mkUnloadedItem itemKids = mkItem ("👻 " <> shortHash hash) unloadedRoute :< itemKids
230235
where
231-
-- TODO we need to return a Route currently, but we may want to return a (LoadTransaction ... ::Query) instead,
236+
-- TODO we need to return an ApiRoute currently, but we may want to return a (LoadTransaction ... :: Query) instead,
232237
-- so we could load unloaded hashes from the menu.
233238
unloadedRoute = Nothing
234239

‎studio/src/View/Transaction.purs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,8 @@ import Halogen.HTML.Core (ClassName(..))
1717
import Halogen.HTML.Properties (classes, href)
1818

1919
import View.Studio.Model (Action(..))
20-
import View.Studio.Model.Route (WiringFiringInfo, ExecutionTrace)
20+
import View.Studio.Model.Route (WiringFiringInfo)
21+
import View.Studio.Model.TxCache (ExecutionTrace)
2122
import Statebox.Client (txUrl)
2223
import Statebox.Core.Lenses (_firingTx, _firing, _firingPath, _GluedTransitionId)
2324
import Statebox.Core.Transaction (HashStr, TxSum, FiringTx, TxId, WiringTx, evalTxSum, isExecution)

0 commit comments

Comments
 (0)