diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Louis Pan (c) 2017 + +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 Louis Pan 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +[![Hackage](https://img.shields.io/hackage/v/glazier-react-widget.svg)](https://hackage.haskell.org/package/glazier-react-widget) + +Composable Widget library using Glazier.React diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/glazier-react-widget.cabal b/glazier-react-widget.cabal new file mode 100644 --- /dev/null +++ b/glazier-react-widget.cabal @@ -0,0 +1,45 @@ +name: glazier-react-widget +version: 0.1.0.0 +synopsis: Generic widget library using glazier-react +description: Generic widget library using glazier-react +homepage: https://github.com/louispan/glazier-react-widget#readme +license: BSD3 +license-file: LICENSE +author: Louis Pan +maintainer: louis@pan.me +copyright: 2017 Louis Pan +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Glazier.React.Widgets.Input + Glazier.React.Widgets.Input.Run + Glazier.React.Widgets.List + Glazier.React.Widgets.List.Run + build-depends: base >= 4.7 && < 5 + , containers >= 0.5 && < 0.6 + , disposable >= 0.2 && < 1 + , dlist >= 0.8 && < 0.9 + , free >= 4.12 && < 5 + , glazier >= 0.10 && < 1 + , glazier-react >= 0.1 && < 1 + , javascript-extras >= 0.2 && < 1 + , lens >= 4 && < 5 + , mmorph >= 1 && < 2 + , mtl >= 2 && < 3 + , pipes-concurrency >= 2 && < 3 + , stm >= 2.4 && < 3 + , transformers >= 0.4 && < 0.6 + default-language: Haskell2010 + ghc-options: -Wall + if impl(ghcjs) + build-depends: ghcjs-base + if !impl(ghcjs) + build-depends: ghcjs-base-stub >= 0.1.0.2 && < 1 + +source-repository head + type: git + location: https://github.com/louispan/glazier-react-widget diff --git a/src/Glazier/React/Widgets/Input.hs b/src/Glazier/React/Widgets/Input.hs new file mode 100644 --- /dev/null +++ b/src/Glazier/React/Widgets/Input.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Glazier.React.Widgets.Input + ( Command(..) + , Action(..) + , AsAction(..) + , Gasket(..) + , HasGasket(..) + , mkGasket + , Model(..) + , HasModel(..) + , mkSuperModel + , Widget + , GModel + , MModel + , SuperModel + , window + , gadget + , whenKeyDown + ) where + +import Control.Applicative +import qualified Control.Disposable as CD +import Control.Lens +import Control.Monad.Free.Church +import Control.Monad.Reader +import Control.Monad.Trans.Maybe +import qualified Data.DList as D +import qualified Data.JSString as J +import qualified GHC.Generics as G +import qualified GHCJS.Foreign.Callback as J +import qualified GHCJS.Types as J +import qualified Glazier as G +import qualified Glazier.React.Component as R +import qualified Glazier.React.Event as R +import qualified Glazier.React.Maker as R +import qualified Glazier.React.Markup as R +import qualified Glazier.React.Widget as R +import qualified JavaScript.Extras as JE + +data Command act + = SetPropertyCommand JE.Property J.JSVal + | GetPropertyCommand J.JSString J.JSVal (J.JSVal -> act) + deriving Functor + +data Action act + = SendCommandsAction [Command act] + | SubmitAction J.JSString + | InputRefAction J.JSVal + | GetPropertyAction J.JSString (J.JSVal -> act) + deriving Functor + +data Model = Model + { _uid :: J.JSString + , _inputRef :: J.JSVal + , _placeholder :: J.JSString + , _className :: J.JSString + } + +data Gasket = Gasket + { _component :: R.ReactComponent + , _onRender :: J.Callback (J.JSVal -> IO J.JSVal) + , _onInputRef :: J.Callback (J.JSVal -> IO ()) + , _onKeyDown :: J.Callback (J.JSVal -> IO ()) + } deriving (G.Generic) + +makeClassyPrisms ''Action +makeClassy ''Gasket +makeClassy ''Model + +mkGasket :: R.MModel Gasket Model -> F (R.Maker (Action act)) Gasket +mkGasket mm = Gasket + <$> R.getComponent + <*> (R.mkRenderer mm $ const render) + <*> (R.mkHandler $ pure . pure . InputRefAction) + <*> (R.mkHandler onKeyDown') + +instance CD.Disposing Model where + disposing _ = CD.DisposeNone + +mkSuperModel :: Model -> F (R.Maker (Action act)) (SuperModel act) +mkSuperModel s = R.mkSuperModel mkGasket $ \gkt -> R.GModel gkt s + +data Widget act +instance R.IsWidget (Widget act) where + type WidgetAction (Widget act) = Action act + type WidgetCommand (Widget act) = Command act + type WidgetModel (Widget act) = Model + type WidgetGasket (Widget act) = Gasket +type GModel act = R.WidgetGModel (Widget act) +type MModel act = R.WidgetMModel (Widget act) +type SuperModel act = R.WidgetSuperModel (Widget act) +instance CD.Disposing Gasket +instance HasGasket (R.GModel Gasket Model) where + gasket = R.widgetGasket +instance HasModel (R.GModel Gasket Model) where + model = R.widgetModel +instance HasGasket (R.SuperModel Gasket Model) where + gasket = R.gModel . gasket +instance HasModel (R.SuperModel Gasket Model) where + model = R.gModel . model + +-- | This is used by parent components to render this component +window :: Monad m => G.WindowT (GModel act) (R.ReactMlT m) () +window = do + s <- ask + lift $ R.lf (s ^. component . to JE.toJS) + [ ("key", s ^. uid . to JE.toJS) + , ("render", s ^. onRender . to JE.toJS) + ] + +-- | This is used by the React render callback +render :: Monad m => G.WindowT (GModel act) (R.ReactMlT m) () +render = do + s <- ask + lift $ R.lf (JE.strJS "input") + [ ("key", s ^. uid . to JE.toJS) + , ("className", s ^. className . to JE.toJS) + , ("placeholder", s ^. placeholder . to JE.toJS) + , ("autoFocus", JE.toJS True) + , ("onKeyDown", s ^. onKeyDown . to JE.toJS) + ] + +whenKeyDown :: J.JSVal -> MaybeT IO (Maybe J.JSString, J.JSVal) +whenKeyDown evt = do + evt' <- MaybeT $ JE.fromJS evt + evt'' <- MaybeT $ R.parseKeyboardEvent evt' + evt''' <- lift $ R.parseEvent $ evt' + -- target is the "input" DOM + input <- lift $ pure . JE.toJS . R.target $ evt''' + let k = R.keyCode evt'' + case k of + -- FIXME: ESCAPE_KEY + 27 -> pure $ (Nothing, input) + -- FIXME: ENTER_KEY + 13 -> do + v <- MaybeT $ JE.getProperty "value" input >>= JE.fromJS + pure $ (Just v, input) + _ -> empty + +onKeyDown' :: J.JSVal -> MaybeT IO [Action act] +onKeyDown' = R.eventHandlerM whenKeyDown goLazy + where + goLazy :: (Maybe J.JSString, J.JSVal) -> MaybeT IO [Action act] + goLazy (ms, j) = pure $ + SendCommandsAction [SetPropertyCommand ("value", JE.toJS J.empty) j] + : maybe [] (pure . SubmitAction) ms + +-- | State update logic. +-- The best practice is to leave this in general Monad m (eg, not MonadIO). +-- This allows gadget to use STM as the base monad which allows for combining concurrently +-- with other stateful STM effects and still maintain a single source of truth. +gadget :: Monad m => G.GadgetT (Action act) (SuperModel act) m (D.DList (Command act)) +gadget = do + a <- ask + case a of + SendCommandsAction cmds -> pure $ D.fromList cmds + + -- parent widgets should detect this case to do something with submitted action + SubmitAction _ -> pure empty + + InputRefAction v -> do + inputRef .= v + pure mempty + + GetPropertyAction prop f -> do + j <- use inputRef + pure $ D.singleton $ GetPropertyCommand prop j f diff --git a/src/Glazier/React/Widgets/Input/Run.hs b/src/Glazier/React/Widgets/Input/Run.hs new file mode 100644 --- /dev/null +++ b/src/Glazier/React/Widgets/Input/Run.hs @@ -0,0 +1,17 @@ +module Glazier.React.Widgets.Input.Run + ( run + ) where + +import Control.Concurrent.STM +import Control.Monad +import qualified JavaScript.Extras as JE +import qualified Pipes.Concurrent as PC +import Glazier.React.Widgets.Input + +run :: PC.Output act -> Command act -> IO () + +run _ (SetPropertyCommand prop j) = JE.setProperty prop j + +run output (GetPropertyCommand prop j f) = do + v <- JE.getProperty prop j + void $ atomically $ PC.send output (f v) diff --git a/src/Glazier/React/Widgets/List.hs b/src/Glazier/React/Widgets/List.hs new file mode 100644 --- /dev/null +++ b/src/Glazier/React/Widgets/List.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Glazier.React.Widgets.List + ( Command(..) + , Action(..) + , AsAction(..) + , Gasket(..) + , HasGasket(..) + , mkGasket + , Model(..) + , HasModel(..) + , mkSuperModel + , Widget + , GModel + , MModel + , SuperModel + , window + , gadget + ) where + +import qualified Control.Disposable as CD +import Control.Lens +import Control.Monad.Free.Church +import Control.Monad.Morph +import Control.Monad.Reader +import Control.Monad.Trans.Maybe +import qualified Data.DList as D +import Data.Foldable +import qualified Data.JSString as J +import qualified Data.List as DL +import qualified Data.Map.Strict as M +import qualified GHC.Generics as G +import qualified GHCJS.Foreign.Callback as J +import qualified GHCJS.Types as J +import qualified Glazier as G +import qualified Glazier.React.Command as R +import qualified Glazier.React.Component as R +import qualified Glazier.React.Maker as R +import qualified Glazier.React.Markup as R +import qualified Glazier.React.Widget as R +import qualified JavaScript.Extras as JE + +data Command key itemWidget + = RenderCommand (R.SuperModel Gasket (Model key itemWidget)) [JE.Property] J.JSVal + | DisposeCommand CD.SomeDisposable + | MakerCommand (F (R.Maker (Action key itemWidget)) (Action key itemWidget)) + | ItemCommand key (R.WidgetCommand itemWidget) + +data Action key itemWidget + = ComponentRefAction J.JSVal + | RenderAction + | ComponentDidUpdateAction + | DestroyItemAction key + | MakeItemAction (key -> key) (key -> R.WidgetModel itemWidget) + | AddItemAction key (R.WidgetSuperModel itemWidget) + | ItemAction key (R.WidgetAction itemWidget) + | SetFilterAction (R.WidgetSuperModel itemWidget -> Bool) + +data Model key itemWidget = Model + { _uid :: J.JSString + , _componentRef :: J.JSVal + , _frameNum :: Int + , _deferredCommands :: D.DList (Command key itemWidget) + , _className ::J.JSString + , _itemKey :: key + , _itemsModel :: M.Map key (R.WidgetSuperModel itemWidget) + , _itemsFilter :: R.WidgetSuperModel itemWidget -> Bool + } + +data Gasket = Gasket + { _component :: R.ReactComponent + , _onRender :: J.Callback (J.JSVal -> IO J.JSVal) + , _onComponentRef :: J.Callback (J.JSVal -> IO ()) + , _onComponentDidUpdate :: J.Callback (J.JSVal -> IO ()) + } deriving (G.Generic) + +makeClassyPrisms ''Action +makeClassy ''Gasket +makeClassy ''Model + +mkGasket + :: G.WindowT (R.WidgetGModel itemWidget) (R.ReactMlT Identity) () + -> R.ReactMlT Identity () + -> MModel key itemWidget + -> F (R.Maker (Action key itemWidget)) Gasket +mkGasket itemWindow separator mm = Gasket + <$> R.getComponent + <*> (R.mkRenderer mm $ const (render itemWindow separator)) + <*> (R.mkHandler $ pure . pure . ComponentRefAction) + <*> (R.mkHandler $ pure . pure . const ComponentDidUpdateAction) + +instance ( CD.Disposing (R.WidgetGasket itemWidget) + , CD.Disposing (R.WidgetModel itemWidget) + ) => + CD.Disposing (Model key itemWidget) where + disposing s = + CD.DisposeList $ foldr ((:) . CD.disposing) [] (s ^. itemsModel) + +mkSuperModel + :: G.WindowT (R.WidgetGModel itemWidget) (R.ReactMlT Identity) () + -> R.ReactMlT Identity () + -> Model key itemWidget + -> F (R.Maker (Action key itemWidget)) (SuperModel key itemWidget) +mkSuperModel itemWindow separator s = R.mkSuperModel (mkGasket itemWindow separator) $ \gkt -> R.GModel gkt s + +data Widget key itemWidget +instance R.IsWidget (Widget key itemWidget) where + type WidgetAction (Widget key itemWidget) = Action key itemWidget + type WidgetCommand (Widget key itemWidget) = Command key itemWidget + type WidgetModel (Widget key itemWidget) = Model key itemWidget + type WidgetGasket (Widget ackey itemWidget) = Gasket +type GModel key itemWidget = R.WidgetGModel (Widget key itemWidget) +type MModel key itemWidget = R.WidgetMModel (Widget key itemWidget) +type SuperModel key itemWidget = R.WidgetSuperModel (Widget key itemWidget) +instance CD.Disposing Gasket +instance HasGasket (R.GModel Gasket (Model key itemWidget)) where + gasket = R.widgetGasket +instance HasModel (R.GModel Gasket (Model key itemWidget)) key itemWidget where + model = R.widgetModel +instance HasGasket (R.SuperModel Gasket (Model key itemWidget)) where + gasket = R.gModel . gasket +instance HasModel (R.SuperModel Gasket (Model key itemWidget)) key itemWidget where + model = R.gModel . model + +-- | This is used by parent components to render this component +window :: Monad m => G.WindowT (GModel key itemWidget) (R.ReactMlT m) () +window = do + s <- ask + lift $ R.lf (s ^. component . to JE.toJS) + [ ("key", s ^. uid . to JE.toJS) + , ("render", s ^. onRender . to JE.toJS) + , ("ref", s ^. onComponentRef . to JE.toJS) + , ("componentDidUpdate", s ^. onComponentDidUpdate . to JE.toJS) + ] + +-- | This is used by the React render callback +render + :: Monad m + => G.WindowT (R.WidgetGModel itemWidget) (R.ReactMlT m) () + -> R.ReactMlT m () + -> G.WindowT (GModel key itemWidget) (R.ReactMlT m) () +render itemWindow separator = do + s <- ask + items <- fmap (view R.gModel) . filter (s ^. itemsFilter) . fmap snd . M.toList <$> view itemsModel + lift $ R.bh (JE.strJS "ul") [ ("key", s ^. uid . to JE.toJS) + , ("className", s ^. className . to JE.toJS) + ] $ do + let itemsWindows = (view G._WindowT itemWindow) <$> items + separatedWindows = DL.intersperse separator itemsWindows + sequenceA_ separatedWindows + +gadget + :: (Ord key, Monad m, CD.Disposing (R.WidgetModel itemWidget), CD.Disposing (R.WidgetGasket itemWidget)) + => (R.WidgetModel itemWidget -> F (R.Maker (R.WidgetAction itemWidget)) (R.WidgetSuperModel itemWidget)) + -> G.GadgetT (R.WidgetAction itemWidget) (R.WidgetSuperModel itemWidget) m (D.DList (R.WidgetCommand itemWidget)) + -> G.GadgetT (Action key itemWidget) (SuperModel key itemWidget) m (D.DList (Command key itemWidget)) +gadget mkItemSuperModel itemGadget = do + a <- ask + case a of + ComponentRefAction node -> do + componentRef .= node + pure mempty + + RenderAction -> + D.singleton <$> (R.basicRenderCmd frameNum componentRef RenderCommand) + + ComponentDidUpdateAction -> do + -- Run delayed commands that need to wait until frame is re-rendered + -- Eg focusing after other rendering changes + cmds <- use deferredCommands + deferredCommands .= mempty + pure cmds + + DestroyItemAction k -> do + -- queue up callbacks to be released after rerendering + ret <- runMaybeT $ do + itemSuperModel <- MaybeT $ use (itemsModel . at k) + let junk = CD.disposing itemSuperModel + deferredCommands %= (`D.snoc` DisposeCommand junk) + -- Remove the todo from the model + itemsModel %= M.delete k + -- on re-render the todo Shim will not get rendered and will be removed by react + D.singleton <$> (R.basicRenderCmd frameNum componentRef RenderCommand) + maybe (pure mempty) pure ret + + MakeItemAction keyMaker itemModelMaker -> do + n <- keyMaker <$> use itemKey + itemKey .= n + pure $ D.singleton $ MakerCommand $ do + sm <- hoistF (R.mapAction $ \act -> ItemAction n act) $ + mkItemSuperModel (itemModelMaker n) + pure $ AddItemAction n sm + + AddItemAction n v -> do + itemsModel %= M.insert n v + D.singleton <$> (R.basicRenderCmd frameNum componentRef RenderCommand) + + ItemAction key _ -> fmap (ItemCommand key) <$> + (magnify (_ItemAction . to snd) + (zoom (itemsModel . at key . _Just) itemGadget)) + + SetFilterAction ftr -> do + itemsFilter .= ftr + D.singleton <$> (R.basicRenderCmd frameNum componentRef RenderCommand) diff --git a/src/Glazier/React/Widgets/List/Run.hs b/src/Glazier/React/Widgets/List/Run.hs new file mode 100644 --- /dev/null +++ b/src/Glazier/React/Widgets/List/Run.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +module Glazier.React.Widgets.List.Run + ( run + ) where + +import Control.Concurrent.STM +import qualified Control.Disposable as CD +import Control.Monad +import Control.Monad.Free.Church +import qualified Glazier.React.Component as R +import qualified Glazier.React.Command.Run as R +import qualified Glazier.React.Maker.Run as R.Maker +import qualified Glazier.React.Widget as R +import Glazier.React.Widgets.List as W.List +import qualified Pipes.Concurrent as PC + +run + :: (key -> R.WidgetCommand itemWidget -> IO ()) -- command runner for the items + -> R.ReactComponent -- for Maker + -> PC.Output (Action key itemWidget) + -> Command key itemWidget + -> IO () + +run _ _ _ (RenderCommand sm props j) = R.componentSetState sm props j + +run _ _ _ (DisposeCommand x) = CD.dispose x + +run _ comp output (MakerCommand mks) = do + act <- iterM (R.Maker.run comp output) mks + void $ atomically $ PC.send output act + +run itemCmdRun _ _ (ItemCommand key itemCmd) = itemCmdRun key itemCmd