module Graphics.UI.WxGeneric.GenericClass
(
genericWidget, genericWidgetEx, modalValuedDialog
, Outer(..)
, toOuter, withLabel, fromOuter, getUnlabeld, setOuterLabel, replacePoorConstrLabel
, 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)
import qualified Graphics.UI.WxGeneric.Composite as C
import qualified Graphics.UI.WxGeneric.Layout as L
import Control.Monad.Reader
import Maybe
import qualified Data.Either as Either
genericWidget :: (WxGen a) => Wx.Window w -> a
-> IO (GenWid a)
genericWidget = genericWidgetEx id id
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
modalValuedDialog :: WxGen a =>
Window w
-> String
-> String
-> a
-> IO (Maybe a)
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 ()
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)) =
Outer lbl (Left (\w -> genWidIO w >>= return . GW.mapValue oldToNew newToOld))
mapValue oldToNew newToOld (Outer lbl (Right genWidIO)) =
Outer lbl (Right (\s w -> genWidIO s w >>= return . GW.mapValue oldToNew newToOld))
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)
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)
fromOuter :: GW.Parms w -> Outer a -> IO (GenWid a)
fromOuter w (Outer _ (Left f)) = f w
fromOuter w (Outer lbl (Right f)) = f (SW.labelString $ SW.humanizeLabel lbl) w
getUnlabeld :: Outer a -> Maybe String
getUnlabeld (Outer lbl (Left _)) = Just $ SW.labelString $ SW.humanizeLabel lbl
getUnlabeld (Outer _ (Right _)) = Nothing
setOuterLabel :: SW.PriLabel -> Outer a -> Outer a
setOuterLabel newLbl = SW.updateLabel (const newLbl)
replacePoorConstrLabel :: String -> Outer a -> Outer a
replacePoorConstrLabel = setOuterLabel . SW.goodConstrLabel
instance WxGen a => SW.Sat (WxGenD a)
where dict = WxGenD { mkWidD = mkWid }
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 (\w -> anyNum ('-':['0'..'9']) x w)
SW.FloatConstr _ -> toOuter (\w -> anyNum ('-':'.':['0'..'9']) x w)
SW.StringConstr [_] -> error "GenericClass: Char not implemented yet"
SW.StringConstr _ -> error "GenericClass: No StringConstr constructors for other than Char."
generateLabel :: a -> SW.PriLabel
generateLabel x = SW.typeLabel wxGenCtx x
data LabeledWid a = LabeledWid (GenWid a) (Maybe (StaticText ())) L.SizedLayout
pickGenWid :: LabeledWid a -> GenWid a
pickGenWid (LabeledWid genWid _ _) = genWid
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
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
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
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
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 :: (SW.Data WxGenD a) => String -> a -> GenWidIO a
anyNum legalChars initial 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
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)
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)