Callback.hs

module Dingo.Internal.Callback
       ( CallbackT          -- re-export without constructors
       , CallbackM          -- re-export without constructors
       , CallbackState      -- re-export
       , addCommand         -- re-export
       , addWidget
       , registerCallback
       , runCallbackT       -- re-export
       ) where

import           Control.Monad (forM_, when)
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Trans.Class (lift)
import           Data.Aeson (ToJSON(..))
import           Data.Typeable (typeOf, typeRepKey)
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.WidgetTypes

-- Register a callback.
registerCallback :: CallbackM () -> CallbackM CallbackId
registerCallback callback = CallbackT $
  -- Register the callback in the session and return its ID.
  lift $ S.registerCallback $ WrapCallback callback

-- | Add a new widget using a given parent. The widget is constructed
-- using the given function which receives the new widget's ID as a parameter.
addWidget :: (Widget w s, Widget w' s') => w' -> (WidgetId -> CallbackM (w, s)) -> CallbackM w
addWidget pw f = do
  -- Construct the widget.
  ((w,s),callbackState) <- lift $ S.addWidget $ \newWidgetId ->
    runCallbackT (f newWidgetId)
  -- Add all the commands from the widget construction.
  augmentState callbackState
  -- Register widget type if necessary.
  widgetTypeRepKey <- liftIO $ typeRepKey $ typeOf w
  registeredWidgetType <- lift $ S.registerWidgetType $ widgetTypeRepKey
  -- Register resource bundles and perform head merges if necessary.
  when registeredWidgetType $ do
    -- Which resources does this widget require?
    let requiredResources = widgetResources $ getWidgetType w
    -- Add all the resource bundles.
    forM_ requiredResources $ \resourceBundle -> do
      -- Register the bundle if necessary.
      bundleRegistered <- lift $ S.registerResourceBundle resourceBundle
      -- If we hadn't registered the bundle before, we'll need to do head
      -- merge.
      when bundleRegistered $
        forM_ (mkHeadMerge resourceBundle) $ \html ->
          addCommand $ HeadMerge html
    -- Head merge other content.
    addCommand $ HeadMerge $ headMergeContent $ getWidgetType w
  -- Append widget HTML to parent.
  addCommand $ AppendToWidgetChildren (getWidgetId pw) (renderWidget w)
  -- Serialize initial state to client.
  addCommand $ AddEncoderDecoderFunctions (getWidgetId w)
    (encodeClientStateJs $ getWidgetType w)
    (decodeClientStateJs $ getWidgetType w)
  addCommand $ SetWidgetValue (getWidgetId w) (toJSON s)
  -- Return the widget
  return w