react (empty) → 0.1.0.0

raw patch · 11 files changed

+424/−0 lines, 11 filesdep +basedep +containersdep +ghcjs-base

Dependencies added: base, containers, ghcjs-base, ghcjs-prim, hashable, jsaddle, jsaddle-warp, mtl, template-haskell, text

Files

CHANGELOG.md +5/−0
LICENSE +30/−0
react.cabal +56/−0
src/React.hs +9/−0
src/React/Component.hs +27/−0
src/React/Element.hs +25/−0
src/React/Export.hs +63/−0
src/React/Hook.hs +68/−0
src/React/JSaddle.hs +89/−0
src/React/Misc.hs +11/−0
src/React/Types.hs +41/−0

+ CHANGELOG.md view

@@ -0,0 +1,5 @@+# Revision history for react++## 0.1.0.0 -- 2023-07-03++* Support for writing basic React widgets in Haskell

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2023, Obsidian Systems LLC++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of Obsidian Systems LLC nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++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.

+ react.cabal view

@@ -0,0 +1,56 @@+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+synopsis:           Create React components in Haskell+description:+  This library provides bindings to React that allow you to write components in+  Haskell.  Typically, these components will be compiled with GHCJS to produce+  JavaScript for inclusion in a React application.++common warnings+    ghc-options: -Wall -Wunused-packages++library+  import:           warnings+  exposed-modules:+    React+    React.Component+    React.Element+    React.Export+    React.Hook+    React.JSaddle+    React.Misc+    React.Types++  build-depends:+    base                               >= 4.14.3 && < 4.15,+    containers                         >= 0.6.5 && < 0.7,+    jsaddle                            >= 0.9.8 && < 0.10,+    template-haskell                   >= 2.16.0 && < 2.17,+    text                               >= 1.2.4 && < 1.3,+    mtl                                >= 2.2.2 && < 2.3+  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: jsaddle-warp >= 0.9.8 && < 0.10++  default-language: Haskell2010+  default-extensions:+    FlexibleInstances+    GeneralizedNewtypeDeriving+    LambdaCase+    OverloadedStrings

+ src/React.hs view

@@ -0,0 +1,9 @@+module React (module X) where++import React.Component as X+import React.Element as X+import React.Export as X+import React.Hook as X+import React.JSaddle as X+import React.Misc as X+import React.Types as X

+ src/React/Component.hs view

@@ -0,0 +1,27 @@+module React.Component where++import Control.Monad.Except+import Control.Monad.Reader+import Language.Javascript.JSaddle hiding (Ref)++import React.JSaddle+import React.Types++--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+  :: FromJSVal props+  => (props -> Hook Element)+  -> ReaderT React JSM (Component props ())+component hook = do+  react <- ask+  f <- lift $ function' $ \_ _ args -> flip runReaderT react $ do+    let propsVal = case args of+          [] -> jsUndefined+          arg0 : _ -> arg0+    props <- liftJSM $ fromJSVal propsVal >>= \case+      Nothing -> fail "Invalid props"+      Just props -> pure props+    e <- unHook $ hook props+    unElement e+  pure $ Component f+

+ src/React/Element.hs view

@@ -0,0 +1,25 @@+module React.Element where++import Control.Monad.Except+import Control.Monad.Reader+import Data.Map (Map)+import Data.Text (Text)+import Language.Javascript.JSaddle hiding (Ref)++import React.Misc+import React.Types++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

+ src/React/Export.hs view

@@ -0,0 +1,63 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+module React.Export where++import Control.Monad.Reader as MTL+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as T+import Language.Haskell.TH+import Language.Haskell.TH.Syntax as TH+import Language.Javascript.JSaddle++import React.Misc+import React.JSaddle ()+import React.Types++#ifndef ghcjs_HOST_OS+import Control.Monad.Except+import qualified Data.Text.IO as T+import Language.Javascript.JSaddle.Warp+#endif++mainExportsToJS :: [Name] -> Q [Dec]+mainExportsToJS names = [d|+    main :: IO ()+    main = exportToJSIO $ sequence $ Map.fromList $(listE $ fmap nameToExportEntry names)+  |]++nameToExportEntry :: Name -> Q Exp+nameToExportEntry n = [| (T.pack $(TH.lift $ nameBase n), MTL.lift . toJSVal =<< $(varE n)) |]++exportToJSIO :: ReaderT React JSM (Map Text JSVal) -> IO ()+exportToJSIO build = runJS $ \arg -> do+  react <- fmap (React . Object) $ arg ! t "react"+  m <- flip runReaderT react build+  _ <- (arg # t "setVal") [m]+  pure ()++runJS :: (JSVal -> JSM ()) -> IO ()++#ifdef ghcjs_HOST_OS++foreign import javascript unsafe "getProgramArg"+    getProgramArg :: JSM JSVal++runJS f = do+  arg <- getProgramArg+  f arg++#else++runJS f = do+  let port = 3001 --TODO: Get this from npm config or something+  run port $ \arg -> f arg `catchError` printJavaScriptException++printJavaScriptException :: JavaScriptException -> JSM ()+printJavaScriptException (JavaScriptException e) = do+  s <- e # t "toString" $ ()+  j <- valToJSON s+  liftIO $ T.putStrLn $ "Exception: " <> tshow j++#endif

+ src/React/Hook.hs view

@@ -0,0 +1,68 @@+module React.Hook where++import Prelude hiding ((!!))++import Control.Monad+import Control.Monad.Except+import Control.Monad.Reader+import Language.Javascript.JSaddle hiding (Ref)++import React.JSaddle+import React.Misc+import React.Types++--TODO: Input can be an initializer function rather than value+--TODO: `set` can take `a -> a` instead of `a`+--TODO: I bet React always returns the same function object for the setter; if we re-wrap the function using `useCallback` each time, we are probably hurting performance by making it be a new object each time and forcing rerendering of children+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

+ src/React/JSaddle.hs view

@@ -0,0 +1,89 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-orphans #-}+-- | Everything in this module belongs in JSaddle, GHCJS-DOM, or similar+module React.JSaddle where++import Prelude hiding ((!!))++import Data.Text (Text)+import qualified Data.Text as T+import Data.Map (Map)+import qualified Data.Map as Map+import Control.Monad+import Data.String++import React.Misc++#ifdef ghcjs_HOST_OS+import Data.Coerce (coerce)+import GHCJS.Foreign.Callback+import qualified JavaScript.Array as Array (toListIO)+import Language.Javascript.JSaddle+#else+import GHCJS.Prim.Internal (primToJSVal)+import Language.Javascript.JSaddle hiding (Ref)+#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 PToJSVal Function where+  pToJSVal (Function _ o) = pToJSVal o++instance PToJSVal Object where+  pToJSVal (Object v) = v++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]++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

+ src/React/Misc.hs view

@@ -0,0 +1,11 @@+module React.Misc where++import Data.Text (Text)+import qualified Data.Text as T++t :: Text -> Text+t = id++tshow :: Show a => a -> Text+tshow = T.pack . show+

+ src/React/Types.hs view

@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}+module React.Types where++import Control.Monad.Reader+import Data.String+import qualified Data.Text as T+import Language.Javascript.JSaddle hiding (Ref)++import React.JSaddle++-- | An object that contains the React library+newtype React = React { unReact :: Object }++instance MakeObject React where+  makeObject = pure . unReact++newtype Component props refVal = Component { unComponent :: Function' }+  deriving (ToJSVal, PToJSVal)++instance MakeObject (Component props refVal) where+  makeObject = makeObject . functionObject' . unComponent++newtype Hook a = Hook { unHook :: ReaderT React JSM a }+  deriving ( Functor+           , Applicative+           , Monad+           , MonadJSM+#ifndef ghcjs_HOST_OS+           , MonadIO+#endif+           )++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