WxGeneric-0.8.1: src/Graphics/UI/WxGeneric/GenericClass.hs
{-# LANGUAGE ExistentialQuantification, FlexibleContexts
, FlexibleInstances, FunctionalDependencies, KindSignatures
, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeSynonymInstances
#-}
{-# OPTIONS -Wall #-}
module Graphics.UI.WxGeneric.GenericClass
( -- * Turning datatypes into widgets
genericWidget, genericWidgetEx, modalValuedDialog
-- * Outer type
, Outer(..)
, toOuter, withLabel, fromOuter, getUnlabeld, setOuterLabel, replacePoorConstrLabel
-- * Generic class (WxGen) and making instancs of WxGen
, WxGen(..), WxGenD(..), wxGenCtx
, singleConstr, polyConstr
, extOuter
)
where
import Graphics.UI.WX as Wx hiding (when)
import qualified Graphics.UI.XTC as XTC
import qualified Graphics.UI.SybWidget as SW
import qualified Graphics.UI.WxGeneric.GenericWidget as GW
import Graphics.UI.WxGeneric.GenericWidget (GenWid, GenWidIO(GenWidIO))
import qualified Graphics.UI.WxGeneric.Composite as C
import qualified Graphics.UI.WxGeneric.Layout as L
import Control.Monad.Reader
import Data.Maybe
import qualified Data.Either as Either
-- |Creates a widget from any type that implements WxGen.
genericWidget :: (WxGen a) => Wx.Window w -> a
-> IO (GenWid a)
genericWidget = genericWidgetEx id id
-- |Creates a widget from any type that implements WxGen.
genericWidgetEx
:: (WxGen a) =>
(GW.GenWidParameters -> GW.GenWidParameters)
-> (Outer a -> Outer a)
-> Wx.Window w -> a
-> IO (GenWid a)
genericWidgetEx parmsFunc outerFunc w x =
do parms <- GW.toParms w $ GW.defaultParms parmsFunc
fromOuter parms $ outerFunc $ mkWid x
-- |Creates a modal dialog containing the 'x' value, an
-- ok-buuton and a cancel-button.
modalValuedDialog :: WxGen a =>
Window w
-> String -- ^Dialog title
-> String -- ^Text at ok-button
-> a -- ^Initial value
-> IO (Maybe a) -- ^Returns Just x if the user presses the ok-button.
-- Otherwise Nothing is returned.
modalValuedDialog w dialogTitle okText x =
do d <- dialog w [ resizeable := True, text := dialogTitle ]
showModal d (helper d)
where helper d endModalForm =
do p <- panel d []
wid <- genericWidget p x
ok <- button p [ text := okText
, on command := do val <- get wid C.widgetValue
endModalForm (Just val)
]
cancel <- button p [ text := "&Cancel"
, on command := endModalForm Nothing
]
set p [ layout := column 10 [ widget wid
, hfloatCenter $ row 10 [ widget ok, widget cancel ]
] ]
return ()
-- |The dictionary type for the WxEcCreator class
data WxGenD a =
WxGenD { mkWidD :: a -> Outer a }
data Outer a = Outer SW.PriLabel (Either (GenWidIO a) (String -> GenWidIO a))
instance GW.MapValue Outer where
mapValue oldToNew newToOld (Outer lbl (Left (GenWidIO genWidIO))) =
Outer lbl (Left $ GenWidIO (\w -> genWidIO w >>= return . GW.mapValue oldToNew newToOld))
mapValue oldToNew newToOld (Outer lbl (Right strToGenWidIO)) =
Outer lbl (Right (\s -> let GenWidIO genWidIO = strToGenWidIO s
in GenWidIO (\w -> genWidIO w >>= return . GW.mapValue oldToNew newToOld)))
-- |Creates an 'Outer' type. The encapsulated widget is labelless.
toOuter :: forall a. (WxGen a) => GenWidIO a -> Outer a
toOuter f = let priLabel = generateLabel (error "WxGeneric call to generateLabel (1)" :: a)
in Outer priLabel (Left f)
-- |Creates an 'Outer' type. The encapsulated widget has a label.
withLabel :: forall a. (WxGen a) => (String -> GenWidIO a) -> Outer a
withLabel f = let priLabel = generateLabel (error "WxGeneric call to generateLabel (2)" :: a)
in Outer priLabel (Right f)
-- |Unpacks an 'Outer' type and returns the encapsulated 'GenWid'.
fromOuter :: GW.Parms w -> Outer a -> IO (GenWid a)
fromOuter w (Outer _ (Left (GenWidIO f))) = f w
fromOuter w (Outer lbl (Right f)) = GW.unWidIO (f (SW.labelString $ SW.humanizeLabel lbl)) w
-- |Returns label if the widget do not show it itself
getUnlabeld :: Outer a -> Maybe String
getUnlabeld (Outer lbl (Left _)) = Just $ SW.labelString $ SW.humanizeLabel lbl
getUnlabeld (Outer _ (Right _)) = Nothing
-- |Sets the label on an 'Outer' type.
setOuterLabel :: SW.PriLabel -> Outer a -> Outer a
setOuterLabel newLbl = SW.updateLabel (const newLbl)
replacePoorConstrLabel :: String -> Outer a -> Outer a
replacePoorConstrLabel = setOuterLabel . SW.goodConstrLabel
-- |Instantiation of the Sat class
instance WxGen a => SW.Sat (WxGenD a)
where dict = WxGenD { mkWidD = mkWid }
-- |The context for generic autoform
wxGenCtx :: SW.Proxy WxGenD
wxGenCtx = error "wxGenCtx"
instance SW.OuterWidget Outer where
updateLabel f (Outer lbl wid) = Outer (f lbl) wid
class ( SW.Data WxGenD a ) => WxGen a
where
mkWid :: a -> Outer a
mkWid x =
case SW.constrRep (SW.toConstr wxGenCtx x) of
SW.AlgConstr _ -> genericOuter True x
SW.IntConstr _ -> toOuter (anyNum ('-':['0'..'9']) x)
SW.FloatConstr _ -> toOuter (anyNum ('-':'.':['0'..'9']) x)
SW.StringConstr [_] -> error "GenericClass: Char not implemented yet" -- FIXME
SW.StringConstr _ -> error "GenericClass: No StringConstr constructors for other than Char."
generateLabel :: a -> SW.PriLabel
generateLabel x = SW.typeLabel wxGenCtx x
-- LabeledWid is only used in this module, as a temporary data structure.
-- data LabeledWid a = LabeledWid { lblWid :: (GenWid a), lblLabel :: Maybe String }
data LabeledWid a = LabeledWid (GenWid a) (Maybe (StaticText ())) L.SizedLayout
pickGenWid :: LabeledWid a -> GenWid a
pickGenWid (LabeledWid genWid _ _) = genWid
-- |Creates an 'Outer' type for a type with a single constructor.
singleConstr :: WxGen a => Bool -> a -> Outer a
singleConstr flatten x = genericCompose $ SW.mkSpliterSingleConstr wxGenCtx (mkWidD SW.dict) x
where
genericCompose :: forall a. WxGen a => SW.Spliter Outer a a
-> Outer a
genericCompose spliter
= case (flatten, SW.mkFullSpliter wxGenCtx spliter) of
(True, (SW.Part onlyPart (SW.Constructor c)))
-> GW.mapValue c (const (SW.partGetter onlyPart)) (SW.partWidget onlyPart)
_ -> withLabel (\s -> GW.valuedCompose $ f spliter s)
toGenWid genWidParms outer =
do let p = GW.getParent genWidParms
createLabel lbl = do newLbl <- GW.transformLabel genWidParms lbl
txt <- staticText p [ text := newLbl ]
return $ Just txt
-- A label must be created just prior to the widget it
-- labels, otherwise keyboard accelerators will not work.
lbl <- maybe (return Nothing) createLabel (getUnlabeld outer)
wid' <- fromOuter (GW.subParms genWidParms) outer
sLay <- L.toSizedLayout wid'
return (LabeledWid wid' lbl sLay)
f spliter lbl genWidParms =
do let p = GW.getParent genWidParms
changeVar <- varCreate (return ())
innerSpliter <- SW.mapPartsMDelay (isNothing . getUnlabeld) (toGenWid genWidParms) spliter
let (withLabels, withoutLabels) =
partitionWidgets (\_ -> (,)) (curry snd) innerSpliter
mapM_ (\wid -> C.propagateFutureEvents C.allEvents wid p) $ map fst withLabels
let innerSpliter' = SW.mapParts pickGenWid innerSpliter
setChange y = do sequence_ (SW.spliterToList (\i -> set i [ on XTC.change := y ])
innerSpliter')
varSet changeVar y
(g, s) = SW.mkGetterSetter wxGenCtx (\w -> get w C.widgetValue)
(\w y -> set w [ C.widgetValue := y ]) innerSpliter'
lay = (GW.getJoinLayout genWidParms) lbl withLabels withoutLabels
getWidTree =
do let toWxWid w = get w GW.widgetTree
(l, r) = partitionWidgets (\w _ _ -> toWxWid w) (\w _ -> toWxWid w) innerSpliter
xs <- sequence (l ++ r)
return $ GW.mkWidTree [] xs
return (lay, g, s, varGet changeVar, setChange, getWidTree)
genericOuter :: (WxGen a) => Bool -> a -> Outer a
genericOuter flatten x
= if SW.isSingleConstructor wxGenCtx x
then singleConstr flatten x
else polyConstr x
partitionWidgets :: (forall a. GenWid a -> StaticText () -> L.SizedLayout -> l)
-> (forall a. GenWid a -> L.SizedLayout -> r)
-> SW.Spliter LabeledWid b c
-> ([l], [r])
partitionWidgets withLabelFunc withoutLabelFunc s =
Either.partitionEithers $ SW.spliterToList helper s where
helper (LabeledWid wid (Just lbl) sLay) = Left $ withLabelFunc wid lbl sLay
helper (LabeledWid wid Nothing sLay) = Right $ withoutLabelFunc wid sLay
-- |Creates an 'Outer' type for a type with more than one constructor.
polyConstr :: forall a. (WxGen a, SW.Data WxGenD a) =>
a -> Outer a
polyConstr x = withLabel (\s -> GW.valuedCompose (f s)) where
f lbl genWidParms =
do let p = GW.getParent genWidParms
getValueProxy <- varCreate (return x)
changeVar <- varCreate (return ())
setChangeProxy <- varCreate (\_ -> return ())
subGenWid <- varCreate (error "Panic! Should not happen. Sub-GenWid not created yet.")
valueMemory <- SW.mkConstrValMap wxGenCtx x
let getter = join $ varGet getValueProxy
setChange y = do chg <- varGet setChangeProxy
chg y
varSet changeVar y
--
-- Radio-view items do not short keyboard shortcuts. Thus no need to
-- do GW.transformLabel.
radioV <- XTC.mkRadioViewEx p show Vertical (SW.constructors wxGenCtx x)
[ XTC.typedSelection := SW.toConstr wxGenCtx x
, text := "Choose constructor" ]
C.propagateFutureEvents C.allEvents radioV p
--
editLbl <- GW.transformLabel genWidParms "Edit in Dialog"
editButton <- button p [ text := editLbl ]
--
widPanel <- panel p []
C.propagateFutureEvents C.allEvents widPanel p
let deleteOldWidgets = get widPanel children >>= mapM_ objectDelete
makeChild y = do -- We do not use GW.subParms here, as we want the internal child widget
-- constructed as if it was a single constructor widget. That is,
-- we keep two-column layout if present.
t <- genericWidget' (GW.setParent widPanel genWidParms) y
varSet subGenWid t
varSet setChangeProxy (\z -> set t [ on XTC.change := z] )
set t [ on XTC.change := join $ varGet changeVar ]
set widPanel [ layout := widget t ]
varSet getValueProxy (get t C.widgetValue)
refit widPanel
genericWidget' w y = fromOuter w $ setOuterLabel SW.labelless $ singleConstr False y
setter y = do getter >>= SW.updateConstrValMap valueMemory
deleteOldWidgets
makeChild y
join $ varGet changeVar
set radioV [ XTC.typedSelection := SW.toConstr wxGenCtx y ]
getWidTree =
do genWid <- varGet subGenWid
fmap (GW.updateChildren (GW.WxWindow radioV:)) $ get genWid GW.widgetTree
makeChild x
set radioV [ on select := do newCon <- get radioV XTC.typedSelection
lastVal <- getter
when (newCon /= SW.toConstr wxGenCtx lastVal)
(SW.alwaysValue valueMemory newCon >>= setter)
]
set editButton [ on command :=
do lastVal <- getter
res <- modalValuedDialog p "Edit value" "OK" lastVal
case res of
Just z -> setter z
_ -> return ()
]
let lay = boxed lbl $ column 10 [ row 10 [ hfill $ widget radioV, vfloatCenter $ widget editButton ]
, fill $ widget widPanel
]
return (lay, getter, setter, varGet changeVar, setChange, getWidTree)
-- ********** AnyNum ****************************************
anyNum :: (SW.Data WxGenD a) => String -> a -> GenWidIO a
anyNum legalChars initial = GenWidIO
(\genWidParms ->
do let p = GW.getParent genWidParms
(sybGet, sybSet) <- SW.numericGetSet wxGenCtx initial
intEn <- textEntry p [ processEnter := True
, on keyboard := handleInput p
]
let getter = get intEn text >>= sybGet
setter x = do stringX <- sybSet x
set intEn [ text := stringX ]
setter initial
C.propagateFutureEvents [C.Mouse, C.Focus] intEn p
return $ GW.mkSingleObservableEx intEn hfill getter setter (GW.singleChild intEn)
)
where
handleInput _ (EventKey (KeyChar c) mods _)
| not (altDown mods || controlDown mods || metaDown mods)
= if c `elem` legalChars
then propagateEvent
else return ()
handleInput p evt = C.propagateWxEvent p keyboard evt -- propagateEvent
-- Why do we need C.propagateWxEvent?
-- GenericList's String should also propagate ALT (and like) events.
-- *********** extOuter *************************************
-- |Makes it possible to choose between competing instances without
-- allowing overlapping instances.
extOuter :: (SW.Typeable a, SW.Typeable b) =>
(a -> Outer a)
-> (b -> Outer b)
-> a -> Outer a
extOuter fn spec_fn arg = case SW.gcast (M spec_fn) of
Just (M spec_fn') -> spec_fn' arg
Nothing -> fn arg
newtype M a = M (a -> Outer a)
-- ************ WxGen instances ****************************************
instance WxGen Char
instance WxGen Int
instance WxGen Integer
instance WxGen Float
instance WxGen Double
instance WxGen ()
instance (WxGen a, WxGen b) => WxGen (a, b)
instance (WxGen a, WxGen b, WxGen c) => WxGen (a, b, c)
instance (WxGen a, WxGen b) => WxGen (Either a b)
instance WxGen a => WxGen (Maybe a)