Clickable ffi

default.nix

@@ -1,18 +1,49 @@
 { pkgs ? import (builtins.fetchTarball {
-    url = "https://github.com/NixOS/nixpkgs/archive/3e2237222b33d8b5754cc1cc3ee155cadd76770d.tar.gz";
+    url = "https://github.com/NixOS/nixpkgs/archive/f4429fde23e1fb20ee27f264e74c28c619d2cebb.tar.gz";
 }) {}
-}: {
-  shell = {
-    javascript = pkgs.mkShell {
-      buildInputs = [
-        pkgs.pkgsCross.ghcjs.buildPackages.haskell.compiler.ghcHEAD
-        pkgs.haskellPackages.cabal-install
-      ];
+}:
+
+let
+  inherit (pkgs.haskell.lib) doJailbreak;
+
+  haskellPackages = pkgs.haskell.packages.ghcHEAD.override {
+    overrides = self: super: {
+      mkDerivation = args: super.mkDerivation ({
+        doCheck = false;
+        doBenchmark = false;
+        doHoogle = true;
+        doHaddock = true;
+        enableLibraryProfiling = false;
+        enableExecutableProfiling = false;
+      } // args);
+
+      htmlt = self.callCabal2nix "htmlt" ./. {};
+
+
+      # th-compat = self.callCabal2nix "th-compat" ./packages/th-compat {};
+      tagged = self.callCabal2nix "tagged" ../fullstack-app/packages/tagged {};
+      th-abstraction = self.callCabal2nix "th-abstraction" ../fullstack-app/packages/th-abstraction {};
+      vector = self.callCabal2nix "vector" ../fullstack-app/packages/vector/vector {};
+      vector-stream = self.callCabal2nix "vector-stream" ../fullstack-app/packages/vector/vector-stream {};
+      unordered-containers = self.callCabal2nix "unordered-containers" ../fullstack-app/packages/unordered-containers {};
+      # text-short = self.callCabal2nix "text-short" ./packages/text-short {};
+      generic-deriving = doJailbreak super.generic-deriving;
+      bifunctors = doJailbreak super.bifunctors;
+      semigroupoids = doJailbreak super.semigroupoids;
+      th-lift = doJailbreak super.th-lift;
+      th-expand-syns = doJailbreak super.th-expand-syns;
+      invariant = doJailbreak super.invariant;
+      free = doJailbreak super.free;
+      th-compat = doJailbreak super.th-compat;
+      lens = doJailbreak super.lens;
     };
-    x86_64 = pkgs.mkShell {
-      buildInputs = [
-        pkgs.haskell.compiler.ghcHEAD
-      ];
+  };
+
+  result = {
+    pkgs = haskellPackages;
+    shell = pkgs.mkShell {
+      inputsFrom = [haskellPackages.htmlt.env];
     };
   };
-}
+in
+  result

examples/charts/App.hs

@@ -0,0 +1,55 @@
+module App where
+
+import Charts qualified as Charts
+import Control.Monad.State
+import Data.Proxy
+import Data.Text (Text)
+import Data.Text qualified as Text
+import GHC.Generics
+import Clickable
+import Clickable.FFI
+
+
+data AppInstance = AppInstance
+  { state_var :: DynVar AppTab
+  } deriving (Generic)
+
+data AppTab
+  = ChartsTab Charts.ChartInstance
+  | HelpTab
+
+new :: ClickM AppInstance
+new = do
+  charts_instance <- Charts.new
+  state_var <- newVar $ ChartsTab charts_instance
+  return AppInstance
+    { state_var
+    }
+
+html :: AppInstance -> HtmlM ()
+html self = do
+  el "style" $ text styles
+  div_ do
+    button_ do
+      text "Open Charts"
+      on @"click" do
+        inst <- Charts.new
+        modifyVar self.state_var $ const $ ChartsTab inst
+    button_ do
+      text "Open Help"
+      on @"click" $ modifyVar self.state_var $ const HelpTab
+  dyn $ self.state_var `mapVar` \case
+    ChartsTab inst -> Charts.html inst
+    HelpTab -> p_ $ text
+      "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod \
+      \tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim \
+      \veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea \
+      \commodo consequat. Duis aute irure dolor in reprehenderit in voluptate \
+      \velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint \
+      \occaecat cupidatat non proident, sunt in culpa qui officia deserunt \
+      \mollit anim id est laborum."
+
+styles :: Text
+styles = "\
+  \ \
+  \ "

examples/charts/Charts.hs

@@ -0,0 +1,103 @@
+module Charts where
+
+import Data.Proxy
+import Control.Monad.State
+import Data.Text (Text)
+import Data.Text qualified as Text
+import GHC.Generics
+
+import Clickable
+import Clickable.FFI
+import PairSelector qualified as PairSelector
+
+-------------------------------------------------------
+-- EXAMPLE OF APPLICATION FEATURING FINANCIAL CHARTS --
+-------------------------------------------------------
+
+data ChartState = ChartState
+  { main_transform :: Transform2D
+  , mouse_position :: Point
+  , counter :: Int
+  } deriving (Show, Eq, Generic)
+
+data ChartInstance = ChartInstance
+  { state_var :: DynVar ChartState
+  , pair_selector_instance :: DynVar PairSelector.PairSelectorState
+  } deriving (Generic)
+
+new :: ClickM ChartInstance
+new = do
+  pair_selector_instance <- PairSelector.new
+  state_var <- newVar ChartState
+    { main_transform = Transform2D 0 0 0 0
+    , mouse_position = Point 0 0
+    , counter = 0
+    }
+  return ChartInstance {state_var, pair_selector_instance}
+
+html :: ChartInstance -> HtmlM ()
+html self = do
+  el "style" $ text styles
+  div_ [class_ "Charts-root"] do
+    h1_ $ text "Canvas with candle chart"
+    div_ do
+      PairSelector.html self.pair_selector_instance
+    div_ do
+      button_ do
+        text "Clickable this button"
+        on @"click" do
+          modifyVar self.state_var \s -> s {counter = s.counter + 1 }
+      button_ do
+        text "Print state"
+        on @"click" do
+          s <- readVar self.state_var
+          consoleLog $ Text.pack $ show s
+      span_ [] $ dynText $ self.state_var `mapVar` \s ->
+        "You clicked " <> Text.pack (show s.counter) <> " times"
+    canvas_ [class_ "Charts-canvas"] $ return ()
+
+styles :: Text
+styles = "\
+  \.Charts-root {\
+  \  max-width: 900;\
+  \  width: 100%\
+  \  padding: 16px;\
+  \  margin: 0 auto;\
+  \}\
+  \.Charts-canvas {\
+  \  width: 100%;\
+  \  height: 550px;\
+  \  border: solid 1px black;\
+  \}\
+  \ "
+
+data Transform2D = Transform2D
+  { a :: Double -- ^ X scaling
+  , c :: Double -- ^ X translation
+  , e :: Double -- ^ Y scaling
+  , f :: Double -- ^ Y translation
+  } deriving (Show, Eq, Generic)
+
+data Point = Point
+  { point_x :: Double
+  , point_y :: Double
+  } deriving (Eq, Show, Generic)
+
+-- setMouseCoords :: Point -> Edit ChartState
+-- setMouseCoords p = Fld (Proxy @"mouse_position") (Ins p)
+
+
+-- moveScreen :: Double -> Jet ChartState -> Jet ChartState
+-- moveScreen dir old =
+--   let
+--     beg = negate old.position.main_transform.c / old.position.main_transform.a
+--     end = (w - old.position.main_transform.c) / old.position.main_transform.a
+--     inc = (end - beg) * dir
+--     w = 1000
+--     c = old.position.main_transform.c -
+--       (inc * old.position.main_transform.a)
+--     new = old.position
+--       { main_transform = old.position.main_transform {c}
+--       }
+--   in
+--     Jet new (Fld (Proxy @"main_transform") (Fld (Proxy @"c") (Ins c)) : old.velocity)

examples/charts/PairSelector.hs

@@ -0,0 +1,45 @@
+module PairSelector where
+
+import Data.Proxy
+import Data.Text (Text)
+import Data.Text qualified as Text
+import Data.Function hiding (on)
+import GHC.Generics
+
+import Clickable
+
+data TradingPair = TradingPair
+  { base :: Text
+  , quote :: Text
+  , exchange :: Text
+  } deriving (Show, Eq, Generic)
+
+data PairSelectorState = PairSelectorState
+  { selected_pair :: Maybe TradingPair
+  , options :: [TradingPair]
+  } deriving (Show, Eq, Generic)
+
+new :: ClickM (DynVar PairSelectorState)
+new =
+  newVar PairSelectorState
+    { selected_pair = Nothing
+    , options = []
+    }
+
+html :: DynVar PairSelectorState -> HtmlM ()
+html self = do
+  el "style" $ text styles
+  div_ [class_ "PairSelector-root"] do
+    button_ do
+      text "Select pair"
+      on @"click" $ modifyVar self \s -> case s.selected_pair of
+        Just _ -> s {selected_pair = Nothing}
+        Nothing -> s {selected_pair = Just $ TradingPair "BTC" "USDT" "MEXC"}
+    span_ $ dynText $ self `mapVar` \s -> s.selected_pair & maybe
+      "Nothing selected"
+      (("Selected pair: " <>) . Text.pack . show)
+
+styles :: Text
+styles = "\
+  \ \
+  \ "

examples/charts/charts.hs

@@ -0,0 +1,11 @@
+import Control.Monad.Reader
+import Clickable
+import "this" App qualified as App
+
+main :: IO ()
+main = return ()
+
+foreign export ccall wasm_main :: IO ()
+wasm_main = do
+  _ <- attach $ liftClickM App.new >>= App.html
+  return ()