{-# 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, pickLayout, pickUser
    , compose, singleComposite, singleCompositeEx
    -- * Mapping attributes
    , mapPanelAttr, forAllChildren
    , mapUserAttr, mapInheritedAttr
    -- * Mapping events
    , mapEventF, mapPanelEvent, mapInheritedEvent
    -- * Event propagation
    , propagateFutureEvents, EventToken(..), allEvents
    , propagateFutureEventsEx, propagateWxEvent
    -- * Is Some Event
    , isEnterOrLeave, isMouseMotion, isMouseWheel
    -- * Other
    , ValuedWidget, widgetValue
    , updateUser, updateInherited
    , Inherit(..), CompositeInherit
    )
where

import Graphics.UI.WX
import Graphics.UI.WXCore hiding (Event)
import qualified Graphics.UI.XTC as 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. 
              , pickLayout :: Layout
              , pickUser   :: user
              }

-- | A marker type, which indicates that we want to derive or inherit all
-- wxHaskell type classes possible.
newtype Inherit super = Inherit { unInherit :: 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

* Parent

* Sized

* 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 (container p lay) user
       set composite props
       return composite

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

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

-- |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 (unInherit . pickUser)

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

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 Parent (Composite user) where
    children     = mapPanelAttr children
    clipChildren = mapPanelAttr clipChildren

instance Sized (Composite user) where
    size = mapPanelAttr size

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 XTC.Observable super => XTC.Observable (CompositeInherit super) where
    change = mapInheritedEvent XTC.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  (unInherit $ pickUser w) x
    itemsDelete w  = itemsDelete (unInherit $ pickUser w)
    itemAppend w x = itemAppend  (unInherit $ 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 (unInherit . 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' lay user) = Composite panel' lay (f user)

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


-- *** Event propagation

{- Which to propagate

mouse     Yes
keyboard  Yes
closing   No, as we already know when the panel is closing
idle      No, as we can already attach that to the panel
resize    No, as we can already attach that to the panel
focus     Yes
activate  (when a frame is (de)-activated, an activiate event is sent) No,
          as it only applies to frames and dialogs.

-}



data EventToken = Mouse
                | Keyboard
                | Focus

allEvents :: [EventToken]
allEvents = [ Mouse, Keyboard, Focus ]

-- | 'propagateFutureEvents' is an easy to use wrapper around
-- 'propagateFutureEvents'.
--
-- 'propagateFutureEvents' propagates future events from one widget to
-- another, based on a list of 'EventToken's. The from widget will
-- usually be a normal wxHaskell widget or some 'Composite'. The to
-- widget will usually be a panel or a frame.
--
propagateFutureEvents :: (Reactive from, Reactive to) => [EventToken] -> from -> to -> IO ()
propagateFutureEvents events from to = sequence_ $ map propHelper events
    where -- We do not want to propagate enter/leave events, as only want these widgets
          -- when leaving/entering the hole widgets.
          propHelper Mouse      = propagateFutureEventsEx (not . isEnterOrLeave) from to mouse mouse
          propHelper Keyboard   = propagateFutureEventsEx (const True) from to keyboard keyboard
          propHelper Focus      = propagateFutureEventsEx (const True) from to focus focus
          
isEnterOrLeave :: EventMouse -> Bool
isEnterOrLeave (MouseEnter _ _) = True
isEnterOrLeave (MouseLeave _ _) = True
isEnterOrLeave _                = False

isMouseMotion ::  EventMouse -> Bool
isMouseMotion (MouseMotion _ _) = True
isMouseMotion _                 = False

isMouseWheel ::  EventMouse -> Bool
isMouseWheel (MouseWheel _ _ _) = True
isMouseWheel _                  = False


-- | Transmit future events from one wxHaskell widget to a
-- parent-widget. All events, where 'propagateThisEvent' returns
-- 'True' is propagated to the parent-widget. If 'False' is returned,
-- then we call 'Graphics.UI.WX.Events.propagateEvent', so the
-- form-widgets normal event handling code will recieve the
-- event. E.g. a button should not propagate click-events to the
-- parent-widget, but the button should handle the click-event itself.
--
-- However, it is essential to note that 'propagateThisEvent' _cannot_
-- be used to decide if the from-widget should have some events
-- blocked. It is only usefull for deciding if events should be
-- propagated to the parent 'Window w'. Even if an event is propagated
-- to a parent-widget, then the parent-widget's event handling code
-- may call 'Graphics.UI.WX.Events.propagateEvent', and then propagate
-- the event back to the from-widget.
-- 
-- Note that we need two Event inputs, otherwise the 'fromWidget' and 'toWidget'
-- must be of the same type.
--
-- See 'propagateFutureEvents' for an easier to use version of
-- 'propagateFutureEventsEx'.
propagateFutureEventsEx
    :: (t -> Bool)                     -- ^ Only propagates events where this function returns true. 
    -> fromWidget                      -- ^ The Window w to propagate from
    -> toWidget                        -- ^ The Window w to propagate from
    -> Event fromWidget  (t -> IO ())  -- ^ From event
    -> Event toWidget    (t -> IO ())  -- ^ To Event
    -> IO ()
propagateFutureEventsEx propagateThisEvent fromWidget toWidget fromEvent toEvent =
    set fromWidget [ on fromEvent := \evt -> if propagateThisEvent evt
                                             then propagateWxEvent toWidget toEvent evt
                                             else propagateEvent
                   ]

-- | Propagate an event to a 'Window w'.
propagateWxEvent :: toWindow -> Event toWindow (inEvt -> IO a) -> inEvt -> IO a
propagateWxEvent toWindow toEvent evt =
    do evtHandler <- get toWindow (on toEvent)
       evtHandler evt