{-#LANGUAGE TemplateHaskell #-}
module Simple.UI.Widgets.Container (
ContainerClass,
Container,
castToContainer,
containerNew,
widgets,
layout,
addTo,
LayoutClass,
LayoutData,
EmptyLayout (..),
EmptyLayoutData (..),
layoutDraw,
layoutComputeSize
) where
import qualified Control.Arrow as Arrow
import Control.Lens ((.=), makeLensesFor)
import Control.Monad
import Control.Monad.IO.Class
import Data.Default.Class
import Simple.UI.Core.Internal.UIApp
import Simple.UI.Core.Attribute
import Simple.UI.Core.Draw
import Simple.UI.Core.ListenerList
import Simple.UI.Widgets.Widget
data EmptyLayout = EmptyLayout
data EmptyLayoutData = EmptyLayoutData
data Container a = Container
{ _containerParent :: Widget
, _containerWidgets :: AttributeList (Widget, LayoutData a)
, _containerLayout :: Attribute a
}
class LayoutClass w where
type LayoutData w
layoutDraw :: ContainerClass c => c w -> Drawing -> Int -> Int -> UIApp u ()
layoutComputeSize :: ContainerClass c => c w -> UIApp u (Int, Int)
class ContainerClass w where
castToContainer :: w a -> Container a
widgets :: w a -> AttributeList (Widget, LayoutData a)
widgets = _containerWidgets . castToContainer
layout :: w a -> Attribute a
layout = _containerLayout . castToContainer
addTo :: (WidgetClass u, MonadIO m) => w a -> u -> LayoutData a -> m ()
addTo c w d = add c widgets (Arrow.first castToWidget) (w, d)
makeLensesFor [("_containerParent", "containerParent")] ''Container
instance LayoutClass EmptyLayout where
type LayoutData EmptyLayout = EmptyLayoutData
layoutDraw _ _ _ _ = return ()
layoutComputeSize _ = return (1, 1)
instance Default EmptyLayoutData where
def = EmptyLayoutData
instance ContainerClass Container where
castToContainer = id
instance WidgetClass (Container a) where
castToWidget = _containerParent
overrideWidget = overrideWidgetHelper containerParent
containerNew :: LayoutClass a => a -> UIApp u (Container a)
containerNew _layout = do
container <- containerNewOverride _layout
on_ container draw $ \drawing width height -> do
fg <- get container colorForeground
bg <- get container colorBackground
drawingRun drawing $ do
drawingSetAttrs fg bg DrawStyleNormal
drawingClear
layoutDraw container drawing width height
on_ container keyPressed $ \key modifiers -> do
_widgets <- get container widgets
forM_ _widgets $ \(widget, _) -> do
en <- get widget enabled
v <- get widget visible
when (en && v) $ fire widget keyPressed (key, modifiers)
return container
containerNewOverride :: LayoutClass a => a -> UIApp u (Container a)
containerNewOverride _layout = override <$> containerNewDefault _layout
where
override container = overrideWidget container $ do
virtualWidgetName .= "container"
virtualWidgetComputeSize .= layoutComputeSize container
containerNewDefault :: LayoutClass a => a -> UIApp u (Container a)
containerNewDefault _layout = do
parent <- widgetNew
_widgets <- attributeNew []
layoutAttr <- attributeNew _layout
return Container
{ _containerParent = parent
, _containerWidgets = _widgets
, _containerLayout = layoutAttr
}