-
Notifications
You must be signed in to change notification settings - Fork 0
/
Core.purs
337 lines (224 loc) · 16.8 KB
/
Core.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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
module Blessed.Internal.Core where
-- export BlessedOp from here
import Prelude
import Effect (Effect)
import Effect.Class (liftEffect)
import Effect.Console as Console
import Effect.Ref (Ref)
import Effect.Ref (new) as Ref
import Prim.Row as R
import Control.Monad.Error.Class (class MonadThrow, throwError)
import Data.Either (Either)
import Data.Tuple (uncurry)
import Data.Tuple (fst, snd) as Tuple
import Data.Tuple.Nested ((/\), type (/\))
import Data.Array ((:))
import Data.Array as Array
import Data.Maybe (Maybe(..))
import Data.Map (Map)
import Data.Map as Map
import Data.Identity (Identity)
import Data.Foldable (foldr)
import Data.Bifunctor (lmap)
import Data.Symbol (reflectSymbol, class IsSymbol)
import Type.Proxy (Proxy(..))
import Data.Argonaut.Core (Json)
import Data.Argonaut.Encode (class EncodeJson, encodeJson)
import Data.Argonaut.Decode (class DecodeJson)
import Data.Codec.Argonaut as CA
import Blessed.Internal.BlessedOp as Op
import Blessed.Internal.BlessedSubj as K
import Blessed.Internal.Command as Cmd
import Blessed.Internal.NodeKey (NodeKey)
import Blessed.Internal.NodeKey as NK
import Blessed.Internal.JsApi as I
import Blessed.Internal.Codec as Codec
import Blessed.Internal.Emitter (initial, split, typeOf, toCore, class Fires, class Events, BlessedEvent) as E
import Blessed.Internal.Foreign (encode, encode', encodeHandler, encodeHandlerRef, HandlerIndex(..)) as Foreign
-- TODO: these function types make reading the code and finding proper things to fit complex, try to get rid of them in the end
type InitFn subj id state = (NodeKey subj id -> Op.BlessedOp state Effect)
type HandlerFn subj id state = (NodeKey subj id -> I.EventJson -> Op.BlessedOp state Effect)
data Attribute :: K.Subject -> Symbol -> Row Type -> Type -> Type -> Type
data Attribute (subj :: K.Subject) (id :: Symbol) (r :: Row Type) state e
= Option String Json
| Handler e (HandlerFn subj id state)
| OptionWithHandlers String Json (Array (e /\ HandlerFn subj id state))
data SoleOption (r :: Row Type)
= SoleOption String Json
instance Functor (Attribute subj id r state) where
map _ (Option str json) = Option str json
map f (Handler e op) = Handler (f e) op
map f (OptionWithHandlers str json handlersArray) = OptionWithHandlers str json $ lmap f <$> handlersArray
-- type Blessed state e = Ref state -> I.SNode state
type Blessed state = I.SNode state
-- see Halogen.Svg.Elements + Halogen.Svg.Properties
-- TODO: these function types make reading the code and finding proper things to fit complex, try to get rid of them in the end
type Node (subj :: K.Subject) (id :: Symbol) (r :: Row Type) state = Array (Attribute subj id r state E.BlessedEvent) -> Array (Blessed state) -> Blessed state
type NodeAnd (subj :: K.Subject) (id :: Symbol) (r :: Row Type) state = Array (Attribute subj id r state E.BlessedEvent) -> Array (Blessed state) -> InitFn subj id state -> Blessed state
type Leaf (subj :: K.Subject) (id :: Symbol) (r :: Row Type) state = Array (Attribute subj id r state E.BlessedEvent) -> Blessed state
type LeafAnd (subj :: K.Subject) (id :: Symbol) (r :: Row Type) state = Array (Attribute subj id r state E.BlessedEvent) -> InitFn subj id state -> Blessed state
type Handler (subj :: K.Subject) (id :: Symbol) (r :: Row Type) state = HandlerFn subj id state -> Attribute subj id r state E.BlessedEvent
splitAttributes :: forall subj id r state e. K.IsSubject subj => IsSymbol id => E.Events e => Array (Attribute subj id r state e) -> Array I.SProp /\ Array (I.SHandler state)
splitAttributes props = Array.catMaybes (lockSProp <$> props) /\ Array.concat (lockSHandler <$> props)
where
nodeKey = NK.make (Proxy :: _ subj) (Proxy :: _ id)
lockSProp (Option str json) = Just $ I.SProp str json
lockSProp (OptionWithHandlers str json _) = Just $ I.SProp str json
lockSProp _ = Nothing
lockSHandler (Handler e op) =
case E.split e of
eventId /\ arguments -> [ Op.makeHandler nodeKey eventId arguments op ]
lockSHandler (OptionWithHandlers _ _ handlersArray) =
Array.concat $ lockSHandler <$> uncurry Handler <$> handlersArray
lockSHandler _ = []
-- FIXME: no `Cons` check here, but only above
option :: forall (subj :: K.Subject) (id :: Symbol) (sym :: Symbol) (r :: Row Type) state a e. IsSymbol sym => EncodeJson a => Proxy sym -> a -> Attribute subj id r state e
option sym = Option (reflectSymbol sym) <<< encodeJson
optionWithHandlers :: forall (subj :: K.Subject) (id :: Symbol) (sym :: Symbol) (r :: Row Type) state a e. IsSymbol sym => EncodeJson a => Proxy sym -> a -> Array (e /\ HandlerFn subj id state) -> Attribute subj id r state e
optionWithHandlers sym json = OptionWithHandlers (reflectSymbol sym) (encodeJson json)
onlyOption :: forall (sym :: Symbol) (r :: Row Type) a. IsSymbol sym => EncodeJson a => Proxy sym -> a -> SoleOption r
onlyOption sym = SoleOption (reflectSymbol sym) <<< encodeJson
-- handler :: forall subj id r state e. Fires subj e => e -> Handler subj id r state E.BlessedEvent
-- handler e handler = E.toCore <$> Handler e handler
handler :: forall subj id r state e. E.Fires subj e => e -> Handler subj id r state
handler e fn = E.toCore <$> Handler e fn
-- on :: forall subj id r state e. Fires subj e => e -> Handler subj id r state E.BlessedEvent
-- on = handler
on :: forall subj id r state e. E.Fires subj e => e -> Handler subj id r state
on = handler
type Getter state m a = Op.BlessedOpGet state m a
type Setter state m a = Op.BlessedOpSet state m
-- FIXME: simplify the types and the chain of classes (lenses?)
class Gets :: K.Subject -> K.Subject -> Symbol -> Symbol -> (Type -> Type) -> Type -> Constraint
class (K.Extends parent subj, K.IsSubject subj, IsSymbol id, IsSymbol prop, Op.Gets m a) <= Gets parent subj id prop m a
instance (K.Extends parent subj, K.IsSubject subj, IsSymbol id, IsSymbol prop, Op.Gets m a) => Gets parent subj id prop m a
class Gets2 :: K.Subject -> K.Subject -> Symbol -> Symbol -> Symbol -> (Type -> Type) -> Type -> Constraint
class (K.Extends parent subj, K.IsSubject subj, IsSymbol id, IsSymbol propA, IsSymbol propB, Op.Gets m a) <= Gets2 parent subj id propA propB m a
instance (K.Extends parent subj, K.IsSubject subj, IsSymbol id, IsSymbol propA, IsSymbol propB, Op.Gets m a) => Gets2 parent subj id propA propB m a
class GetsC :: forall k. K.Subject -> K.Subject -> Symbol -> Symbol -> (Type -> Type) -> k -> Constraint
class (K.Extends parent subj, K.IsSubject subj, IsSymbol id, IsSymbol prop, Op.GetsC m a) <= GetsC parent subj id prop m a
instance (K.Extends parent subj, K.IsSubject subj, IsSymbol prop, IsSymbol id, Op.GetsC m a) => GetsC parent subj id prop m a
class GetsC2 :: forall k. K.Subject -> K.Subject -> Symbol -> Symbol -> Symbol -> (Type -> Type) -> k -> Constraint
class (K.Extends parent subj, K.IsSubject subj, IsSymbol id, IsSymbol propA, IsSymbol propB, Op.GetsC m a) <= GetsC2 parent subj id propA propB m a
instance (K.Extends parent subj, K.IsSubject subj, IsSymbol id, IsSymbol propA, IsSymbol propB, Op.GetsC m a) => GetsC2 parent subj id propA propB m a
class Sets :: K.Subject -> K.Subject -> Symbol -> Symbol -> (Type -> Type) -> Type -> Constraint
class (K.Extends parent subj, K.IsSubject subj, IsSymbol id, IsSymbol prop, Op.Sets m a) <= Sets parent subj id prop m a
instance (K.Extends parent subj, K.IsSubject subj, IsSymbol id, IsSymbol prop, Op.Sets m a) => Sets parent subj id prop m a
class Sets2 :: K.Subject -> K.Subject -> Symbol -> Symbol -> Symbol -> (Type -> Type) -> Type -> Constraint
class (K.Extends parent subj, K.IsSubject subj, IsSymbol id, IsSymbol propA, IsSymbol propB, Op.Sets m a) <= Sets2 parent subj id propA propB m a
instance (K.Extends parent subj, K.IsSubject subj, IsSymbol id, IsSymbol propA, IsSymbol propB, Op.Sets m a) => Sets2 parent subj id propA propB m a
class SetsC :: forall k. K.Subject -> K.Subject -> Symbol -> Symbol -> (Type -> Type) -> k -> Constraint
class (K.Extends parent subj, K.IsSubject subj, IsSymbol id, IsSymbol prop, Op.SetsC m a) <= SetsC parent subj id prop m a
instance (K.Extends parent subj, K.IsSubject subj, IsSymbol prop, IsSymbol id, Op.SetsC m a) => SetsC parent subj id prop m a
class SetsC2 :: forall k. K.Subject -> K.Subject -> Symbol -> Symbol -> Symbol -> (Type -> Type) -> k -> Constraint
class (K.Extends parent subj, K.IsSubject subj, IsSymbol id, IsSymbol propA, IsSymbol propB, Op.SetsC m a) <= SetsC2 parent subj id propA propB m a
instance (K.Extends parent subj, K.IsSubject subj, IsSymbol id, IsSymbol propA, IsSymbol propB, Op.SetsC m a) => SetsC2 parent subj id propA propB m a
-- FIXME: simplify the types and the chain of classes (lenses?)
-- type GetterFn :: forall k. K.Subject -> K.Subject -> Symbol -> Symbol -> k -> Row Type -> Type -> (Type -> Type) -> Type -> Type
type GetterFn (subj :: K.Subject) (id :: Symbol) (prop :: Symbol) state (m :: Type -> Type) a =
Proxy prop -> NodeKey subj id -> Getter state m a
type GetterFn2 (subj :: K.Subject) (id :: Symbol) (propA :: Symbol) (propB :: Symbol) state (m :: Type -> Type) a =
Proxy propA -> Proxy propB -> NodeKey subj id -> Getter state m a
-- type GetterFnC :: forall k. K.Subject -> K.Subject -> Symbol -> Symbol -> k -> Row Type -> Type -> (Type -> Type) -> Type -> Type
type GetterFnC (subj :: K.Subject) (id :: Symbol) (prop :: Symbol) state (m :: Type -> Type) a =
Proxy prop -> CA.JsonCodec a -> NodeKey subj id -> Getter state m a
type GetterFnC2 (subj :: K.Subject) (id :: Symbol) (propA :: Symbol) (propB :: Symbol) state (m :: Type -> Type) a =
Proxy propA -> Proxy propB -> CA.JsonCodec a -> NodeKey subj id -> Getter state m a
type SetterFn (subj :: K.Subject) (id :: Symbol) (prop :: Symbol) state (m :: Type -> Type) a =
Proxy prop -> a -> NodeKey subj id -> Setter state m a
type SetterFn2 (subj :: K.Subject) (id :: Symbol) (propA :: Symbol) (propB :: Symbol) state (m :: Type -> Type) a =
Proxy propA -> Proxy propB -> a -> NodeKey subj id -> Setter state m a
type SetterFnC (subj :: K.Subject) (id :: Symbol) (prop :: Symbol) state (m :: Type -> Type) a =
Proxy prop -> CA.JsonCodec a -> a -> NodeKey subj id -> Setter state m a
type SetterFnC2 (subj :: K.Subject) (id :: Symbol) (propA :: Symbol) (propB :: Symbol) state (m :: Type -> Type) a =
Proxy propA -> Proxy propB -> CA.JsonCodec a -> a -> NodeKey subj id -> Setter state m a
getter :: forall parent subj id prop state m a. Gets parent subj id prop m a => Proxy parent -> GetterFn subj id prop state m a
getter _ prop nodeKey =
Op.performGet (NK.rawify nodeKey) $ Cmd.get $ reflectSymbol prop
getterC :: forall parent subj id prop state m a. GetsC parent subj id prop m a => Proxy parent -> GetterFnC subj id prop state m a
getterC _ prop codec nodeKey =
Op.performGetC codec (NK.rawify nodeKey) $ Cmd.get $ reflectSymbol prop
getter2 :: forall parent subj id propA propB state m a. Gets2 parent subj id propA propB m a => Proxy parent -> GetterFn2 subj id propA propB state m a
getter2 _ propA propB nodeKey =
Op.performGet (NK.rawify nodeKey) $ Cmd.getP [ reflectSymbol propA, reflectSymbol propB ]
getterC2 :: forall parent subj id propA propB state m a. GetsC2 parent subj id propA propB m a => Proxy parent -> GetterFnC2 subj id propA propB state m a
getterC2 _ propA propB codec nodeKey =
Op.performGetC codec (NK.rawify nodeKey) $ Cmd.getP [ reflectSymbol propA, reflectSymbol propB ]
method ∷ forall subj id state (m ∷ Type -> Type). K.IsSubject subj => IsSymbol id => NodeKey subj id → String → Array Json → Op.BlessedOp state m
method nodeKey name args =
Op.perform (NK.rawify nodeKey) $ Cmd.call name args
nmethod ∷ forall subj id state (m ∷ Type -> Type). K.IsSubject subj => IsSymbol id => NodeKey subj id → String → Array (Cmd.NodeOrJson state) → Op.BlessedOp state m
nmethod nodeKey name args =
Op.getStateRef >>= \stateRef ->
let
foldF (Cmd.JsonArg json) (allJsons /\ allHandlers) = Array.snoc allJsons json /\ allHandlers
foldF (Cmd.NodeArg node) (allJsons /\ allHandlers) =
case Foreign.encode' stateRef (Just $ NK.rawify nodeKey) node of
nodeEnc /\ nodeHandlers -> Array.snoc allJsons (CA.encode Codec.nodeEnc nodeEnc) /\ (allHandlers <> nodeHandlers)
jsonArgs /\ handlers = foldr foldF ([] /\ []) args
in Op.perform (NK.rawify nodeKey) $ Cmd.callEx name jsonArgs handlers
cmethod ∷ forall subj id state (m ∷ Type -> Type) e. E.Fires subj e => E.Events e => K.IsSubject subj => IsSymbol id => NodeKey subj id → String → Array Json -> Array (e /\ HandlerFn subj id state) → Op.BlessedOp state m
cmethod nodeKey name jsonArgs handlers =
Op.getStateRef >>= \stateRef ->
let
rawNodeKey = NK.rawify nodeKey
encodeHandler index (event /\ op) =
case E.split event of
eventId /\ arguments ->
let
sHandler = Op.makeHandler nodeKey eventId arguments op
handlerIndex = Foreign.HandlerIndex $ 1000 + index
in Foreign.encodeHandlerRef rawNodeKey handlerIndex sHandler
/\ Foreign.encodeHandler stateRef rawNodeKey handlerIndex sHandler
handlersPairs = Array.mapWithIndex encodeHandler handlers
encodedHandlersRefs = CA.encode Codec.handlerRefEnc <$> Tuple.fst <$> handlersPairs
encodedHandlers = Tuple.snd <$> handlersPairs
in Op.perform (NK.rawify nodeKey) $ Cmd.callEx name (jsonArgs <> encodedHandlersRefs) encodedHandlers
-- in Op.perform (NK.rawify nodeKey) $ Cmd.callEx name (encodedHandlersRefs) encodedHandlers
-- in Op.perform (NK.rawify nodeKey) $ Cmd.callEx name jsonArgs encodedHandlers
subscription ∷ forall subj id state (m ∷ Type -> Type) e. K.IsSubject subj => IsSymbol id => E.Fires subj e => NodeKey subj id → e → HandlerFn subj id state -> Op.BlessedOp state m
subscription nodeKey event op =
Op.getStateRef >>= \stateRef ->
case E.split event of
eventId /\ arguments ->
Op.perform (NK.rawify nodeKey)
$ Cmd.sub (E.typeOf eventId) arguments
$ Foreign.encodeHandler stateRef (NK.rawify nodeKey) (Foreign.HandlerIndex 0)
$ Op.makeHandler nodeKey eventId arguments op
on' :: forall subj id state (m ∷ Type -> Type) e. K.IsSubject subj => IsSymbol id => E.Fires subj e => e → HandlerFn subj id state -> NodeKey subj id → Op.BlessedOp state m
on' e h key = subscription key e h
setter ∷ forall parent subj id prop state (m ∷ Type -> Type) a. Sets parent subj id prop m a => Proxy parent -> SetterFn subj id prop state m a
setter _ prop cvalue nodeKey =
Op.perform (NK.rawify nodeKey) $ Cmd.set (reflectSymbol prop) $ encodeJson cvalue
setter2 ∷ forall parent subj id propA propB state (m ∷ Type -> Type) a. Sets2 parent subj id propA propB m a => Proxy parent -> SetterFn2 subj id propA propB state m a
setter2 _ propA propB cvalue nodeKey =
Op.perform (NK.rawify nodeKey) $ Cmd.setP [ reflectSymbol propA, reflectSymbol propB ] $ encodeJson cvalue
setterC ∷ forall parent subj id prop state (m ∷ Type -> Type) a. SetsC parent subj id prop m a => Proxy parent -> SetterFnC subj id prop state m a
setterC _ prop codec cvalue nodeKey =
Op.perform (NK.rawify nodeKey) $ Cmd.set (reflectSymbol prop) $ CA.encode codec cvalue
setterC2 ∷ forall parent subj id propA propB state (m ∷ Type -> Type) a. SetsC2 parent subj id propA propB m a => Proxy parent -> SetterFnC2 subj id propA propB state m a
setterC2 _ propA propB codec cvalue nodeKey =
Op.perform (NK.rawify nodeKey) $ Cmd.setP [ reflectSymbol propA, reflectSymbol propB ] $ CA.encode codec cvalue
instance EncodeJson (SoleOption r) where
encodeJson (SoleOption name value)
= CA.encode Codec.propJson { name, value }
encode :: forall state. Ref state -> Blessed state -> I.BlessedEnc
encode = Foreign.encode
node :: forall subj id state r. K.IsSubject subj => IsSymbol id => NodeKey subj id -> Node subj id state r
node nodeKey attrs children =
I.SNode (NK.rawify nodeKey) sprops children handlers
where sprops /\ handlers = splitAttributes attrs
nodeAnd :: forall subj id state r e. K.IsSubject subj => IsSymbol id => E.Events e => Proxy e -> NodeKey subj id -> NodeAnd subj id state r
nodeAnd _ nodeKey attrs children fn =
I.SNode (NK.rawify nodeKey) sprops children (Op.makeHandler nodeKey initialId initalArgs (\id _ -> fn id) : handlers)
where
sprops /\ handlers = splitAttributes attrs
initialId /\ initalArgs = E.split (E.initial :: e)
run :: forall state. state -> Blessed state -> Effect Unit
run state blessed =
runAnd state blessed $ pure unit
runAnd :: forall state. state -> Blessed state -> Op.BlessedOp state Effect -> Effect Unit
runAnd state blessed op = do
stateRef <- Ref.new state
liftEffect $ Op.execute_ $ Foreign.encode stateRef blessed
Op.runM' stateRef op