{-# LANGUAGE ExistentialQuantification, FlexibleContexts
  , FlexibleInstances, FunctionalDependencies
  , GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses
  , RankNTypes, ScopedTypeVariables #-}
{-# OPTIONS -Wall #-}

{- |Contains GenWid, which is the type used for the inner widget in WxGeneric. Plus
functions to create GenWid.

GenWid contains a valued version of 'Composite'.
-}
module Graphics.UI.WxGeneric.GenericWidget
    ( valuedCompose
    , mkGenWid, mkSingleObservable, mkSingleObservableEx, GenWid, GenWidIO(GenWidIO), unWidIO
    , MapValue(..)
    , module Graphics.UI.WxGeneric.GenericWidget.Parameters
    , module Graphics.UI.WxGeneric.GenericWidget.WidgetTree
    )
where

import Graphics.UI.WX
import qualified Graphics.UI.WXCore as WXCore
import qualified Graphics.UI.XTC as XTC
import qualified Graphics.UI.WxGeneric.Composite as C
import Graphics.UI.WxGeneric.GenericWidget.Parameters
import Graphics.UI.WxGeneric.GenericWidget.WidgetTree

data GenWidIO a = GenWidIO (forall w. Parms w -> IO (GenWid a))

unWidIO :: GenWidIO a -> forall w. Parms w -> IO (GenWid a)
unWidIO (GenWidIO f) = f

-- |Composing multiple widgets into a composite GenWid. It is similar
-- to 'C.compose'.
valuedCompose :: (Parms (WXCore.CPanel ())
                  -> IO (Layout, IO a, a -> IO(), IO (IO ()), IO() -> IO(), IO WidTree)
                 )
               -> GenWidIO a
valuedCompose f = GenWidIO 
  (\genWidParms ->
    do let w = getParent genWidParms
       p <- panel w []
       C.propagateFutureEvents C.allEvents p w
       (lay, getter, setter, getChange, setChange, getWidTree) <- f (setParent p genWidParms)
       return $ mkGenWidEx p (container p lay) getter setter getChange setChange getWidTree
  )
-- *** ValuedCmds

data ValuedCmds a = ValuedCmds
    { pickGetValue   :: IO a
    , pickSetValue   :: a -> IO ()
    , pickGetChange  :: IO (IO ())
    , pickSetChange  :: IO() -> IO()
    , pickGetWidTree :: IO WidTree
    }
instance XTC.Observable (ValuedCmds a) where
    change = newEvent "change" pickGetChange pickSetChange

instance C.ValuedWidget a (ValuedCmds a) where
    widgetValue = newAttr "valued" pickGetValue pickSetValue

-- *** GenWid

newtype GenWid a = GenWid { unGenWid :: (C.CompositeInherit (ValuedCmds a)) }
    deriving ( Widget, Able, Bordered, Child, Dimensions, Identity, Literate, Visible, Reactive, Parent, Sized
             , XTC.Observable, C.ValuedWidget a
             )

-- |Creates a GenWid using monadic actions.
mkGenWid :: forall w a.
            Window w -> IO a -> (a -> IO ()) -> IO (IO ()) -> (IO() -> IO()) -> (IO WidTree)
         -> GenWid a
mkGenWid w getVal setVal getChg setChg getWidTree = 
    GenWid $ C.singleComposite w (C.Inherit (ValuedCmds getVal setVal getChg setChg getWidTree))

-- |Creates a GenWid using monadic actions.
mkGenWidEx :: forall w a.
              Window w -> Layout -> IO a -> (a -> IO ()) -> IO (IO ()) -> (IO() -> IO()) -> (IO WidTree)
           -> GenWid a
mkGenWidEx w lay getVal setVal getChg setChg getWidTree = 
    GenWid $ C.singleCompositeEx w lay (C.Inherit (ValuedCmds getVal setVal getChg setChg getWidTree))

-- |Creates a GenWid using an Observable widget, a get-value action
-- and a set-value action.
mkSingleObservable :: forall w a. (XTC.Observable (Window w)) =>
                      Window w -> IO a -> (a -> IO ()) -> IO WidTree
                   -> GenWid a
{-# DEPRECATED mkSingleObservable "Use mkSingleObservableEx in stead" #-}
mkSingleObservable wid getter setter getWidTree =
    mkGenWid wid getter setter getChange setChange getWidTree
        where getChange   = get wid (on XTC.change)
              setChange x = set wid [on XTC.change := x]

-- |Creates a GenWid using an Observable widget, a get-value action
-- and a set-value action.
mkSingleObservableEx
    :: forall w a. (XTC.Observable (Window w)) =>
       Window w -> (Layout -> Layout) -> IO a -> (a -> IO ()) -> IO WidTree
    -> GenWid a
mkSingleObservableEx wid lay getter setter getWidTree =
    mkGenWidEx wid (lay $ widget wid) getter setter getChange setChange getWidTree
        where getChange   = get wid (on XTC.change)
              setChange x = set wid [on XTC.change := x]

-- *** MapValue class

class MapValue (valued :: * -> *) where
    -- |Maps the value a type.
    mapValue :: (old -> new)        -- ^old to new conversion
             -> (old -> new -> old) -- ^new to old conversion. This functions also get the current
                                    --  old value as input.
             -> valued old          -- ^old type
             -> valued new          -- ^new type

instance MapValue GenWid where
    mapValue oldToNew newToOld (GenWid composite) =
        let updateCmds valuedCmds =
                valuedCmds { pickGetValue = pickGetValue valuedCmds >>= return . oldToNew
                           , pickSetValue = \x -> do old <- pickGetValue valuedCmds
                                                     pickSetValue valuedCmds (newToOld old x)
                           }
        in GenWid $ C.updateInherited updateCmds composite

-- *** WidTree

instance WidgetTree (GenWid a) where
    widgetTree = readAttr "widgetTree"
                 (pickGetWidTree . C.unInherit . C.pickUser . unGenWid)




{- Wonder if anybody is missing these two functions?

-- |Makes a GenWid from a an ordinary WxHaskell 'Window w' (widget)
-- that implements Observable and ValuedWidget.
fromWidget :: forall w a. (Observable (Window w), ValuedWidget a (Window w)) =>
              (forall w'. Window w' -> IO (Window w))
           -> GenWidIO a
fromWidget wid = fromWidget' widgetValue change wid

-- |Similar to fromWidget, except you explicitly gives the widgetValue
-- (ValuedWidget) attribute and change (Observable) event.
fromWidget' :: forall w a.
               Attr (Window w) a
            -> Event (Window w) (IO ())
            -> (forall w'. Window w' -> IO (Window w))
            -> IO WidTree
            -> GenWidIO a
fromWidget' valueAttr observable toWindowW  getWidTree w
    = do windowW <- toWindowW w
         return $ mkGenWid windowW (get windowW valueAttr) (\x -> set windowW [ valueAttr := x ])
                         (get windowW (on observable)) (\x -> set windowW [ on observable := x ])
                         getWidTree
-}