init

basic haskell-halogen project, `app/Main.hs` from
Swordlash/haskell-halogen@0db1410e5bf2a383148fa067ae46a986a87c30c4

13 files changed, 501 insertions, 0 deletions

diff --git a/.envrc b/.envrc
new file mode 100644
index 0000000..1d953f4
--- /dev/null
+++ b/.envrc
@@ -0,0 +1 @@
+use nix
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..0424d86
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,2 @@
+/dist-newstyle
+/.emcache
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..dd902f4
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,26 @@
+Copyright (c) 2025, Alexander Foremny
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the
+   distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..168a8b5
--- /dev/null
+++ b/README.md
@@ -0,0 +1,14 @@
+# achat
+
+## cabal (development)
+
+```console
+cabal build
+firefox dist-newstyle/build/javascript-ghcjs/ghc-9.10.1/achat-0.1.0.0/x/achat/build/achat/achat.jsexe/index.html
+```
+
+## nix (package)
+
+```console
+firefox $(nix-build --no-out-link -A achat)/share/achat.jsexe/index.html 
+```
diff --git a/achat.cabal b/achat.cabal
new file mode 100644
index 0000000..766bf67
--- /dev/null
+++ b/achat.cabal
@@ -0,0 +1,22 @@
+cabal-version: 3.4
+name:          achat
+version:       0.1.0.0
+license:       BSD-2-Clause
+license-file:  LICENSE
+maintainer:    aforemny@posteo.de
+author:        Alexander Foremny
+category:      Web
+build-type:    Simple
+
+executable achat
+    main-is:          Main.hs
+    hs-source-dirs:   app
+    default-language: Haskell2010
+    build-depends:
+        base,
+        clay,
+        haskell-halogen-core,
+        kan-extensions,
+        protolude,
+        row-types,
+        unliftio
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"
diff --git a/app/index.html b/app/index.html
new file mode 100644
index 0000000..a8e9c48
--- /dev/null
+++ b/app/index.html
@@ -0,0 +1,11 @@
+<!DOCTYPE html>
+<html>
+  <head>
+    <meta charset="utf-8">
+    <link rel='stylesheet' href="base.css" />
+    <link rel='stylesheet' href="index.css" />
+  </head>
+  <body>
+    <script src='all.js'></script>
+  </body>
+</html>
diff --git a/cabal.project b/cabal.project
new file mode 100644
index 0000000..4a0bae6
--- /dev/null
+++ b/cabal.project
@@ -0,0 +1,3 @@
+packages: .
+with-compiler: javascript-unknown-ghcjs-ghc
+with-hc-pkg: javascript-unknown-ghcjs-ghc-pkg
diff --git a/default.nix b/default.nix
new file mode 100644
index 0000000..9c7a8a1
--- /dev/null
+++ b/default.nix
@@ -0,0 +1,27 @@
+{ pkgs ? import sources.nixpkgs {
+    overlays = [
+      (import ./pkgs { inherit (pkgs.haskell) lib; })
+    ];
+  }
+, sources ? import ./nix/sources.nix
+}:
+let
+  ghc = "ghc910";
+  haskellPackages = pkgs.pkgsCross.ghcjs.haskell.packages.${ghc};
+in
+rec {
+  inherit haskellPackages;
+  inherit (haskellPackages) achat;
+  shell = haskellPackages.shellFor {
+    packages = _: [
+      haskellPackages.achat
+    ];
+    nativeBuildInputs = [
+      pkgs.haskell.packages.${ghc}.cabal-install
+      pkgs.haskell.packages.${ghc}.ormolu
+    ];
+    shellHook = ''
+      export EM_CACHE="${toString ./.}/.emcache" # nixos/nixpkgs#282509
+    '';
+  };
+}
diff --git a/nix/sources.json b/nix/sources.json
new file mode 100644
index 0000000..57e75d7
--- /dev/null
+++ b/nix/sources.json
@@ -0,0 +1,26 @@
+{
+    "haskell-halogen": {
+        "branch": "master",
+        "description": "Port of purescript-halogen to Haskell",
+        "homepage": null,
+        "owner": "Swordlash",
+        "repo": "haskell-halogen",
+        "rev": "0db1410e5bf2a383148fa067ae46a986a87c30c4",
+        "sha256": "0zrnixngfighngza2y3ps8pj0v7pdaflspiyi7742k691q17vbg8",
+        "type": "tarball",
+        "url": "https://github.com/Swordlash/haskell-halogen/archive/0db1410e5bf2a383148fa067ae46a986a87c30c4.tar.gz",
+        "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
+    },
+    "nixpkgs": {
+        "branch": "nixpkgs-unstable",
+        "description": "Nix Packages collection",
+        "homepage": null,
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "632f04521e847173c54fa72973ec6c39a371211c",
+        "sha256": "16l9l6jbx2xy751p2nbz14fd9qgk9qsns38pihr5g12fk7361fsi",
+        "type": "tarball",
+        "url": "https://github.com/NixOS/nixpkgs/archive/632f04521e847173c54fa72973ec6c39a371211c.tar.gz",
+        "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
+    }
+}
diff --git a/nix/sources.nix b/nix/sources.nix
new file mode 100644
index 0000000..fe3dadf
--- /dev/null
+++ b/nix/sources.nix
@@ -0,0 +1,198 @@
+# This file has been generated by Niv.
+
+let
+
+  #
+  # The fetchers. fetch_<type> fetches specs of type <type>.
+  #
+
+  fetch_file = pkgs: name: spec:
+    let
+      name' = sanitizeName name + "-src";
+    in
+    if spec.builtin or true then
+      builtins_fetchurl { inherit (spec) url sha256; name = name'; }
+    else
+      pkgs.fetchurl { inherit (spec) url sha256; name = name'; };
+
+  fetch_tarball = pkgs: name: spec:
+    let
+      name' = sanitizeName name + "-src";
+    in
+    if spec.builtin or true then
+      builtins_fetchTarball { name = name'; inherit (spec) url sha256; }
+    else
+      pkgs.fetchzip { name = name'; inherit (spec) url sha256; };
+
+  fetch_git = name: spec:
+    let
+      ref =
+        spec.ref or (
+          if spec ? branch then "refs/heads/${spec.branch}" else
+          if spec ? tag then "refs/tags/${spec.tag}" else
+          abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"
+        );
+      submodules = spec.submodules or false;
+      submoduleArg =
+        let
+          nixSupportsSubmodules = builtins.compareVersions builtins.nixVersion "2.4" >= 0;
+          emptyArgWithWarning =
+            if submodules
+            then
+              builtins.trace
+                (
+                  "The niv input \"${name}\" uses submodules "
+                  + "but your nix's (${builtins.nixVersion}) builtins.fetchGit "
+                  + "does not support them"
+                )
+                { }
+            else { };
+        in
+        if nixSupportsSubmodules
+        then { inherit submodules; }
+        else emptyArgWithWarning;
+    in
+    builtins.fetchGit
+      ({ url = spec.repo; inherit (spec) rev; inherit ref; } // submoduleArg);
+
+  fetch_local = spec: spec.path;
+
+  fetch_builtin-tarball = name: throw
+    ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`.
+        $ niv modify ${name} -a type=tarball -a builtin=true'';
+
+  fetch_builtin-url = name: throw
+    ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`.
+        $ niv modify ${name} -a type=file -a builtin=true'';
+
+  #
+  # Various helpers
+  #
+
+  # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695
+  sanitizeName = name:
+    (
+      concatMapStrings (s: if builtins.isList s then "-" else s)
+        (
+          builtins.split "[^[:alnum:]+._?=-]+"
+            ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name)
+        )
+    );
+
+  # The set of packages used when specs are fetched using non-builtins.
+  mkPkgs = sources: system:
+    let
+      sourcesNixpkgs =
+        import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; };
+      hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;
+      hasThisAsNixpkgsPath = <nixpkgs> == ./.;
+    in
+    if builtins.hasAttr "nixpkgs" sources
+    then sourcesNixpkgs
+    else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then
+      import <nixpkgs> { }
+    else
+      abort
+        ''
+          Please specify either <nixpkgs> (through -I or NIX_PATH=nixpkgs=...) or
+          add a package called "nixpkgs" to your sources.json.
+        '';
+
+  # The actual fetching function.
+  fetch = pkgs: name: spec:
+
+    if ! builtins.hasAttr "type" spec then
+      abort "ERROR: niv spec ${name} does not have a 'type' attribute"
+    else if spec.type == "file" then fetch_file pkgs name spec
+    else if spec.type == "tarball" then fetch_tarball pkgs name spec
+    else if spec.type == "git" then fetch_git name spec
+    else if spec.type == "local" then fetch_local spec
+    else if spec.type == "builtin-tarball" then fetch_builtin-tarball name
+    else if spec.type == "builtin-url" then fetch_builtin-url name
+    else
+      abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}";
+
+  # If the environment variable NIV_OVERRIDE_${name} is set, then use
+  # the path directly as opposed to the fetched source.
+  replace = name: drv:
+    let
+      saneName = stringAsChars (c: if (builtins.match "[a-zA-Z0-9]" c) == null then "_" else c) name;
+      ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";
+    in
+    if ersatz == "" then drv else
+      # this turns the string into an actual Nix path (for both absolute and
+      # relative paths)
+    if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}";
+
+  # Ports of functions for older nix versions
+
+  # a Nix version of mapAttrs if the built-in doesn't exist
+  mapAttrs = builtins.mapAttrs or (
+    f: set: with builtins;
+    listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set))
+  );
+
+  # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295
+  range = first: last: if first > last then [ ] else builtins.genList (n: first + n) (last - first + 1);
+
+  # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257
+  stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1));
+
+  # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269
+  stringAsChars = f: s: concatStrings (map f (stringToCharacters s));
+  concatMapStrings = f: list: concatStrings (map f list);
+  concatStrings = builtins.concatStringsSep "";
+
+  # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331
+  optionalAttrs = cond: as: if cond then as else { };
+
+  # fetchTarball version that is compatible between all the versions of Nix
+  builtins_fetchTarball = { url, name ? null, sha256 }@attrs:
+    let
+      inherit (builtins) lessThan nixVersion fetchTarball;
+    in
+    if lessThan nixVersion "1.12" then
+      fetchTarball ({ inherit url; } // (optionalAttrs (name != null) { inherit name; }))
+    else
+      fetchTarball attrs;
+
+  # fetchurl version that is compatible between all the versions of Nix
+  builtins_fetchurl = { url, name ? null, sha256 }@attrs:
+    let
+      inherit (builtins) lessThan nixVersion fetchurl;
+    in
+    if lessThan nixVersion "1.12" then
+      fetchurl ({ inherit url; } // (optionalAttrs (name != null) { inherit name; }))
+    else
+      fetchurl attrs;
+
+  # Create the final "sources" from the config
+  mkSources = config:
+    mapAttrs
+      (
+        name: spec:
+          if builtins.hasAttr "outPath" spec
+          then
+            abort
+              "The values in sources.json should not have an 'outPath' attribute"
+          else
+            spec // { outPath = replace name (fetch config.pkgs name spec); }
+      )
+      config.sources;
+
+  # The "config" used by the fetchers
+  mkConfig =
+    { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null
+    , sources ? if sourcesFile == null then { } else builtins.fromJSON (builtins.readFile sourcesFile)
+    , system ? builtins.currentSystem
+    , pkgs ? mkPkgs sources system
+    }: rec {
+      # The sources, i.e. the attribute set of spec name to spec
+      inherit sources;
+
+      # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers
+      inherit pkgs;
+    };
+
+in
+mkSources (mkConfig { }) // { __functor = _: settings: mkSources (mkConfig settings); }
diff --git a/pkgs/default.nix b/pkgs/default.nix
new file mode 100644
index 0000000..b46e6f8
--- /dev/null
+++ b/pkgs/default.nix
@@ -0,0 +1,23 @@
+{ lib
+, sources ? import ../nix/sources.nix
+, ...
+}:
+(self: super: {
+  haskell = super.haskell // {
+    packageOverrides = self: super: {
+      achat = (self.callCabal2nix "achat" ../. { }).overrideAttrs (_: {
+        postInstall = ''
+          mkdir -p $out/share
+          cp -a ./dist/build/achat/achat.jsexe $out/share
+        '';
+      });
+      haskell-halogen-core = lib.dontCheck (self.callCabal2nix "haskell-halogen-core" sources.haskell-halogen { });
+      protolude = lib.dontHaddock (
+        lib.appendConfigureFlags (lib.doJailbreak super.protolude) [
+          "--ghc-option=-fno-safe-haskell"
+          "--ghc-option=-fno-warn-x-partial"
+        ]);
+      clay = self.callHackage "clay" "0.15.0" { };
+    };
+  };
+})
diff --git a/shell.nix b/shell.nix
new file mode 100644
index 0000000..a6bdf20
--- /dev/null
+++ b/shell.nix
@@ -0,0 +1 @@
+(import ./. { }).shell