{-# OPTIONS -fno-warn-orphans #-}

{-

No warning about orhpans?

About orhpan instances see:

* http://lukepalmer.wordpress.com/2009/01/25/a-world-without-orphans/
(read comments too) - this links gives the easiest to understand
introduction to orhpan instances.
* http://www.haskell.org/ghc/docs/latest/html/users_guide/separate-compilation.html#orphan-modules

We could remove this warning by moving the WxGen [a] instance to
GenericClass. But GenericClass is already big enough.

We cannot just move:

instance (GC.WxGen a, Show a) => GC.WxGen [a] where
    mkWid xs = (mkDefaultListOuter `GC.extOuter` mkStringOuter) xs

to GenericClass, as mkDefaultListOuter depends upon WxGen. Thus we
will have circular dependencies: GenericClass -> GenericList
GenericClass. I would prefer orhpan instances to circular dependencies
any day.

However, it is important that GenericList is always (indirectly)
imported when people use the WxGen class. Otherwise people will not
see the WxGen [a] implementation. And worse they might create their
own implementation of WxGen [a], which will waste work and lead to
bigger issues in the long run (see Luke's blogpost above). But
GenericList do not have to be in any export list, as instances are
exported without being in export list.

The sure way to force the importation of WxGen [a] is to:

* Graphics.UI.WxGeneric.GenericClass is not a public module
* Graphics.UI.WxGeneric exports everything from GenericClass
* Graphics.UI.WxGeneric imports GenericList

-}

-- |Exports an instance for 'WxGen' [a]. It handles [Char] instances specially.
module Graphics.UI.WxGeneric.GenericList
    ( )
where

import Graphics.UI.SybWidget(gToString)
import qualified Graphics.UI.SybWidget.InstanceCreator as InstanceCreator

import qualified Graphics.UI.WxGeneric.GenericClass  as GC
import qualified Graphics.UI.WxGeneric.GenericWidget as GW
import qualified Graphics.UI.WxGeneric.Composite     as C

import Graphics.UI.WX as Wx
import qualified Graphics.UI.XTC as XTC

import Data.Maybe
import Control.Monad
import Data.List(partition)

instance (GC.WxGen a, Show a) => GC.WxGen [a] where
    mkWid xs = (mkDefaultListOuter `GC.extOuter` mkStringOuter) xs

mkStringOuter :: String -> GC.Outer String
mkStringOuter x = GC.replacePoorConstrLabel "String" $ GC.toOuter helper where
    helper genWidParms = 
        do let p = GW.getParent genWidParms
           te <- textEntry p [ text := x ]
           C.propagateFutureEvents [C.Mouse, C.Focus] te p
           let getter     = get te text
               setter val = set te [ text := val ]
           return $ GW.mkSingleObservableEx te hfill getter setter 
                      (GW.singleChild te)


-- A function to show lists in a GUI.
mkDefaultListOuter :: (GC.WxGen a, Show a) => [a] -> GC.Outer [a]
mkDefaultListOuter xs = GC.toOuter (GW.valuedCompose helper) where
    helper genWidParms =
        do let p = GW.getParent genWidParms
               shortenLongLines ys = if length ys > maxListWidth
                                     then take (maxListWidth - 4) ys ++ " ..."
                                     else ys
               maxListWidth = 20
           changeVar <- varCreate (return ())
           ls <- XTC.mkMultiListViewEx p (shortenLongLines . gToString) [ XTC.typedItems := xs ]
           let mkButton lbl = do newLbl <- GW.transformLabel genWidParms lbl
                                 button p [ text := newLbl ]
           up     <- mkButton "Up"
           down   <- mkButton "Down"
           remove <- mkButton "Remove"
           edit   <- mkButton "Edit"
           add    <- mkButton "Add"
           let allButtons = [up, down, remove, edit, add]
           mapM_ (\w -> C.propagateFutureEvents [C.Keyboard, C.Focus] w p) allButtons
           -- We do not propagate any mouse events, as they should be used by the buttons
           let mouseEvts x   = C.isMouseMotion x || C.isMouseWheel x
               attachMouse w = C.propagateFutureEventsEx mouseEvts w p mouse mouse
           mapM_ attachMouse allButtons
               

           C.propagateFutureEvents C.allEvents ls p
           let -- The minimum size for list is somewhat arbitrary. Maybe it should be
               -- a tuning parameter?
               lay = column 10 [ minsize (sz 100 80) $ fill $ widget ls
                               , hfloatCenter $ row 5 $ map widget allButtons
                               ]
               whenOne [y] f = f y
               whenOne _ _   = False
               updateEnabledness =
                   do selected <- get ls selections
                      ys       <- get ls XTC.typedItems
                      set up     [ enabled := whenOne selected (> 0) ]
                      set down   [ enabled := whenOne selected (< (length ys - 1)) ]
                      set remove [ enabled := (length selected > 0) ]
                      set edit   [ enabled := (length selected == 1) ]
               setCmd wid f = set wid [ on command := 
                                           do selected <- get ls selections
                                              items'   <- get ls XTC.typedItems
                                              res <- f selected items'
                                              case res of
                                                Nothing -> return ()
                                                Just (newItems, newSel) ->
                                                    do set ls [ XTC.typedItems := newItems
                                                              , selections := newSel
                                                              ]
                                                       updateEnabledness
                                                       join (varGet changeVar)
                                      ]
           let upCmd [i] items' | i > 0  = return $ Just (swapItems i (i-1) items', [i-1])
               upCmd _ _ = return Nothing
           setCmd up upCmd

           let downCmd [i] items' | i < (length items' - 1)
                   = return $ Just (swapItems  i (i+1) items', [i+1])
               downCmd _ _ = return Nothing
           setCmd down downCmd
           
           let removeCmd selected items' =
                   return $ Just ( snd $ splitWithIndices selected items', [])
           setCmd remove removeCmd

           let addCmd Nothing  = errorDialog p "Internal error" "Could not create base instance"
               addCmd (Just x) = do y <- GC.modalValuedDialog p "Adding element" "&Add" x
                                    case y of
                                      Nothing -> return ()
                                      Just y' -> do set ls [ XTC.typedItems :~ (++ [y'])
                                                           , selections := []
                                                           ]
                                                    updateEnabledness
                                                    join (varGet changeVar)
           set add [ on command := addCmd (InstanceCreator.createInstance' GC.wxGenCtx (head xs)) ]

           let editCmd [s] items' =
                   do x <- GC.modalValuedDialog p "Editng element" "&Ok" (items' !! s)
                      case x of
                        Nothing -> return Nothing
                        Just x' -> return $ Just (replace x' s items', [s])
               editCmd _ _ = return Nothing
           setCmd edit editCmd
           
           set ls [ on select := updateEnabledness >> propagateEvent ]
           updateEnabledness
           return ( lay, get ls XTC.typedItems, \ys -> set ls [XTC.typedItems := ys]
                  , varGet changeVar, varSet changeVar, GW.singleChild ls)

-- |Splits a list in two parts, according to the indices
-- parameter. The first is the indices, the second are the rest of
-- list.
splitWithIndices :: [Int] -> [a] -> ([a], [a])
splitWithIndices indices xs = 
    let (toTake, toLeave) = partition move $ zip [0..] xs
        move (x, _) = elem x indices
    in (map snd toTake, map snd toLeave)
                            

-- |Replaces an item in a list. 
replace :: a       -- ^ The new item. 
        -> Int     -- ^ Index (starting at 0) to replace. Must be less than the lists length.
        -> [a] -> [a]
replace x index xs = take index xs ++ [x] ++ drop (index + 1) xs

-- |Replaces an item in a list. 
swapItems :: Int     -- ^ First index (starting at 0) to swap. Must be less than the lists length.
          -> Int     -- ^ Second index (starting at 0) to replace. Must be less than the lists length.
          -> [a] -> [a]
swapItems first second xs =
    replace (xs !! second) first $ replace (xs !! first) second xs