WidgetSet.hs

module Dingo.Internal.WidgetSet
       ( WidgetSet
       , emptyWidgetSet
       , getWidgetState
       , setWidgetState
       , setWidgetStateJ
       ) where

import           Data.Aeson (Value, Result(..), fromJSON)
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as H
import           Data.Typeable (cast)
import           Dingo.Internal.Base
import           Dingo.Internal.WidgetTypes (Widget(..))

-- Existential wrapper type for widgets to be able to store them homogeneously.
data StateBox w = forall s . (Widget w s, Show w) => StateBox (w, s)

data WidgetBox = forall w . WidgetBox (StateBox w)

-- Show instance for WidgetBox.
instance Show WidgetBox where
  show (WidgetBox (StateBox (w,s))) = showWidget w s

-- WidgetSet data type.
newtype WidgetSet = WidgetSet { unWidgetSet :: HashMap WidgetId WidgetBox }
                  deriving (Show)

-- The empty widget set.
emptyWidgetSet :: WidgetSet
emptyWidgetSet = WidgetSet H.empty

-- Set a widget's state.
setWidgetState :: (Widget w s, Show w) => w -> s -> WidgetSet -> WidgetSet
setWidgetState w s (WidgetSet ws) =
  WidgetSet $ H.insert (getWidgetId w) (WidgetBox (StateBox (w,s))) ws

-- Set a widget's state from a JSON object.
setWidgetStateJ :: WidgetId -> Value -> WidgetSet -> WidgetSet
setWidgetStateJ widgetId j (WidgetSet ws) =
  WidgetSet $ H.adjust (update j) widgetId ws
  where
    update :: Value -> WidgetBox -> WidgetBox
    update json (WidgetBox (StateBox (w0,s0))) =
      WidgetBox (StateBox (w0, f $ fromJSON json))
        where
          f (Error _) = s0 -- Couldn't convert JSON; leave state unmodified.
          f (Success s) = s -- Set state.

-- Get a widget's state.
getWidgetState :: (Show w, Widget w s) => WidgetSet -> w -> Maybe s
getWidgetState ws w =
  case H.lookup (getWidgetId w) $ unWidgetSet ws of
    Nothing -> Nothing
    Just (WidgetBox (StateBox (_, s))) -> cast s