{-# LANGUAGE FlexibleContexts, RecursiveDo, ScopedTypeVariables #-} {-# OPTIONS -fno-warn-orphans #-} module Graphics.UI.AF.WxForm.WxList ( multiLineEC, listECChooser -- * List with sub-window for editing elements ) where {- Old - remove when WxM-refactoring is over. , listEC, ListAction -- ** Functions to aid creating custom made actions , oneToMany, one -- ** Standard actions , standardActions, moveItemDown, moveItemUp, editItem, addItem, removeItem -- * List with embedded elements , listWithEmbeddedElement, ListActionEmbedded -- ** Functions to aid creating custom made actions , oneToManyEmbedded, oneEmbedded -- ** Standard actions , standardEmbeddedActions , moveItemDownEmbedded, moveItemUpEmbedded, addItemEmbedded, removeItemEmbedded -} import Graphics.UI.WX hiding (value, label, identity, enabled, item, items, Parent, parent, swap, when) import qualified Graphics.UI.WX as WX (enabled, items) import Maybe(fromJust) import List ( (\\), intersperse ) import Control.Monad(when) import qualified Graphics.UI.AF.General as AF import Graphics.UI.AF.WxForm.WxFormImplementation import Graphics.UI.AF.WxForm.ComIO import Graphics.UI.AF.WxForm.EditorComponent -- |A type-specific case for lists. instance (ECCreator a, Show a, Eq a, AF.GInstanceCreator a) => ECCreator [a] where --makeEC xs = (listEC standardActions `extEC` strings `extEC` listOfStrings) xs makeEC xs = (listECChooser `extEC` strings `extEC` listOfStrings) xs {- -- |Chooses between 'listWithEmbeddedElement' and 'listEC'. The choice -- is by using the 'goDeeper' function. listECChooser :: forall a. (ECCreator a, Show a, AF.GInstanceCreator a) => [a] -> EC [a] () listECChooser xs = chooseEC elemPriority header goDeeper embeddedList nonEmbeddedList xs where (elemPriority, header) = maybe (BadConstr, "A list") goodHeader (elementHeader (head xs)) goodHeader (PriLabel pri label) = (pri, ("List of " ++ label)) embeddedList = AF.comState AF.stateless . listWithEmbeddedElement' nonEmbeddedList = AF.comState AF.stateless . addButtons standardActions . listEC -} listECChooser :: forall a. (ECCreator a, Show a, Eq a, AF.GInstanceCreator a) => MakeEC [a] listECChooser xs = listWithEmbeddedElement' xs -- setLabel $ PriLabel GoodConstr "A list" -- FIXME: better to name like "A list of ...". But this is currently (20071221) not possible. -- We need to be able to set the label from within WxM. listWithEmbeddedElement' :: forall a. (ECCreator a, Show a, Eq a, AF.GInstanceCreator a, ECCreator [a]) => MakeEC [a] listWithEmbeddedElement' xs = AF.builderToCom $ do (list, selectedSt) <- listEC' xs let anElement :: a anElement = fromJust AF.createInstance element <- AF.builderCom anElement elementWhichIsEdited <- AF.state (Nothing::(Maybe Int)) let setList ys = do selected <- AF.getValue selectedSt AF.setValue list ys AF.setValue selectedSt selected update = do selected <- AF.getValue selectedSt elementWhichIsEdited' <- AF.getValue elementWhichIsEdited ls <- AF.getValue list l <- AF.getValue element case (elementWhichIsEdited', selected) of (Nothing, [i]) -> do AF.setValue elementWhichIsEdited $ Just i AF.setValue element $ ls !! i (Just i, [j]) -> do setList $ replace l i ls when (i /= j) $ do AF.setValue element $ ls !! j AF.setValue elementWhichIsEdited $ Just j (Just _, _) -> do AF.setValue elementWhichIsEdited Nothing _ -> return () AF.addListener update selectedSt AF.addListener update element AF.enabledWhen selectedSt (\x -> length x == 1) element let listButton name f = AF.button name (listAction f) listAction f = do selected <- AF.getValue selectedSt values <- AF.getValue list (values', selected', edited') <- f values selected AF.setValue list values' AF.setValue elementWhichIsEdited edited' AF.setValue selectedSt selected' let moveItemDown values [i] = return (swap i (i+1) values, [i+1], Just $ i+1) moveItemDown values selected = return (values, selected, Nothing) midEnabled [selected] ys = (length xs >= 2) && (selected + 1) < length ys midEnabled _ _ = False -- moveItemUp values [i] = return (swap i (i-1) values, [i-1], Just $ i-1) moveItemUp values selected = return (values, selected, Nothing) miuEnabled [selected] ys = (length ys >= 2) && selected >= 1 miuEnabled _ _ = False -- addItem values _ = do AF.setValue element anElement let newList = values ++ [anElement] lastItem = length newList - 1 return (newList, [lastItem], Just lastItem) -- deleteItem values selected = return (removeIndices values selected, [], Nothing) diEnabled (_:_) = True diEnabled _ = False removeIndices ys indices = map (ys !!) $ [0..(length ys) - 1] \\ indices listButton "Down" moveItemDown >>= AF.enabledWhen2 selectedSt list midEnabled listButton "Up" moveItemUp >>= AF.enabledWhen2 selectedSt list miuEnabled listButton "Add..." addItem listButton "Delete" deleteItem >>= AF.enabledWhen selectedSt diEnabled return list -- |A list ComJ and selected ComH. The list do not have any buttons. listEC' :: forall a. (ECCreator a, Eq a, Show a, AF.GInstanceCreator a) => [a] -> WxM (ComH [a], ComH [Int]) listEC' xs = mdo Parent w <- getPanel listBox <- io $ multiListBox w [] st <- getterSetterComIO (get listBox selections) setSelected listVar <- io $ varCreate [] let gui = SelfContained (\_ -> return $ fill $ widget listBox) labelless signalChange' = -- A workaround - see below. mdo t <- timer listBox [ interval := 100 , on command := do unsafeSignalChange st objectDelete t ] return() setSelected ys = do unsetOnSelect -- otherwise we fire selection events set listBox [ selections := ys ] setOnSelect -- now we can fire selection events again setOnSelect = set listBox [ on select := do signalChange' propagateEvent ] unsetOnSelect = set listBox [ on select := propagateEvent ] --setGuiEnable _ = return () setGuiEnable enable = set listBox [ WX.enabled := enable ] setGuiVal ys = do currentValue <- varGet listVar when (ys /= currentValue) $ do unsetOnSelect -- otherwise we fire selection events set listBox [ WX.items := map (shortenLongLines . show) ys ] varSet listVar ys setOnSelect shortenLongLines ys = if length ys > maxListWidth then take (maxListWidth - 4) ys ++ " ..." else ys io $ setOnSelect io $ set listBox [ -- The select-events is not enough. They do not see unselect events. on mouse := \_ -> do signalChange' propagateEvent ] (comH, _) <- addCustomGui xs setGuiVal listBox gui return (comH, guilessInnerEC' st) -- |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. swap :: 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] swap first second xs = replace (xs !! second) first $ replace (xs !! first) second xs -------------------------------------------------------------------------------- -- |Constructs an 'EC' for single-line text string. strings :: String -> EC String strings xs = AF.builderToCom $ do Parent w <- getPanel te <- io $ textEntry w [ processEnter := True ] let gui = singleGui (badConstrLabel "A text-string") te hfill setGuiValue x = set te [ text := x ] (comH, parms) <- addCustomGui xs setGuiValue te gui io $ set te [ on focus := \_ -> do get te text >>= (testInputParm' parms) SetOnReject propagateEvent ] return comH -- |Constructs an 'EC' for multi-line text string. listOfStrings :: MakeEC [String] listOfStrings xs = AF.mapValue myLines (const myUnlines) (multiLineEC $ myUnlines xs) where -- we cannot use the Preludes lines & unlines -function as: lines $ unlines xs != xs myLines "" = [] myLines ys = lines $ if last ys == '\n' then ys ++ "\n" else ys myUnlines ys = concat $ intersperse "\n" ys -- |Constructs an 'EC' for multi-line text string. multiLineEC :: MakeEC String multiLineEC xs = AF.builderToCom $ do Parent w <- getPanel tc <- io $ textCtrl w [ processEnter := True ] let gui = SelfContained (\l -> return $ boxed l (fill $ widget tc)) (PriLabel BadConstr "Text") -- We could also make into an "ordinary" gui element as: -- gui = singleGui label' tc fill setGuiValue ys = set tc [ text := ys ] (comH, parms) <- addCustomGui xs setGuiValue tc gui io$ set tc [ on focus := \_ -> do get tc text >>= (testInputParm' parms) SetOnReject propagateEvent ] io $ (readGuiOnGetValParm' parms) (get tc text) -- FIXME: This is cheating as we do not make limit checks. -- However, limit check would currently blow away performance for large -- texts - even if no tests were actually performed. Thus we need -- to redesign the limit checks. return (typeLift (\cio -> cio { pickAppendVal = Just $ \ys -> do appendText tc ys }) comH) {- = Future enhancements that require WxHaskell changed = Custom sensitive popup menus are not implemented, as WxHaskell support for them is rudimentary. Likewise, for double-clicking a menu item. However, when they are easily possible we could have: * User definable popups * Remove & edit popups (double click could edit) * Sort according to column (also requires tabular format) It is not possible to click the same button more than once, without moving the mouse pointer away from the button and then onto it again. This is a WxHaskell or maybe GtkWxHaskell issue. Also the list should probably require CTRL to select multiple. This is how multi-select lists normally function - for example a file explorer. = Other future enhancements = * More user control of layout Is this needed? * Could add tooltips explaining why diabled buttons, are disabled. However, this could confuse the user, as it would be unconventionel. Though the risk seems slight, as the presented text could explain what is going on, for example: \"The button is disabled as ...\". Furthermore, it would be almost completely unobtrusive. * zero 'Action' function (like the 'one' or 'oneToMany' functions) * Tabular form when practical ** Use wxGrid control - see Grid example in wxHaskell distribution. *** Or use listCtrl * The function listCtrlHitTest might be usefull for detecting on which item a double click occured -} {- Design rationale: If we split up String and [a], like: instance ECCreator String where ... instance ECCreator [a] where ... then it requires overlapping instances. Therefore, we instead do as above and merged String and [a] case. -}