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,8 @@ +# Glazier.React examples + +## TodoMVC +This is a fully featured TodoMVC in in Haskell and ReactJS using the [glazier-react](https://github.com/louispan/glazier-react) library. + +For a live demo, see https://louispan.github.io/glazier-react-examples/ + +For more details, see the [todo example README.md](https://github.com/louispan/glazier-react-examples/tree/master/examples/todo) 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/examples/todo/haskell/app/Main.hs b/examples/todo/haskell/app/Main.hs new file mode 100644 --- /dev/null +++ b/examples/todo/haskell/app/Main.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} + +module Main (main) where + +import Control.Concurrent.MVar +import Control.Concurrent.STM +import qualified Control.Disposable as CD +import Control.Lens +import Control.Monad.Free.Church +import Control.Monad.IO.Class +import Control.Monad.Morph +import Control.Monad.State.Strict +import Control.Monad.Trans.Maybe +import qualified Data.DList as D +import Data.Foldable +import qualified Data.JSString as J +import qualified GHCJS.Foreign.Callback as J +import qualified GHCJS.Marshal.Pure as J +import qualified GHCJS.Types as J +import qualified Glazier as G +import qualified Glazier.React.Component as R +import qualified Glazier.React.Maker as R +import qualified Glazier.React.Maker.Run as R.Maker +import qualified Glazier.React.Markup as R +import qualified Glazier.React.Model as R +import qualified Glazier.React.ReactDOM as RD +import qualified Glazier.React.Widget as R +import qualified Glazier.React.Widgets.Input as W.Input +import qualified Glazier.React.Widgets.List as W.List +import qualified Pipes as P +import qualified Pipes.Concurrent as PC +import qualified Pipes.Lift as PL +import qualified Pipes.Misc as PM +import qualified Pipes.Prelude as PP +import qualified Todo.App as TD.App +import qualified Todo.App.Run as TD.App +import qualified Todo.Footer as TD.Footer +import qualified Todo.Todo as TD.Todo +import qualified Todo.Filter as TD.Filter + +mkAppModel :: F (R.Maker TD.App.Action) TD.App.Model +mkAppModel = TD.App.Model + <$> R.mkKey + <*> pure J.nullRef + <*> pure 0 + <*> hoistF (R.mapAction TD.App.InputAction) (R.mkSuperModel W.Input.widget =<< + W.Input.Model + <$> R.mkKey + <*> pure J.nullRef + <*> pure "What needs to be done?" + <*> pure "new-todo") + <*> hoistF (R.mapAction TD.App.TodosAction) (R.mkSuperModel (W.List.widget mempty TD.Todo.widget) =<< + W.List.Model + <$> R.mkKey + <*> pure J.nullRef + <*> pure 0 + <*> pure mempty + <*> pure "todo-list" + <*> pure 0 + <*> pure mempty + <*> pure (const True)) + <*> hoistF (R.mapAction TD.App.FooterAction) (R.mkSuperModel TD.Footer.widget =<< + TD.Footer.Model + <$> R.mkKey + <*> pure J.nullRef + <*> pure 0 + <*> pure 0 + <*> pure 0 + <*> pure TD.Filter.All) + +-- | 'main' is used to create React classes and setup callbacks to be used externally by the browser. +-- GHCJS runs 'main' lazily. +-- The code here only start running after all javascript is loaded. +-- Ie. h$main(h$mainZCZCMainzimain) just schedules the work to be executed after all javascript is loaded. +main :: IO () +main = do + -- Create a 'Pipes.Concurrent' mailbox for receiving actions from html events. + -- NB. using 'PC.bounded 1' also works without deadlocks, but doesn't save memory + -- blocked events are kept by the GHCJCS runtime. + (output, input) <- PC.spawn $ PC.unbounded + + muid <- newMVar 0 + + component <- R.mkComponent + + -- App Model + s <- iterM (R.Maker.run muid component output) (mkAppModel >>= R.mkSuperModel TD.App.widget) + + -- Start the App render + root <- js_getElementById "root" + e <- R.markedElement (hoist (hoist generalize) TD.App.window) (s ^. R.design) + RD.render (J.pToJSVal e) root + + -- The footer uses hashChange to fire events + onHashChange' <- iterM (R.Maker.run muid component output) + (hoistF (R.mapAction TD.App.FooterAction) (R.mkHandler TD.Footer.onHashChange)) + js_addHashChangeListener onHashChange' + + -- Fire the initial hashChange action + hash <- js_getHash + void $ runMaybeT $ do + acts <- fmap TD.App.FooterAction <$> TD.Footer.withHashChange hash + traverse_ (\act -> lift $ atomically $ PC.send output act >>= guard) acts + + -- Run the gadget effect which reads actions from 'Pipes.Concurrent.Input' + -- and notifies html React of any state changes. + -- runEffect will only stop if input is finished (which in this example never does). + s' <- P.runEffect $ appEffect s muid component output input + + -- Cleanup + -- We actually never get here because in this example runEffect never quits + -- but in other apps, gadgetEffect might be quit-able (eg with MaybeT) + -- so let's just be explicit where cleanup code would be. + CD.dispose (CD.disposing s') + CD.dispose (CD.disposing onHashChange') + +appEffect + :: MonadIO io + => R.SuperModelOf TD.App.Widget + -> MVar Int + -> R.ReactComponent + -> PC.Output TD.App.Action + -> PC.Input TD.App.Action + -> P.Effect io (R.SuperModelOf TD.App.Widget) +appEffect s muid component output input = + PL.execStateP s $ + appProducerIO input P.>-> + runCommandsPipe muid component output P.>-> + PP.drain + +appProducerIO + :: MonadIO io + => PC.Input TD.App.Action + -> P.Producer' (D.DList TD.App.Command) (StateT (R.SuperModelOf TD.App.Widget) io) () +appProducerIO input = hoist (hoist (liftIO . atomically)) (appProducer input) + +appProducer + :: PC.Input TD.App.Action + -> P.Producer' (D.DList TD.App.Command) (StateT (R.SuperModelOf TD.App.Widget) STM) () +appProducer input = PM.execInput input (G.runGadgetT (hoist generalize TD.App.gadget)) + +runCommandsPipe + :: (MonadState (R.SuperModelOf TD.App.Widget) io, MonadIO io) + => MVar Int + -> R.ReactComponent + -> PC.Output TD.App.Action + -> P.Pipe (D.DList TD.App.Command) () io () +runCommandsPipe muid component output = PP.mapM (runCommands muid component output) + +runCommands + :: (Foldable t, MonadState (R.SuperModelOf TD.App.Widget) io, MonadIO io) + => MVar Int + -> R.ReactComponent + -> PC.Output TD.App.Action + -> t TD.App.Command + -> io () +runCommands muid component output = traverse_ (liftIO . TD.App.run muid component output) + +#ifdef __GHCJS__ + +foreign import javascript unsafe + "$r = document.getElementById($1);" + js_getElementById :: J.JSString -> IO J.JSVal + +foreign import javascript unsafe + "window.addEventListener('hashchange', $1, false);" + js_addHashChangeListener :: J.Callback a -> IO () + +foreign import javascript unsafe + "$r = window.location.hash;" + js_getHash :: IO J.JSString + +#else + +js_getElementById :: J.JSString -> IO J.JSVal +js_getElementById _ = pure J.nullRef + +js_addHashChangeListener :: J.Callback a -> IO () +js_addHashChangeListener _ = pure () + +js_getHash :: IO J.JSString +js_getHash = pure J.empty + + +#endif diff --git a/examples/todo/haskell/app/Todo/App.hs b/examples/todo/haskell/app/Todo/App.hs new file mode 100644 --- /dev/null +++ b/examples/todo/haskell/app/Todo/App.hs @@ -0,0 +1,308 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Todo.App + ( TodosKey + , Command(..) + , Action(..) + , AsAction(..) + , Plan(..) + , HasPlan(..) + , mkPlan + , Model(..) + , HasModel(..) + , Design + , Frame + , SuperModel + , Widget + , widget + , 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 qualified Data.DList as D +import qualified Data.JSString as J +import qualified Data.Map.Strict as M +import Data.Semigroup +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.Model as R +import qualified Glazier.React.Widget as R +import qualified Glazier.React.Widgets.Input as W.Input +import qualified Glazier.React.Widgets.List as W.List +import qualified JavaScript.Extras as JE +import qualified Todo.Todo as TD.Todo +import qualified Todo.Footer as TD.Footer +import qualified Todo.Filter as TD.Filter + +type TodosKey = Int + +data Command + = RenderCommand (R.SuperModel Model Plan) [JE.Property] J.JSVal + | SendActionsCommand [Action] + | InputCommand W.Input.Command + | TodosCommand (W.List.Command TodosKey TD.Todo.Widget) + | FooterCommand TD.Footer.Command + +data Action + = ComponentRefAction J.JSVal + | RenderAction + | ToggleCompleteAllAction + | InputAction W.Input.Action + | TodosAction (W.List.Action TodosKey TD.Todo.Widget) + | FooterAction TD.Footer.Action + + +data Model = Model + { _key :: J.JSString + , _componentRef :: J.JSVal + , _frameNum :: Int + , _input :: R.SuperModelOf W.Input.Widget + , _todos :: R.SuperModelOf (W.List.Widget TodosKey TD.Todo.Widget) + , _footer :: R.SuperModelOf TD.Footer.Widget + } + +data Plan = Plan + { _component :: R.ReactComponent + , _onRender :: J.Callback (J.JSVal -> IO J.JSVal) + , _onComponentRef :: J.Callback (J.JSVal -> IO ()) + , _fireToggleCompleteAll :: J.Callback (J.JSVal -> IO ()) + } deriving (G.Generic) + +makeClassyPrisms ''Action +makeClassy ''Model +makeClassy ''Plan + +mkPlan :: R.Frame Model Plan -> F (R.Maker Action) Plan +mkPlan mm = Plan + <$> R.getComponent + <*> (R.mkRenderer mm (const render)) + <*> (R.mkHandler $ pure . pure . ComponentRefAction) + <*> (R.mkHandler $ pure . pure . const ToggleCompleteAllAction) + +instance CD.Disposing Plan +instance CD.Disposing Model where + disposing s = CD.DisposeList $ + CD.disposing (s ^. input) + : foldr ((:) . CD.disposing) [] (s ^. (todos . W.List.itemsModel)) + +-- Link Glazier.React.Model's HasPlan/HasModel with this widget's HasPlan/HasModel from makeClassy +instance HasPlan (R.Design Model Plan) where + plan = R.plan +instance HasModel (R.Design Model Plan) where + model = R.model +instance HasPlan (R.SuperModel Model Plan) where + plan = R.design . plan +instance HasModel (R.SuperModel Model Plan) where + model = R.design . model + +type Design = R.Design Model Plan +type Frame = R.Frame Model Plan +type SuperModel = R.SuperModel Model Plan + +---------------------------------------------------------- + +type Widget = R.Widget Command Action Model Plan +widget :: R.Widget Command Action Model Plan +widget = R.Widget + mkPlan + window + gadget + +hasActiveTodos :: M.Map TodosKey (R.SuperModelOf TD.Todo.Widget) -> Bool +hasActiveTodos = getAny . foldMap (Any . isActiveTodo) + +isActiveTodo :: (R.SuperModelOf TD.Todo.Widget) -> Bool +isActiveTodo = view (TD.Todo.model . TD.Todo.completed . to not) + +-- | This is used by parent components to render this component +window :: G.WindowT (R.Design Model Plan) (R.ReactMlT Identity) () +window = do + s <- ask + lift $ R.lf (s ^. component . to JE.toJS) + [ ("key", s ^. key . to JE.toJS) + , ("render", s ^. onRender . to JE.toJS) + , ("ref", s ^. onComponentRef . to JE.toJS) + ] + +-- | This is used by the React render callback +render :: G.WindowT (R.Design Model Plan) (R.ReactMlT Identity) () +render = do + s <- ask + lift $ R.bh (JE.strJS "header") [("className", JE.strJS "header")] $ do + R.bh (JE.strJS "h1") [("key", JE.strJS "heading")] (R.txt "todos") + view G._WindowT inputWindow s + view G._WindowT mainWindow s + +mainWindow :: G.WindowT (R.Design Model Plan) (R.ReactMlT Identity) () +mainWindow = do + -- only render if there are todos + ts <- view (todos . W.List.itemsModel) + if null ts + then pure () + else do + s <- ask + lift $ R.bh (JE.strJS "section") [ ("key", JE.strJS "main") + , ("className", JE.strJS "main") + ] $ do + -- Complete all checkbox + R.lf (JE.strJS "input") + [ ("key", JE.strJS "toggle-all") + , ("className", JE.strJS "toggle-all") + , ("type", JE.strJS "checkbox") + , ("checked", s ^. todos . W.List.itemsModel . to (JE.toJS . not . hasActiveTodos)) + , ("onChange", s ^. fireToggleCompleteAll . to JE.toJS) + ] + -- Render the list of todos + view G._WindowT todoListWindow s + + -- Render the footer + view G._WindowT footerWindow s + +inputWindow :: G.WindowT (R.Design Model Plan) (R.ReactMlT Identity) () +inputWindow = magnify (input . R.design) W.Input.window + +todoListWindow :: G.WindowT (R.Design Model Plan) (R.ReactMlT Identity) () +todoListWindow = magnify (todos . R.design) W.List.window + +footerWindow :: G.WindowT (R.Design Model Plan) (R.ReactMlT Identity) () +footerWindow = magnify (footer . R.design) TD.Footer.window + +updateFooterGadget :: G.GadgetT Action (R.SuperModel Model Plan) Identity (D.DList Command) +updateFooterGadget = do + (active, completed) <- use (todos . W.List.itemsModel . to (M.partition isActiveTodo)) + pure $ D.singleton $ SendActionsCommand + [FooterAction $ TD.Footer.SetCountsAction (length active) (length completed)] + +gadget :: G.GadgetT Action (R.SuperModel Model Plan) Identity (D.DList Command) +gadget = do + a <- ask + case a of + ComponentRefAction node -> do + componentRef .= node + pure mempty + + RenderAction -> + D.singleton <$> R.basicRenderCmd frameNum componentRef RenderCommand + + ToggleCompleteAllAction -> do + s <- use (todos . W.List.itemsModel) + let b = hasActiveTodos s + let acts = M.foldMapWithKey (toggleCompleteAll b) s + pure $ D.singleton $ SendActionsCommand $ D.toList $ acts `D.snoc` TodosAction W.List.RenderAction + + InputAction (W.Input.SubmitAction str) -> do + cmds <- inputGadget + let str' = J.strip str + cmds' <- if J.null str' + then pure mempty + else pure . D.singleton $ SendActionsCommand [TodosAction $ W.List.MakeItemAction + (+ 1) + (pure . toTodoModel str') + ] + pure $ cmds `mappend` cmds' + + InputAction _ -> inputGadget + + TodosAction (W.List.ItemAction k TD.Todo.DestroyAction) -> do + cmds <- todosGadget + cmds' <- pure $ D.singleton $ SendActionsCommand [TodosAction $ W.List.DestroyItemAction k] + pure $ cmds `mappend` cmds' + + TodosAction (W.List.DestroyItemAction _) -> do + cmds <- todosGadget + ts <- use (todos . W.List.itemsModel) + -- if ts is now empty, we need to render app again (to hide todo list & footer) + cmds' <- if (null ts) + then D.singleton <$> R.basicRenderCmd frameNum componentRef RenderCommand + else pure mempty + cmds'' <- updateFooterGadget + pure $ cmds `mappend` cmds' `mappend` cmds'' + + TodosAction (W.List.AddItemAction _ _) -> do + ts <- use (todos . W.List.itemsModel) + cmds <- todosGadget + -- if ts was empty, we need to render app again (to hide todo list & footer) + cmds' <- if (null ts) + then D.singleton <$> R.basicRenderCmd frameNum componentRef RenderCommand + else pure mempty + cmds'' <- updateFooterGadget + pure $ cmds `mappend` cmds' `mappend` cmds'' + + TodosAction (W.List.ItemAction _ TD.Todo.ToggleCompletedAction) -> do + cmds <- todosGadget + cmds' <- updateFooterGadget + pure $ cmds `mappend` cmds' `D.snoc` SendActionsCommand [TodosAction W.List.RenderAction] + + TodosAction _ -> do + cmds <- todosGadget + cmds' <- updateFooterGadget + pure $ cmds `mappend` cmds' + + FooterAction TD.Footer.ClearCompletedAction -> do + cmds <- footerGadget + (todos . W.List.itemsModel) %= M.filter isActiveTodo + cmds' <- updateFooterGadget + pure $ cmds `mappend` cmds' `D.snoc` SendActionsCommand [TodosAction W.List.RenderAction] + + FooterAction (TD.Footer.SetFilterAction _) -> do + cmds <- footerGadget + ftr <- use (footer . TD.Footer.filter) + let p = case ftr of + TD.Filter.All -> const True + TD.Filter.Active -> isActiveTodo + TD.Filter.Completed -> not . isActiveTodo + pure $ cmds `D.snoc` SendActionsCommand [TodosAction $ W.List.SetFilterAction p] + + FooterAction _ -> footerGadget + + where + toTodoModel :: J.JSString -> TodosKey -> TD.Todo.Model + toTodoModel str k = TD.Todo.Model + (J.pack . show $ k) + J.nullRef + 0 + mempty + J.nullRef + str + False + False + + toggleCompleteAll + :: Bool + -> TodosKey + -> R.SuperModelOf TD.Todo.Widget + -> D.DList Action + toggleCompleteAll b k todoSuperModel = + if (todoSuperModel ^. (TD.Todo.model . TD.Todo.completed) /= b) + then D.singleton $ TodosAction $ W.List.ItemAction k (TD.Todo.SetCompletedAction b) + else mempty + +inputGadget :: G.GadgetT Action (R.SuperModel Model Plan) Identity (D.DList Command) +inputGadget = fmap InputCommand <$> magnify _InputAction (zoom input W.Input.gadget) + +todosGadget :: G.GadgetT Action (R.SuperModel Model Plan) Identity (D.DList Command) +todosGadget = fmap TodosCommand <$> magnify _TodosAction (zoom todos + (W.List.gadget + (R.mkSuperModel TD.Todo.widget) + TD.Todo.gadget)) + +footerGadget :: G.GadgetT Action (R.SuperModel Model Plan) Identity (D.DList Command) +footerGadget = fmap FooterCommand <$> magnify _FooterAction (zoom footer TD.Footer.gadget) diff --git a/examples/todo/haskell/app/Todo/App/Run.hs b/examples/todo/haskell/app/Todo/App/Run.hs new file mode 100644 --- /dev/null +++ b/examples/todo/haskell/app/Todo/App/Run.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +module Todo.App.Run where + +import Control.Concurrent.STM +import Control.Concurrent.MVar +import Control.Lens +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe +import Data.Foldable +import qualified Glazier.React.Command.Run as R +import qualified Glazier.React.Component as R +import qualified Glazier.React.Widgets.Input.Run as W.Input +import qualified Glazier.React.Widgets.List as W.List +import qualified Glazier.React.Widgets.List.Run as W.List +import qualified Pipes.Concurrent as PC +import Todo.App as TD.App +import qualified Todo.Footer.Run as TD.Footer +import qualified Todo.Todo.Run as TD.Todo + +run :: MVar Int -> R.ReactComponent -> PC.Output Action -> Command -> IO () + +run _ _ _ (RenderCommand sm props j) = R.componentSetState sm props j + +run _ _ output (SendActionsCommand acts) = + void $ runMaybeT $ + traverse_ (\act -> lift $ atomically $ PC.send output act >>= guard) acts + +run _ _ _ (InputCommand cmd) = W.Input.run cmd + +run muid comp output (TodosCommand cmd) = + W.List.run + (\k -> TD.Todo.run (contramap (TodosAction . W.List.ItemAction k) output)) + muid + comp + (contramap TodosAction output) + cmd + +run _ _ _ (FooterCommand cmd) = TD.Footer.run cmd diff --git a/examples/todo/haskell/app/Todo/Filter.hs b/examples/todo/haskell/app/Todo/Filter.hs new file mode 100644 --- /dev/null +++ b/examples/todo/haskell/app/Todo/Filter.hs @@ -0,0 +1,4 @@ +module Todo.Filter where + +data Filter = All | Active | Completed + deriving (Eq, Show) diff --git a/examples/todo/haskell/app/Todo/Footer.hs b/examples/todo/haskell/app/Todo/Footer.hs new file mode 100644 --- /dev/null +++ b/examples/todo/haskell/app/Todo/Footer.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Todo.Footer + ( Command(..) + , Action(..) + , AsAction(..) + , Plan(..) + , HasPlan(..) + , mkPlan + , Model(..) + , HasModel(..) + , Design + , Frame + , SuperModel + , Widget + , widget + , window + , gadget + , onHashChange + , whenHashChange + , withHashChange + ) where + +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.Marshal 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.Event as R +import qualified Glazier.React.Maker as R +import qualified Glazier.React.Markup as R +import qualified Glazier.React.Model as R +import qualified Glazier.React.Widget as R +import qualified JavaScript.Extras as JE +import Prelude hiding (filter) +import qualified Prelude as P +import qualified Todo.Filter as TD.Filter + +data Command + = RenderCommand (R.SuperModel Model Plan) [JE.Property] J.JSVal + +data Action + = ComponentRefAction J.JSVal + | RenderAction + | ClearCompletedAction + | SetFilterAction TD.Filter.Filter + | SetCountsAction Int Int + +data Model = Model + { _key :: J.JSString + , _componentRef :: J.JSVal + , _frameNum :: Int + , _activeCount :: Int + , _completedCount :: Int + , _filter :: TD.Filter.Filter + } + +instance CD.Disposing Model where + disposing _ = CD.DisposeNone + +data Plan = Plan + { _component :: R.ReactComponent + , _onRender :: J.Callback (J.JSVal -> IO J.JSVal) + , _onComponentRef :: J.Callback (J.JSVal -> IO ()) + , _fireClearCompleted :: J.Callback (J.JSVal -> IO ()) + } deriving G.Generic + +instance CD.Disposing Plan +makeClassyPrisms ''Action +makeClassy ''Plan +makeClassy ''Model + +mkPlan :: R.Frame Model Plan -> F (R.Maker Action) Plan +mkPlan mm = Plan + <$> R.getComponent + <*> (R.mkRenderer mm $ const render) + <*> (R.mkHandler $ pure . pure . ComponentRefAction) + <*> (R.mkHandler $ pure . pure . const ClearCompletedAction) + +-- Link Glazier.React.Model's HasPlan/HasModel with this widget's HasPlan/HasModel from makeClassy +instance HasPlan (R.Design Model Plan) where + plan = R.plan +instance HasModel (R.Design Model Plan) where + model = R.model +instance HasPlan (R.SuperModel Model Plan) where + plan = R.design . plan +instance HasModel (R.SuperModel Model Plan) where + model = R.design . model + +type Design = R.Design Model Plan +type Frame = R.Frame Model Plan +type SuperModel = R.SuperModel Model Plan + +type Widget = R.Widget Command Action Model Plan +widget :: R.Widget Command Action Model Plan +widget = R.Widget + mkPlan + window + gadget + +-- | This is used by parent components to render this component +window :: G.WindowT (R.Design Model Plan) (R.ReactMlT Identity) () +window = do + s <- ask + lift $ R.lf (s ^. component . to JE.toJS) + [ ("key", s ^. key . to JE.toJS) + , ("render", s ^. onRender . to JE.toJS) + , ("ref", s ^. onComponentRef . to JE.toJS) + ] + +render :: G.WindowT (R.Design Model Plan) (R.ReactMlT Identity) () +render = do + s <- ask + lift $ R.bh (JE.strJS "footer") [("className", JE.strJS "footer")] $ do + R.bh (JE.strJS "span") [ ("className", JE.strJS "todo-count") + , ("key", JE.strJS "todo-count")] $ do + R.bh (JE.strJS "strong") [("key", JE.strJS "items")] (s ^. activeCount . to show . to J.pack . to R.txt) + R.txt " items left" + R.bh (JE.strJS "ul") [("className", JE.strJS "filters") + , ("key", JE.strJS "filters")] $ do + R.bh (JE.strJS "li") [("key", JE.strJS "filter-all")] $ + R.bh (JE.strJS "a") + [ ("href", JE.strJS "#/") + , ("key", JE.strJS "all") + , ("className", classNames [("selected", s ^. filter == TD.Filter.All)]) + ] $ + R.txt "All" + (R.txt " ") + R.bh (JE.strJS "li") [("key", JE.strJS "filter-active")] $ + R.bh (JE.strJS "a") + [ ("href", JE.strJS "#/active") + , ("key", JE.strJS "active") + , ("className", classNames [("selected", s ^. filter == TD.Filter.Active)]) + ] $ + R.txt "Active" + (R.txt " ") + R.bh (JE.strJS "li") [("key", JE.strJS "filter-completed")] $ + R.bh (JE.strJS "a") + [ ("href", JE.strJS "#/completed") + , ("key", JE.strJS "completed") + , ("className", classNames [("selected", s ^. filter == TD.Filter.Completed)]) + ] $ + R.txt "Completed" + if (s ^. completedCount > 0) + then R.bh (JE.strJS "button") [("key", JE.strJS "clear-completed") + , ("className", JE.strJS "clear-completed") + , ("onClick", s ^. fireClearCompleted . to JE.toJS)] $ + (R.txt "Clear completed") + else mempty + +classNames :: [(J.JSString, Bool)] -> J.JSVal +classNames = JE.toJS . J.unwords . fmap fst . P.filter snd + +gadget :: G.GadgetT Action (R.SuperModel Model Plan) Identity (D.DList Command) +gadget = do + a <- ask + case a of + ComponentRefAction node -> do + componentRef .= node + pure mempty + + RenderAction -> + D.singleton <$> R.basicRenderCmd frameNum componentRef RenderCommand + + -- parent widget need to handle this action explicitly + ClearCompletedAction -> pure mempty + + SetFilterAction ftr -> do + filter .= ftr + D.singleton <$> R.basicRenderCmd frameNum componentRef RenderCommand + + SetCountsAction activeCnt completedCnt -> do + activeCount .= activeCnt + completedCount .= completedCnt + D.singleton <$> R.basicRenderCmd frameNum componentRef RenderCommand + +-- | This needs to be explictly registered by the Main app +onHashChange :: J.JSVal -> MaybeT IO [Action] +onHashChange = R.eventHandlerM whenHashChange withHashChange + +-- | Provide split up parts of onHashChange in case the applications +-- needs to combine other widgets that also uses hashchange event +whenHashChange :: J.JSVal -> MaybeT IO J.JSString +whenHashChange evt = do + newURL <- MaybeT (JE.getProperty "newURL" evt >>= J.fromJSVal) -- FIXME: Use Nullable? + let (_, newHash) = J.breakOn "#" newURL + pure newHash + +-- | Provide split up parts of onHashChange in case the applications +-- needs to combine other widgets that also uses hashchange event +withHashChange :: J.JSString -> MaybeT IO [Action] +withHashChange newHash = + case newHash of + "#/active" -> pure [SetFilterAction TD.Filter.Active] + "#/completed" -> pure [SetFilterAction TD.Filter.Completed] + _ -> pure [SetFilterAction TD.Filter.All] diff --git a/examples/todo/haskell/app/Todo/Footer/Run.hs b/examples/todo/haskell/app/Todo/Footer/Run.hs new file mode 100644 --- /dev/null +++ b/examples/todo/haskell/app/Todo/Footer/Run.hs @@ -0,0 +1,10 @@ +module Todo.Footer.Run + ( run + ) where + +import qualified Glazier.React.Command.Run as R +import Todo.Footer + +run :: Command -> IO () + +run (RenderCommand sm props j) = R.componentSetState sm props j diff --git a/examples/todo/haskell/app/Todo/Todo.hs b/examples/todo/haskell/app/Todo/Todo.hs new file mode 100644 --- /dev/null +++ b/examples/todo/haskell/app/Todo/Todo.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Todo.Todo + ( Command(..) + , Action(..) + , AsAction(..) + , Plan(..) + , HasPlan(..) + , mkPlan + , Model(..) + , HasModel(..) + , Design + , Frame + , SuperModel + , Widget + , widget + , window + , gadget + ) where + +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.Nullable 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.Event as R +import qualified Glazier.React.Maker as R +import qualified Glazier.React.Markup as R +import qualified Glazier.React.Model as R +import qualified Glazier.React.Widget as R +import qualified Glazier.React.Widgets.Input as W.Input +import qualified JavaScript.Extras as JE + +data Command + = RenderCommand (R.SuperModel Model Plan) [JE.Property] J.JSVal + | SetPropertyCommand JE.Property J.JSVal + | FocusNodeCommand J.JSVal + | SendActionsCommand [Action] + +data Action + = ComponentRefAction J.JSVal + | RenderAction + | ComponentDidUpdateAction + | SendCommandsAction [Command] + | EditRefAction J.JSVal + | StartEditAction + | FocusEditAction + | ToggleCompletedAction + | SetCompletedAction Bool + | DestroyAction + | CancelEditAction + | SubmitAction J.JSString + +data Model = Model + { _key :: J.JSString + , _componentRef :: J.JSVal + , _frameNum :: Int + , _deferredActions :: D.DList Action + , _editRef :: J.JSVal + , _value :: J.JSString + , _completed :: Bool + , _editing :: Bool + } + +instance CD.Disposing Model where + disposing _ = CD.DisposeNone + +data Plan = Plan + { _component :: R.ReactComponent + , _onRender :: J.Callback (J.JSVal -> IO J.JSVal) + , _onComponentRef :: J.Callback (J.JSVal -> IO ()) + , _onComponentDidUpdate :: J.Callback (J.JSVal -> IO ()) + , _onEditRef :: J.Callback (J.JSVal -> IO ()) + , _fireToggleComplete :: J.Callback (J.JSVal -> IO ()) + , _fireStartEdit :: J.Callback (J.JSVal -> IO ()) + , _fireDestroy :: J.Callback (J.JSVal -> IO ()) + , _fireCancelEdit :: J.Callback (J.JSVal -> IO ()) + , _onEditKeyDown :: J.Callback (J.JSVal -> IO ()) + } deriving G.Generic + +instance CD.Disposing Plan +makeClassyPrisms ''Action +makeClassy ''Plan +makeClassy ''Model + +mkPlan :: R.Frame Model Plan -> F (R.Maker Action) Plan +mkPlan mm = Plan + <$> R.getComponent + <*> (R.mkRenderer mm $ const render) + <*> (R.mkHandler $ pure . pure . ComponentRefAction) + <*> (R.mkHandler $ pure . pure . const ComponentDidUpdateAction) + <*> (R.mkHandler $ pure . pure . EditRefAction) + <*> (R.mkHandler $ pure . pure . const ToggleCompletedAction) + <*> (R.mkHandler $ pure . pure . const StartEditAction) + <*> (R.mkHandler $ pure . pure . const DestroyAction) + <*> (R.mkHandler $ pure . pure . const CancelEditAction) + <*> (R.mkHandler onEditKeyDown') + +-- Link Glazier.React.Model's HasPlan/HasModel with this widget's HasPlan/HasModel from makeClassy +instance HasPlan (R.Design Model Plan) where + plan = R.plan +instance HasModel (R.Design Model Plan) where + model = R.model +instance HasPlan (R.SuperModel Model Plan) where + plan = R.design . plan +instance HasModel (R.SuperModel Model Plan) where + model = R.design . model + +type Design = R.Design Model Plan +type Frame = R.Frame Model Plan +type SuperModel = R.SuperModel Model Plan + +type Widget = R.Widget Command Action Model Plan +widget :: R.Widget Command Action Model Plan +widget = R.Widget + mkPlan + window + gadget + +-- | This is used by parent components to render this component +window :: G.WindowT (R.Design Model Plan) (R.ReactMlT Identity) () +window = do + s <- ask + lift $ R.lf (s ^. component . to JE.toJS) + [ ("key", s ^. key . to JE.toJS) + , ("render", s ^. onRender . to JE.toJS) + , ("ref", s ^. onComponentRef . to JE.toJS) + , ("componentDidUpdate", s ^. onComponentDidUpdate . to JE.toJS) + ] + +render :: G.WindowT (R.Design Model Plan) (R.ReactMlT Identity) () +render = do + s <- ask + lift $ R.bh (JE.strJS "li") [ ("className", classNames [ ("completed", s ^. completed) + , ("editing", s ^. editing)]) + ] $ do + R.bh (JE.strJS "div") [ ("key", JE.strJS "view") + , ("className", JE.strJS "view") + ] $ do + R.lf (JE.strJS "input") [ ("key", JE.strJS "toggle") + , ("className", JE.strJS "toggle") + , ("type", JE.strJS "checkbox") + , ("checked", s ^. completed . to JE.toJS) + , ("onChange", s ^. fireToggleComplete . to JE.toJS) + ] + R.bh (JE.strJS "label") [ ("key", JE.strJS "label") + , ("onDoubleClick", s ^. fireStartEdit. to JE.toJS) + ] (s ^. value . to R.txt) + R.lf (JE.strJS "button") [ ("key", JE.strJS "destroy") + , ("className", JE.strJS "destroy") + , ("onClick", s ^. fireDestroy . to JE.toJS) + ] + -- For uncontrolled components, we need to generate a new key per render + -- in order for react to use the new defaultValue + R.lf (JE.strJS "input") [ ("key", JE.toJS $ J.unwords + [ s ^. key + , s ^. frameNum . to show . to J.pack + ]) + , ("ref", s ^. onEditRef . to JE.toJS) + , ("className", JE.strJS "edit") + , ("defaultValue", s ^. value . to JE.toJS) + , ("defaultChecked", s ^. completed . to JE.toJS) + , ("onBlur", s ^. fireCancelEdit . to JE.toJS) + , ("onKeyDown", s ^. onEditKeyDown . to JE.toJS) + ] + +classNames :: [(J.JSString, Bool)] -> J.JSVal +classNames = JE.toJS . J.unwords . fmap fst . filter snd + +onEditKeyDown' :: J.JSVal -> MaybeT IO [Action] +onEditKeyDown' = R.eventHandlerM W.Input.whenKeyDown goLazy + where + goLazy :: (Maybe J.JSString, J.JSVal) -> MaybeT IO [Action] + goLazy (ms, j) = pure $ + SendCommandsAction [SetPropertyCommand ("value", JE.toJS J.empty) j] + : maybe [CancelEditAction] (pure . SubmitAction) ms + +gadget :: G.GadgetT Action (R.SuperModel Model Plan) Identity (D.DList Command) +gadget = do + a <- ask + case a of + -- common widget actions + + ComponentRefAction node -> do + componentRef .= node + pure mempty + + RenderAction -> + D.singleton <$> R.basicRenderCmd frameNum componentRef RenderCommand + + ComponentDidUpdateAction -> do + -- Run delayed action that need to wait until frame is re-rendered + -- Eg focusing after other rendering changes + acts <- use deferredActions + deferredActions .= mempty + -- st :: Action -> StateT SuperModel m (D.DList Command) + pure $ D.singleton $ SendActionsCommand $ D.toList acts + + SendCommandsAction cmds -> pure $ D.fromList cmds + + -- widget specific actions + -- Focus after rendering changed because a new input element might have been rendered + FocusEditAction -> do + input <- use editRef + ret <- runMaybeT $ do + input' <- MaybeT $ pure $ J.nullableToMaybe (J.Nullable input) + pure $ D.singleton $ FocusNodeCommand input' + maybe (pure mempty) pure ret + + EditRefAction v -> do + editRef .= v + pure mempty + + ToggleCompletedAction -> do + completed %= not + D.singleton <$> R.basicRenderCmd frameNum componentRef RenderCommand + + SetCompletedAction b -> do + completed .= b + D.singleton <$> R.basicRenderCmd frameNum componentRef RenderCommand + + StartEditAction -> do + ret <- runMaybeT $ do + b <- use completed + guard (not b) + editing .= True + -- Need to delay focusing until after the next render + deferredActions %= (`D.snoc` FocusEditAction) + D.singleton <$> R.basicRenderCmd frameNum componentRef RenderCommand + maybe (pure mempty) pure ret + + -- parent widgets should detect this case to do something with submitted action + DestroyAction -> pure mempty + + CancelEditAction -> do + editing .= False + D.singleton <$> R.basicRenderCmd frameNum componentRef RenderCommand + + SubmitAction v -> do + -- trim the text + let v' = J.strip v + value .= v' + editing .= False + if J.null v' + then pure $ D.singleton $ SendActionsCommand [DestroyAction] + else D.singleton <$> R.basicRenderCmd frameNum componentRef RenderCommand diff --git a/examples/todo/haskell/app/Todo/Todo/Run.hs b/examples/todo/haskell/app/Todo/Todo/Run.hs new file mode 100644 --- /dev/null +++ b/examples/todo/haskell/app/Todo/Todo/Run.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE CPP #-} +module Todo.Todo.Run + ( run + ) where + +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe +import Data.Foldable +import qualified GHCJS.Types as J +import qualified Glazier.React.Command.Run as R +import qualified JavaScript.Extras as JE +import qualified Pipes.Concurrent as PC +import Todo.Todo + +run :: PC.Output Action -> Command -> IO () + +run _ (SetPropertyCommand prop j) = JE.setProperty prop j + +run _ (RenderCommand sm props j) = R.componentSetState sm props j + +run _ (FocusNodeCommand j) = js_focus j + +run output (SendActionsCommand acts) = + void $ runMaybeT $ + traverse_ (\act -> lift $ atomically $ PC.send output act >>= guard) acts + +#ifdef __GHCJS__ + +foreign import javascript unsafe + "if ($1 && $1['focus']) { $1['focus'](); }" + js_focus :: J.JSVal -> IO () + +#else + +js_focus :: J.JSVal -> IO () +js_focus _ = pure () + +#endif diff --git a/examples/todo/haskell/jsbits/global.js b/examples/todo/haskell/jsbits/global.js new file mode 100644 --- /dev/null +++ b/examples/todo/haskell/jsbits/global.js @@ -0,0 +1,2 @@ +// a global for interoperability between html and haskell. +var hgr$todo$registry = new hgr$registry(); diff --git a/glazier-react-examples.cabal b/glazier-react-examples.cabal new file mode 100644 --- /dev/null +++ b/glazier-react-examples.cabal @@ -0,0 +1,58 @@ +name: glazier-react-examples +version: 0.4.0.0 +synopsis: Examples of using glazier-react +description: Examples of using glazier-react +homepage: https://github.com/louispan/glazier-react#readme +license: BSD3 +license-file: LICENSE +author: Louis Pan +maintainer: louis@pan.me +copyright: 2017 Louis Pan +category: Web, GUI +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +executable glazier-react-todo + hs-source-dirs: examples/todo/haskell/app + other-modules: Todo.App + Todo.App.Run + Todo.Todo + Todo.Todo.Run + Todo.Filter + Todo.Footer + Todo.Footer.Run + main-is: Main.hs + js-sources: examples/todo/haskell/jsbits/global.js + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + cpp-options: -DGHCJS_BROWSER + build-depends: base >= 4.7 && < 5 + , containers >= 0.5 && < 0.6 + , disposable >= 0.2.0.2 && < 1 + , dlist >= 0.8 && < 0.9 + , free >= 4.12 && < 5 + , glazier >= 0.10 && < 1 + , glazier-react >= 0.4 && < 1 + , glazier-react-widget >= 0.4 && < 1 + , javascript-extras >= 0.2.0.2 && < 1 + , lens >= 4 && < 5 + , mmorph >= 1 && < 2 + , mtl >= 2 && < 3 + , pipes >= 4 && < 5 + , pipes-concurrency >= 2 && < 3 + , pipes-misc >= 0.2.5 && < 1 + , stm >= 2.4 && < 3 + , text >= 1.2 && < 1.3 + , transformers >= 0.4 && < 0.6 + , unordered-containers >= 0.2.7 && < 0.3 + default-language: Haskell2010 + default-extensions: ApplicativeDo + if impl(ghcjs) + build-depends: ghcjs-base + , ghcjs-prim >= 0.1 && < 0.2 + 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-examples