WidgetConf - currently TclHaskell specific

General configuration options for widget items.
These form a set of classes with a default Tcl-tk configure set method.
to do: remove the default method and therefore makes these more generic
Then we need to define real instances in the Widgets module. For each there
is a behavior version of the configuration option as well as the static one.

\begin{code}
module WidgetConf where
import WidgetSetImpl 
import AbstractInterface
import StaticTypes (Color,Rect)
import FranCore (ColorB,Event,IntB,StringB,BoolB,RectB,Behavior,lift0)
import qualified TclPrimImpl as T
import TclPrimImpl (Menu)
import BVars
import Identify
import Listener

(%%) :: String -> String -> Conf w
(%%) w c = Conf [Config $ w T.%% c]


instance Has_activeforeground Style
instance Has_activebackground Style
instance Has_foreground Style
instance Has_background Style
instance Has_borderwidth Style
instance Has_disabledforeground Style
instance Has_fillColor Style
instance Has_font Style
instance Has_highlightbackground Style
instance Has_highlightcolor Style
instance Has_highlightthickness Style
instance Has_justify Style
instance Has_selectforeground Style
instance Has_selectbackground Style
instance Has_selectcolor Style
instance Has_selectborderwidth Style

class WidgetItem w => Has_activeforeground w where
  activeforeground   :: Color -> Conf w
  activeforeground x =  "activeforeground" %% fromColor x

class WidgetItem w => Has_activebackground w where
  activebackground   :: Color -> Conf w
  activebackground x =  "activebackground" %% fromColor x

class WidgetItem w => Has_anchor w where
  anchor   :: Anchor -> Conf w
  anchor x =  "anchor" %% fromAnchor x 

class WidgetItem w => Has_aspect w where
 aspect :: Int -> Conf w
 aspect n = "aspect" %% show n

class WidgetItem w => Has_background w where
  background   :: Color -> Conf w
  background x = "background" %% fromColor x

class WidgetItem w => Has_bitmap w where
  bitmap   :: Bitmap -> Conf w
  bitmap x = "bitmap" %% fromBitmap x

class WidgetItem w => Has_borderwidth w where
  borderwidth   :: Int -> Conf w
  borderwidth x =  "borderwidth" %% show x

class WidgetItem w => Has_cursor w where
  cursor   :: Cursor -> Conf w
  cursor x =  "cursor" %% fromCursor x

class WidgetItem w => Has_disabledforeground w where
  disabledforeground :: Color -> Conf w
  disabledforeground x = "disabledforeground" %% fromColor x

disabledforegroundB :: Has_disabledforeground w => ColorB -> Conf w
disabledforegroundB = confBh disabledforeground

class WidgetItem w => Has_exportselection w where
  exportselection :: Bool -> Conf w
  exportselection x = "exportselection" %% show x

class WidgetItem w => Has_password w where
  password   :: Char -> Conf w
  password x =  "show" %% [x]

class WidgetItem w => Has_selectmode w where
  selectmode   :: SelectMode -> Conf w
  selectmode x =  "selectmode" %% fromSelectMode x

class WidgetItem w => Has_fillColor w where
  fillColor   :: Color -> Conf w
  fillColor x =  "fill" %% fromColor x

class WidgetItem w => Has_font w where
  font   :: Font -> Conf w
  font x = "font" %% fromFont x

class WidgetItem w => Has_foreground w where
  foreground   :: Color -> Conf w
  foreground x = "foreground" %% fromColor x

class WidgetItem w => Has_height w where
  height   :: Int -> Conf w
  height x = "height" %% show x

class WidgetItem w => Has_highlightbackground w where
  highlightbackground   :: Color -> Conf w
  highlightbackground x =  "highlightbackground" %% fromColor x

class WidgetItem w => Has_highlightcolor w where
  highlightcolor   :: Color -> Conf w
  highlightcolor x =  "highlightcolor" %% fromColor x

class WidgetItem w => Has_highlightthickness w where
  highlightthickness   :: Int -> Conf w
  highlightthickness x =  "highlightthickness" %% show x

class WidgetItem w => Has_hor_orient w where
  hor_orient   :: Bool -> Conf w
  hor_orient x =  "orient" %% show x

class WidgetItem w => Has_image w where
  image :: Image -> Conf w
  image x = "image" %% fromImage x

class WidgetItem w => Has_indicatoron w where
  indicatoron   :: Bool -> Conf w
  indicatoron x =  "indicatoron" %% show x

class WidgetItem w => Has_justify w where
  justify   :: Justify -> Conf w
  justify x = "justify" %% fromJustify x

class WidgetItem w => Has_active_state w where
  active_state   :: ActiveState -> Conf w
  active_state x = "state" %% fromActiveState x

class WidgetItem w => Has_outline w where
  outline   :: Color -> Conf w
  outline x = "outline" %% fromColor x

class WidgetItem w => Has_padx w where
  padx   :: Int -> Conf w
  padx x =  "padx" %% show x

class WidgetItem w => Has_pady w where
  pady   :: Int -> Conf w
  pady x =  "pady" %% show x

class WidgetItem w => Has_readOnly w where
  readOnly :: Bool -> Conf w 
  readOnly w = "state" %% fromBool w
    where
      fromBool False = "normal"
      fromBool True = "disabled"

class WidgetItem w => Has_relief w where
  relief   :: Relief -> Conf w
  relief x = "relief" %% fromRelief x

class WidgetItem w => Has_sca_from w where
  sca_from   :: Int -> Conf w
  sca_from x = "from" %% show x

class WidgetItem w => Has_sca_length w where
  sca_length   :: Int -> Conf w
  sca_length x = "length" %% show x

class WidgetItem w => Has_sca_to w where
  sca_to   :: Int -> Conf w
  sca_to x = "to" %% show x

class WidgetItem w => Has_scrollregion w where
  scrollregion   :: Rect -> Conf w
  scrollregion x = "scrollregion" %% fromRegion x

class WidgetItem w => Has_selectbackground w where
  selectbackground   :: Color -> Conf w
  selectbackground x = "selectbackground" %% fromColor x

class WidgetItem w => Has_selectborderwidth w where
  selectborderwidth   :: Int -> Conf w
  selectborderwidth x =  "selectborderwidth" %% show x

class WidgetItem w => Has_selectcolor w where
  selectcolor   :: Color -> Conf w
  selectcolor x = "selectcolor" %% fromColor x

class WidgetItem w => Has_selectforeground w where
  selectforeground   :: Color -> Conf w
  selectforeground x = "selectforeground" %% fromColor x

class WidgetItem w => Has_setgrid w where
  setgrid   :: Bool -> Conf w
  setgrid x = "setgrid"%% show x

class WidgetItem w => Has_takefocus w where
  takefocus   :: Bool -> Conf w
  takefocus x = "takefocus" %% show x

class WidgetItem w => Has_tags w where
  tags   :: [String] -> Conf w
  tags x = "tags" %% T.tcl_string (unwords x)

class WidgetItem w => Has_text w where
  text   :: String -> Conf w
  text x =  "text" %% T.tcl_string x

class WidgetItem w => Has_tickinterval w where
  tickinterval   :: Int -> Conf w
  tickinterval x =  "tickinterval" %% show x

class WidgetItem w => Has_troughcolor w where
  troughcolor   :: Color -> Conf w
  troughcolor x =  "troughcolor" %% fromColor x

class WidgetItem w => Has_underline w where
  underline   :: Int -> Conf w
  underline x = "underline" %% show x

class WidgetItem w => Has_width w where
  width   :: Int -> Conf w
  width x = "width" %% show x

class WidgetItem w => Has_wrap w where
  wrap   :: Wrap -> Conf w
  wrap x = "wrap" %% fromWrap x

class WidgetItem w => Has_wraplength w where
  wraplength   :: Int -> Conf w
  wraplength x = "wraplength" %% show x

class WidgetItem w => Has_tearoff w where
  tearoff :: Bool -> Conf w
  tearoff x = "tearoff" %% show x

confBh :: (WidgetItem w,Eq a) => (a -> Conf w) -> Behavior a -> Conf w
confBh f bh =
 case f (error "should not be evaluated") of
  Conf [x] ->  confBeh (identify x ) f bh

exportselectionB :: Has_exportselection w => BoolB -> Conf w
exportselectionB = confBh exportselection

tearoffB :: Has_tearoff w => BoolB -> Conf w
tearoffB = confBh tearoff 

activebackgroundB :: Has_activebackground w => ColorB -> Conf w
activebackgroundB mbc = confBh activebackground mbc

activeforegroundB :: Has_activeforeground w => ColorB -> Conf w
activeforegroundB mbc = confBh activeforeground mbc

type AnchorB = Behavior Anchor

northB = lift0 N
southB = lift0 S
eastB = lift0 E
westB = lift0 W
neB = lift0 NE
nwB = lift0 NW
seB = lift0 SE
swB = lift0 SW
centerB = lift0 C

anchorB :: Has_anchor w => AnchorB -> Conf w
anchorB = confBh anchor 

aspectB ::  Has_aspect w => IntB -> Conf w
aspectB = confBh aspect

backgroundB :: Has_background w => ColorB -> Conf w
backgroundB a = confBh background a

bitmapB :: Has_bitmap w => Behavior Bitmap -> Conf w
bitmapB a = confBh bitmap a

borderwidthB :: Has_borderwidth w => IntB -> Conf w
borderwidthB a = confBh borderwidth a

cursorB :: Has_cursor w => Behavior Cursor -> Conf w
cursorB a = confBh cursor a

passwordB :: Has_password w => Behavior Char -> Conf w
passwordB a = confBh password a

fillColorB :: Has_fillColor w => ColorB -> Conf w
fillColorB a = confBh fillColor a

fontB :: Has_font w => Behavior Font -> Conf w
fontB a = confBh font a

foregroundB :: Has_foreground w => ColorB -> Conf w
foregroundB a = confBh foreground a

heightB :: Has_height w => IntB -> Conf w
heightB a = confBh height a

imageB :: Has_image w => Behavior Image -> Conf w
imageB = confBh image

highlightbackgroundB :: Has_highlightbackground w => ColorB -> Conf w
highlightbackgroundB a = confBh highlightbackground a

highlightcolorB :: Has_highlightcolor w => ColorB -> Conf w
highlightcolorB a = confBh highlightcolor a

highlightthicknessB :: Has_highlightthickness w => IntB -> Conf w
highlightthicknessB a = confBh highlightthickness  a

hor_orientB :: Has_hor_orient w  => BoolB -> Conf w
hor_orientB a = confBh hor_orient a

indicatoronB :: Has_indicatoron w => BoolB -> Conf w
indicatoronB a = confBh indicatoron a

type JustifyB = Behavior Justify

leftJB = lift0 LeftJ
rightJB = lift0 RightJ
centerJB = lift0 CenterJ

justifyB :: Has_justify w => JustifyB -> Conf w
justifyB a = confBh justify a

type ActiveStateB = Behavior ActiveState
activeB = lift0 Active
disabledB = lift0 Disabled
normalB = lift0 Normal

active_stateB :: Has_active_state w => ActiveStateB -> Conf w
active_stateB a = confBh active_state  a

outlineB :: Has_outline w => ColorB -> Conf w
outlineB a = confBh outline a

padxB :: Has_padx w => IntB -> Conf w
padxB a = confBh padx a

padyB :: Has_pady w => IntB -> Conf w
padyB a = confBh pady a

readOnlyB :: Has_readOnly w => BoolB -> Conf w
readOnlyB b = confBh readOnly b

type ReliefB = Behavior Relief

raisedB = lift0 Raised
sunkenB = lift0 Sunken
flatB = lift0 Flat
ridgeB = lift0 Ridge
solidB = lift0 Solid
grooveB = lift0 Groove

reliefB :: Has_relief w => ReliefB -> Conf w
reliefB a = confBh relief  a

sca_fromB :: Has_sca_from w => IntB -> Conf w
sca_fromB a = confBh sca_from a

sca_lengthB :: Has_sca_length w => IntB -> Conf w
sca_lengthB a = confBh sca_length  a

sca_toB :: Has_sca_to w => IntB -> Conf w
sca_toB a = confBh sca_to  a

scrollregionB :: Has_scrollregion w => RectB -> Conf w
scrollregionB a = confBh scrollregion a

type SelectModeB = Behavior SelectMode

singleB = lift0 SingleMode
browseB = lift0 BrowseMode
multipleB = lift0 MultipleMode
extendedB = lift0 ExtendedMode

selectmodeB :: Has_selectmode w => SelectModeB -> Conf w
selectmodeB a = confBh selectmode a

selectbackgroundB :: Has_selectbackground w => ColorB -> Conf w
selectbackgroundB a = confBh selectbackground a

selectborderwidthB :: Has_selectborderwidth w => IntB -> Conf w
selectborderwidthB a = confBh selectborderwidth a

selectcolorB :: Has_selectcolor w => ColorB -> Conf w
selectcolorB a = confBh selectcolor a

selectforegroundB :: Has_selectforeground w => ColorB -> Conf w
selectforegroundB a = confBh selectforeground a

setgridB :: Has_setgrid w => BoolB -> Conf w
setgridB a = confBh setgrid a

takefocusB :: Has_takefocus w => BoolB -> Conf w
takefocusB a = confBh takefocus a

textB :: Has_text w => StringB -> Conf w
textB a = confBh text a

tickintervalB :: Has_tickinterval w => IntB -> Conf w
tickintervalB a = confBh tickinterval a

troughcolorB :: Has_troughcolor w => ColorB -> Conf w
troughcolorB a = confBh troughcolor  a

underlineB :: Has_underline w => IntB -> Conf w
underlineB a = confBh underline a

widthB :: Has_width w => IntB -> Conf w
widthB a = confBh width a

type WrapB = Behavior Wrap

noWrapB = lift0 NoWrap
charWrapB = lift0 CharWrap
wordWrapB = lift0 WordWrap

wrapB :: Has_wrap w => WrapB -> Conf w
wrapB a = confBh wrap  a

wraplengthB :: Has_wraplength w => IntB -> Conf w
wraplengthB a = confBh wraplength a

wgt_label :: String -> Conf w
wgt_label s = "label" %% T.tcl_string s
\end{code}