WidgetSetImpl - Tcl specific
This module provides basic tcl specific

\begin{code}
module WidgetSetImpl (module WidgetSetImpl) where
import AbstractInterface
import qualified TclPrimImpl as T
import Identify
import StaticTypes
import IOExts
import Compatibility
import Listener
import List
import Monad
\end{code}


Instances for tcl-tk widgets

All tcl-tk widgets are widget items.
Don't allow destruction of the root window, that only happens when we quit.

\begin{code}
instance WidgetItem (T.Widget c w) where
 destroy w | T.wpath w == "." = return ()
 destroy w = T.destroy w
 uniqueId w = identify $ T.wtag w
 cset w c = T.cset' w c
 addFinaliserW w act = T.addFinaliserW w act
\end{code}

Windows, all panel widgets, all canvas widgets, all tag widgets, all
embedded text widgets are bindable (ie they can listen to user input).

\begin{code}
instance Bindable T.Window where
 bind = bindWidget

instance Bindable (T.PWidget w) where
 bind = bindWidget

instance Bindable (T.CWidget w) where
 bind = bindWidget

instance Bindable (T.TWidget w) where
 bind = bindWidget

instance Bindable (T.EWidget w) where
 bind = bindWidget
\end{code}

There is a special bindable instance for canvas widgets.
This is important when listening to mouse movement on canvases.
It is common to move canvas items around. When doing this we usually
listen to the mouse movement on the parent canvas to get the movement
coordinates in canvas coordinates. This messes up with canvas window 
items (ie placing panel items in canvases). Mouse input when over the
panel item goes to it and not to the canvas. We can fix this y listening
to mouse movements on the top level window (which hears everything)
and then translate the mouse coordinates into the canvas coordinates.
(ok, its a bit of a hack :-)

\begin{code}
instance Bindable T.Canvas where
 bind = bindWidget' bindArgs

bindArgs :: T.Canvas -> (Bool,Bool,String,String) -> ([String] -> IO ()) 
         -> IO (IO ())
bindArgs c (brk,_,"<Motion>",xy) a = do
   p <- T.tclW c $ \c -> ["winfo toplevel",c]
   w <- T.totcl_wwidget p T.TkTop (T.getTclGUIInfo c)
   let bind = T.bindArgs w (brk,True,"<Motion>","XY") 
   case xy of
    "XY" -> bind a
    "xy" -> bind (a' p)
         where a' p [x,y] = do 
                  x' <- T.tclW c $ \c -> ["winfo rootx", c]
                  y' <- T.tclW c $ \c -> ["winfo rooty", c]    
                  let x'' = T.parseInt x - T.parseInt x'
                      y'' = T.parseInt y - T.parseInt y'
                  a [show x'',show y'']
bindArgs c w a = T.bindArgs c w a

\end{code}

Tcl-tk action listeners. bind to the command from the widget the IO action 
from the listener. (See Listener.hs for more on fireListener').

\begin{code}

actionW :: T.Widget w c -> Listener () -> IO (IO ())
actionW w l = do
 rm <- fixIO $ \rm -> do
	 op <- fireListener' l rm
	 rm <- T.bindCommand w (op ())
	 return rm
 return $ rm

instance Has_Action T.Button where
 action = actionW

instance Has_Action T.MButton where
 action = actionW

instance Has_Action T.MCheckbutton where
 action = actionW

instance Has_Action T.MRadiobutton where
 action = actionW

instance Has_Action T.Radiobutton where
 action = actionW

instance Has_Action T.Checkbutton where
 action = actionW

instance Has_Action T.Scale where
 action = actionW

\end{code}

Tcl-tk windows are window items

\begin{code}
instance WindowItem WindowPrim where
 showWindow = T.showWindow
 hideWindow = T.hideWindow
 iconifyWindow = T.iconifyWindow
 getWinPanel w = return $ Panel w
\end{code}

Panel items - Panel widgets are panel items, and can be added to boxes 
and grids, and removed from them.

\begin{code}
instance PanelItem (T.PWidget w) where
 gridAdd = gridAdd'
 boxAdd = boxAdd'
 raise a b = T.raise a (fmap getWPath' b)
 lower a b = T.lower a (fmap getWPath' b)
\end{code}

Tcl-tk frames are panels.

\begin{code}
instance IsPanel T.Frame where
 mkSubPanel w = do
   f <- T.frame w []
   return $! Panel f
 setGridLayout frm = do 
   return $! Grid frm
 setBoxLayout frm = do
   ref <- newIORef PackAbove
   elts <- newIORef []
   return $! Box frm ref elts
\end{code}

It's also useful to make tcl-tk windows panels; this allows us to write
getWinPanel without making a child frame, thereby allowing us to have
just one winpanel. This is a bit of a dodgy hack as it means we have to
make tcl-tk windows into panel items. to do: rethink. 

\begin{code}
instance PanelItem WindowPrim where
 gridAdd _ _ _ _ = return (return ())
 boxAdd _ _ _ _ = return (return ())
 raise _ _ = return ()
 lower _ _ = return ()

instance IsPanel WindowPrim where
 mkSubPanel w = do
  f <- T.frame w []
  return $! Panel f
 setGridLayout w = do
  return $! Grid w
 setBoxLayout w = do
  ref <- newIORef PackAbove
  elts <- newIORef []
  return $! Box w ref elts
\end{code}

How do we actually translate actions and User actions into tcl-tk terminology.
We turn the action into a tcl-tk specific data using wrapWC. 
We then turn the listener into an IO action and bind the widget to fire the IO
action. The function fireListener' expects a remove action which is the
unregister action for the widget binding.

\begin{code}

bindWidget :: T.Widget a b -> Action -> Listener UserAction -> IO (IO ())
bindWidget = bindWidget' T.bindArgs

bindWidget' :: (T.Widget a b -> (Bool,Bool,String,String) 
                -> ([String] -> IO ()) -> IO (IO ()))
            -> T.Widget a b -> Action -> Listener UserAction -> IO (IO ())
bindWidget' _ w AskDestroy l = do
 tellop <- fireListener l
 addFinaliserW w (tellop Destroy)
 return (return ())
bindWidget' bindArgs w ask act = do
   let (ask'@(_,_,s,_),op') = wrapWC ask
   rm <- fixIO $ \rm -> do
	   tellop <- fireListener' act rm
	   rm <- bindArgs w ask' (runBC tellop op')
           return $ rm
   return rm

runBC :: (UserAction -> IO ()) -> ([String] -> Maybe UserAction) -> [String] -> IO ()
runBC tell op xs = do
    case op xs of 
       Nothing -> return ()
       Just v -> tell v
\end{code}

We use wrapWC to convert an action into Tcl-tk specific bind data,
and to get back a function to turn the widget specific data into a
User Action.

The Tcl-tk specific data means the following:
1 The first boolean argument will normally be false, indicating that the event 
  should be processed as normal. When the flag is True, after the callback has 
  been invoked to service the event, no further event processing will take 
  place.
2 The second boolean causes the callback to be added to other bindings for the 
  widget when True.
3 The first String argument is the name of the event we're binding to.
4 The second String argument given access to the the Tcl-tk % mechanism.
  This allows us to access the parameters from the user input, such as the
  mouse coordinates when listening to mouse motion.

\begin{code}
wrapWC :: Action -> ((Bool,Bool,String,String),[String] -> Maybe UserAction)
wrapWC (AskButton n b mods) = ((False,True,
                               "<" ++ showMods mods ++ "Button" ++ 
                                 (if b then "Press-" else "Release-" )
                                 ++ show n ++ ">",
			       ""),
                           const $ Just (Button n b mods))

wrapWC (AskMotion mods) = ((False,True,"<" ++ showMods mods ++ "Motion>","xy"),
                     f')
      where
	f' [x,y] = Just $ MouseMove (worldToPoint2 (xx,yy)) mods
	      where
		xx = T.parseInt x 
                yy = T.parseInt y
	f' _ = Nothing
wrapWC AskDestroy = ((False,True,"<Destroy>",""),const $ Just Destroy)
wrapWC (AskEnter mods) = ((False,True,"<" ++ showMods mods ++ "Enter>",""),const $ Just $ Enter mods)
wrapWC (AskLeave mods) = ((False,True,"<" ++ showMods mods ++ "Leave>",""),const $ Just $ Leave mods)
wrapWC (AskKey b mbk mods) = 
       ((False,False,
        "<" ++ showMods mods ++ "Key" ++ (if b then "Press" else "Release") ++
        (case mbk of Nothing -> ">"
                     Just c' -> "-"++showKey c'++">"),
        "K"),
        f')
      where 
           f' [s] = Just $ CharKey b (fromKey s) mods
           f' _ = Nothing
wrapWC (AskAction s nm) = ((False,True,"<" ++ s ++ ">",nm),
			   f)
  where
    f [s'] = Just $ ExtAction s s'
    f _ = Nothing
wrapWC AskResize = ((False,True,"<Configure>","wh"),f')
      where
          f' [w,h] = Just $ Resize (worldToVector2' w h)
          f' _ = Nothing
wrapWC _ = ((False,False,"",""),const Nothing)
\end{code}


How do we actually add tcl-tk panel widgets to grids

\begin{code}
gridAdd' :: T.PWidget w -> Grid -> (Int,Int) -> [GridBagConstraint] 
         -> IO (IO ())
gridAdd' w (Grid p) (x,y) cs = do
   T.gridAdd w ([T.Tcl_Any "in" (getWPath p),
                   T.Tcl_Any "row" (show y),
		   T.Tcl_Any "column" (show x)] ++ 
		  map fromGridBagConstraint cs)
   return $ T.gridForget w

fromGridBagConstraint :: GridBagConstraint -> T.TclPack
fromGridBagConstraint (WidthX x) = T.Tcl_Any "columnspan " (show x)
fromGridBagConstraint (WidthY y) = T.Tcl_Any "rowspan " (show y)
fromGridBagConstraint (GridPad (PadX x)) = T.Tcl_Any "padx" (show x)
fromGridBagConstraint (GridPad (PadY x)) = T.Tcl_Any "pady" (show x)
fromGridBagConstraint (GridPadInternal (PadX x)) = T.Tcl_Any "ipadx" (show x)
fromGridBagConstraint (GridPadInternal (PadY x)) = T.Tcl_Any "ipady" (show x)
fromGridBagConstraint (GridAnchor a) = T.Tcl_Any "sticky" (fromAnchor a)
fromGridBagConstraint (GridFill FillX) = T.Tcl_Any "sticky" "we"
fromGridBagConstraint (GridFill FillY) = T.Tcl_Any "sticky" "ns"
fromGridBagConstraint (GridFill FillXY) = T.Tcl_Any "sticky" "nswe"
\end{code}

How do we actually add tcl-tk panel widgets to boxes.
We work out the location of the element in the box, in particular
to calculate this we need to know what is at the head of the list of items
in the box. To put an object at the front. We then update the list
with this element.

\begin{code}
boxAdd' :: T.PWidget a -> Box -> PlacePos Ident -> [PackInfo] -> IO (IO ())
boxAdd' w (Box p ref eltsRef) pos pinfo = do
   let uid = uniqueId w
   let pth = getWPath' uid
   let gui = T.getTclGUIInfo w
   elts <- readIORef eltsRef
   let hd = case elts of 
		[] -> Nothing 
		(x:xs) -> Just $ getWPath' x
   writeIORef eltsRef $ insertElt uid pos elts 
   pm <- readIORef ref 
   T.packAdd w (T.Tcl_Any "in" (getWPath p):
	        fromPlacePos hd pm pos ++      
	        map fromPack pinfo)
   return $ T.packForget w

insertElt :: Ident -> PlacePos Ident -> [Ident] -> [Ident]
insertElt p PlaceTop xs = p:xs
insertElt p PlaceBottom xs = xs ++ [p]
insertElt p (PlaceBefore x) xs = before x p xs
 where
  before x p [] = [p]
  before x p (id:as) = if id == x then p:id:as else id:before x p as
insertElt p (PlaceAfter x) xs = after x p xs
 where
  after x p [] = [p]
  after x p (id:as) = if id == x then id:p:as 
		      else id:after x p as
\end{code}

Now we'll go on to define a set of functions to translate from the 
WH data types into tcl-tk land

get the widget path from a widget item and more specifically from its
unique id.

\begin{code}
getWPath :: WidgetItem w => w -> String
getWPath w = getWPath' $ uniqueId w

getWPath' :: Ident -> String
getWPath' (IdentS s) = s
\end{code}

Turn a place position and pack mode into tcl-tk pack arguments.
If at the top place before the head of the list; if at the bottom place
it (by default it appears at the end); otherwise place before or after
the given element.

\begin{code}
fromPlacePos :: Maybe T.WPath -> PackMode -> PlacePos Ident -> [T.TclPack]
fromPlacePos _ pm (PlaceBefore i) = 
 [fromPackMode pm,T.Tcl_Any "before" $ getWPath' i]
fromPlacePos _ pm (PlaceAfter i) = 
 [fromPackMode pm,T.Tcl_Any "after" $ getWPath' i]
fromPlacePos (Just w) pm PlaceTop = [fromPackMode pm, T.Tcl_Any "before" w]
fromPlacePos _ pm _ = [fromPackMode pm]

fromPackMode :: PackMode -> T.TclPack
fromPackMode PackAbove = T.Tcl_Any  "side" "top"
fromPackMode PackBeside = T.Tcl_Any "side" "left"
\end{code}

Translate packinfo into tcl-tk
\begin{code}
fromPack :: PackInfo -> T.TclPack
fromPack (PackFill f) = T.Tcl_Any "fill" (fromFill f)
fromPack (PackExpand True) = T.Tcl_Any "expand" "1"
fromPack (PackExpand False) = T.Tcl_Any "expand" "0"
fromPack (PackFree s s2) = T.Tcl_Any  s s2
fromPack (PackAnchor a) = T.Tcl_Any  "anchor" (fromAnchor a)
fromPack (PackPad (PadX x)) = T.Tcl_Any  "padx" (show x)
fromPack (PackPad (PadY y)) = T.Tcl_Any  "pady" (show y)
fromPack (PackPadInternal (PadX x)) = T.Tcl_Any "ipadx" (show x)
fromPack (PackPadInternal (PadY y)) = T.Tcl_Any "ipady" (show y)
\end{code}

likewise fill data
\begin{code}
fromFill :: Fill -> String
fromFill FillX = "x"
fromFill FillY = "y"
fromFill FillXY = "both"
\end{code}

likewise anchors
\begin{code}
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"
\end{code}

Turn a tcl-tk string into and back from the Key data type.

\begin{code}
fromKey :: String -> Key
fromKey "Return" = Return
fromKey "Escape" = Escape
fromKey "Tab" = Tab
fromKey "Caps_Lock" = Caps
fromKey "Shift_L" = Shift
fromKey "Control_L" = Control
fromKey "Alt_L" = Alt
fromKey "space" = Space
fromKey "App" = App
fromKey "Left" = CursorLeft
fromKey "Right" = CursorRight
fromKey "Down" = CursorDown
fromKey "Up" = CursorUp
fromKey "Next" = Next
fromKey "Prior" = Prior
fromKey "Delete" = Delete
fromKey "Insert" = Insert
fromKey "Home" = Home
fromKey "End" = End
fromKey "BackSpace" = BackSpace
fromKey [c] = KeyChar c
fromKey ('F':xs) = F $ read xs
fromKey "equal" = KeyChar '='
fromKey "minus" = KeyChar '-'
fromKey "parenright" = KeyChar ')'
fromKey "parenleft" = KeyChar '('
fromKey "asterisk" = KeyChar '*'
fromKey "ampersand" = KeyChar '&'
fromKey "asciicircum" = KeyChar '^'
fromKey "percent" = KeyChar '%'
fromKey "dollar" = KeyChar '$'
fromKey "quotedlbl" = KeyChar '"'
fromKey "braceleft" = KeyChar '['
fromKey "braceright" = KeyChar ']'
fromKey "colon" = KeyChar ':'
fromKey "at" = KeyChar '@'
fromKey "asciitilde" = KeyChar '~'
fromKey "question" = KeyChar '?'
fromKey "greater" = KeyChar '>'
fromKey "less" = KeyChar '<' 
fromKey "slash" = KeyChar '/' 
fromKey "period" = KeyChar '.'
fromKey "comma" = KeyChar ','
fromKey "semicolon" = KeyChar ';'
fromKey "quoteright" = KeyChar '\''
fromKey "numbersign" = KeyChar '#'
fromKey "bracketright" = KeyChar ']'
fromKey "bracketleft" = KeyChar '['
fromKey "quoteleft" = KeyChar '`'
fromKey "apostrophe" = KeyChar '\''
fromKey "bar" = KeyChar '|'
fromKey "plus" = KeyChar '+'
fromKey "underscore" = KeyChar '_'
fromKey "backslash" = KeyChar '\\'
fromKey "exclam" = KeyChar '!'
fromKey "quotedbl" = KeyChar '"'
fromKey "sterling" = KeyChar '\156'
fromKey "grave" = KeyChar '`'
fromKey "notsign" = KeyChar '\170'
fromKey s = Key s
 
showKey :: Key -> String
showKey Return = "Return"
showKey Escape = "Escape"
showKey Tab = "Tab"
showKey Caps = "Caps_Lock"
showKey Shift = "Shift_L"
showKey Control = "Control_L"
showKey Alt = "Alt_L"
showKey Space = "space"
showKey App = "App"
showKey CursorLeft = "Left"
showKey CursorDown = "Down"
showKey CursorRight = "Right"
showKey CursorUp = "Up"
showKey Next = "Next"
showKey Prior = "Prior"
showKey Delete = "Delete"
showKey Insert = "Insert"
showKey Home = "Home"
showKey End = "End"
showKey BackSpace = "BackSpace"
showKey (F x) = "F" ++ show x
showKey (KeyChar c) = show c
showKey (Key s) = s
\end{code}

Handle the Modifier type in tcl-tk

\begin{code}
showMod :: Modifier -> String
showMod (AMod s) = s
showMod DoubleM = "Double"
showMod ShiftM = "Shift"
showMod TripleM = "Triple"
showMod AltM = "Alt"
showMod ControlM = "Control"

showMod (ButtonPressedM n) = "Button" ++ show n
showMod m = show m

showMods :: [Modifier] -> String
showMods [] = ""
showMods (x:xs) = concat $ fmap (\x -> x ++ "-") $ map showMod (x:xs)
\end{code}

helper function to compose one list of configs over another
\begin{code}
overideCfgs :: [Config] -> [Config] -> [Config]
overideCfgs cs1 cs2 = unionBy T.sameConfig cs1 cs2
\end{code}

translate colors into tcl-tk rgb. Fran uses values in the range 0-1, 
tcl-tk in the range 0 - 255 so convert.

\begin{code}
fromColor :: Color -> String
fromColor (ColorRGB r g b) = T.tcl_string $  
 T.rgb (f r) (f g) (f b)
   where
     f v = round (v * 255)
\end{code}

bitmaps, currently just named bitmaps are valid

\begin{code}
data Bitmap = Bitmap String
 deriving Eq

fromBitmap :: Bitmap -> String
fromBitmap (Bitmap s) = T.tcl_string s

namedBitmap = Bitmap
\end{code}

fonts, currently named fonts with a point size and some style attributes
\begin{code}
data Font = Font String
 deriving Eq

fromFont :: Font -> String
fromFont (Font s) = T.tcl_string s

namedFont :: String -> Int -> [FontStyle] -> Font
namedFont a b c = Font $ a ++ " " ++ show b ++ " " ++
                         (unwords $ map showFont c)

data FontStyle = Bold | Italic | Underline | Overstrike | Roman 
 deriving Eq

showFont Bold = "bold"
showFont Italic = "italic"
showFont Underline = "underline"
showFont Overstrike = "overstrike"
showFont Roman = "roman"
\end{code}

cursors - only named cursors so far
\begin{code}
data Cursor = Cursor String
 deriving Eq

fromCursor :: Cursor -> String
fromCursor (Cursor s) = T.tcl_string s

namedCursor = Cursor
\end{code}

only named images so far
\begin{code}
data Image = Image String
 deriving Eq
fromImage :: Image -> String
fromImage (Image s) = s
namedImage = Image
\end{code}

turn select mode into tcl-tk 
\begin{code}
fromSelectMode :: SelectMode -> String
fromSelectMode SingleMode =  "single"
fromSelectMode BrowseMode = "browse"
fromSelectMode MultipleMode =  "multiple"
fromSelectMode ExtendedMode =  "extended"
\end{code}

turn justify into tcl-tk 
\begin{code}
fromJustify :: Justify -> String
fromJustify LeftJ = "left"
fromJustify RightJ = "right"
fromJustify CenterJ = "center"
\end{code}

turn relief into tcl-tk
\begin{code}
fromRelief :: Relief -> String
fromRelief Raised = "raised"
fromRelief Sunken = "sunken"
fromRelief Flat = "flat"
fromRelief Ridge = "ridge"
fromRelief Solid = "solid"
fromRelief Groove = "groove"
\end{code}

translate active state 
\begin{code}
fromActiveState Active = "active"
fromActiveState Disabled = "disabled"
fromActiveState Normal = "normal"
\end{code}

translate rectangular regions
\begin{code}
fromRegion :: Rect -> String
fromRegion (RectLLUR (Point2XY llx lly) (Point2XY urx ury)) =
  show llx ++ " " ++ 
  show lly ++ " " ++
  show urx ++ " " ++
  show ury ++ " "
\end{code}

translate scroll units into tcl

\begin{code}
fromScroll :: ScrollUnits -> T.ScrollUnit
fromScroll (FullScreens x) = T.ScrollPages x
fromScroll (Units x) = T.ScrollUnits x
\end{code}

finally translate wrap arguments

\begin{code}
fromWrap :: Wrap -> String
fromWrap NoWrap = "none"
fromWrap CharWrap = "char"
fromWrap WordWrap = "word"
\end{code}


Some coordinate helper functions to translate to and from points and vectors
to tcl-tk land

\begin{code}
pointToWorld :: Point2 -> (Int,Int)
pointToWorld (Point2XY x y) = (round x,round y)

vectorToWorld :: Vector2 -> (Int,Int)
vectorToWorld (Vector2XY v1 v2) = (round v1,round v2)

pointToWorld' :: Point2 -> String
pointToWorld' (Point2XY x y) = (round x `joinInts` round y)

vectorToWorld' :: Vector2 -> String
vectorToWorld' (Vector2XY v1 v2) = (round v1 `joinInts` round v2)

worldToPoint2 :: (Int,Int) -> Point2
worldToPoint2 (x,y) = point2XY (fromInt x) (fromInt y)

worldToVector2' :: String -> String -> Vector2
worldToVector2' x y = Vector2XY (fromInt $ T.parseInt x) (fromInt $ T.parseInt y)

worldToPoint2' :: String -> String -> Point2
worldToPoint2' x y = Point2XY (fromInt $ T.parseInt x) (fromInt $ T.parseInt y)

joinInts :: Int -> Int -> String
joinInts x y = show x ++ " " ++ show y
\end{code}