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

-- |Module to ease composing zero-to-many widgets to a larger
-- composite widget.
module Graphics.UI.WxGeneric.Composite
    ( -- * Composite type
      Composite, pickPanel, pickUser
    , compose, singleComposite
    -- * Mapping attributes
    , mapPanelAttr, forAllChildren
    , mapUserAttr, mapInheritedAttr
    -- * Mapping events
    , mapEventF, mapPanelEvent, mapInheritedEvent
    -- * Other
    , ValuedWidget, widgetValue
    , updateUser, updateInherited
    , Inherit(..), CompositeInherit
    )
where

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

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

-- |Data type which contains a composite widget
data Composite user = forall w. 
    Composite { pickPanel :: Window w    -- ^ Contains the widget, which this Composite represent.
                                         -- The term widget is used broadly here. It can either refer to
                                         -- some basic widget, like a text-box, or to a panel containing
                                         -- multiple sub-widgets. 
              , pickUser  :: user
              }

-- | A marker type, which indicates that we want to derive or inherit all
-- wxHaskell type classes possible.
newtype Inherit super = Inherit { inherit :: super }

-- Ugly name CompositeInherit - but could not figure out a better one.
type CompositeInherit super = Composite (Inherit super)

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

The composite will automatically implement the following classes:

* Widget

* Able

* Bordered

* Child

* Dimensions

* Identity

* Literate

* Visible

* Reactive (event class)

if the user type = (Inherit x) and x implements one of the following
classes, then so will the Composite:

* Items

* Observable

* Selection

* Selections

* Textual

* Commanding (event class)

* Selecting (event class)

* ValuedWidget

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

@
type MyComposite = Composite user
 
instance Foo MyComposite where
   ...
@

-}

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

-- |Encapsulate a single 'Window w' in the composite type
singleComposite :: Window w -> user -> Composite user
singleComposite w = Composite w

-- |Used when an attribute should apply to the panel
mapPanelAttr :: (forall w. Attr (Window w) attr) -> Attr (Composite user) attr
mapPanelAttr attr = newAttr (attrName attr) getter setter
    where getter (Composite wid _)   = get wid attr
          setter (Composite wid _) x = set wid [ attr := x ]

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


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

-- |Used when an attribute should apply to the inherited "usertype"
mapInheritedAttr :: Attr super attr -> Attr (CompositeInherit super) attr
mapInheritedAttr = mapAttrW (inherit . pickUser)

-- *** Inherit from Widget w
instance Widget (Composite user) where
    widget (Composite w _) = widget w

instance Able (Composite user) where
    enabled = mapPanelAttr enabled

instance Bordered (Composite user) where
    border = mapPanelAttr border

instance Child (Composite user) where
    parent = mapPanelAttr parent

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

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

instance Identity (Composite user) where
    identity = mapPanelAttr identity

instance Literate (Composite 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 user) where
    visible = mapPanelAttr visible
    refresh (Composite w _) = refresh w
    fullRepaintOnResize = mapPanelAttr 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 (CompositeInherit super) where
    checkable = mapInheritedAttr checkable
    checked   = mapInheritedAttr checked

instance Help super => Help (CompositeInherit super) where
    help = mapInheritedAttr help

instance Observable super => Observable (CompositeInherit super) where
    change = mapInheritedEvent change

instance Tipped super => Tipped (CompositeInherit super) where
    tooltip = mapInheritedAttr 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 (CompositeInherit super) String where
    itemCount      = mapInheritedAttr itemCount
    items          = mapInheritedAttr items
    item x         = mapInheritedAttr (item x)
    itemDelete w x = itemDelete  (inherit $ pickUser w) x
    itemsDelete w  = itemsDelete (inherit $ pickUser w)
    itemAppend w x = itemAppend  (inherit $ pickUser w) x

instance Selection super => Selection (CompositeInherit super) where
    selection = mapInheritedAttr selection

instance Selections super => Selections (CompositeInherit super) where
    selections = mapInheritedAttr selections

instance Textual super => Textual (CompositeInherit super) where
    text = mapInheritedAttr text

-- We need to use (super a) to make this instance decidable
instance ValuedWidget a (super a) => ValuedWidget a (Composite (Inherit (super a))) where
    widgetValue = mapInheritedAttr widgetValue

-- *** Events

-- | Mapping events from the Panel ()
mapPanelEvent :: (forall w. Event (Window w) event) -> Event (Composite user) event
mapPanelEvent event = newEvent "" getter setter where
    getter (Composite w _)     = get w (on event)
    setter (Composite w _) val = set w [ on event := val ]

-- |Mapping events from the inherited "usertype"
mapInheritedEvent :: Event super event -> Event (CompositeInherit super) event
mapInheritedEvent event = mapEventF (inherit . pickUser) 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 (CompositeInherit super) where
    select = mapInheritedEvent select

instance Commanding super => Commanding (CompositeInherit super) where
    command = mapInheritedEvent command

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

-- We should also do Paint

-- Should properly rename ValuedWidget to Valued, but there is already
-- a type class called Valued in WxHaskell. However, WxHaskell's
-- definition do not really work for widgets. It only seems to work
-- for Var-s.
class ValuedWidget value widget | widget -> value where
    -- |An attribute for the value of a widget. The value should have as precise
    -- a type as possible. For example a slider should properly have type Attr Slider Int.
    widgetValue :: Attr widget value


-- GHC error message: 
-- Record update for the non-Haskell-98 data type `Composite' is not (yet) supported
-- Use pattern-matching instead
--
-- Thus we avoid pattern matching here.
updateUser :: (user -> user') -> Composite user -> Composite user'
updateUser f (Composite panel' user) = Composite panel' (f user)

updateInherited :: (super -> super') -> CompositeInherit super -> CompositeInherit super'
updateInherited f (Composite panel' super) = Composite panel' (Inherit $ f $ inherit super)