1 files changed, 147 insertions, 0 deletions
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
index 0000000..2f0cce9
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,147 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QualifiedDo #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
+
+module Main where
+
+import Clay qualified as C
+import DOM.HTML.Indexed qualified as I
+import Data.Functor.Coyoneda
+import Data.NT
+import Data.Row
+import Halogen as H
+import Halogen.Component.Debounced
+import Halogen.HTML as HH
+import Halogen.HTML.Events as HE
+import Halogen.HTML.Layout as L
+import Halogen.HTML.Layout.BoxLayout
+import Halogen.HTML.Layout.GridBagLayout
+import Halogen.HTML.Properties as HP
+import Halogen.Subscription qualified as HS
+import Halogen.VDom.DOM.Monad
+import Protolude hiding (log)
+import UnliftIO (MonadUnliftIO)
+
+#if defined(javascript_HOST_ARCH)
+import Halogen.IO.Util as HA
+import Halogen.VDom.Driver (runUI)
+#endif
+
+attachComponent :: IO (HalogenSocket Query Int IO)
+logStr :: Text -> IO ()
+
+#if defined(javascript_HOST_ARCH)
+attachComponent =
+  HA.awaitBody >>= runUI component ()
+logStr = log
+#else
+attachComponent = panic "This module can only be run on JavaScript"
+logStr = putStrLn
+#endif
+
+main :: IO ()
+main = do
+  HalogenSocket {messages} <- attachComponent
+
+  void $ HS.subscribe messages $ \st ->
+    logStr $ "State changed: " <> show st
+
+{-
+forever $ do
+  threadDelay 5_000_000
+  void $ query (IncrementQ ())
+  threadDelay 5_000_000
+  void $ query (DecrementQ ())
+  -}
+
+data Action = Increment Int | Decrement Int | Init
+
+type Slots = ("debounced" .== H.Slot VoidF () ())
+
+data Query a = IncrementQ a | DecrementQ a
+
+component :: forall m. (MonadDOM m, MonadUnliftIO m) => H.Component Query () Int m
+component =
+  H.mkComponent $
+    H.ComponentSpec
+      { initialState,
+        render,
+        eval = H.mkEval $ H.defaultEval {handleAction, handleQuery, initialize = Just Init}
+      }
+  where
+    initialState _ = pure 0
+
+    render :: (MonadDOM m, MonadUnliftIO m) => Int -> H.ComponentHTML Action Slots m
+    render state =
+      L.runLayoutM (defGridBagSettings {rows = 3, cols = 3}) $ L.do
+        L.with (GridBagLayoutConstraints 1 1 2 2) $ L.runLayoutM Vertical $ L.do
+          HH.button [HE.onClick $ const $ Decrement 1] [HH.text "-"]
+          L.if_ (state > 5) $ HH.button [HE.onClick $ const $ Decrement 2] [HH.text "--"]
+          HH.div_ [HH.text $ show state]
+          HH.button [HE.onClick $ const $ Increment 1] [HH.text "+"]
+          L.if_ (state > 5) $ HH.button [HE.onClick $ const $ Increment 2] [HH.text "++"]
+          slot_ "debounced" () debComp ()
+          HH.div_ [HH.text "Test sentinel element"]
+          L.end
+
+        L.with (GridBagLayoutConstraints 3 3 1 1) $
+          HH.div [HP.style $ C.border (C.px 2) C.solid C.black] [HH.text "Banner!"]
+
+        L.end
+
+    handleQuery = \case
+      IncrementQ cb -> do
+        modify (+ 1)
+        get >>= H.raise
+        pure $ Just cb
+      DecrementQ cb -> do
+        modify (subtract 1)
+        get >>= H.raise
+        pure $ Just cb
+
+    handleAction = \case
+      Init ->
+        lift $ log "Initialized"
+      Increment n -> do
+        modify (+ n)
+        get >>= H.raise
+      Decrement n -> do
+        modify (subtract n)
+        get >>= H.raise
+
+---------------------------------------
+
+newtype DebChanged = DebChanged Text
+
+debComp :: (MonadDOM m, MonadUnliftIO m) => Component VoidF () () m
+debComp = unsafeMkDebouncedComponent 0.5 $ ComponentSpec {initialState, render, eval}
+  where
+    initialState _ = pure ""
+
+    render txt = runLayoutM Vertical $ L.do
+      HH.div_ [HH.text "The text below is debounced"]
+      HH.div_ [HH.text $ "Input content: " <> txt]
+      HH.input
+        [ HP.type_ I.InputText,
+          HP.value txt,
+          HP.style $ C.width C.auto,
+          HE.onInputValueChange $ Just . DebChanged
+        ]
+      L.end
+
+    eval = NT $ \case
+      Initialize a -> pure a
+      Finalize a -> pure a
+      Receive _i a -> pure a
+      Action (DebChanged str) a ->
+        put str $> a
+      Query (Coyoneda _req _fct) _f -> panic "Void2"