glazier-react-examples (empty) → 0.4.0.0
raw patch · 13 files changed
+1169/−0 lines, 13 filesdep +basedep +containersdep +disposablesetup-changed
Dependencies added: base, containers, disposable, dlist, free, ghcjs-base, ghcjs-base-stub, ghcjs-prim, glazier, glazier-react, glazier-react-widget, javascript-extras, lens, mmorph, mtl, pipes, pipes-concurrency, pipes-misc, stm, text, transformers, unordered-containers
Files
- LICENSE +30/−0
- README.md +8/−0
- Setup.hs +2/−0
- examples/todo/haskell/app/Main.hs +189/−0
- examples/todo/haskell/app/Todo/App.hs +308/−0
- examples/todo/haskell/app/Todo/App/Run.hs +44/−0
- examples/todo/haskell/app/Todo/Filter.hs +4/−0
- examples/todo/haskell/app/Todo/Footer.hs +212/−0
- examples/todo/haskell/app/Todo/Footer/Run.hs +10/−0
- examples/todo/haskell/app/Todo/Todo.hs +262/−0
- examples/todo/haskell/app/Todo/Todo/Run.hs +40/−0
- examples/todo/haskell/jsbits/global.js +2/−0
- glazier-react-examples.cabal +58/−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,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)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/todo/haskell/app/Main.hs view
@@ -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
+ examples/todo/haskell/app/Todo/App.hs view
@@ -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)
+ examples/todo/haskell/app/Todo/App/Run.hs view
@@ -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
+ examples/todo/haskell/app/Todo/Filter.hs view
@@ -0,0 +1,4 @@+module Todo.Filter where++data Filter = All | Active | Completed+ deriving (Eq, Show)
@@ -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]
@@ -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
+ examples/todo/haskell/app/Todo/Todo.hs view
@@ -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
+ examples/todo/haskell/app/Todo/Todo/Run.hs view
@@ -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
+ examples/todo/haskell/jsbits/global.js view
@@ -0,0 +1,2 @@+// a global for interoperability between html and haskell.+var hgr$todo$registry = new hgr$registry();
+ glazier-react-examples.cabal view
@@ -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