-
Notifications
You must be signed in to change notification settings - Fork 0
/
Routed.purs
92 lines (75 loc) · 2.33 KB
/
Routed.purs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
module Chameleon.Impl.Halogen.Mount.Routed
( RouteIO
, RouteSpec
, mkRoutableComponent
)
where
import Prelude
import Data.Maybe (Maybe(..))
import Data.These (These(..))
import Effect (Effect)
import Effect.Aff (Aff)
import Halogen (ComponentSlot, HalogenM, get, liftEffect, subscribe)
import Halogen as H
import Halogen as Halogen
import Halogen.HTML (HTML)
import Halogen.Subscription (makeEmitter)
import Chameleon.Impl.Halogen (HalogenHtml)
import Chameleon.Impl.Halogen as VDOM.Halogen
type UI html msg sta =
{ view :: sta -> html msg
, update :: msg -> sta -> sta
, init :: sta
}
data Msg route msg = Init | ChildMsg msg | MsgNewRoute route
type RouteSpec route msg sta =
{ updateStateFromRoute :: route -> sta -> sta
, mkRoute :: msg -> sta -> These route msg
}
type RouteIO route =
{ pushRoute :: route -> Effect Unit
, listen :: (route -> Effect Unit) -> Effect (Effect Unit)
}
mkRoutableComponent
:: forall q i o msg sta route
. { routeIO :: RouteIO route
, routeSpec :: RouteSpec route msg sta
, onStateChange :: sta -> sta -> Effect Unit
}
-> UI HalogenHtml msg sta
-> (Halogen.Component q i o Aff)
mkRoutableComponent { routeSpec, routeIO, onStateChange } ui =
H.mkComponent
{ initialState
, render
, eval: H.mkEval $ H.defaultEval
{ handleAction = handleAction
, initialize = Just Init
}
}
where
initialState :: i -> sta
initialState _ = ui.init
render :: sta -> HTML (ComponentSlot () Aff (Msg route msg)) (Msg route msg)
render state = VDOM.Halogen.runHalogenHtml $ ChildMsg <$> ui.view state
handleAction :: Msg route msg -> HalogenM sta (Msg route msg) () o Aff Unit
handleAction msg_ = do
oldState <- get
case msg_ of
Init -> do
_ <- subscribe (map MsgNewRoute $ makeEmitter routeIO.listen)
pure unit
MsgNewRoute route -> do
H.modify_ $ routeSpec.updateStateFromRoute route
ChildMsg msg -> do
state <- get
case routeSpec.mkRoute msg state of
This route -> do
liftEffect $ routeIO.pushRoute route
That msg' -> do
H.modify_ $ ui.update msg'
Both route msg' -> do
liftEffect $ routeIO.pushRoute route
H.modify_ $ ui.update msg'
newState <- get
liftEffect $ onStateChange oldState newState