Initial commit

.gitignore

@@ -0,0 +1 @@
+dist-newstyle

cabal.project

@@ -0,0 +1,22 @@
+packages: .
+allow-newer:
+  react-haskell:void,
+  ghcjs-base,
+  aeson,
+  attoparsec,
+  lens
+
+packages react-haskell
+  flags: +ghcjs
+  build-depends: ghcjs-dom,
+                 ghcjs-base
+
+package reflex-dom
+  flags: -webkit2gtk
+
+
+constraints:
+  --TODO: This should be pinned in reflex-platform
+  --TODO: Make sure to pin both of these
+  --hashable == 1.3.5.0,
+  aeson == 2.0.3.0

default.nix

@@ -0,0 +1,25 @@
+{
+  reflex-platform ? import ./dep/reflex-platform { system = builtins.currentSystem; }
+}: (reflex-platform.project ({ pkgs, thunkSource, ... }: {
+  name = "reflex-react";
+  src = ./.;
+  ghcjs-compiler-nix-name = "ghcjs8107JSString"; #TODO: This must be default
+  compiler-nix-name = "ghc8107Splices"; #TODO: This must be default
+  shells = ps: with ps; [ react ];
+  inputThunks = [
+    {
+      thunk = ./dep/jsaddle;
+      subdirs = [
+        "jsaddle"
+        "jsaddle-warp"
+      ];
+    }
+    ./dep/jsaddle-dom
+  ];
+})).extend (self: super: {
+  shells = super.shells // {
+     ghc = self.shell-driver {
+       crossBuilds = [ ];
+     };
+  };
+})

dep/jsaddle-dom/default.nix

@@ -0,0 +1,2 @@
+# DO NOT HAND-EDIT THIS FILE
+import (import ./thunk.nix)

dep/jsaddle-dom/github.json

@@ -0,0 +1,8 @@
+{
+  "owner": "obsidiansystems",
+  "repo": "jsaddle-dom",
+  "branch": "dylang/jsaddle-core2",
+  "private": false,
+  "rev": "330d5da385b1823b1d5a38eb47f2c4d3aae3639a",
+  "sha256": "1xxwqs3v6q2148bivy2j40029njpv90x83hxdmr2998yakcjlqmk"
+}

dep/jsaddle-dom/thunk.nix

@@ -0,0 +1,12 @@
+# DO NOT HAND-EDIT THIS FILE
+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
+  if !fetchSubmodules && !private then builtins.fetchTarball {
+    url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
+  } else (import (builtins.fetchTarball {
+  url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
+  sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
+}) {}).fetchFromGitHub {
+    inherit owner repo rev sha256 fetchSubmodules private;
+  };
+  json = builtins.fromJSON (builtins.readFile ./github.json);
+in fetch json

dep/jsaddle/default.nix

@@ -0,0 +1,2 @@
+# DO NOT HAND-EDIT THIS FILE
+import (import ./thunk.nix)

dep/jsaddle/github.json

@@ -0,0 +1,8 @@
+{
+  "owner": "obsidiansystems",
+  "repo": "jsaddle",
+  "branch": "ryantrinkle/cors-allow-all-origins",
+  "private": false,
+  "rev": "5dd4e7f0e2534c1a53bb1b7df413f2de0febbcd8",
+  "sha256": "0phn9bw9c20s7hmn9f0zf0ij9y35j2pla7fj2kkjcc473sldnjk3"
+}

dep/jsaddle/thunk.nix

@@ -0,0 +1,12 @@
+# DO NOT HAND-EDIT THIS FILE
+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
+  if !fetchSubmodules && !private then builtins.fetchTarball {
+    url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
+  } else (import (builtins.fetchTarball {
+  url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
+  sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
+}) {}).fetchFromGitHub {
+    inherit owner repo rev sha256 fetchSubmodules private;
+  };
+  json = builtins.fromJSON (builtins.readFile ./github.json);
+in fetch json

dep/reexportsToStubs.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE RecordWildCards #-}
+
+import Distribution.PackageDescription.Parsec
+import Distribution.PackageDescription
+import Distribution.Types.Library
+import Distribution.Types.ModuleReexport
+import Distribution.Verbosity
+import Distribution.ModuleName (components)
+import System.Environment (getArgs)
+import System.Directory (createDirectoryIfMissing)
+import System.FilePath ((</>), (<.>), joinPath, takeDirectory)
+import Data.List.Split (splitOn)
+import Data.List (intercalate)
+
+-- Helper function to convert a module name to a file path
+convertModuleToPath :: String -> FilePath
+convertModuleToPath moduleName = "src" </> joinPath (splitOn "." moduleName) <.> "hs"
+
+-- Function to write a file with the given module structure
+writeModuleFile :: (String, String) -> IO ()
+writeModuleFile (originalModule, newModule) = do
+    let content = unlines
+            [ "module " ++ newModule ++ " (module X) where"
+            , ""
+            , "import " ++ originalModule ++ " as X"
+            ]
+        filePath = convertModuleToPath newModule
+    createDirectoryIfMissing True (takeDirectory filePath)
+    writeFile filePath content
+
+main :: IO ()
+main = do
+    args <- getArgs
+    case args of
+        [fileName] -> do
+            result <- parseCabalFile fileName
+            case result of
+                Left err -> putStrLn $ "Error: " ++ err
+                Right reexports -> mapM_ writeModuleFile reexports
+        _ -> putStrLn "Usage: cabal-file-parser <filename.cabal>"
+
+parseCabalFile :: FilePath -> IO (Either String [(String, String)])
+parseCabalFile filePath = do
+    result <- readGenericPackageDescription silent filePath
+    let maybeMainLib = case condLibrary result of
+            Just (CondNode lib _ _) -> Just lib
+            Nothing -> Nothing
+        subLibs = [lib | (_, CondNode lib _ _) <- condSubLibraries result]
+        libs = maybe subLibs (:subLibs) maybeMainLib
+    return $ case libs of
+        (lib:_) -> Right (extractReexportedModules lib)
+        [] -> Left "No library found in .cabal file."
+
+extractReexportedModules :: Library -> [(String, String)]
+extractReexportedModules lib =
+    map (\ModuleReexport{..} -> (moduleNameString moduleReexportOriginalName, moduleNameString moduleReexportName)) (reexportedModules lib)
+
+moduleNameString = intercalate "." . components

dep/reflex-dom/default.nix

@@ -0,0 +1,2 @@
+# DO NOT HAND-EDIT THIS FILE
+import (import ./thunk.nix)

dep/reflex-dom/github.json

@@ -0,0 +1,8 @@
+{
+  "owner": "reflex-frp",
+  "repo": "reflex-dom",
+  "branch": "dn-jsaddle-core2-4",
+  "private": false,
+  "rev": "4bd2ae77727180d2cd2d4ea4be79ddcb7c39fe10",
+  "sha256": "16l9iw287p9vzdk7w7fdfxm1zsxd158x87z2yk9h5ksvsq5vdfhv"
+}

dep/reflex-dom/thunk.nix

@@ -0,0 +1,12 @@
+# DO NOT HAND-EDIT THIS FILE
+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
+  if !fetchSubmodules && !private then builtins.fetchTarball {
+    url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
+  } else (import (builtins.fetchTarball {
+  url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
+  sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
+}) {}).fetchFromGitHub {
+    inherit owner repo rev sha256 fetchSubmodules private;
+  };
+  json = builtins.fromJSON (builtins.readFile ./github.json);
+in fetch json

dep/reflex-platform/default.nix

@@ -0,0 +1,2 @@
+# DO NOT HAND-EDIT THIS FILE
+import (import ./thunk.nix)

dep/reflex-platform/github.json

@@ -0,0 +1,8 @@
+{
+  "owner": "reflex-frp",
+  "repo": "reflex-platform",
+  "branch": "dn/mars-ghcjs-fixes",
+  "private": false,
+  "rev": "250ff12b4fc340f461413118d365bebaf2024378",
+  "sha256": "0chcaamcwxh0lqrp5kdy4b5kl7ii070kzc2adwnsfnfl34c0fql4"
+}

dep/reflex-platform/thunk.nix

@@ -0,0 +1,12 @@
+# DO NOT HAND-EDIT THIS FILE
+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
+  if !fetchSubmodules && !private then builtins.fetchTarball {
+    url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
+  } else (import (builtins.fetchTarball {
+  url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
+  sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
+}) {}).fetchFromGitHub {
+    inherit owner repo rev sha256 fetchSubmodules private;
+  };
+  json = builtins.fromJSON (builtins.readFile ./github.json);
+in fetch json

dep/reflex/default.nix

@@ -0,0 +1,2 @@
+# DO NOT HAND-EDIT THIS FILE
+import (import ./thunk.nix)

dep/reflex/github.json

@@ -0,0 +1,8 @@
+{
+  "owner": "reflex-frp",
+  "repo": "reflex",
+  "branch": "dn/debugging-06-08-rebased-on-0822",
+  "private": false,
+  "rev": "d492217c586dd1eadbbdbcfe9ccd87eae3009e81",
+  "sha256": "001c9civdpv14sb0fssscgyw8mly7bb7iiw6bh15n339ls01cf8k"
+}

dep/reflex/thunk.nix

@@ -0,0 +1,12 @@
+# DO NOT HAND-EDIT THIS FILE
+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
+  if !fetchSubmodules && !private then builtins.fetchTarball {
+    url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
+  } else (import (builtins.fetchTarball {
+  url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
+  sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
+}) {}).fetchFromGitHub {
+    inherit owner repo rev sha256 fetchSubmodules private;
+  };
+  json = builtins.fromJSON (builtins.readFile ./github.json);
+in fetch json

react.cabal

@@ -0,0 +1,63 @@
+cabal-version:      3.0
+name:               react
+version:            0.1.0.0
+license:            BSD-3-Clause
+license-file:       LICENSE
+author:             Obsidian Systems LLC
+maintainer:         maintainer@obsidian.systems
+category:           Web
+build-type:         Simple
+extra-doc-files:    CHANGELOG.md
+
+common warnings
+    ghc-options: -Wall
+
+library
+  import:           warnings
+  exposed-modules:
+    React
+
+  build-depends:    base
+                  , jsaddle
+                  , jsaddle-dom
+                  , ghcjs-dom
+                  , text
+                  , containers
+                  , mtl
+                  , deepseq
+                  , aeson
+                  , scientific
+                  , bytestring
+                  , stm
+                  , ref-tf
+                  , transformers
+                  , unliftio-core
+                  , exceptions
+                  , async
+                  , primitive
+                  , lens
+                  , ghc-prim
+                  , http-types
+                  , entropy
+                  , base64-bytestring
+                  , witherable
+                  , foreign-store
+                  , dependent-sum
+                  , reflection
+  hs-source-dirs:
+    src
+
+  if impl(ghcjs)
+    build-depends: ghcjs-base == 0.2.*
+                  , ghcjs-prim
+                  -- This is to allow the hashable patches to work
+                  -- the hashable should to be pinned in reflex-platform
+                  , hashable == 1.3.5.0
+  else
+    build-depends: websockets
+                  , wai
+                  , wai-websockets
+                  , warp
+                  , jsaddle-warp
+
+  default-language: Haskell2010

shell.nix

@@ -0,0 +1 @@
+(import ./. {}).shells.ghc

src/React.hs

@@ -0,0 +1,273 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+module React where
+
+import Prelude hiding ((!!))
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import Language.Javascript.JSaddle hiding (Ref)
+import Control.Monad.IO.Class
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.Reader
+import Data.String
+
+#ifndef ghcjs_HOST_OS
+import GHCJS.Prim.Internal (primToJSVal)
+import Data.Coerce (coerce)
+#else
+import GHCJS.Foreign.Callback
+import qualified JavaScript.Array as Array (toListIO, fromListIO)
+#endif
+
+t :: Text -> Text
+t = id
+
+tshow :: Show a => a -> Text
+tshow = T.pack . show
+
+#ifndef ghcjs_HOST_OS
+printJavaScriptException :: JavaScriptException -> JSM ()
+printJavaScriptException (JavaScriptException e) = do
+  s <- e # t "toString" $ ()
+  j <- valToJSON s
+  liftIO $ T.putStrLn $ "Exception: " <> tshow j
+#endif
+
+#ifndef ghcjs_HOST_OS
+instance PToJSVal Text where
+  pToJSVal s = primToJSVal $ PrimVal_String s
+
+instance PToJSVal Int where
+  pToJSVal i = primToJSVal $ PrimVal_Number $ fromIntegral i
+#endif
+
+instance IsString JSVal where
+  fromString = pToJSVal . T.pack
+
+instance ToJSVal v => ToJSVal (Map Text v) where
+  toJSVal m = do
+    o@(Object oVal) <- obj
+    forM_ (Map.toList m) $ \(k, v) -> do
+      (o <# k) =<< toJSVal v
+    pure oVal
+
+consoleLog :: ToJSVal a => a -> JSM JSVal
+consoleLog x = (global ! t "console") # t "log" $ [x]
+
+instance ToJSVal (Component props refVal) where
+  toJSVal (Component f) = toJSVal f
+
+instance PToJSVal (Component props refVal) where
+  pToJSVal (Component f) = pToJSVal f
+
+instance PToJSVal Function where
+  pToJSVal (Function _ o) = pToJSVal o
+
+instance PToJSVal Object where
+  pToJSVal (Object v) = v
+
+newtype Component props refVal = Component { unComponent :: Function' }
+
+newtype Hook a = Hook { unHook :: ReaderT React JSM a }
+  deriving (Functor, Applicative, Monad)
+
+newtype Render a = Render { unRender :: ReaderT React JSM a }
+  deriving (Functor, Applicative, Monad)
+
+-- | An object that contains the React library
+newtype React = React { unReact :: Object }
+
+instance MakeObject React where
+  makeObject = pure . unReact
+
+instance MakeObject (Component props refVal) where
+  makeObject = makeObject . functionObject' . unComponent
+
+newtype Element = Element { unElement :: ReaderT React JSM JSVal }
+
+instance IsString Element where
+  fromString = Element . pure . pToJSVal . T.pack
+
+newtype Tag = Tag { unTag :: JSVal }
+
+instance IsString Tag where
+  fromString = Tag . pToJSVal . T.pack
+
+createElement :: Tag -> Map Text JSVal -> [Element] -> Element
+createElement etag props children = Element $ do
+  react <- ask
+  createdChildren <- mapM unElement children
+  lift $ react # t "createElement" $ [pure $ unTag etag, toJSVal props] <> fmap pure createdChildren
+
+createFragment :: [Element] -> Element
+createFragment = createFragmentWithProps mempty
+
+createFragmentWithProps :: Map Text JSVal -> [Element] -> Element
+createFragmentWithProps props children = Element $ do
+  react <- ask
+  fragmentTag <- lift $ fmap Tag $ react ! t "Fragment"
+  unElement $ createElement fragmentTag props children
+
+--TODO: The Hook section shouldn't have any control flow to it; probably it also shouldn't depend on props except in specific ways
+component :: Hook (JSVal -> Render Element) -> ReaderT React JSM (Component JSVal ())
+component (Hook hook) = do
+  react <- ask
+  f <- lift $ function' $ \_ _ args -> flip runReaderT react $ do
+    render <- hook
+    let props = case args of
+          [] -> jsUndefined
+          arg0 : _ -> arg0
+    e <- unRender $ render props
+    unElement e
+  pure $ Component f
+
+--TODO: Input can be an initializer function rather than value
+--TODO: `set` can take `a -> a` instead of `a`
+useState :: (ToJSVal a, FromJSVal a) => a -> Hook (a, a -> JSM ())
+useState initialValue = Hook $ do
+  react <- ask
+  initialJSVal <- lift $ toJSVal initialValue
+  result <- lift $ (react # t "useState") initialJSVal
+  Just s <- lift $ fromJSVal =<< result !! 0 --TODO: Exception handling
+  setter <- lift $ result !! 1
+  pure
+    ( s
+    , \v' -> void $ call setter nullObject [v']
+    )
+
+useRef :: JSVal -> Hook JSVal
+useRef initialValue = Hook $ do
+  react <- ask
+  lift $ (react # t "useRef") initialValue
+
+useEffect :: (JSVal -> JSVal -> [JSVal] -> JSM JSVal) -> Maybe [JSVal] -> Hook ()
+useEffect f deps = Hook $ do
+  react <- ask
+  Function' _ cb <- lift $ function' f
+  depsArg <- case deps of
+    Nothing -> pure []
+    Just someDeps -> do
+      depsArray <- lift $ toJSVal someDeps
+      pure [depsArray]
+  _ <- lift $ (react # t "useEffect") $ [pToJSVal cb] <> depsArg
+  pure ()
+
+useMemo :: (ToJSVal a, FromJSVal a) => JSM a -> Maybe [JSVal] -> Hook a
+useMemo a deps = Hook $ do
+  react <- ask
+  Function' _ cb <- lift $ function' $ \_ _ _ -> toJSVal =<< a
+  depsArg <- case deps of
+    Nothing -> pure []
+    Just someDeps -> do
+      depsArray <- lift $ toJSVal someDeps
+      pure [depsArray]
+  resultVal <- lift $ (react # t "useMemo") $ [pToJSVal cb] <> depsArg
+  Just result <- lift $ fromJSVal resultVal
+  pure result
+
+useCallback :: ToJSVal result => (JSVal -> JSVal -> [JSVal] -> JSM result) -> Maybe [JSM JSVal] -> Hook JSVal
+useCallback f deps = Hook $ do
+  react <- ask
+  Function' _ cb <- lift $ function' $ \fObj this args -> toJSVal =<< f fObj this args
+  depsArg <- case deps of
+    Nothing -> pure []
+    Just someDeps -> do
+      depsArray <- lift $ toJSVal =<< sequence someDeps
+      pure [depsArray]
+  lift $ (react # t "useCallback") $ [pToJSVal cb] <> depsArg
+
+--------------------------------------------------------------------------------
+-- Not yet supported
+--------------------------------------------------------------------------------
+
+type DispatchFunction a = a -> Effect ()
+
+type Reducer s a = s -> a -> s
+
+useContext :: Context a -> Hook a
+useContext = undefined
+
+data Context a
+
+createContext :: a -> IO (Context a)
+createContext = undefined
+
+provider :: Context a -> a -> Render b -> Render b
+provider = undefined
+
+data Ref a
+
+forwardRef :: (props -> Ref refVal -> Hook (Render ())) -> Component props refVal
+forwardRef = undefined
+
+useImperativeHandle :: Ref a -> Effect a -> Maybe [JSVal] -> Hook ()
+useImperativeHandle = undefined
+
+useReducer :: Reducer s a -> a -> Maybe (a -> a) -> Hook (a, DispatchFunction a)
+useReducer = undefined
+
+useTransition :: Hook (Bool, Effect () -> Effect ())
+useTransition = undefined
+
+useDeferredValue :: a -> Hook a
+useDeferredValue = undefined
+
+useDebugValue :: a -> Maybe (a -> b) -> Hook ()
+useDebugValue = undefined
+
+useId :: Hook Text
+useId = undefined
+
+useSyncExternalStore :: (IO () -> IO (IO ())) -> IO a -> Maybe (IO a) -> Hook ()
+useSyncExternalStore = undefined
+
+newtype Effect a = Effect { unEffect :: JSM a }
+  deriving (Functor, Applicative, Monad)
+
+-- TODO: Add the following in jsaddle
+type JSCallAsFunction' = JSVal      -- ^ Function object
+                     -> JSVal      -- ^ this
+                     -> [JSVal]    -- ^ Function arguments
+                     -> JSM JSVal  -- ^ Return value
+
+function' :: JSCallAsFunction' -- ^ Haskell function to call
+         -> JSM Function'     -- ^ Returns a JavaScript function object that will
+                             --   call the Haskell one when it is called
+#ifdef ghcjs_HOST_OS
+function' f = do
+    callback <- syncCallback2' $ \this args -> do
+        rargs <- Array.toListIO (coerce args)
+        f this this rargs -- TODO pass function object through
+    Function' callback <$> makeFunctionWithCallback' callback
+#else
+function' f = do
+    (cb, f') <- newSyncCallback'' f --TODO: "ContinueAsync" behavior
+    return $ Function' cb $ Object f'
+#endif
+
+#ifdef ghcjs_HOST_OS
+data Function' = Function' {functionCallback' :: Callback (JSVal -> JSVal -> IO JSVal), functionObject' :: Object}
+#else
+data Function' = Function' {functionCallback' :: CallbackId, functionObject' :: Object}
+#endif
+
+#ifdef ghcjs_HOST_OS
+foreign import javascript unsafe "$r = function () { return $1(this, arguments); }"
+    makeFunctionWithCallback' :: Callback (JSVal -> JSVal -> IO JSVal) -> IO Object
+#endif
+
+instance ToJSVal Function' where
+    toJSVal = toJSVal . functionObject'
+
+instance PToJSVal Function' where
+  pToJSVal (Function' _ o) = pToJSVal o