{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}
{-# OPTIONS -Wall #-}

-- |Module to ease composing zero-to-many widgets to a larger
-- composite widget.
module Composite
    ( -- * Composite type
      Composite, pickPanel, pickSuper, pickUser
    , compose
    -- * Mapping attributes
    , mapFromPanel, forAllChildren
    , mapFromSuper
    , mapFromUser
    -- * Mapping events
    , mapEventF, mapEventSuper, mapEventPanel
    )
where

import Graphics.UI.WX
import Graphics.UI.WXCore hiding (Event)

-- What about Styled, Dockable, and Pictured classes?

-- |Data type which contains a composite widget
data Composite super user =
    Composite { pickPanel :: Panel ()
              , pickSuper :: super
              , pickUser  :: user
              }

{- |Composes zero-to-many widgets to a larger composite widget

The composite will automatically implement the following classes:

* Widget
* Able
* Bordered
* Child
* Dimensions
* Identiy
* Literate
* Visible
* Reactive (event class)

if the supertype implements one of the following classes, so will the
Composite:

* Items
* Selection
* Selections
* Textual
* Commanding (event class)
* Selecting (event class)

if the composite needs to implement more classes it should be done as
follows:

type MyComposite = Composite super user

instance Foo MyComposite where
   ...

-}
compose :: (Panel () -> IO (Layout, super, user))
        -> Window w -> [Prop (Composite super user)] -> IO (Composite super user)
compose f w props =
    do p <- panel w []
       (lay, super, user) <- f p
       set p [ layout := container p lay  ]
       let composite = Composite p super user
       set composite props
       return composite

-- |Used when an attribute should apply to the panel
mapFromPanel :: Attr (Panel ()) attr -> Attr (Composite super user) attr
mapFromPanel = mapAttrW pickPanel

-- |Used when an attribute should apply to the panel and all of its
-- children
forAllChildren :: Attr (Window ()) attr -> Attr (Panel ()) attr
               -> Attr (Composite super user) attr
forAllChildren childAttr panelAttr = newAttr (attrName panelAttr) getter setter
    where getter w     = get (pickPanel w) panelAttr
          setter w val = do set (pickPanel w) [ panelAttr := val ]
                            xs <- get (pickPanel w) children
                            mapM_ (\x -> set x [ childAttr := val ]) xs


-- |Used when an attribute should apply to the "supertype"
mapFromSuper :: Attr super attr -> Attr (Composite super user) attr
mapFromSuper = mapAttrW pickSuper

-- |Used when an attribute should apply to the "usertype"
mapFromUser :: Attr user attr -> Attr (Composite super user) attr
mapFromUser = mapAttrW pickUser

-- *** Inherit from Panel ()
instance Widget (Composite super user) where
    widget w = widget (pickPanel w)

instance Able (Composite super user) where
    enabled = mapFromPanel enabled

instance Bordered (Composite super user) where
    border = mapFromPanel border

instance Child (Composite super user) where
    parent = mapFromPanel parent

instance Colored (Composite super user) where
    bgcolor = forAllChildren bgcolor bgcolor
    color   = forAllChildren color color

-- Does this instance declaration make sense?
instance Dimensions (Composite super user) where
    outerSize   = mapFromPanel outerSize
    position    = mapFromPanel position
    area        = mapFromPanel area
    bestSize    = mapFromPanel bestSize
    clientSize  = mapFromPanel clientSize
    virtualSize = mapFromPanel virtualSize

instance Identity (Composite super user) where
    identity = mapFromPanel identity

instance Literate (Composite super user) where
    font          = forAllChildren font font
    fontSize      = forAllChildren fontSize fontSize
    fontWeight    = forAllChildren fontWeight fontWeight
    fontFamily    = forAllChildren fontFamily fontFamily
    fontShape     = forAllChildren fontShape fontShape
    fontFace      = forAllChildren fontFace fontFace
    fontUnderline = forAllChildren fontUnderline fontUnderline
    textColor     = forAllChildren textColor textColor
    textBgcolor   = forAllChildren textBgcolor textBgcolor

instance Visible (Composite super user) where
    visible = mapFromPanel visible
    refresh = refresh . pickPanel
    fullRepaintOnResize = mapFromPanel fullRepaintOnResize
    -- fullRepaintOnResize unfortunately do not make any sense,
    -- it must be set at creation time, but the panel has no
    -- attributes set at creation time :(

-- *** Inherit from super

instance Checkable super => Checkable (Composite super user) where
    checkable = mapFromSuper checkable
    checked   = mapFromSuper checked

instance Help super => Help (Composite super user) where
    help = mapFromSuper help

instance Tipped super => Tipped (Composite super user) where
    tooltip = mapFromSuper tooltip

-- if we change String into just "a", then we also need the flag
-- -fallow-undecidable-instances, which we do not want to do.
instance Items super String => Items (Composite super user) String where
    itemCount      = mapFromSuper itemCount
    items          = mapFromSuper items
    item x         = mapFromSuper (item x)
    itemDelete w x = itemDelete  (pickSuper w) x
    itemsDelete w  = itemsDelete (pickSuper w)
    itemAppend w x = itemAppend  (pickSuper w) x

instance Selection super => Selection (Composite super user) where
    selection = mapFromSuper selection

instance Selections super => Selections (Composite super user) where
    selections = mapFromSuper selections

instance Textual super => Textual (Composite super user) where
    text = mapFromSuper text

-- *** Events

-- | Mapping events from supertype
mapEventSuper :: Event super event -> Event (Composite super user) event
mapEventSuper event = mapEventF pickSuper event

-- | Mapping events from the Panel ()
mapEventPanel :: Event (Panel ()) event -> Event (Composite super user) event
mapEventPanel event = mapEventF pickPanel event

-- | Mapping events using a mapper function
mapEventF :: (to -> from) -> Event from event -> Event to event
mapEventF f event = newEvent "" getter setter where
    getter w     = get (f w) (on event)
    setter w val = set (f w) [ on event := val ]
           

instance Selecting super => Selecting (Composite super user) where
    select = mapEventSuper select

instance Commanding super => Commanding (Composite super user) where
    command = mapEventSuper command

instance Reactive (Composite super user) where
    mouse    = mapEventPanel mouse
    keyboard = mapEventPanel keyboard
    closing  = mapEventPanel closing
    idle     = mapEventPanel idle
    resize   = mapEventPanel resize
    focus    = mapEventPanel focus
    activate = mapEventPanel activate

-- We should also do Paint