module Glazier.React.Widgets.List
( Command(..)
, Action(..)
, AsAction(..)
, Gasket(..)
, HasGasket(..)
, mkGasket
, Model(..)
, HasModel(..)
, mkSuperModel
, Widget
, GModel
, MModel
, SuperModel
, window
, gadget
) where
import qualified Control.Disposable as CD
import Control.Lens
import Control.Monad.Free.Church
import Control.Monad.Morph
import Control.Monad.Reader
import Control.Monad.Trans.Maybe
import qualified Data.DList as D
import Data.Foldable
import qualified Data.JSString as J
import qualified Data.List as DL
import qualified Data.Map.Strict as M
import qualified GHC.Generics as G
import qualified GHCJS.Foreign.Callback as J
import qualified GHCJS.Types as J
import qualified Glazier as G
import qualified Glazier.React.Command as R
import qualified Glazier.React.Component as R
import qualified Glazier.React.Maker as R
import qualified Glazier.React.Markup as R
import qualified Glazier.React.Widget as R
import qualified JavaScript.Extras as JE
data Command key itemWidget
= RenderCommand (R.SuperModel Gasket (Model key itemWidget)) [JE.Property] J.JSVal
| DisposeCommand CD.SomeDisposable
| MakerCommand (F (R.Maker (Action key itemWidget)) (Action key itemWidget))
| ItemCommand key (R.WidgetCommand itemWidget)
data Action key itemWidget
= ComponentRefAction J.JSVal
| RenderAction
| ComponentDidUpdateAction
| DestroyItemAction key
| MakeItemAction (key -> key) (key -> R.WidgetModel itemWidget)
| AddItemAction key (R.WidgetSuperModel itemWidget)
| ItemAction key (R.WidgetAction itemWidget)
| SetFilterAction (R.WidgetSuperModel itemWidget -> Bool)
data Model key itemWidget = Model
{ _uid :: J.JSString
, _componentRef :: J.JSVal
, _frameNum :: Int
, _deferredCommands :: D.DList (Command key itemWidget)
, _className ::J.JSString
, _itemKey :: key
, _itemsModel :: M.Map key (R.WidgetSuperModel itemWidget)
, _itemsFilter :: R.WidgetSuperModel itemWidget -> Bool
}
data Gasket = Gasket
{ _component :: R.ReactComponent
, _onRender :: J.Callback (J.JSVal -> IO J.JSVal)
, _onComponentRef :: J.Callback (J.JSVal -> IO ())
, _onComponentDidUpdate :: J.Callback (J.JSVal -> IO ())
} deriving (G.Generic)
makeClassyPrisms ''Action
makeClassy ''Gasket
makeClassy ''Model
mkGasket
:: G.WindowT (R.WidgetGModel itemWidget) (R.ReactMlT Identity) ()
-> R.ReactMlT Identity ()
-> MModel key itemWidget
-> F (R.Maker (Action key itemWidget)) Gasket
mkGasket itemWindow separator mm = Gasket
<$> R.getComponent
<*> (R.mkRenderer mm $ const (render itemWindow separator))
<*> (R.mkHandler $ pure . pure . ComponentRefAction)
<*> (R.mkHandler $ pure . pure . const ComponentDidUpdateAction)
instance ( CD.Disposing (R.WidgetGasket itemWidget)
, CD.Disposing (R.WidgetModel itemWidget)
) =>
CD.Disposing (Model key itemWidget) where
disposing s =
CD.DisposeList $ foldr ((:) . CD.disposing) [] (s ^. itemsModel)
mkSuperModel
:: G.WindowT (R.WidgetGModel itemWidget) (R.ReactMlT Identity) ()
-> R.ReactMlT Identity ()
-> Model key itemWidget
-> F (R.Maker (Action key itemWidget)) (SuperModel key itemWidget)
mkSuperModel itemWindow separator s = R.mkSuperModel (mkGasket itemWindow separator) $ \gkt -> R.GModel gkt s
data Widget key itemWidget
instance R.IsWidget (Widget key itemWidget) where
type WidgetAction (Widget key itemWidget) = Action key itemWidget
type WidgetCommand (Widget key itemWidget) = Command key itemWidget
type WidgetModel (Widget key itemWidget) = Model key itemWidget
type WidgetGasket (Widget ackey itemWidget) = Gasket
type GModel key itemWidget = R.WidgetGModel (Widget key itemWidget)
type MModel key itemWidget = R.WidgetMModel (Widget key itemWidget)
type SuperModel key itemWidget = R.WidgetSuperModel (Widget key itemWidget)
instance CD.Disposing Gasket
instance HasGasket (R.GModel Gasket (Model key itemWidget)) where
gasket = R.widgetGasket
instance HasModel (R.GModel Gasket (Model key itemWidget)) key itemWidget where
model = R.widgetModel
instance HasGasket (R.SuperModel Gasket (Model key itemWidget)) where
gasket = R.gModel . gasket
instance HasModel (R.SuperModel Gasket (Model key itemWidget)) key itemWidget where
model = R.gModel . model
window :: Monad m => G.WindowT (GModel key itemWidget) (R.ReactMlT m) ()
window = do
s <- ask
lift $ R.lf (s ^. component . to JE.toJS)
[ ("key", s ^. uid . to JE.toJS)
, ("render", s ^. onRender . to JE.toJS)
, ("ref", s ^. onComponentRef . to JE.toJS)
, ("componentDidUpdate", s ^. onComponentDidUpdate . to JE.toJS)
]
render
:: Monad m
=> G.WindowT (R.WidgetGModel itemWidget) (R.ReactMlT m) ()
-> R.ReactMlT m ()
-> G.WindowT (GModel key itemWidget) (R.ReactMlT m) ()
render itemWindow separator = do
s <- ask
items <- fmap (view R.gModel) . filter (s ^. itemsFilter) . fmap snd . M.toList <$> view itemsModel
lift $ R.bh (JE.strJS "ul") [ ("key", s ^. uid . to JE.toJS)
, ("className", s ^. className . to JE.toJS)
] $ do
let itemsWindows = (view G._WindowT itemWindow) <$> items
separatedWindows = DL.intersperse separator itemsWindows
sequenceA_ separatedWindows
gadget
:: (Ord key, Monad m, CD.Disposing (R.WidgetModel itemWidget), CD.Disposing (R.WidgetGasket itemWidget))
=> (R.WidgetModel itemWidget -> F (R.Maker (R.WidgetAction itemWidget)) (R.WidgetSuperModel itemWidget))
-> G.GadgetT (R.WidgetAction itemWidget) (R.WidgetSuperModel itemWidget) m (D.DList (R.WidgetCommand itemWidget))
-> G.GadgetT (Action key itemWidget) (SuperModel key itemWidget) m (D.DList (Command key itemWidget))
gadget mkItemSuperModel itemGadget = do
a <- ask
case a of
ComponentRefAction node -> do
componentRef .= node
pure mempty
RenderAction ->
D.singleton <$> (R.basicRenderCmd frameNum componentRef RenderCommand)
ComponentDidUpdateAction -> do
cmds <- use deferredCommands
deferredCommands .= mempty
pure cmds
DestroyItemAction k -> do
ret <- runMaybeT $ do
itemSuperModel <- MaybeT $ use (itemsModel . at k)
let junk = CD.disposing itemSuperModel
deferredCommands %= (`D.snoc` DisposeCommand junk)
itemsModel %= M.delete k
D.singleton <$> (R.basicRenderCmd frameNum componentRef RenderCommand)
maybe (pure mempty) pure ret
MakeItemAction keyMaker itemModelMaker -> do
n <- keyMaker <$> use itemKey
itemKey .= n
pure $ D.singleton $ MakerCommand $ do
sm <- hoistF (R.mapAction $ \act -> ItemAction n act) $
mkItemSuperModel (itemModelMaker n)
pure $ AddItemAction n sm
AddItemAction n v -> do
itemsModel %= M.insert n v
D.singleton <$> (R.basicRenderCmd frameNum componentRef RenderCommand)
ItemAction key _ -> fmap (ItemCommand key) <$>
(magnify (_ItemAction . to snd)
(zoom (itemsModel . at key . _Just) itemGadget))
SetFilterAction ftr -> do
itemsFilter .= ftr
D.singleton <$> (R.basicRenderCmd frameNum componentRef RenderCommand)