DButtonF

{-# LANGUAGE CPP #-}
module DButtonF(
  ButtonF,buttonF,buttonF',buttonF'',setLabel
  ) where
import FDefaults
import ButtonF(oldButtonF)
--import Fudget
--import Geometry(Rect)
import PushButtonF(Click)
import Xtypes
import Defaults(buttonFont,fgColor,bgColor)
import CmdLineEnv(argKeyList)
import CompOps((>^=<),(>=^^<))
--import Spops(concmapSP)
import SpEither(mapFilterSP)--filterRightSP
import EitherUtils(stripEither)
import SerCompF(idRightF)
import Spacers(Distance(..))
import Alignment(aCenter) --,Alignment(..)
import Graphic
import GCAttrs --(ColorSpec,colorSpec) -- + instances

{-
HBC uses "cpp -C -traditional" which causes all the  to be left behind
when the macro definitions are processed. That is why the definitions
are inside a comment.







  
-}

newtype ButtonF lbl = Pars [Pars lbl]
data Pars lbl
  = FontSpec FontSpec
  | Keys [(ModState, KeySym)]
  | FgColorSpec ColorSpec
  | BgColorSpec ColorSpec
  | Margin Distance
  | Align Alignment
  | Label lbl

instance HasFontSpec (ButtonF a) where {  setFontSpec p (Pars ps) = Pars (FontSpec p:ps);   getFontSpecMaybe (Pars ps) = getparMaybe (\x->case x of FontSpec p -> Just p; _-> Nothing) ps }
instance HasKeys (ButtonF a) where {  setKeys p (Pars ps) = Pars (Keys p:ps);   getKeysMaybe (Pars ps) = getparMaybe (\x->case x of Keys p -> Just p; _-> Nothing) ps }
instance HasFgColorSpec (ButtonF a) where {  setFgColorSpec p (Pars ps) = Pars (FgColorSpec p:ps);   getFgColorSpecMaybe (Pars ps) = getparMaybe (\x->case x of FgColorSpec p -> Just p; _-> Nothing) ps }
instance HasBgColorSpec (ButtonF a) where {  setBgColorSpec p (Pars ps) = Pars (BgColorSpec p:ps);   getBgColorSpecMaybe (Pars ps) = getparMaybe (\x->case x of BgColorSpec p -> Just p; _-> Nothing) ps }
instance HasMargin (ButtonF a) where {  setMargin p (Pars ps) = Pars (Margin p:ps);   getMarginMaybe (Pars ps) = getparMaybe (\x->case x of Margin p -> Just p; _-> Nothing) ps }
instance HasAlign (ButtonF a) where {  setAlign p (Pars ps) = Pars (Align p:ps);   getAlignMaybe (Pars ps) = getparMaybe (\x->case x of Align p -> Just p; _-> Nothing) ps }
setLabel p = cust (\ (Pars ps) -> Pars (Label p:ps)); getLabel (Pars ps) = getpar (\x->case x of Label p -> Just p; _-> Nothing) ps; getLabelMaybe (Pars ps) = getparMaybe (\x->case x of Label p -> Just p; _-> Nothing) ps

buttonF s = buttonF' standard s
buttonF' pm s = noPF $ buttonF'' pm s

buttonF'' ::
  Graphic lbl => Customiser (ButtonF lbl) -> lbl -> PF (ButtonF lbl) Click Click
buttonF'' pmod s =
    stripEither >^=<
    idRightF (oldButtonF align marg font bg fg keys lbl >=^^< mapFilterSP relbl)
  where
    lbl  = getLabel ps
    font = getFontSpec ps
    keys = getKeys ps
    ps   = pmod ps0
    bg   = getBgColorSpec ps
    fg   = getFgColorSpec ps
    marg = getMargin ps
    align = getAlign ps
    ps0  = Pars [FontSpec (fontSpec buttonFont), Keys [],Margin 2,Align aCenter,
		 FgColorSpec buttonfg, BgColorSpec buttonbg, Label s]
    --relbl pmod' = [lbl | let Pars ps'=pmod' (Pars []), Label lbl<-ps']
    relbl pmod' = getLabelMaybe (pmod' (Pars []))

buttonbg = colorSpec (argKeyList "buttonbg" [bgColor,"white"])
buttonfg = colorSpec (argKeyList "buttonfg" [fgColor,"black"])