WxGeneric-0.6.0: src/Graphics/UI/WxGeneric/GenericList.hs
{-# 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