glazier-react-examples 0.4.0.0 → 0.6.0.0
raw patch · 8 files changed
+319/−336 lines, 8 filesdep ~disposabledep ~glazier-reactdep ~glazier-react-widget
Dependency ranges changed: disposable, glazier-react, glazier-react-widget, javascript-extras
Files
- examples/todo/haskell/app/Main.hs +31/−46
- examples/todo/haskell/app/Todo/App.hs +119/−119
- examples/todo/haskell/app/Todo/App/Run.hs +5/−2
- examples/todo/haskell/app/Todo/Footer.hs +69/−68
- examples/todo/haskell/app/Todo/Todo.hs +88/−89
- examples/todo/haskell/app/Todo/Todo/Run.hs +2/−4
- examples/todo/haskell/jsbits/global.js +0/−2
- glazier-react-examples.cabal +5/−6
examples/todo/haskell/app/Main.hs view
@@ -39,38 +39,19 @@ 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)+appOutline :: TD.App.Outline+appOutline = TD.App.Schema+ (W.Input.Schema+ "What needs to be done?"+ "new-todo")+ (W.List.Schema+ "todo-list"+ 0+ mempty+ (const True))+ (TD.Footer.Schema 0 0 TD.Filter.All) -- | 'main' is used to create React classes and setup callbacks to be used externally by the browser. -- GHCJS runs 'main' lazily.@@ -87,17 +68,18 @@ component <- R.mkComponent + let appWidget = TD.App.widget mempty -- App Model- s <- iterM (R.Maker.run muid component output) (mkAppModel >>= R.mkSuperModel TD.App.widget)+ s <- iterM (R.Maker.run muid component output) (R.mkGizmo' appWidget appOutline) -- Start the App render root <- js_getElementById "root"- e <- R.markedElement (hoist (hoist generalize) TD.App.window) (s ^. R.design)+ e <- R.markedElement (hoist (hoist generalize) (R.window appWidget)) (s ^. R.scene) 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))+ (R.hoistWithAction TD.App.FooterAction (R.mkHandler TD.Footer.onHashChange)) js_addHashChangeListener onHashChange' -- Fire the initial hashChange action@@ -109,7 +91,7 @@ -- 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+ s' <- P.runEffect $ appEffect (R.gadget appWidget) s muid component output input -- Cleanup -- We actually never get here because in this example runEffect never quits@@ -120,31 +102,34 @@ appEffect :: MonadIO io- => R.SuperModelOf TD.App.Widget+ => R.GadgetOf TD.App.Widget+ -> R.GizmoOf 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 =+ -> P.Effect io (R.GizmoOf TD.App.Widget)+appEffect appGadget s muid component output input = PL.execStateP s $- appProducerIO input P.>->+ appProducerIO appGadget 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)+ => R.GadgetOf TD.App.Widget+ -> PC.Input TD.App.Action+ -> P.Producer' (D.DList TD.App.Command) (StateT (R.GizmoOf TD.App.Widget) io) ()+appProducerIO appGadget input = hoist (hoist (liftIO . atomically)) (appProducer appGadget 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))+ :: R.GadgetOf TD.App.Widget+ -> PC.Input TD.App.Action+ -> P.Producer' (D.DList TD.App.Command) (StateT (R.GizmoOf TD.App.Widget) STM) ()+appProducer appGadget input = PM.execInput input (G.runGadgetT (hoist generalize appGadget )) runCommandsPipe- :: (MonadState (R.SuperModelOf TD.App.Widget) io, MonadIO io)+ :: (MonadState (R.GizmoOf TD.App.Widget) io, MonadIO io) => MVar Int -> R.ReactComponent -> PC.Output TD.App.Action@@ -152,7 +137,7 @@ runCommandsPipe muid component output = PP.mapM (runCommands muid component output) runCommands- :: (Foldable t, MonadState (R.SuperModelOf TD.App.Widget) io, MonadIO io)+ :: (Foldable t, MonadState (R.GizmoOf TD.App.Widget) io, MonadIO io) => MVar Int -> R.ReactComponent -> PC.Output TD.App.Action
examples/todo/haskell/app/Todo/App.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}@@ -8,22 +9,18 @@ {-# LANGUAGE TypeFamilies #-} module Todo.App- ( TodosKey- , Command(..)+ ( Command(..) , Action(..) , AsAction(..) , Plan(..) , HasPlan(..)- , mkPlan- , Model(..)- , HasModel(..)- , Design- , Frame- , SuperModel+ , Schema(..)+ , HasSchema(..)+ , Outline+ , Model , Widget , widget- , window- , gadget+ , TodosKey ) where import qualified Control.Disposable as CD@@ -55,8 +52,9 @@ type TodosKey = Int data Command- = RenderCommand (R.SuperModel Model Plan) [JE.Property] J.JSVal- | SendActionsCommand [Action]+ = RenderCommand (R.Gizmo Model Plan) [JE.Property] J.JSVal+ | SendTodosActionsCommand [W.List.Action TodosKey TD.Todo.Widget]+ | SendFooterActionCommand TD.Footer.Action | InputCommand W.Input.Command | TodosCommand (W.List.Command TodosKey TD.Todo.Widget) | FooterCommand TD.Footer.Command@@ -69,31 +67,44 @@ | 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 Schema t = Schema+ { _input :: R.SchemaType t W.Input.Widget+ , _todos :: R.SchemaType t (W.List.Widget TodosKey TD.Todo.Widget)+ , _footer :: R.SchemaType t TD.Footer.Widget } +type Model = Schema R.WithGizmo+type Outline = Schema R.WithOutline+instance R.ToOutline Model Outline where+ outline (Schema a b c) = Schema (R.outline a) (R.outline b) (R.outline c)++mkModel :: R.ReactMlT Identity () -> Outline -> F (R.Maker Action) Model+mkModel separator (Schema a b c) = Schema+ <$> (R.hoistWithAction InputAction (R.mkGizmo' W.Input.widget a))+ <*> (R.hoistWithAction TodosAction (R.mkGizmo' (W.List.widget separator TD.Todo.widget) b))+ <*> (R.hoistWithAction FooterAction (R.mkGizmo' TD.Footer.widget c))+ data Plan = Plan { _component :: R.ReactComponent+ , _key :: J.JSString+ , _frameNum :: Int+ , _componentRef :: J.JSVal , _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 ''Schema makeClassy ''Plan -mkPlan :: R.Frame Model Plan -> F (R.Maker Action) Plan-mkPlan mm = Plan+mkPlan :: R.ReactMlT Identity () -> R.Frame Model Plan -> F (R.Maker Action) Plan+mkPlan separator mm = Plan <$> R.getComponent- <*> (R.mkRenderer mm (const render))+ <*> R.mkKey+ <*> pure 0+ <*> pure J.nullRef+ <*> (R.mkRenderer mm (const (render separator))) <*> (R.mkHandler $ pure . pure . ComponentRefAction) <*> (R.mkHandler $ pure . pure . const ToggleCompleteAllAction) @@ -101,98 +112,93 @@ instance CD.Disposing Model where disposing s = CD.DisposeList $ CD.disposing (s ^. input)- : foldr ((:) . CD.disposing) [] (s ^. (todos . W.List.itemsModel))+ : CD.disposing (s ^. footer)+ : foldr ((:) . CD.disposing) [] (s ^. (todos . W.List.items)) -- Link Glazier.React.Model's HasPlan/HasModel with this widget's HasPlan/HasModel from makeClassy-instance HasPlan (R.Design Model Plan) where+instance HasPlan (R.Scene 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------------------------------------------------------------+instance HasSchema (R.Scene Model Plan) R.WithGizmo where+ schema = R.model+instance HasPlan (R.Gizmo Model Plan) where+ plan = R.scene . plan+instance HasSchema (R.Gizmo Model Plan) R.WithGizmo where+ schema = R.scene . schema -type Widget = R.Widget Command Action Model Plan-widget :: R.Widget Command Action Model Plan-widget = R.Widget- mkPlan+type Widget = R.Widget Command Action Outline Model Plan+widget :: R.ReactMlT Identity () -> Widget+widget separator = R.Widget+ (mkModel separator)+ (mkPlan separator) window- gadget+ (gadget separator) -hasActiveTodos :: M.Map TodosKey (R.SuperModelOf TD.Todo.Widget) -> Bool-hasActiveTodos = getAny . foldMap (Any . isActiveTodo)+hasActiveTodos :: M.Map TodosKey (R.GizmoOf TD.Todo.Widget) -> Bool+hasActiveTodos = getAny . foldMap (Any . isActiveTodo . R.outline) -isActiveTodo :: (R.SuperModelOf TD.Todo.Widget) -> Bool-isActiveTodo = view (TD.Todo.model . TD.Todo.completed . to not)+isActiveTodo :: (R.OutlineOf TD.Todo.Widget) -> Bool+isActiveTodo = view (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 :: G.WindowT (R.Scene 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)+ 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+render :: R.ReactMlT Identity () -> G.WindowT (R.Scene Model Plan) (R.ReactMlT Identity) ()+render separator = 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")+ lift $ R.bh "header" [("className", "header")] $ do+ R.bh "h1" [("key", "heading")] (R.txt "todos") view G._WindowT inputWindow s- view G._WindowT mainWindow s+ view G._WindowT (mainWindow separator) s -mainWindow :: G.WindowT (R.Design Model Plan) (R.ReactMlT Identity) ()-mainWindow = do+mainWindow :: R.ReactMlT Identity () -> G.WindowT (R.Scene Model Plan) (R.ReactMlT Identity) ()+mainWindow separator = do -- only render if there are todos- ts <- view (todos . W.List.itemsModel)+ ts <- view (todos . W.List.items) if null ts then pure () else do s <- ask- lift $ R.bh (JE.strJS "section") [ ("key", JE.strJS "main")- , ("className", JE.strJS "main")- ] $ do+ lift $ R.bh "section" [ ("key", "main")+ , ("className", "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)- ]+ R.lf "input" [ ("key", "toggle-all")+ , ("className", "toggle-all")+ , ("type", "checkbox")+ , ("checked", s ^. todos . W.List.items . to (JE.toJS' . not . hasActiveTodos))+ , ("onChange", s ^. fireToggleCompleteAll . to JE.toJS')+ ] -- Render the list of todos- view G._WindowT todoListWindow s+ view G._WindowT (todoListWindow separator) 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+inputWindow :: G.WindowT (R.Scene Model Plan) (R.ReactMlT Identity) ()+inputWindow = magnify (input . R.scene) (R.window W.Input.widget) -todoListWindow :: G.WindowT (R.Design Model Plan) (R.ReactMlT Identity) ()-todoListWindow = magnify (todos . R.design) W.List.window+todoListWindow :: R.ReactMlT Identity () -> G.WindowT (R.Scene Model Plan) (R.ReactMlT Identity) ()+todoListWindow separator = magnify (todos . R.scene) (R.window (W.List.widget separator TD.Todo.widget)) -footerWindow :: G.WindowT (R.Design Model Plan) (R.ReactMlT Identity) ()-footerWindow = magnify (footer . R.design) TD.Footer.window+footerWindow :: G.WindowT (R.Scene Model Plan) (R.ReactMlT Identity) ()+footerWindow = magnify (footer . R.scene) (R.window TD.Footer.widget) -updateFooterGadget :: G.GadgetT Action (R.SuperModel Model Plan) Identity (D.DList Command)+updateFooterGadget :: G.GadgetT Action (R.Gizmo 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)]+ (active, completed) <- use (todos . W.List.items . to (M.partition (isActiveTodo . R.outline)))+ pure $ D.singleton $ SendFooterActionCommand+ (TD.Footer.SetCountsAction (length active) (length completed)) -gadget :: G.GadgetT Action (R.SuperModel Model Plan) Identity (D.DList Command)-gadget = do+gadget :: R.ReactMlT Identity () -> G.GadgetT Action (R.Gizmo Model Plan) Identity (D.DList Command)+gadget separator = do a <- ask case a of ComponentRefAction node -> do@@ -203,17 +209,17 @@ D.singleton <$> R.basicRenderCmd frameNum componentRef RenderCommand ToggleCompleteAllAction -> do- s <- use (todos . W.List.itemsModel)+ s <- use (todos . W.List.items) let b = hasActiveTodos s let acts = M.foldMapWithKey (toggleCompleteAll b) s- pure $ D.singleton $ SendActionsCommand $ D.toList $ acts `D.snoc` TodosAction W.List.RenderAction+ pure $ D.singleton $ SendTodosActionsCommand $ D.toList $ acts `D.snoc` 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+ else pure . D.singleton $ SendTodosActionsCommand [W.List.MakeItemAction (+ 1) (pure . toTodoModel str') ]@@ -222,13 +228,13 @@ InputAction _ -> inputGadget TodosAction (W.List.ItemAction k TD.Todo.DestroyAction) -> do- cmds <- todosGadget- cmds' <- pure $ D.singleton $ SendActionsCommand [TodosAction $ W.List.DestroyItemAction k]+ cmds <- todosGadget separator+ cmds' <- pure $ D.singleton $ SendTodosActionsCommand [W.List.DestroyItemAction k] pure $ cmds `mappend` cmds' TodosAction (W.List.DestroyItemAction _) -> do- cmds <- todosGadget- ts <- use (todos . W.List.itemsModel)+ cmds <- todosGadget separator+ ts <- use (todos . W.List.items) -- 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@@ -237,8 +243,8 @@ pure $ cmds `mappend` cmds' `mappend` cmds'' TodosAction (W.List.AddItemAction _ _) -> do- ts <- use (todos . W.List.itemsModel)- cmds <- todosGadget+ ts <- use (todos . W.List.items)+ cmds <- todosGadget separator -- 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@@ -247,20 +253,20 @@ pure $ cmds `mappend` cmds' `mappend` cmds'' TodosAction (W.List.ItemAction _ TD.Todo.ToggleCompletedAction) -> do- cmds <- todosGadget+ cmds <- todosGadget separator cmds' <- updateFooterGadget- pure $ cmds `mappend` cmds' `D.snoc` SendActionsCommand [TodosAction W.List.RenderAction]+ pure $ cmds `mappend` cmds' `D.snoc` SendTodosActionsCommand [W.List.RenderAction] TodosAction _ -> do- cmds <- todosGadget+ cmds <- todosGadget separator cmds' <- updateFooterGadget pure $ cmds `mappend` cmds' FooterAction TD.Footer.ClearCompletedAction -> do cmds <- footerGadget- (todos . W.List.itemsModel) %= M.filter isActiveTodo+ (todos . W.List.items) %= M.filter (isActiveTodo . R.outline) cmds' <- updateFooterGadget- pure $ cmds `mappend` cmds' `D.snoc` SendActionsCommand [TodosAction W.List.RenderAction]+ pure $ cmds `mappend` cmds' `D.snoc` SendTodosActionsCommand [W.List.RenderAction] FooterAction (TD.Footer.SetFilterAction _) -> do cmds <- footerGadget@@ -269,40 +275,34 @@ TD.Filter.All -> const True TD.Filter.Active -> isActiveTodo TD.Filter.Completed -> not . isActiveTodo- pure $ cmds `D.snoc` SendActionsCommand [TodosAction $ W.List.SetFilterAction p]+ pure $ cmds `D.snoc` SendTodosActionsCommand [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+ toTodoModel :: J.JSString -> TodosKey -> R.ModelOf TD.Todo.Widget+ toTodoModel str _ = TD.Todo.Schema str False 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)+ -> R.GizmoOf TD.Todo.Widget+ -> D.DList (W.List.Action TodosKey TD.Todo.Widget)+ toggleCompleteAll b k todoGizmo =+ if todoGizmo ^. (TD.Todo.schema . TD.Todo.completed) /= b+ then D.singleton $ 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)+inputGadget :: G.GadgetT Action (R.Gizmo Model Plan) Identity (D.DList Command)+inputGadget = fmap InputCommand <$> magnify _InputAction (zoom input (R.gadget W.Input.widget)) -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))+todosGadget :: R.ReactMlT Identity () -> G.GadgetT Action (R.Gizmo Model Plan) Identity (D.DList Command)+todosGadget separator = fmap TodosCommand <$> magnify _TodosAction (zoom todos+ (R.gadget (W.List.widget separator TD.Todo.widget))) -footerGadget :: G.GadgetT Action (R.SuperModel Model Plan) Identity (D.DList Command)-footerGadget = fmap FooterCommand <$> magnify _FooterAction (zoom footer TD.Footer.gadget)+footerGadget :: G.GadgetT Action (R.Gizmo Model Plan) Identity (D.DList Command)+footerGadget = fmap FooterCommand <$> magnify _FooterAction (zoom footer (R.gadget TD.Footer.widget))
examples/todo/haskell/app/Todo/App/Run.hs view
@@ -27,9 +27,12 @@ run _ _ _ (RenderCommand sm props j) = R.componentSetState sm props j -run _ _ output (SendActionsCommand acts) =+run _ _ output (SendTodosActionsCommand acts) = void $ runMaybeT $- traverse_ (\act -> lift $ atomically $ PC.send output act >>= guard) acts+ traverse_ (\act -> lift $ atomically $ PC.send output act >>= guard) (TodosAction <$> acts)++run _ _ output (SendFooterActionCommand act) =+ void $ atomically $ PC.send output (FooterAction act) run _ _ _ (InputCommand cmd) = W.Input.run cmd
@@ -11,18 +11,14 @@ ( Command(..) , Action(..) , AsAction(..)+ , Schema(..)+ , HasSchema(..) , Plan(..) , HasPlan(..)- , mkPlan- , Model(..)- , HasModel(..)- , Design- , Frame- , SuperModel+ , Outline+ , Model , Widget , widget- , window- , gadget , onHashChange , whenHashChange , withHashChange@@ -37,7 +33,6 @@ 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@@ -53,7 +48,7 @@ import qualified Todo.Filter as TD.Filter data Command- = RenderCommand (R.SuperModel Model Plan) [JE.Property] J.JSVal+ = RenderCommand (R.Gizmo Model Plan) [JE.Property] J.JSVal data Action = ComponentRefAction J.JSVal@@ -62,112 +57,118 @@ | SetFilterAction TD.Filter.Filter | SetCountsAction Int Int -data Model = Model- { _key :: J.JSString- , _componentRef :: J.JSVal- , _frameNum :: Int- , _activeCount :: Int+data Schema = Schema+ { _activeCount :: Int , _completedCount :: Int , _filter :: TD.Filter.Filter } -instance CD.Disposing Model where- disposing _ = CD.DisposeNone+type Model = Schema+type Outline = Schema+instance R.ToOutline Model Outline where outline = id +mkModel :: Outline -> F (R.Maker Action) Model+mkModel = pure+ data Plan = Plan { _component :: R.ReactComponent+ , _key :: J.JSString+ , _componentRef :: J.JSVal+ , _frameNum :: Int , _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+makeClassy ''Schema mkPlan :: R.Frame Model Plan -> F (R.Maker Action) Plan mkPlan mm = Plan <$> R.getComponent+ <*> R.mkKey+ <*> pure J.nullRef+ <*> pure 0 <*> (R.mkRenderer mm $ const render) <*> (R.mkHandler $ pure . pure . ComponentRefAction) <*> (R.mkHandler $ pure . pure . const ClearCompletedAction) +instance CD.Disposing Plan+instance CD.Disposing Model where+ disposing _ = CD.DisposeNone+ -- Link Glazier.React.Model's HasPlan/HasModel with this widget's HasPlan/HasModel from makeClassy-instance HasPlan (R.Design Model Plan) where+instance HasPlan (R.Scene 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+instance HasSchema (R.Scene Model Plan) where+ schema = R.model+instance HasPlan (R.Gizmo Model Plan) where+ plan = R.scene . plan+instance HasSchema (R.Gizmo Model Plan) where+ schema = R.scene . schema -type Widget = R.Widget Command Action Model Plan-widget :: R.Widget Command Action Model Plan+type Widget = R.Widget Command Action Outline Model Plan+widget :: Widget widget = R.Widget+ mkModel mkPlan window gadget -- | This is used by parent components to render this component-window :: G.WindowT (R.Design Model Plan) (R.ReactMlT Identity) ()+window :: G.WindowT (R.Scene 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)+ 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 :: G.WindowT (R.Scene 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)+ lift $ R.bh "footer" [("className", "footer")] $ do+ R.bh "span" [ ("className", "todo-count")+ , ("key", "todo-count")] $ do+ R.bh "strong" [("key", "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.bh "ul" [("className", "filters")+ , ("key", "filters")] $ do+ R.bh "li" [("key", "filter-all")] $+ R.bh "a" [ ("href", "#/")+ , ("key", "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")+ R.txt " "+ R.bh "li" [("key", "filter-active")] $+ R.bh "a"+ [ ("href", "#/active")+ , ("key", "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")+ R.txt " "+ R.bh "li" [("key", "filter-completed")] $+ R.bh "a"+ [ ("href", "#/completed")+ , ("key", "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")+ then R.bh "button" [("key", "clear-completed")+ , ("className", "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+classNames :: [(J.JSString, Bool)] -> JE.JSVar+classNames = JE.toJS' . J.unwords . fmap fst . P.filter snd -gadget :: G.GadgetT Action (R.SuperModel Model Plan) Identity (D.DList Command)+gadget :: G.GadgetT Action (R.Gizmo Model Plan) Identity (D.DList Command) gadget = do a <- ask case a of@@ -198,7 +199,7 @@ -- 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?+ newURL <- MaybeT (JE.fromJS' <$> JE.getProperty "newURL" evt) let (_, newHash) = J.breakOn "#" newURL pure newHash
examples/todo/haskell/app/Todo/Todo.hs view
@@ -11,18 +11,14 @@ ( Command(..) , Action(..) , AsAction(..)+ , Schema(..)+ , HasSchema(..) , Plan(..) , HasPlan(..)- , mkPlan- , Model(..)- , HasModel(..)- , Design- , Frame- , SuperModel+ , Outline+ , Model , Widget , widget- , window- , gadget ) where import qualified Control.Disposable as CD@@ -34,7 +30,6 @@ 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@@ -48,41 +43,44 @@ import qualified JavaScript.Extras as JE data Command- = RenderCommand (R.SuperModel Model Plan) [JE.Property] J.JSVal+ = RenderCommand (R.Gizmo Model Plan) [JE.Property] J.JSVal | SetPropertyCommand JE.Property J.JSVal | FocusNodeCommand J.JSVal- | SendActionsCommand [Action]+ | SendDestroyActionCommand data Action = ComponentRefAction J.JSVal | RenderAction | ComponentDidUpdateAction- | SendCommandsAction [Command]+ | SetPropertyAction JE.Property J.JSVal | 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+data Schema = Schema+ { _value :: J.JSString , _completed :: Bool , _editing :: Bool+ , _autoFocusEdit :: Bool } -instance CD.Disposing Model where- disposing _ = CD.DisposeNone+type Model = Schema+type Outline = Schema+instance R.ToOutline Model Outline where outline = id +mkModel :: Outline -> F (R.Maker Action) Model+mkModel = pure+ data Plan = Plan { _component :: R.ReactComponent+ , _key :: J.JSString+ , _frameNum :: Int+ , _componentRef :: J.JSVal+ , _editRef :: J.JSVal , _onRender :: J.Callback (J.JSVal -> IO J.JSVal) , _onComponentRef :: J.Callback (J.JSVal -> IO ()) , _onComponentDidUpdate :: J.Callback (J.JSVal -> IO ())@@ -94,14 +92,17 @@ , _onEditKeyDown :: J.Callback (J.JSVal -> IO ()) } deriving G.Generic -instance CD.Disposing Plan makeClassyPrisms ''Action makeClassy ''Plan-makeClassy ''Model+makeClassy ''Schema mkPlan :: R.Frame Model Plan -> F (R.Maker Action) Plan mkPlan mm = Plan <$> R.getComponent+ <*> R.mkKey+ <*> pure 0+ <*> pure J.nullRef+ <*> pure J.nullRef <*> (R.mkRenderer mm $ const render) <*> (R.mkHandler $ pure . pure . ComponentRefAction) <*> (R.mkHandler $ pure . pure . const ComponentDidUpdateAction)@@ -112,86 +113,88 @@ <*> (R.mkHandler $ pure . pure . const CancelEditAction) <*> (R.mkHandler onEditKeyDown') +instance CD.Disposing Plan+instance CD.Disposing Model where+ disposing _ = CD.DisposeNone+ -- Link Glazier.React.Model's HasPlan/HasModel with this widget's HasPlan/HasModel from makeClassy-instance HasPlan (R.Design Model Plan) where+instance HasPlan (R.Scene 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+instance HasSchema (R.Scene Model Plan) where+ schema = R.model+instance HasPlan (R.Gizmo Model Plan) where+ plan = R.scene . plan+instance HasSchema (R.Gizmo Model Plan) where+ schema = R.scene . schema -type Widget = R.Widget Command Action Model Plan-widget :: R.Widget Command Action Model Plan+type Widget = R.Widget Command Action Outline Model Plan+widget :: Widget widget = R.Widget+ mkModel mkPlan window gadget -- | This is used by parent components to render this component-window :: G.WindowT (R.Design Model Plan) (R.ReactMlT Identity) ()+window :: G.WindowT (R.Scene 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)+ 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 :: G.WindowT (R.Scene 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)- ]+ lift $ R.bh "li" [ ("className", classNames [ ("completed", s ^. completed)+ , ("editing", s ^. editing)])+ ] $ do+ R.bh "div" [ ("key", "view")+ , ("className", "view")+ ] $ do+ R.lf "input" [ ("key", "toggle")+ , ("className", "toggle")+ , ("type", "checkbox")+ , ("checked", s ^. completed . to JE.toJS')+ , ("onChange", s ^. fireToggleComplete . to JE.toJS')+ ]+ R.bh "label" [ ("key", "label")+ , ("onDoubleClick", s ^. fireStartEdit. to JE.toJS')+ ] (s ^. value . to R.txt)+ R.lf "button" [ ("key", "destroy")+ , ("className", "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+ R.lf "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)- ]+ , ("ref", s ^. onEditRef . to JE.toJS')+ , ("className", "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+classNames :: [(J.JSString, Bool)] -> JE.JSVar+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]+ -- We have finished with the edit input form, reset the input value to keep the DOM clean.+ SetPropertyAction ("value", JE.toJS' J.empty) j : maybe [CancelEditAction] (pure . SubmitAction) ms -gadget :: G.GadgetT Action (R.SuperModel Model Plan) Identity (D.DList Command)+gadget :: G.GadgetT Action (R.Gizmo Model Plan) Identity (D.DList Command) gadget = do a <- ask case a of@@ -207,22 +210,18 @@ 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+ focus' <- use autoFocusEdit+ autoFocusEdit .= False+ -- Focus after rendering changed because a new input element might have been rendered ret <- runMaybeT $ do- input' <- MaybeT $ pure $ J.nullableToMaybe (J.Nullable input)+ guard focus'+ input <- use editRef+ input' <- MaybeT $ pure $ JE.fromJS input pure $ D.singleton $ FocusNodeCommand input' maybe (pure mempty) pure ret + SetPropertyAction props j -> pure $ D.singleton $ SetPropertyCommand props j+ EditRefAction v -> do editRef .= v pure mempty@@ -241,7 +240,7 @@ guard (not b) editing .= True -- Need to delay focusing until after the next render- deferredActions %= (`D.snoc` FocusEditAction)+ autoFocusEdit .= True D.singleton <$> R.basicRenderCmd frameNum componentRef RenderCommand maybe (pure mempty) pure ret @@ -258,5 +257,5 @@ value .= v' editing .= False if J.null v'- then pure $ D.singleton $ SendActionsCommand [DestroyAction]+ then pure $ D.singleton $ SendDestroyActionCommand else D.singleton <$> R.basicRenderCmd frameNum componentRef RenderCommand
examples/todo/haskell/app/Todo/Todo/Run.hs view
@@ -7,7 +7,6 @@ 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@@ -22,9 +21,8 @@ run _ (FocusNodeCommand j) = js_focus j -run output (SendActionsCommand acts) =- void $ runMaybeT $- traverse_ (\act -> lift $ atomically $ PC.send output act >>= guard) acts+run output SendDestroyActionCommand =+ void $ runMaybeT $ lift $ atomically $ PC.send output DestroyAction >>= guard #ifdef __GHCJS__
− examples/todo/haskell/jsbits/global.js
@@ -1,2 +0,0 @@-// a global for interoperability between html and haskell.-var hgr$todo$registry = new hgr$registry();
glazier-react-examples.cabal view
@@ -1,5 +1,5 @@ name: glazier-react-examples-version: 0.4.0.0+version: 0.6.0.0 synopsis: Examples of using glazier-react description: Examples of using glazier-react homepage: https://github.com/louispan/glazier-react#readme@@ -23,18 +23,17 @@ 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+ , disposable >= 0.2.0.4 && < 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+ , glazier-react >= 0.6.0 && < 1+ , glazier-react-widget >= 0.6.0 && < 1+ , javascript-extras >= 0.3 && < 1 , lens >= 4 && < 5 , mmorph >= 1 && < 2 , mtl >= 2 && < 3