module TclConf (module PlacePos,module TclConf) where
import TclPrimExports
import qualified TclPrimImpl as T
import GUIMonad
import PlacePos
import Utils

data Conf w = Config Config

cset :: Widget a b -> [Conf b] -> GUI ()
cset w cs = 
 case fromConf cs of
  cs -> do 
     liftIO $ T.cset' w cs
 
cget :: Widget a b -> (c -> Conf b) -> GUI String
cget w c = case c undefined of
	    (Config c) -> liftIO $ T.cget' w c
     
fromConf :: [Conf w] -> [Config]
fromConf xs = map from xs
 where
   from (Config c) = c
 
data Anchor = N | S | E | W | NE | NW | SE | SW | C
 deriving (Eq,Show)

data SelectMode = SingleMode | BrowseMode | MultipleMode
                | ExtendedMode
 deriving (Show,Eq)
data Justify = LeftJ | RightJ | CenterJ
 deriving (Show,Eq)
data Relief = Raised | Sunken | Flat | Ridge | Solid | Groove
 deriving (Show,Eq)
data Wrap = NoWrap | CharWrap | WordWrap
 deriving (Show,Eq)
data ActiveState = Active | Disabled | Normal
 deriving (Show,Eq)

fromActiveState Active = "active"
fromActiveState Disabled = "disabled"
fromActiveState Normal = "normal"

fillX,fillY,fillXY :: PackInfo
fillX = PackFill FillX
fillY = PackFill FillY
fillXY = PackFill FillXY

expand :: Bool -> PackInfo
expand = PackExpand

packPadX,packPadY :: Int -> PackInfo
packPadX n = PackPad (PadX n)
packPadY n = PackPad (PadY n)

inFrame :: Frame -> PackInfo
inFrame f = PackIn $ T.wpath f

inWindow :: Window -> PackInfo
inWindow f = PackIn $ T.wpath f

packH,packV :: PackInfo
packH = PackMode PackHorizontal
packV = PackMode PackVertical

packPos = PackPos
packAnchor = PackAnchor

data PackInfo = 
        PackFill ! Fill
      | PackExpand ! Bool
      | PackFree ! String ! String
      | PackAnchor ! Anchor
      | PackPad ! Pad
      | PackPadInternal ! Pad
      | PackIn ! WPath
      | PackMode ! PackMode
      | PackPos ! (PlacePos WPath)
 deriving (Show,Eq)

data Pad = PadX ! Int | PadY ! Int 
 deriving (Show,Eq)

data PackMode = PackVertical | PackHorizontal
 deriving (Show,Eq)

data Fill = FillX | FillY | FillXY
 deriving (Show,Eq)

widthX,heightY :: Int -> GridInfo
widthX = WidthX
heightY = HeightY
gpadX,gpadY,gpadIX,gpadIY :: Int -> GridInfo
gpadX = GridPad . PadX
gpadY = GridPad . PadY
gpadIX = GridPadInternal . PadX
gpadIY = GridPadInternal . PadY
ganchor = GridAnchor
gfillX = GridFill FillX
gfillY = GridFill FillY
gfillXY = GridFill FillXY

ginFrame :: Frame -> GridInfo
ginFrame = GridIn . wpath 

ginWindow :: Window -> GridInfo
ginWindow = GridIn . wpath

data GridInfo =
	  WidthX ! Int
	| HeightY ! Int
	| GridPad ! Pad
	| GridPadInternal ! Pad
	| GridAnchor ! Anchor
	| GridFill ! Fill
	| GridIn ! WPath

fromSelectMode :: SelectMode -> String
fromSelectMode SingleMode =  "single"
fromSelectMode BrowseMode = "browse"
fromSelectMode MultipleMode =  "multiple"
fromSelectMode ExtendedMode =  "extended"

fromJustify :: Justify -> String
fromJustify LeftJ = "left"
fromJustify RightJ = "right"
fromJustify CenterJ = "center"

fromRelief :: Relief -> String
fromRelief Raised = "raised"
fromRelief Sunken = "sunken"
fromRelief Flat = "flat"
fromRelief Ridge = "ridge"
fromRelief Solid = "solid"
fromRelief Groove = "groove"

type Rect = (Coord,Coord)

fromRegion :: Rect -> String
fromRegion ((llx,lly),(urx,ury)) = tcl_string $
  show llx ++ " " ++ 
  show lly ++ " " ++
  show urx ++ " " ++
  show ury ++ " "

fromWrap :: Wrap -> String
fromWrap NoWrap = "none"
fromWrap CharWrap = "char"
fromWrap WordWrap = "word"


fromGridInfo :: GridInfo -> TclPack
fromGridInfo (WidthX x) = Tcl_Any "columnspan " (show x)
fromGridInfo (HeightY y) = Tcl_Any "rowspan " (show y)
fromGridInfo (GridPad (PadX x)) = Tcl_Any "padx" (show x)
fromGridInfo (GridPad (PadY x)) = Tcl_Any "pady" (show x)
fromGridInfo (GridPadInternal (PadX x)) = Tcl_Any "ipadx" (show x)
fromGridInfo (GridPadInternal (PadY x)) = Tcl_Any "ipady" (show x)
fromGridInfo (GridAnchor a) = Tcl_Any "sticky" (fromAnchor a)
fromGridInfo (GridFill FillX) = Tcl_Any "sticky" "we"
fromGridInfo (GridFill FillY) = Tcl_Any "sticky" "ns"
fromGridInfo (GridFill FillXY) = Tcl_Any "sticky" "nswe"
fromGridInfo (GridIn x) = Tcl_Any "in" x

fromFill :: Fill -> String
fromFill FillX = "x"
fromFill FillY = "y"
fromFill FillXY = "both"

fromAnchor :: Anchor -> String
fromAnchor N = "n"
fromAnchor S = "s"
fromAnchor E = "e"
fromAnchor W = "w"
fromAnchor NE = "ne"
fromAnchor NW = "nw"
fromAnchor SE = "se"
fromAnchor SW = "sw"
fromAnchor C = "c"

fromPlacePos :: Maybe WPath -> PackMode -> PlacePos WPath -> [TclPack]
fromPlacePos _ pm (PlaceBefore i) = [fromPackMode pm,Tcl_Any "before" i]
fromPlacePos _ pm (PlaceAfter i) = [fromPackMode pm,Tcl_Any "after" i]
fromPlacePos (Just w) pm PlaceTop = [fromPackMode pm, Tcl_Any "before" w]
fromPlacePos _ pm _ = [fromPackMode pm]

fromPackMode :: PackMode -> TclPack
fromPackMode PackVertical = Tcl_Any  "side" "top"
fromPackMode PackHorizontal = Tcl_Any "side" "left"

fromPack :: PackInfo -> TclPack
fromPack (PackFill f) = Tcl_Any "fill" (fromFill f)
fromPack (PackExpand True) = Tcl_Any "expand" "1"
fromPack (PackExpand False) = Tcl_Any "expand" "0"
fromPack (PackFree s s2) = Tcl_Any  s s2
fromPack (PackAnchor a) = Tcl_Any  "anchor" (fromAnchor a)
fromPack (PackPad (PadX x)) = Tcl_Any  "padx" (show x)
fromPack (PackPad (PadY y)) = Tcl_Any  "pady" (show y)
fromPack (PackPadInternal (PadX x)) = Tcl_Any "ipadx" (show x)
fromPack (PackPadInternal (PadY y)) = Tcl_Any "ipady" (show y)
fromPack (PackIn p) = Tcl_Any "in" p
fromPack _ = Tcl_Any "" ""

getPackMode :: PackInfo -> Maybe PackMode 
getPackMode (PackMode m) = Just m
getPackMode _ = Nothing

getPackPos :: PackInfo -> Maybe (PlacePos WPath)
getPackPos  (PackPos m) = Just m
getPackPos _ = Nothing

gridAdd' :: PWidget w -> Coord -> [GridInfo] -> IO ()
gridAdd' w (x,y) cs = 
 T.gridAdd w ([
	       Tcl_Any "row" (show y),
	       Tcl_Any "column" (show x)] ++ map fromGridInfo cs)

gridForget' :: PWidget w -> IO ()
gridForget' w = T.gridForget w

packAdd' :: PWidget w -> [PackInfo] -> IO ()
packAdd' w ps = do
 let ps' = map fromPack ps
 let par = maybe (parentWPath w) (\(Tcl_Any _ p) -> p) (T.isIn ps')
 xs <- T.tclW w $ \w -> ["pack slaves",par]
 let hd = case words xs of 
            [] -> Nothing
            (x:xs) -> Just x
 let pm = case (findMaybe getPackMode ps,findMaybe getPackPos ps) of
            (Just pm,Just ppos) -> fromPlacePos hd pm ppos
            (Nothing,Just ppos) -> fromPlacePos hd PackVertical ppos
            (Just pm,Nothing) -> [fromPackMode pm]
            (Nothing,Nothing) -> []
 
 T.packAdd w (pm ++ map fromPack ps)

packForget' :: PWidget w -> IO ()
packForget' w = T.packForget w


-- Conf Clases -----------------------------------------------
 
(%%) :: String -> String -> Conf w
a %% b = Config $ a T.%% b

(%#) :: String -> GUI () -> Conf w
a %# b = Config $ a T.%# (flip runGUI b)

class Has_activebackground w where
  activebackground   :: String -> Conf w
  activebackground x = "activebackground" %% tcl_string x

class Has_activeforeground w where
  activeforeground   :: String -> Conf w
  activeforeground x =  "activeforeground" %% tcl_string x

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

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

class Has_background w where
  background   :: String -> Conf w
  background x = "background" %% tcl_string x

class Has_bitmap w where
  bitmap   :: String -> Conf w
  bitmap x = "bitmap" %% tcl_string x

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

class Has_command w where
  command   :: (GUI ()) -> Conf w
  command x = "command" %# x

class Has_cursor w where
  cursor   :: String -> Conf w
  cursor x =  "cursor" %% tcl_string x

class Has_disabledforeground w where
  disabledforeground :: String -> Conf w
  disabledforeground x = "disabledforeground" %% tcl_string x

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

class Has_ent_show w where
  ent_show   :: Char -> Conf w
  ent_show x =  "show" %% [x]

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

class Has_fill w where
  fill   :: String -> Conf w
  fill x =  "fill" %% tcl_string x

class Has_font w where
  font   :: String -> Conf w
  font x = "font" %% tcl_string x

class Has_foreground w where
  foreground   :: String -> Conf w
  foreground x = "foreground" %% tcl_string x

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

class Has_highlightbackground w where
  highlightbackground   :: String -> Conf w
  highlightbackground x =  "highlightbackground" %% tcl_string x

class Has_highlightcolor w where
  highlightcolor   :: String -> Conf w
  highlightcolor x =  "highlightcolor" %% tcl_string x

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

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

class Has_image w where
  image :: String -> Conf w
  image x = "image" %% tcl_string x

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

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

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

class Has_outline w where
  outline   :: String -> Conf w
  outline x = "outline" %% tcl_string x

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

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

class Has_postcommand w where
  postcommand   :: (GUI ()) -> Conf w
  postcommand x = "postcommand" %# x

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

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

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

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

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

class Has_selectbackground w where
  selectbackground   :: String -> Conf w
  selectbackground x = "selectbackground" %% tcl_string x

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

class Has_selectcolor w where
  selectcolor   :: String -> Conf w
  selectcolor x = "selectcolor" %% tcl_string x

class Has_selectforeground w where
  selectforeground   :: String -> Conf w
  selectforeground x = "selectforeground" %% tcl_string x

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

class Has_sliderlength w where
  sliderlength   :: Int -> Conf w
  sliderlength x = "sliderlength" %% show x

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

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

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

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

class Has_troughcolor w where
  troughcolor   :: String -> Conf w
  troughcolor x =  "troughcolor" %% tcl_string x

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

class Has_use_menu w where
  use_menu   :: Menu -> Conf w
  use_menu x =  "menu" %% T.wpath x

class Has_wgt_label w where
  wgt_label   :: String -> Conf w
  wgt_label x =  "label" %% tcl_string x

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

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

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