glazier-react-widget (empty) → 0.1.0.0
raw patch · 8 files changed
+524/−0 lines, 8 filesdep +basedep +containersdep +disposablesetup-changed
Dependencies added: base, containers, disposable, dlist, free, ghcjs-base, ghcjs-base-stub, glazier, glazier-react, javascript-extras, lens, mmorph, mtl, pipes-concurrency, stm, transformers
Files
- LICENSE +30/−0
- README.md +3/−0
- Setup.hs +2/−0
- glazier-react-widget.cabal +45/−0
- src/Glazier/React/Widgets/Input.hs +176/−0
- src/Glazier/React/Widgets/Input/Run.hs +17/−0
- src/Glazier/React/Widgets/List.hs +214/−0
- src/Glazier/React/Widgets/List/Run.hs +37/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,3 @@+[](https://hackage.haskell.org/package/glazier-react-widget)++Composable Widget library using Glazier.React
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ glazier-react-widget.cabal view
@@ -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
+ src/Glazier/React/Widgets/Input.hs view
@@ -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
+ src/Glazier/React/Widgets/Input/Run.hs view
@@ -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)
+ src/Glazier/React/Widgets/List.hs view
@@ -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)
+ src/Glazier/React/Widgets/List/Run.hs view
@@ -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