Add benchmarks

.gitignore

@@ -24,5 +24,3 @@ locals.nix
 node_modules
 package.json
 yarn.lock
-benchmarks.jsexe
-benchmarks

8.10.7.nix

@@ -41,16 +41,21 @@ let
     foundation = cure super.foundation;
     basement = cure super.basement;
     gauge = cure super.gauge;
+    http-api-data = cure super.http-api-data;
+    network-uri = cure super.network-uri;
   };
 
-  ghcjsPackages = pkgs.haskell.packages.ghcjs810.override {
+  mkPackages = self: super: super.override {
     overrides = lib.composeExtensions (self: super:
       lib.mapAttrs (k: v: self.callCabal2nix k v {}) (extraPackages super)
     ) overrides;
-  };
+  } // {
-in
-  ghcjsPackages // {
     shell = pkgs.mkShell {
-      inputsFrom = [ghcjsPackages.htmlt.env];
+      inputsFrom = [self.htmlt.env];
     };
-  }
+  };
+
+in rec {
+  ghcjs = mkPackages ghcjs pkgs.haskell.packages.ghcjs810;
+  ghc = mkPackages ghc pkgs.haskellPackages;
+}

8.6.0.nix

@@ -7,31 +7,43 @@ let
   inherit (pkgs) lib haskell;
   pkgs = import nixpkgs {};
   reflexPlatform = import reflexPlatformSrc {};
+  cure = p: haskell.lib.dontCheck (haskell.lib.doJailbreak p);
 
   reflexPlatformSrc = builtins.fetchGit {
     url = "https://github.com/reflex-frp/reflex-platform.git";
     rev = "f019863c21ee85498e6a6e0072e617b2462b70ed";
   };
 
+  ghcjsBaseDummySrc = builtins.fetchGit {
+    url = "git@github.com:lagunoff/ghcjs-base-dummy.git";
+    rev = "ec549b970fc7d0f8031e8f2fc943dac89e443f69";
+  };
+
   extraPackages = super: {
     gauge = builtins.fetchGit {
       url = "https://github.com/vincenthz/hs-gauge.git";
       rev = "3069be4752a4c0f2ac310e66b44d7929763da19c";
     };
+  } // lib.optionalAttrs (!(super.ghc.isGhcjs or false)) {
+    ghcjs-base = ghcjsBaseDummySrc;
   };
 
   overrides = self: super: {
     htmlt = self.callCabal2nixWithOptions "htmlt" ./. "-fexamples" {};
+  } // lib.optionalAttrs (!(super.ghc.isGhcjs or false)) {
+    ghcjs-base = cure super.ghcjs-base;
   };
 
-  ghcjsPackages = reflexPlatform.ghcjs.override {
+  mkPackages = self: super: super.override {
     overrides = lib.composeExtensions (self: super:
       lib.mapAttrs (k: v: self.callCabal2nix k v {}) (extraPackages super)
     ) overrides;
-  };
+  } // {
-in
-  ghcjsPackages // {
     shell = pkgs.mkShell {
-      inputsFrom = [ghcjsPackages.htmlt.env];
+      inputsFrom = [self.htmlt.env];
     };
-  }
+  };
+in rec {
+  ghcjs = mkPackages ghcjs reflexPlatform.ghcjs;
+  ghc = mkPackages ghc pkgs.haskellPackages;
+}

benchmarks/benchmarks.hs

@@ -0,0 +1,28 @@
+import Control.Monad
+import Control.Monad.IO.Class
+import Gauge
+import HtmlT
+
+main = defaultMain
+  [ bench "benchDynamics 100 10 10" $ whnfIO (benchDynamics 100 10 10)
+  , bench "benchDynamics 10 100 10" $ whnfIO (benchDynamics 10 100 10)
+  , bench "benchDynamics 10 10 100" $ whnfIO (benchDynamics 10 10 100)
+  ]
+
+benchDynamics :: Int -> Int -> Int -> IO ()
+benchDynamics eventsNum subsNum fireNum = startReactive do
+  -- Create a bunch of 'DynRef's
+  refsList <- forM [1..eventsNum] $ const (newRef (0 :: Int))
+  outputRef <- newRef Nothing
+  -- Sum all of their values into a single 'Dynamic' using
+  -- 'Applicative' instance
+  let sumDyn = fmap sum . sequenceA . fmap fromRef $ refsList
+  -- Attach subsNum amount of subscriptions
+  sequence_ $ take subsNum $ repeat $ subscribeAndWrite sumDyn outputRef
+  -- And fire modification event for each 'DynRef' fireNum times
+  forM_ [1..fireNum] $ const $
+    forM_ refsList $ liftIO . sync . flip modifyRef succ
+  where
+    subscribeAndWrite from to = void $ subscribe (dynamic_updates from) $
+      writeRef to . Just
+    startReactive act = newReactiveEnv >>= flip runReactiveEnvT act

htmlt.cabal

@@ -94,12 +94,14 @@ library
   build-depends:
     base,
     ghcjs-base,
-    ghcjs-prim,
     bytestring,
     containers,
     exceptions,
     mtl,
     text
+  if impl(ghcjs)
+    build-depends:
+      ghcjs-prim,
 
 executable htmlt-hello
   import: htmlt-common         
@@ -128,7 +130,6 @@ executable htmlt-todomvc
     generic-lens,
     mtl,
     ghcjs-base,
-    ghcjs-prim,
     htmlt,
     text,
   if !flag(examples)
@@ -150,7 +151,6 @@ executable htmlt-simple-routing
     generic-lens,
     mtl,
     ghcjs-base,
-    ghcjs-prim,
     network-uri,
     http-api-data,
     htmlt,
@@ -158,3 +158,15 @@ executable htmlt-simple-routing
   if !flag(examples)
     buildable: False
   
+executable htmlt-benchmarks
+  import: htmlt-common         
+  main-is: benchmarks.hs
+  hs-source-dirs: ./benchmarks/
+  build-depends:
+    base,
+    htmlt,
+    text,
+    gauge,
+  if !flag(examples)
+    buildable: False
+  

shell.nix

@@ -1 +1 @@
-(import ./8.6.0.nix {}).shell
+(import ./8.6.0.nix {}).ghcjs.shell

src/HtmlT/Types.hs

@@ -11,7 +11,6 @@ import GHCJS.Types
 import HtmlT.Event
 
 -- | HtmlT is nothing more than just a newtype over ReaderT HtmlEnv,
--- that's all!
 newtype HtmlT m a = HtmlT {unHtmlT :: ReaderT HtmlEnv m a}
   deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader HtmlEnv
     , MonadFix, MonadCatch, MonadThrow, MonadMask, MonadTrans)