module Dingo.Internal.Callback
( CallbackT
, CallbackM
, CallbackState
, addCommand
, addWidget
, registerCallback
, runCallbackT
) where
import Control.Monad (forM_, when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
import Data.Aeson (ToJSON(..))
import Dingo.Internal.Base (CallbackId, WidgetId, Command(..))
import Dingo.Internal.CallbackTypes
import Dingo.Internal.Html (mkHeadMerge)
import qualified Dingo.Internal.Session as S
import Dingo.Internal.TypeableShim (getTypeId)
import Dingo.Internal.WidgetTypes
registerCallback :: CallbackM () -> CallbackM CallbackId
registerCallback callback = CallbackT $
lift $ S.registerCallback $ WrapCallback callback
addWidget :: (Widget w s, Widget w' s') => w' -> (WidgetId -> CallbackM (w, s)) -> CallbackM w
addWidget pw f = do
((w,s),callbackState) <- lift $ S.addWidget $ \newWidgetId ->
runCallbackT (f newWidgetId)
augmentState callbackState
widgetTypeId <- liftIO $ getTypeId w
registeredWidgetType <- lift $ S.registerWidgetType $ widgetTypeId
when registeredWidgetType $ do
let requiredResources = widgetResources $ getWidgetType w
forM_ requiredResources $ \resourceBundle -> do
bundleRegistered <- lift $ S.registerResourceBundle resourceBundle
when bundleRegistered $
forM_ (mkHeadMerge resourceBundle) $ \html ->
addCommand $ HeadMerge html
addCommand $ HeadMerge $ headMergeContent $ getWidgetType w
addCommand $ AppendToWidgetChildren (getWidgetId pw) (renderWidget w)
addCommand $ AddEncoderDecoderFunctions (getWidgetId w)
(encodeClientStateJs $ getWidgetType w)
(decodeClientStateJs $ getWidgetType w)
addCommand $ SetWidgetValue (getWidgetId w) (toJSON s)
return w