module Graphics.UI.WxGeneric.GenericWidget.Parameters
( Parms
, subParms
, getParent, setParent
, getJoinLayout, transformLabel
, GenWidParameters(..), defaultParms, toParms
, TransformLabel, mkTransformLabel, idLabel, greedyShortcuts
)
where
import Graphics.UI.WX
import qualified Graphics.UI.WxGeneric.Layout as L
import qualified Data.Set as Set
import qualified Data.Char as Char
import Control.Monad.State as St
data GenWidParameters = GenWidParameters
{ joinLayout :: L.JoinLayout
, labelTransform :: TransformLabel
}
defaultParms :: (GenWidParameters -> GenWidParameters) -> GenWidParameters
defaultParms f = f (GenWidParameters L.smartLayout (greedyShortcuts []))
toParms :: Window w -> GenWidParameters -> IO (Parms w)
toParms w parms = do lblTrans <- varCreate (labelTransform parms)
return $ Parms w True (joinLayout parms) L.oneColumnLayout lblTrans
data Parms w = Parms
{ pickParent :: Window w
, pickIsTop :: Bool
, pickTopLayout :: L.JoinLayout
, pickLayout :: L.JoinLayout
, pickLabelTransform :: Var TransformLabel
}
subParms :: Parms w -> Parms w
subParms parms
= parms { pickIsTop = False }
setParent :: Window w -> Parms w' -> Parms w
setParent w parms
= parms { pickParent = w }
getParent :: Parms w -> Window w
getParent = pickParent
getJoinLayout :: Parms w -> L.JoinLayout
getJoinLayout p =
case pickIsTop p of
True -> pickTopLayout p
False -> pickLayout p
transformLabel :: Parms w -> String -> IO String
transformLabel parms lbl
= do lblTrans <- varGet $ pickLabelTransform parms
case lblTrans of
TL s f -> do let (newLbl, newSt) = runState (f lbl) s
varSet (pickLabelTransform parms) $ TL newSt f
return newLbl
data TransformLabel = forall s. TL s (String -> State s String)
mkTransformLabel :: s -> (String -> State s String) -> TransformLabel
mkTransformLabel = TL
idLabel :: TransformLabel
idLabel = mkTransformLabel () return
greedyShortcuts :: [Char] -> TransformLabel
greedyShortcuts usedShortcutLetters = mkTL
where
mkTL = mkTransformLabel (Set.fromList usedShortcutLetters) (State . newLbl)
newLbl lbl used
= case span (\x -> Set.member (Char.toLower x) used || (not $ Char.isAlpha x)) lbl of
(_, []) -> (lbl, used)
(alreadyUsed, (x:xs)) -> (alreadyUsed ++ ('&':x:xs), Set.insert (Char.toLower x) used)