-
Notifications
You must be signed in to change notification settings - Fork 0
/
Run.purs
120 lines (107 loc) · 3.18 KB
/
Run.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
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
module InteractiveData.Run
( ctxNoWrap
, getExtract
, getUi
, run
) where
import Prelude
import Chameleon (class Html)
import Data.Identity (Identity(..))
import Data.Maybe (Maybe)
import Data.Newtype (un)
import DataMVC.Types (DataResult, DataUI, DataUICtx(..), DataUiInterface(..))
import DataMVC.Types.DataUI (runDataUi)
import InteractiveData.Core (class IDHtml, DataTree(..), IDSurface, IDViewCtx)
import InteractiveData.Core.Types.IDSurface (runIdSurface)
import InteractiveData.Core.Types.IDViewCtx (defaultViewCtx)
import InteractiveData.Core.Types.IDHtmlT (IDHtmlT, runIDHtmlT)
import MVC.Types (UI)
run
:: forall html fm fs msg sta a
. Html html
=> { name :: String
, context :: DataUICtx (IDSurface (IDHtmlT html)) fm fs
, fullscreen :: Boolean
, showLogo :: Boolean
}
-> DataUI (IDSurface (IDHtmlT html)) fm fs msg sta a
-> DataUiInterface html msg sta a
run { name, context, fullscreen, showLogo } dataUi =
dataUi
# flip runDataUi context
# hoistSrf (runHtml { name, fullscreen, showLogo })
getUi
:: forall html msg sta a
. { initData :: Maybe a }
-> DataUiInterface html msg sta a
-> UI html msg sta
getUi { initData } (DataUiInterface { view, init, update }) =
{ view
, init: init initData
, update
}
getExtract
:: forall html msg sta a
. DataUiInterface html msg sta a
-> (sta -> DataResult a)
getExtract (DataUiInterface { extract }) = extract
hoistSrf
:: forall srf1 srf2 msg sta a
. (srf1 ~> srf2)
-> DataUiInterface srf1 msg sta a
-> DataUiInterface srf2 msg sta a
hoistSrf nat (DataUiInterface itf) = DataUiInterface itf
{ view = itf.view >>> nat
}
runHtml
:: forall html msg
. Html html
=> { name :: String, fullscreen :: Boolean, showLogo :: Boolean }
-> IDSurface (IDHtmlT html) msg
-> html msg
runHtml { name, fullscreen, showLogo } =
let
runSurface :: (IDSurface (IDHtmlT html)) msg -> (IDHtmlT html) msg
runSurface = runIdSurface { path: [] } >>> un DataTree >>> _.view
viewCtx :: IDViewCtx
viewCtx =
(defaultViewCtx { label: name })
{ fullscreen = fullscreen
, showLogo = showLogo
}
in
runSurface >>> runIDHtmlT viewCtx
ctxNoWrap :: forall html. IDHtml html => DataUICtx (IDSurface html) Identity Identity
ctxNoWrap = DataUICtx
{ wrap: \s -> s
# imapMsg Identity (un Identity)
# imapState Identity (un Identity)
}
imapMsg
:: forall srf msg1 msg2 sta a
. Functor srf
=> (msg1 -> msg2)
-> (msg2 -> msg1)
-> DataUiInterface srf msg1 sta a
-> DataUiInterface srf msg2 sta a
imapMsg mapMsg unmapMsg (DataUiInterface itf) = DataUiInterface
{ init: itf.init
, update: \msg state -> itf.update (unmapMsg msg) state
, view: itf.view >>> map mapMsg
, extract: itf.extract
, name: itf.name
}
imapState
:: forall srf msg sta1 sta2 a
. Functor srf
=> (sta1 -> sta2)
-> (sta2 -> sta1)
-> DataUiInterface srf msg sta1 a
-> DataUiInterface srf msg sta2 a
imapState mapState unmapState (DataUiInterface itf) = DataUiInterface
{ init: itf.init >>> mapState
, update: \msg state -> mapState $ itf.update msg (unmapState state)
, view: unmapState >>> itf.view
, extract: unmapState >>> itf.extract
, name: itf.name
}