Skip to content

Commit cb1f351

Browse files
lagunofflagunoff
committed
More renaming
1 parent 6bb3644 commit cb1f351

File tree

11 files changed

+675
-569
lines changed

11 files changed

+675
-569
lines changed

‎Clickable/Float.hs renamed to ‎Clickable/Binary.hs

+2-4
Original file line numberDiff line numberDiff line change
@@ -6,11 +6,9 @@
66
{-# LANGUAGE UnboxedTuples #-}
77
{-# LANGUAGE LambdaCase #-}
88
{-# LANGUAGE DerivingStrategies #-}
9-
{-| Normal `Data.Binary.Binary` instances for floating-point numbers
10-
replacing the impractical and unnatural encoding in the default
11-
instances for `Float` and `Double`
9+
{-| Override `Data.Binary.Binary` instances for floating-point numbers
1210
-}
13-
module Clickable.Float where
11+
module Clickable.Binary where
1412

1513
import Data.Binary
1614
import Data.Binary.Get

‎Clickable/HTML.hs

+177-77
Original file line numberDiff line numberDiff line change
@@ -13,87 +13,89 @@ module Clickable.HTML where
1313

1414
import Clickable.Internal
1515
import Clickable.Types
16-
import Control.Monad.Reader
1716
import Data.Kind (Type)
1817
import Data.Text (Text)
1918
import GHC.Generics (Generic)
2019
import Unsafe.Coerce (unsafeCoerce)
20+
import Control.Monad.Trans
21+
import Data.IORef
22+
import Control.Monad
2123

2224
el :: Text -> HTML a -> HTML a
2325
el tagName child = HTML \s e -> do
24-
e.hte_send $ PushStack $ CreateElement tagName
26+
e.ien_command $ PushStack $ CreateElement tagName
2527
(r, _) <- child.unHTML Nothing e
26-
e.hte_send PopIns
28+
e.ien_command PopIns
2729
pure (r, s)
2830
{-# INLINE el #-}
2931

3032
elns :: Text -> Text -> HTML a -> HTML a
3133
elns ns tagName child = HTML \s e -> do
32-
e.hte_send $ PushStack $ CreateElementNS ns tagName
34+
e.ien_command $ PushStack $ CreateElementNS ns tagName
3335
(r, _) <- child.unHTML s e
34-
e.hte_send PopIns
36+
e.ien_command PopIns
3537
pure (r, s)
3638
{-# INLINE elns #-}
3739

3840
text :: Text -> HTML ()
3941
text content = HTML \s e -> do
40-
e.hte_send $ PushStack $ CreateTextNode content
41-
e.hte_send PopIns
42+
e.ien_command $ PushStack $ CreateText content
43+
e.ien_command PopIns
4244
return ((), s)
4345
{-# INLINE text #-}
4446

4547
dynText :: Dynamic Text -> HTML ()
4648
dynText contentDyn = HTML \s e -> do
47-
c <- readVal contentDyn
49+
c <- readDyn contentDyn
4850
refId <- newRefId.unJSM e
49-
e.hte_send $ PushStack $ CreateTextNode c
50-
e.hte_send $ AssignRef refId (PeekStack 0)
51-
e.hte_send PopIns
51+
e.ien_command $ PushStack $ CreateText c
52+
e.ien_command $ AssignRef refId (PeekStack 0)
53+
e.ien_command PopIns
5254
let k nval = JSM \e' ->
53-
e'.hte_send $ UpdateTextNode (Ref refId) nval
55+
e'.ien_command $ UpdateText (Ref refId) nval
5456
(subscribe contentDyn k).unJSM e
5557
pure ((), s)
5658
{-# INLINEABLE dynText #-}
5759

58-
property :: ToValue val => Text -> val -> HTML ()
60+
property :: ToJSVal val => Text -> val -> HTML ()
5961
property k v = HTML \s e -> do
60-
e.hte_send $ ElementProp (PeekStack 0) k $ toValue v
62+
e.ien_command $ ElementProp (PeekStack 0) k $ toJSVal v
6163
pure ((), s)
6264
{-# INLINE property #-}
6365

64-
dynProp :: ToValue val => Text -> Dynamic val -> HTML ()
66+
dynProp :: ToJSVal val => Text -> Dynamic val -> HTML ()
6567
dynProp propName dynVal = HTML \s e -> do
66-
(refId, s') <- saveStackTip.unHTML s e
67-
initVal <- readVal dynVal
68-
e.hte_send $ ElementProp (PeekStack 0) propName $ toValue initVal
68+
(refId, s') <- saveStackHead.unHTML s e
69+
initVal <- readDyn dynVal
70+
e.ien_command $ ElementProp (PeekStack 0) propName $ toJSVal initVal
6971
let k nval = JSM \e' ->
70-
e'.hte_send $ ElementProp (Ref refId) propName $ toValue nval
72+
e'.ien_command $ ElementProp (Ref refId) propName $ toJSVal nval
7173
unJSM (subscribe dynVal k) e
7274
pure ((), s')
7375
{-# INLINE dynProp #-}
7476

7577
attribute :: Text -> Text -> HTML ()
7678
attribute k v = HTML \s e -> do
77-
e.hte_send $ ElementAttr (PeekStack 0) k v
79+
e.ien_command $ ElementAttr (PeekStack 0) k v
7880
pure ((), s)
7981
{-# INLINE attribute #-}
8082

8183
dynAttr :: Text -> Dynamic Text -> HTML ()
8284
dynAttr propName dynVal = HTML \s e -> do
83-
(refId, s') <- saveStackTip.unHTML s e
84-
initVal <- readVal dynVal
85-
e.hte_send $ ElementAttr (PeekStack 0) propName initVal
85+
(refId, s') <- saveStackHead.unHTML s e
86+
initVal <- readDyn dynVal
87+
e.ien_command $ ElementAttr (PeekStack 0) propName initVal
8688
let k nval = JSM \e' ->
87-
e'.hte_send $ ElementAttr (Ref refId) propName nval
89+
e'.ien_command $ ElementAttr (Ref refId) propName nval
8890
unJSM (subscribe dynVal k) e
8991
pure ((), s')
9092
{-# INLINE dynAttr #-}
9193

9294
toggleClass :: Text -> Dynamic Bool -> HTML ()
9395
toggleClass className dynEnable = HTML \s e -> do
94-
(refId, s') <- saveStackTip.unHTML s e
95-
v <- readVal dynEnable
96-
let k enable = JSM \e' -> e'.hte_send
96+
(refId, s') <- saveStackHead.unHTML s e
97+
v <- readDyn dynEnable
98+
let k enable = JSM \e' -> e'.ien_command
9799
if enable
98100
then ClassListAdd (Ref refId) className
99101
else ClassListRemove (Ref refId) className
@@ -102,17 +104,17 @@ toggleClass className dynEnable = HTML \s e -> do
102104
pure ((), s')
103105
{-# INLINE toggleClass #-}
104106

105-
addEventListener :: FromValue a => (Event a -> Expr) -> (a -> JSM ()) -> JSM ()
106-
addEventListener connectScript k = do
107-
e <- reactive \scope s ->
108-
let k' = local (\e -> e {hte_scope = scope}) . k
109-
eventId = EventId s.next_id
110-
(s', unSubRef) = newRefIdOp scope s {next_id = s.next_id + 1}
111-
newSub = SubscriptionSimple scope (unsafeFromEventId eventId) (mapM_ k' . fromValue . unsafeCoerce)
112-
newFin = CustomFinalizer scope $ enqueueExpr $ Apply (Ref unSubRef) []
113-
s'' = s' {subscriptions = newSub : s.subscriptions, finalizers = newFin : s.finalizers}
114-
in (s'', AssignRef unSubRef (connectScript (Event eventId)))
115-
enqueueExpr e
107+
addEventListener :: FromJSVal a => (Event a -> JSExp) -> (a -> JSM ()) -> JSM ()
108+
addEventListener addScript k =
109+
reactive add >>= jsCmd where
110+
add scope s = (s''', cmd) where
111+
k' = localScope scope . k
112+
eventId = EventId s.ist_id_supply
113+
(s', unsub) = newRefIdFn scope s {ist_id_supply = s.ist_id_supply + 1}
114+
s'' = subscribeEventFn (unsafeFromEventId eventId)
115+
(mapM_ k' . fromJSVal . unsafeCoerce) scope s'
116+
s''' = installFinalizerFn (jsCmd $ Apply (Ref unsub) []) scope s''
117+
cmd = AssignRef unsub $ addScript $ Event eventId
116118

117119
class IsEventName eventName where
118120
type EventListenerCb eventName :: Type
@@ -137,42 +139,43 @@ defaultEventListenerOptions = EventListenerOptions {
137139
stop_propagation = False
138140
}
139141

140-
genericEvent :: EventListenerOptions -> Text -> Expr -> Event () -> Expr
141-
genericEvent opt eventName target (Event eventId) =
142-
Eval
143-
("(function(target, trigger){\n\
144-
\ function listener(event){\n\
145-
\ " <> preventDefaultStmt <> "\n\
146-
\ " <> stopPropagationStmt <> "\n\
147-
\ trigger();\n\
148-
\ }\n\
149-
\ target.addEventListener('" <> UnsafeJavaScript eventName <> "', listener);\n\
150-
\ return () => target.removeEventListener('" <> UnsafeJavaScript eventName <> "', listener);\n\
151-
\})") `Apply` [target, Lam (TriggerEvent eventId Null)]
142+
genericEvent :: EventListenerOptions -> Text -> JSExp -> Event () -> JSExp
143+
genericEvent opt eventName target (Event eid) =
144+
Eval script `Apply` [target, Lam (TriggerEvent eid Null)]
152145
where
146+
script =
147+
("(function(target, trigger){\n\
148+
\ function listener(event){\n\
149+
\ " <> preventDefaultStmt <> "\n\
150+
\ " <> stopPropagationStmt <> "\n\
151+
\ trigger();\n\
152+
\ }\n\
153+
\ target.addEventListener('" <> UnsafeJavaScript eventName <> "', listener);\n\
154+
\ return () => target.removeEventListener('" <> UnsafeJavaScript eventName <> "', listener);\n\
155+
\})")
153156
preventDefaultStmt = if opt.prevent_default then "event.preventDefault();" else ""
154157
stopPropagationStmt = if opt.stop_propagation then "event.stopPropagation();" else ""
155158

156-
unsafeConnectEvent :: Expr -> UnsafeJavaScript -> Event a -> Expr
159+
unsafeConnectEvent :: JSExp -> UnsafeJavaScript -> Event a -> JSExp
157160
unsafeConnectEvent target ujs (Event eid) =
158161
Eval ujs `Apply` [target, Lam (TriggerEvent eid (Arg 0))]
159162

160-
attachHTML :: Expr -> HTML a -> JSM a
161-
attachHTML rootEl contents = JSM \e -> do
162-
e.hte_send $ PushStack rootEl
163+
attachTo :: JSExp -> HTML a -> JSM a
164+
attachTo rootEl contents = JSM \e -> do
165+
e.ien_command $ PushStack rootEl
163166
(r, _) <- contents.unHTML Nothing e
164-
e.hte_send PopStack
167+
e.ien_command PopStack
165168
pure r
166169

167-
attachToBody :: HTML a -> JSM a
168-
attachToBody = attachHTML $ Id "document" `Dot` "body"
170+
attach :: HTML a -> JSM a
171+
attach = attachTo $ Id "document" `Dot` "body"
169172

170-
saveStackTip :: HTML RefId
171-
saveStackTip = HTML \s e ->
173+
saveStackHead :: HTML RefId
174+
saveStackHead = HTML \s e ->
172175
case s of
173176
Nothing -> do
174177
refId <- newRefId.unJSM e
175-
e.hte_send $ AssignRef refId $ PeekStack 0
178+
e.ien_command $ AssignRef refId $ PeekStack 0
176179
return (refId, Just refId)
177180
Just saved ->
178181
pure (saved, s)
@@ -199,23 +202,120 @@ data Location = Location {
199202
-- of the URL.
200203
hash :: Text
201204
} deriving stock (Show, Eq, Generic)
202-
deriving anyclass (FromValue, ToValue)
205+
deriving anyclass (FromJSVal, ToJSVal)
203206

204207
-- https://developer.mozilla.org/en-US/docs/Web/API/Window/popstate_event
205-
popstateEvent :: Event Location -> Expr
208+
popstateEvent :: Event Location -> JSExp
206209
popstateEvent (Event eventId) =
207-
Eval
208-
"(function(target, trigger){\n\
209-
\ function listener(){\n\
210-
\ trigger({\n\
211-
\ protocol: location.protocol,\n\
212-
\ hostname: location.hostname,\n\
213-
\ port: location.port,\n\
214-
\ pathname: location.pathname,\n\
215-
\ search: location.search,\n\
216-
\ hash: location.hash\n\
217-
\ });\n\
218-
\ }\n\
219-
\ target.addEventListener('popstate', listener);\n\
220-
\ return () => target.removeEventListener('popstate', listener);\n\
221-
\})" `Apply` [Id "window", Lam (TriggerEvent eventId (Arg 0))]
210+
Eval script `Apply` [Id "window", Lam (TriggerEvent eventId (Arg 0))]
211+
where
212+
script =
213+
"(function(target, trigger){\n\
214+
\ function listener(){\n\
215+
\ trigger({\n\
216+
\ protocol: location.protocol,\n\
217+
\ hostname: location.hostname,\n\
218+
\ port: location.port,\n\
219+
\ pathname: location.pathname,\n\
220+
\ search: location.search,\n\
221+
\ hash: location.hash\n\
222+
\ });\n\
223+
\ }\n\
224+
\ target.addEventListener('popstate', listener);\n\
225+
\ return () => target.removeEventListener('popstate', listener);\n\
226+
\})"
227+
228+
dyn :: Dynamic (HTML ()) -> HTML ()
229+
dyn val = do
230+
brackets <- liftJSM insertBrackets
231+
scope <- liftJSM newScope
232+
initialVal <- liftJSM $ readDyn val
233+
let
234+
update html = do
235+
liftJSM $ clearBrackets brackets
236+
html
237+
exec h =
238+
localScope scope $ customize (Ref brackets) h
239+
liftJSM $ exec $ update initialVal
240+
liftJSM $ subscribe val \newVal -> do
241+
freeScope scope
242+
exec $ update newVal
243+
244+
-- | Auxilliary datatype used in 'simpleList' implementation
245+
data ElemEnv a = ElemEnv {
246+
brackets :: RefId,
247+
state_var :: DynVar a,
248+
elem_scope :: ScopeId
249+
}
250+
251+
-- | Display dynamic collection of widgets. NOTE: changes in `DynVar
252+
-- a` do not automatically propagate into the larger state. See
253+
-- `OverrideVar` and todomvc example to see one way to upstream
254+
-- changes into the larger state.
255+
simpleList ::
256+
forall a. Dynamic [a] ->
257+
(Int -> DynVar a -> HTML ()) ->
258+
HTML ()
259+
simpleList listDyn h = liftJSM do
260+
internalStateRef <- liftIO $ newIORef ([] :: [ElemEnv a])
261+
brackets <- insertBrackets
262+
let
263+
exec brackets' scope =
264+
localScope scope . customize (Ref brackets')
265+
exec1 brackets' = customize (Ref brackets')
266+
267+
setup :: Int -> [a] -> [ElemEnv a] -> JSM [ElemEnv a]
268+
setup idx new existing = case (existing, new) of
269+
([], []) -> return []
270+
-- New list is longer, append new elements
271+
([], x:xs) -> do
272+
e <- newElem x
273+
exec e.brackets e.elem_scope $ h idx e.state_var
274+
fmap (e:) $ setup (idx + 1) xs []
275+
-- New list is shorter, delete the elements that no longer
276+
-- present in the new list
277+
(r:rs, []) -> do
278+
finalizeElems True (r:rs)
279+
return []
280+
-- Update existing elements along the way
281+
(r:rs, y:ys) -> do
282+
writeVar r.state_var y
283+
fmap (r:) $ setup (idx + 1) ys rs
284+
newElem :: a -> JSM (ElemEnv a)
285+
newElem a = do
286+
elem_scope <- newScope
287+
localScope elem_scope do
288+
state_var <- newVar a
289+
brackets' <- insertBrackets
290+
return ElemEnv {elem_scope, state_var, brackets = brackets'}
291+
finalizeElems :: Bool -> [ElemEnv a] -> JSM ()
292+
finalizeElems remove = mapM_ \ee -> do
293+
when remove $ detachBrackets ee.brackets
294+
destroyScope ee.elem_scope
295+
updateList :: [a] -> JSM ()
296+
updateList new = do
297+
eenvs <- liftIO $ readIORef internalStateRef
298+
newEenvs <- setup 0 new eenvs
299+
liftIO $ writeIORef internalStateRef newEenvs
300+
initialVal <- readDyn listDyn
301+
exec1 brackets $ liftJSM $ updateList initialVal
302+
subscribe listDyn $ exec1 brackets . liftJSM . updateList
303+
304+
insertBrackets :: JSM RefId
305+
insertBrackets = do
306+
brackets <- newRefId
307+
jsCmd $ AssignRef brackets InsertBrackets
308+
pure brackets
309+
310+
clearBrackets :: RefId -> JSM ()
311+
clearBrackets rid = jsCmd $ ClearBrackets $ Ref rid
312+
313+
detachBrackets :: RefId -> JSM ()
314+
detachBrackets rid = jsCmd $ DetachBrackets $ Ref rid
315+
316+
customize :: JSExp -> HTML a -> JSM a
317+
customize elm action = JSM \e -> do
318+
e.ien_command $ PushStack elm
319+
(r, _) <- action.unHTML Nothing e
320+
e.ien_command PopStack
321+
pure r

0 commit comments

Comments
 (0)