AutoForms-0.4.0: src/Graphics/UI/AF/WxForm/WxList.hs
{-# 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.
-}