More renaming

lagunoff · Nov 17, 2024 · 93de34f · 93de34f
1 parent 6bb3644
commit 93de34f
Show file tree

Hide file tree

Showing 11 changed files with 675 additions and 570 deletions.
diff --git a/Clickable/Float.hs → Clickable/Binary.hs b/Clickable/Float.hs → Clickable/Binary.hs
@@ -6,11 +6,9 @@
 {-# LANGUAGE UnboxedTuples #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE DerivingStrategies #-}
-{-| Normal `Data.Binary.Binary` instances for floating-point numbers
-replacing the impractical and unnatural encoding in the default
-instances for `Float` and `Double`
+{-| Override `Data.Binary.Binary` instances for floating-point numbers
 -}
-module Clickable.Float where
+module Clickable.Binary where
 
 import Data.Binary
 import Data.Binary.Get

diff --git a/Clickable/HTML.hs b/Clickable/HTML.hs
@@ -13,87 +13,89 @@ module Clickable.HTML where
 
 import Clickable.Internal
 import Clickable.Types
-import Control.Monad.Reader
 import Data.Kind (Type)
 import Data.Text (Text)
 import GHC.Generics (Generic)
 import Unsafe.Coerce (unsafeCoerce)
+import Control.Monad.Trans
+import Data.IORef
+import Control.Monad
 
 el :: Text -> HTML a -> HTML a
 el tagName child = HTML \s e -> do
-  e.hte_send $ PushStack $ CreateElement tagName
+  e.ien_command $ PushStack $ CreateElement tagName
   (r, _) <- child.unHTML Nothing e
-  e.hte_send PopIns
+  e.ien_command PopIns
   pure (r, s)
 {-# INLINE el #-}
 
 elns :: Text -> Text -> HTML a -> HTML a
 elns ns tagName child = HTML \s e -> do
-  e.hte_send $ PushStack $ CreateElementNS ns tagName
+  e.ien_command $ PushStack $ CreateElementNS ns tagName
   (r, _) <- child.unHTML s e
-  e.hte_send PopIns
+  e.ien_command PopIns
   pure (r, s)
 {-# INLINE elns #-}
 
 text :: Text -> HTML ()
 text content = HTML \s e -> do
-  e.hte_send $ PushStack $ CreateTextNode content
-  e.hte_send PopIns
+  e.ien_command $ PushStack $ CreateText content
+  e.ien_command PopIns
   return ((), s)
 {-# INLINE text #-}
 
 dynText :: Dynamic Text -> HTML ()
 dynText contentDyn = HTML \s e -> do
-  c <- readVal contentDyn
+  c <- readDyn contentDyn
   refId <- newRefId.unJSM e
-  e.hte_send $ PushStack $ CreateTextNode c
-  e.hte_send $ AssignRef refId (PeekStack 0)
-  e.hte_send PopIns
+  e.ien_command $ PushStack $ CreateText c
+  e.ien_command $ AssignRef refId (PeekStack 0)
+  e.ien_command PopIns
   let k nval = JSM \e' ->
-        e'.hte_send $ UpdateTextNode (Ref refId) nval
+        e'.ien_command $ UpdateText (Ref refId) nval
   (subscribe contentDyn k).unJSM e
   pure ((), s)
 {-# INLINEABLE dynText #-}
 
-property :: ToValue val => Text -> val -> HTML ()
+property :: ToJSVal val => Text -> val -> HTML ()
 property k v = HTML \s e -> do
-  e.hte_send $ ElementProp (PeekStack 0) k $ toValue v
+  e.ien_command $ ElementProp (PeekStack 0) k $ toJSVal v
   pure ((), s)
 {-# INLINE property #-}
 
-dynProp :: ToValue val => Text -> Dynamic val -> HTML ()
+dynProp :: ToJSVal val => Text -> Dynamic val -> HTML ()
 dynProp propName dynVal = HTML \s e -> do
-  (refId, s') <- saveStackTip.unHTML s e
-  initVal <- readVal dynVal
-  e.hte_send $ ElementProp (PeekStack 0) propName $ toValue initVal
+  (refId, s') <- saveStackHead.unHTML s e
+  initVal <- readDyn dynVal
+  e.ien_command $ ElementProp (PeekStack 0) propName $ toJSVal initVal
   let k nval = JSM \e' ->
-        e'.hte_send $ ElementProp (Ref refId) propName $ toValue nval
+        e'.ien_command $ ElementProp (Ref refId) propName $ toJSVal nval
   unJSM (subscribe dynVal k) e
   pure ((), s')
 {-# INLINE dynProp #-}
 
 attribute :: Text -> Text -> HTML ()
 attribute k v = HTML \s e -> do
-  e.hte_send $ ElementAttr (PeekStack 0) k v
+  e.ien_command $ ElementAttr (PeekStack 0) k v
   pure ((), s)
 {-# INLINE attribute #-}
 
 dynAttr :: Text -> Dynamic Text -> HTML ()
 dynAttr propName dynVal = HTML \s e -> do
-  (refId, s') <- saveStackTip.unHTML s e
-  initVal <- readVal dynVal
-  e.hte_send $ ElementAttr (PeekStack 0) propName initVal
+  (refId, s') <- saveStackHead.unHTML s e
+  initVal <- readDyn dynVal
+  e.ien_command $ ElementAttr (PeekStack 0) propName initVal
   let k nval = JSM \e' ->
-        e'.hte_send $ ElementAttr (Ref refId) propName nval
+        e'.ien_command $ ElementAttr (Ref refId) propName nval
   unJSM (subscribe dynVal k) e
   pure ((), s')
 {-# INLINE dynAttr #-}
 
 toggleClass :: Text -> Dynamic Bool -> HTML ()
 toggleClass className dynEnable = HTML \s e -> do
-  (refId, s') <- saveStackTip.unHTML s e
-  v <- readVal dynEnable
-  let k enable = JSM \e' -> e'.hte_send
+  (refId, s') <- saveStackHead.unHTML s e
+  v <- readDyn dynEnable
+  let k enable = JSM \e' -> e'.ien_command
           if enable
             then ClassListAdd (Ref refId) className
             else ClassListRemove (Ref refId) className
@@ -102,17 +104,17 @@ toggleClass className dynEnable = HTML \s e -> do
   pure ((), s')
 {-# INLINE toggleClass #-}
 
-addEventListener :: FromValue a => (Event a -> Expr) -> (a -> JSM ()) -> JSM ()
-addEventListener connectScript k = do
-  e <- reactive \scope s ->
-    let k' = local (\e -> e {hte_scope = scope}) . k
-        eventId = EventId s.next_id
-        (s', unSubRef) = newRefIdOp scope s {next_id = s.next_id + 1}
-        newSub = SubscriptionSimple scope (unsafeFromEventId eventId) (mapM_ k' . fromValue . unsafeCoerce)
-        newFin = CustomFinalizer scope $ enqueueExpr $ Apply (Ref unSubRef) []
-        s'' = s' {subscriptions = newSub : s.subscriptions, finalizers = newFin : s.finalizers}
-     in (s'', AssignRef unSubRef (connectScript (Event eventId)))
-  enqueueExpr e
+addEventListener :: FromJSVal a => (Event a -> JSExp) -> (a -> JSM ()) -> JSM ()
+addEventListener addScript k =
+  reactive add >>= jsCmd where
+    add scope s = (s''', cmd) where
+      k' = localScope scope . k
+      eventId = EventId s.ist_id_supply
+      (s', unsub) = newRefIdFn scope s {ist_id_supply = s.ist_id_supply + 1}
+      s'' = subscribeEventFn (unsafeFromEventId eventId)
+        (mapM_ k' . fromJSVal . unsafeCoerce) scope s'
+      s''' = installFinalizerFn (jsCmd $ Apply (Ref unsub) []) scope s''
+      cmd = AssignRef unsub $ addScript $ Event eventId
 
 class IsEventName eventName where
   type EventListenerCb eventName :: Type
@@ -137,42 +139,43 @@ defaultEventListenerOptions = EventListenerOptions {
   stop_propagation = False
 }
 
-genericEvent :: EventListenerOptions -> Text -> Expr -> Event () -> Expr
-genericEvent opt eventName target (Event eventId) =
-  Eval
-    ("(function(target, trigger){\n\
-    \  function listener(event){\n\
-    \    " <> preventDefaultStmt <> "\n\
-    \    " <> stopPropagationStmt <> "\n\
-    \    trigger();\n\
-    \  }\n\
-    \  target.addEventListener('" <> UnsafeJavaScript eventName <> "', listener);\n\
-    \  return () => target.removeEventListener('" <> UnsafeJavaScript eventName <> "', listener);\n\
-    \})") `Apply` [target, Lam (TriggerEvent eventId Null)]
+genericEvent :: EventListenerOptions -> Text -> JSExp -> Event () -> JSExp
+genericEvent opt eventName target (Event eid) =
+  Eval script `Apply` [target, Lam (TriggerEvent eid Null)]
   where
+    script =
+      ("(function(target, trigger){\n\
+      \  function listener(event){\n\
+      \    " <> preventDefaultStmt <> "\n\
+      \    " <> stopPropagationStmt <> "\n\
+      \    trigger();\n\
+      \  }\n\
+      \  target.addEventListener('" <> UnsafeJavaScript eventName <> "', listener);\n\
+      \  return () => target.removeEventListener('" <> UnsafeJavaScript eventName <> "', listener);\n\
+      \})")
     preventDefaultStmt = if opt.prevent_default then "event.preventDefault();" else ""
     stopPropagationStmt = if opt.stop_propagation then "event.stopPropagation();" else ""
 
-unsafeConnectEvent :: Expr -> UnsafeJavaScript -> Event a -> Expr
+unsafeConnectEvent :: JSExp -> UnsafeJavaScript -> Event a -> JSExp
 unsafeConnectEvent target ujs (Event eid) =
   Eval ujs `Apply` [target, Lam (TriggerEvent eid (Arg 0))]
 
-attachHTML :: Expr -> HTML a -> JSM a
-attachHTML rootEl contents = JSM \e -> do
-  e.hte_send $ PushStack rootEl
+attachTo :: JSExp -> HTML a -> JSM a
+attachTo rootEl contents = JSM \e -> do
+  e.ien_command $ PushStack rootEl
   (r, _) <- contents.unHTML Nothing e
-  e.hte_send PopStack
+  e.ien_command PopStack
   pure r
 
-attachToBody :: HTML a -> JSM a
-attachToBody = attachHTML $ Id "document" `Dot` "body"
+attach :: HTML a -> JSM a
+attach = attachTo $ Id "document" `Dot` "body"
 
-saveStackTip :: HTML RefId
-saveStackTip = HTML \s e ->
+saveStackHead :: HTML RefId
+saveStackHead = HTML \s e ->
   case s of
     Nothing -> do
       refId <- newRefId.unJSM e
-      e.hte_send $ AssignRef refId $ PeekStack 0
+      e.ien_command $ AssignRef refId $ PeekStack 0
       return (refId, Just refId)
     Just saved ->
       pure (saved, s)
@@ -199,23 +202,120 @@ data Location = Location {
   -- of the URL.
   hash :: Text
 } deriving stock (Show, Eq, Generic)
-  deriving anyclass (FromValue, ToValue)
+  deriving anyclass (FromJSVal, ToJSVal)
 
 -- https://developer.mozilla.org/en-US/docs/Web/API/Window/popstate_event
-popstateEvent :: Event Location -> Expr
+popstateEvent :: Event Location -> JSExp
 popstateEvent (Event eventId) =
-  Eval
-    "(function(target, trigger){\n\
-    \  function listener(){\n\
-    \    trigger({\n\
-    \      protocol: location.protocol,\n\
-    \      hostname: location.hostname,\n\
-    \      port: location.port,\n\
-    \      pathname: location.pathname,\n\
-    \      search: location.search,\n\
-    \      hash: location.hash\n\
-    \    });\n\
-    \  }\n\
-    \  target.addEventListener('popstate', listener);\n\
-    \  return () => target.removeEventListener('popstate', listener);\n\
-    \})" `Apply` [Id "window", Lam (TriggerEvent eventId (Arg 0))]
+  Eval script `Apply` [Id "window", Lam (TriggerEvent eventId (Arg 0))]
+  where
+    script =
+      "(function(target, trigger){\n\
+      \  function listener(){\n\
+      \    trigger({\n\
+      \      protocol: location.protocol,\n\
+      \      hostname: location.hostname,\n\
+      \      port: location.port,\n\
+      \      pathname: location.pathname,\n\
+      \      search: location.search,\n\
+      \      hash: location.hash\n\
+      \    });\n\
+      \  }\n\
+      \  target.addEventListener('popstate', listener);\n\
+      \  return () => target.removeEventListener('popstate', listener);\n\
+      \})"
+
+dyn :: Dynamic (HTML ()) -> HTML ()
+dyn val = do
+  brackets <- liftJSM insertBrackets
+  scope <- liftJSM newScope
+  initialVal <- liftJSM $ readDyn val
+  let
+    update html = do
+      liftJSM $ clearBrackets brackets
+      html
+    exec h =
+      localScope scope $ customize (Ref brackets) h
+  liftJSM $ exec $ update initialVal
+  liftJSM $ subscribe val \newVal -> do
+    freeScope scope
+    exec $ update newVal
+
+-- | Auxilliary datatype used in 'simpleList' implementation
+data ElemEnv a = ElemEnv {
+  brackets :: RefId,
+  state_var :: DynVar a,
+  elem_scope :: ScopeId
+}
+
+-- | Display dynamic collection of widgets. NOTE: changes in `DynVar
+-- a` do not automatically propagate into the larger state. See
+-- `OverrideVar` and todomvc example to see one way to upstream
+-- changes into the larger state.
+simpleList ::
+  forall a. Dynamic [a] ->
+  (Int -> DynVar a -> HTML ()) ->
+  HTML ()
+simpleList listDyn h = liftJSM do
+  internalStateRef <- liftIO $ newIORef ([] :: [ElemEnv a])
+  brackets <- insertBrackets
+  let
+    exec brackets' scope =
+      localScope scope . customize (Ref brackets')
+    exec1 brackets' = customize (Ref brackets')
+
+    setup :: Int -> [a] -> [ElemEnv a] -> JSM [ElemEnv a]
+    setup idx new existing = case (existing, new) of
+      ([], []) -> return []
+      -- New list is longer, append new elements
+      ([], x:xs) -> do
+        e <- newElem x
+        exec e.brackets e.elem_scope $ h idx e.state_var
+        fmap (e:) $ setup (idx + 1) xs []
+      -- New list is shorter, delete the elements that no longer
+      -- present in the new list
+      (r:rs, []) -> do
+        finalizeElems True (r:rs)
+        return []
+      -- Update existing elements along the way
+      (r:rs, y:ys) -> do
+        writeVar r.state_var y
+        fmap (r:) $ setup (idx + 1) ys rs
+    newElem :: a -> JSM (ElemEnv a)
+    newElem a = do
+      elem_scope <- newScope
+      localScope elem_scope do
+        state_var <- newVar a
+        brackets' <- insertBrackets
+        return ElemEnv {elem_scope, state_var, brackets = brackets'}
+    finalizeElems :: Bool -> [ElemEnv a] -> JSM ()
+    finalizeElems remove = mapM_ \ee -> do
+      when remove $ detachBrackets ee.brackets
+      destroyScope ee.elem_scope
+    updateList :: [a] -> JSM ()
+    updateList new = do
+      eenvs <- liftIO $ readIORef internalStateRef
+      newEenvs <- setup 0 new eenvs
+      liftIO $ writeIORef internalStateRef newEenvs
+  initialVal <- readDyn listDyn
+  exec1 brackets $ liftJSM $ updateList initialVal
+  subscribe listDyn $ exec1 brackets . liftJSM . updateList
+
+insertBrackets :: JSM RefId
+insertBrackets = do
+  brackets <- newRefId
+  jsCmd $ AssignRef brackets InsertBrackets
+  pure brackets
+
+clearBrackets :: RefId -> JSM ()
+clearBrackets rid = jsCmd $ ClearBrackets $ Ref rid
+
+detachBrackets :: RefId -> JSM ()
+detachBrackets rid = jsCmd $ DetachBrackets $ Ref rid
+
+customize :: JSExp -> HTML a -> JSM a
+customize elm action = JSM \e -> do
+  e.ien_command $ PushStack elm
+  (r, _) <- action.unHTML Nothing e
+  e.ien_command PopStack
+  pure r