{-# 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