diff --git a/HTk/Canvasitems/Arc.hs b/HTk/Canvasitems/Arc.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Canvasitems/Arc.hs
@@ -0,0 +1,129 @@
+-- | HTk\'s /arc/ canvas item.
+-- An arc object on a canvas widget.
+module HTk.Canvasitems.Arc (
+
+ Arc,
+ createArc,
+
+ extent,
+ getExtent,
+
+ start,
+ getStart
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.Configuration
+import HTk.Canvasitems.CanvasItem
+import HTk.Canvasitems.CanvasTag
+import HTk.Canvasitems.CanvasItemAux
+import Util.Computation
+import Events.Synchronized
+import Events.Destructible
+
+
+-- -----------------------------------------------------------------------
+-- arc
+-- -----------------------------------------------------------------------
+
+-- | The @Arc@ datatype.
+data Arc = Arc GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- constructor
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new arc item.
+createArc :: Canvas
+ -- ^ the parent canvas.
+ -> [Config Arc]
+ -- ^ the list of configuration options for this arc.
+ -> IO Arc
+ -- ^ An arc item.
+createArc cnv cnf =
+ createCanvasItem cnv ARC Arc cnf [(-1,-1),(-1,-1)]
+
+
+-- -----------------------------------------------------------------------
+-- instantiations
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject Arc where
+ toGUIObject (Arc w) = w
+ cname _ = "Arc"
+
+-- | An arc item can be destroyed.
+instance Destroyable Arc where
+ -- Destroys an arc item.
+ destroy = destroy . toGUIObject
+
+-- | You can synchronize on an arc item.
+instance Synchronized Arc where
+ -- Synchronizes on an arc item.
+ synchronize = synchronize . toGUIObject
+
+-- | An arc is a canvas item (any canvas item is an instance of the abstract
+-- @class CanvasItem@).
+instance CanvasItem Arc
+
+-- | An arc item can have several tags (handlers for a set of canvas items).
+instance TaggedCanvasItem Arc
+
+-- | An arc is a filled canvas item (it has filling, outline, outline width,
+-- and stipple configurations).
+instance FilledCanvasItem Arc
+
+-- | An alternative way to specify arc\'s coords.
+instance HasGeometry Arc where
+ -- Sets the arc\'s geometry (width, height, upper left position).
+ geometry = itemGeo
+ -- Gets the arcs geometry (width, height, upper left position).
+ getGeometry = getGeo
+
+-- | You can specify the (upper left) position of an arc.
+instance HasPosition Arc where
+ -- Sets the arc\'s (upper left) position.
+ position = itemPosition
+ -- Gets the (upper left) position of the arc.
+ getPosition = getItemPosition
+
+-- | You can specify the size of an arc.
+instance HasSize Arc where
+ -- Sets the width of an arc.
+ width = itemWidth
+ -- Gets the width of an arc.
+ getWidth = getItemWidth
+ -- Sets the height of an arc.
+ height = itemHeight
+ -- Gets the height of an arc.
+ getHeight = getItemHeight
+ -- Sets the size (width, height) of an arc.
+ size = itemSize
+ -- Gets the size (width, height) of an arc.
+ getSize = getItemSize
+
+
+-- -----------------------------------------------------------------------
+-- config options
+-- -----------------------------------------------------------------------
+
+type Degree = Double
+
+-- | Sets the length of an arc in counter-clockwise direction.
+extent :: Degree -> Config Arc
+extent d w = cset w "extent" d
+
+-- | Gets the length of an arc in counter-clockwise direction.
+getExtent :: Arc -> IO Degree
+getExtent w = cget w "extent"
+
+-- | Sets the starting angle of an arc.
+start :: Degree -> Config Arc
+start d w = cset w "start" d
+
+-- | Gets the starting angle of an arc.
+getStart :: Arc -> IO Degree
+getStart w = cget w "start"
diff --git a/HTk/Canvasitems/BitMapItem.hs b/HTk/Canvasitems/BitMapItem.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Canvasitems/BitMapItem.hs
@@ -0,0 +1,108 @@
+-- | HTk\'s /bitmap/ canvas item.
+-- A bitmap object on a canvas widget.
+module HTk.Canvasitems.BitMapItem (
+
+ BitMapItem,
+ createBitMapItem
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.Configuration
+import HTk.Kernel.Colour(toColour)
+import HTk.Canvasitems.CanvasItem
+import HTk.Canvasitems.CanvasTag
+import HTk.Canvasitems.CanvasItemAux
+import HTk.Components.BitMap
+import Util.Computation
+import Events.Synchronized
+import Events.Destructible
+
+
+-- -----------------------------------------------------------------------
+-- BitMapItem
+-- -----------------------------------------------------------------------
+
+-- | The @BitMapItem@ datatype.
+newtype BitMapItem = BitMapItem GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- constructor
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new bitmap item.
+createBitMapItem :: Canvas
+ -- ^ the parent canvas.
+ -> [Config BitMapItem]
+ -- ^ the list of configuration options for this bitmap
+ -- item.
+ -> IO BitMapItem
+ -- ^ A bitmap item.
+createBitMapItem cnv cnf =
+ createCanvasItem cnv BITMAPITEM BitMapItem cnf [(-1,-1)]
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject BitMapItem where
+ toGUIObject (BitMapItem w) = w
+ cname _ = "BitMapItem"
+
+-- | A bitmap item can be destroyed.
+instance Destroyable BitMapItem where
+ -- Destroys a bitmap item.
+ destroy = destroy . toGUIObject
+
+-- | A bitmap item is a canvas item (any canvas item is an instance of the
+-- abstract @class CanvasItem@).
+instance CanvasItem BitMapItem
+
+-- | A bitmap item can have several tags (handlers for a set of canvas
+-- items).
+instance TaggedCanvasItem BitMapItem
+
+-- | You can specify the position of a bitmap item.
+instance HasPosition BitMapItem where
+ -- Sets the position of the bitmap item.
+ position = itemPositionD2
+ -- Gets the position of the bitmap item.
+ getPosition = getItemPositionD2
+
+-- | You can specify the anchor position of a bitmap item.
+instance HasCanvAnchor BitMapItem where
+ -- Sets the anchor position of a bitmap item.
+ canvAnchor a w = cset w "anchor" a
+ -- Gets the anchor position of a bitmap item.
+ getCanvAnchor w = cget w "anchor"
+
+-- | A bitmap item is a filled canvas item (it has filling, outline,
+-- outline width, and stipple configurations).
+instance FilledCanvasItem BitMapItem where
+ -- Sets the filling (foreground) of a bitmap item.
+ filling c w = cset w "foreground" (toColour c)
+ -- Gets the filling (foreground) of a bitmap item.
+ getFilling w = cget w "foreground"
+ -- Sets the outline (background) of a bitmap item.
+ outline c w = cset w "background" (toColour c)
+ -- Gets the outline (background) of a bitmap item.
+ getOutline w = cget w "background"
+ -- Dummy configuration (no effect).
+ outlinewidth c w = return w
+ -- Dummy configuration (no effect).
+ getOutlineWidth w = return cdefault
+ -- Sets the bitmap handle for this item.
+ stipple b w = setBitMapHandle w "bitmap" b True
+ -- Gets the bitmap handle for this item.
+ getStipple w = getBitMapHandle w "bitmap"
+
+-- | A bitmap item is a container for a bitmap object.
+instance HasBitMap BitMapItem
+
+-- | You can synchronize on a bitmap item.
+instance Synchronized BitMapItem where
+ -- Synchronizes on a bitmap item.
+ synchronize w = synchronize (toGUIObject w)
diff --git a/HTk/Canvasitems/CanvasItem.hs b/HTk/Canvasitems/CanvasItem.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Canvasitems/CanvasItem.hs
@@ -0,0 +1,248 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | The @module CanvasItem@ exports basic classes and
+-- general functionality on canvas items.
+module HTk.Canvasitems.CanvasItem (
+
+ Canvas,
+
+ HasCoords(..),
+
+ CanvasItem,
+ FilledCanvasItem(..),
+ SegmentedCanvasItem(..),
+
+ moveItem,
+ scaleItem,
+
+ raiseItem,
+ lowerItem,
+ putItemOnTop,
+ putItemAtBottom,
+
+ itemsNotOnSameCanvas,
+
+ declVar,
+ declVarList,
+
+) where
+
+import Data.List (intersperse)
+
+import HTk.Widgets.Canvas
+import HTk.Kernel.Core
+import HTk.Kernel.Geometry
+import HTk.Kernel.Colour
+import HTk.Components.BitMap
+import Util.Computation
+import Events.Synchronized
+
+
+-- -----------------------------------------------------------------------
+-- class CanvasItem, etc.
+-- -----------------------------------------------------------------------
+
+-- | Any canvas item is an instance of the abstract
+-- @class CanvasItem@.
+class GUIObject w => CanvasItem w
+
+-- | You can set the coords (position \/ size) of a canvas item on the
+-- parent canvas.
+class HasCoords w where
+ -- Sets the coord(s) of a canvas item on the parent canvas.
+ coord :: Coord -> Config w
+ -- Gets the coord(s) of a canvas item on the parent canvas.
+ getCoord :: w -> IO Coord
+
+-- | Any canvas item has coords on the parent canvas.
+instance CanvasItem w => HasCoords w where
+ -- Sets the coord(s) of a canvas item on the parent canvas.
+ coord co item =
+ do
+ try (execMethod item (\nm -> tkCoordItem nm co))
+ return item
+ -- Gets the coord(s) of a canvas item on the parent canvas.
+ getCoord item = evalMethod item (\nm -> tkGetCoordItem nm)
+
+-- | Any canvas item has a filling, outline, outline width and stipple
+-- configuration.
+class CanvasItem w => FilledCanvasItem w where
+ -- Sets the filling of a canvas item.
+ filling :: ColourDesignator c => c -> Config w
+ -- Gets the filling of a canvas item.
+ getFilling :: w -> IO Colour
+ -- Sets the outline colour of a canvas item.
+ outline :: ColourDesignator c => c -> Config w
+ -- Gets the outline colour of a canvas item.
+ getOutline :: w -> IO Colour
+ -- Sets the stipple configuration of a canvas item.
+ stipple :: BitMapHandle -> Config w
+ -- Gets the stipple configuration of a canvas item.
+ getStipple :: w -> IO BitMapHandle
+ -- Sets the outline width of a canvas item.
+ outlinewidth :: Distance -> Config w
+ -- Gets the outline width of a canvas item.
+ getOutlineWidth :: w -> IO Distance
+ filling c w = cset w "fill" (toColour c)
+ getFilling w = cget w "fill"
+ outline c w = cset w "outline" (toColour c)
+ getOutline w = cget w "outline"
+ stipple b w = setBitMapHandle w "stipple" b True
+ getStipple w = getBitMapHandle w "stipple"
+ outlinewidth b w = cset w "width" b
+ getOutlineWidth w = cget w "width"
+
+-- | Segmented canvas items have a splinesteps and smooth configuration.
+class CanvasItem w => SegmentedCanvasItem w where
+ -- Sets the number of line segments that approximate the spline.
+ splinesteps :: Int -> Config w
+ -- Gets the number of line segments that approximate the spline.
+ getSplinesteps :: w -> IO Int
+ -- Sets the smooth configuration (if @true@ a spline curve is
+ -- drawn around the points).
+ smooth :: Bool -> Config w
+ -- Gets the actual smooth setting.
+ getSmooth :: w -> IO Bool
+ splinesteps c w = cset w "splinesteps" c
+ getSplinesteps w = cget w "splinesteps"
+ smooth c w = cset w "smooth" c
+ getSmooth w = cget w "smooth"
+
+
+-- -----------------------------------------------------------------------
+-- canvas item operations
+-- -----------------------------------------------------------------------
+
+-- | Moves a canvas item horizontally and vertically by the given
+-- distances.
+moveItem :: (Synchronized w, CanvasItem w) =>
+ w -> Distance -> Distance -> IO ()
+moveItem item x y =
+ synchronize item (execMethod item (\nm -> tkMoveItem nm x y))
+
+-- | Scales a canvas item horizontally and vertically by the given
+-- distances.
+scaleItem :: (Synchronized w, CanvasItem w) =>
+ w -> Distance -> Distance -> Double -> Double -> IO ()
+scaleItem item x y xs ys =
+ synchronize item (execMethod item (\nm -> tkScaleItem nm x y xs ys))
+
+
+-- -----------------------------------------------------------------------
+-- layering operations
+-- -----------------------------------------------------------------------
+
+-- | Moves an item above another item in the display list.
+raiseItem :: (CanvasItem ci,CanvasItem w) => ci -> w -> IO ()
+raiseItem item1 item2 =
+ do
+ onSameCanvas item1 item2
+ nm2 <- getObjectName (toGUIObject item2)
+ execMethod item1 (\nm1 -> tkRaiseItem nm1 (Just nm2))
+
+-- | Moves an item below another item in the display list.
+lowerItem :: (CanvasItem ci,CanvasItem w) => ci -> w -> IO ()
+lowerItem item1 item2 =
+ do
+ onSameCanvas item1 item2
+ nm2 <- getObjectName (toGUIObject item2)
+ execMethod item1 (\nm1 -> tkLowerItem nm1 (Just nm2))
+
+-- | Puts an item on top of the display list.
+putItemOnTop :: CanvasItem w => w -> IO ()
+putItemOnTop item = execMethod item (\nm -> tkRaiseItem nm Nothing)
+
+-- | Puts an items at bottom of the display list.
+putItemAtBottom :: CanvasItem ci => ci -> IO ()
+putItemAtBottom item = execMethod item (\nm -> tkLowerItem nm Nothing)
+
+
+-- -----------------------------------------------------------------------
+-- utility
+-- -----------------------------------------------------------------------
+
+-- | Raises an exception if two given items do not have the same parent
+-- canvas.
+onSameCanvas :: (CanvasItem i1,CanvasItem i2) => i1 -> i2 -> IO ()
+onSameCanvas i1 i2 =
+ do
+ c1 <- getParentObjectID (toGUIObject i1)
+ c2 <- getParentObjectID (toGUIObject i2)
+ unless (c1 == c2) (raise itemsNotOnSameCanvas)
+
+-- | Exception raised by @CanasItem.onSameCanvas@.
+itemsNotOnSameCanvas :: IOError
+itemsNotOnSameCanvas =
+ userError "the two canvas items are not on the same canvas"
+
+
+-- -----------------------------------------------------------------------
+-- unparsing of commands
+-- -----------------------------------------------------------------------
+
+tkMoveItem :: ObjectName -> Distance -> Distance -> TclScript
+tkMoveItem (CanvasItemName nm item) x y =
+ declVar item ++
+ [show nm ++ " move " ++ show item ++ " " ++ show x ++ " " ++ show y]
+
+tkMoveItem _ _ _ = []
+{-# INLINE tkMoveItem #-}
+
+tkScaleItem :: ObjectName -> Distance -> Distance -> Double -> Double ->
+ TclScript
+tkScaleItem (CanvasItemName nm item) x y xs ys =
+ declVar item ++
+ [show nm ++ " scale " ++ show item ++ " " ++
+ show x ++ " " ++ show y ++ " " ++
+ show xs ++ " " ++ show ys,
+ show nm ++ " coords " ++ show item]
+tkScaleItem _ _ _ _ _ = []
+{-# INLINE tkScaleItem #-}
+
+tkCoordItem :: ObjectName -> Coord -> TclScript
+tkCoordItem (CanvasItemName nm item) co =
+ declVar item ++
+ [show nm ++ " coords " ++ show item ++ " " ++ show (toGUIValue co)]
+tkCoordItem _ _ = []
+{-# INLINE tkCoordItem #-}
+
+tkGetCoordItem :: ObjectName -> TclScript
+tkGetCoordItem (CanvasItemName nm item) =
+ declVar item ++
+ [show nm ++ " coords " ++ show item]
+tkGetCoordItem _ = []
+
+tkRaiseItem :: ObjectName -> Maybe ObjectName -> TclScript
+tkRaiseItem (CanvasItemName nm item) Nothing =
+ declVar item ++
+ [show nm ++ " raise " ++ show item]
+tkRaiseItem (CanvasItemName nm item1) (Just (CanvasItemName _ item2)) =
+ declVar item1 ++ declVar item2 ++
+ [show nm ++ " raise " ++ show item1 ++ " " ++ show item2]
+tkRaiseItem _ _ = []
+{-# INLINE tkRaiseItem #-}
+
+tkLowerItem :: ObjectName -> Maybe ObjectName -> TclScript
+tkLowerItem (CanvasItemName nm item) Nothing =
+ declVar item ++
+ [show nm ++ " lower " ++ show item]
+tkLowerItem (CanvasItemName nm item1) (Just (CanvasItemName _ item2)) =
+ declVar item1 ++ declVar item2 ++
+ [show nm ++ " lower " ++ show item1 ++ " " ++ show item2]
+tkLowerItem _ _ = []
+{-# INLINE tkLowerItem #-}
+
+-- | Retrieve all tagnames in a complex tag expression and declare
+-- them global in form of a TclScript
+declVar :: CanvasTagOrID -> TclScript
+declVar tid@(CanvasTagOrID _) = ["global " ++ (drop 1 (show tid))]
+declVar (CanvasTagNot tid) = declVar tid
+declVar (CanvasTagAnd tid1 tid2) = declVar tid1 ++ declVar tid2
+declVar (CanvasTagOr tid1 tid2) = declVar tid1 ++ declVar tid2
+declVar (CanvasTagXOr tid1 tid2) = declVar tid1 ++ declVar tid2
+
+-- | Retrieve all tagnames in a complex tag expression and declare
+-- them global in form of a TclCmd
+declVarList :: CanvasTagOrID -> TclCmd
+declVarList = concat . intersperse ";" . declVar
diff --git a/HTk/Canvasitems/CanvasItemAux.hs b/HTk/Canvasitems/CanvasItemAux.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Canvasitems/CanvasItemAux.hs
@@ -0,0 +1,170 @@
+module HTk.Canvasitems.CanvasItemAux (
+
+ createCanvasItem,
+
+ itemGeo,
+ getGeo,
+ setGeo,
+
+ itemWidth,
+ getItemWidth,
+
+ itemHeight,
+ getItemHeight,
+
+ itemSize,
+ getItemSize,
+
+ itemPosition,
+ getItemPosition,
+
+ itemPositionD2,
+ getItemPositionD2,
+
+ canvasitemMethods
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.Geometry
+import HTk.Canvasitems.CanvasItem
+import Util.Computation
+
+
+-- -----------------------------------------------------------------------
+-- geometry
+-- -----------------------------------------------------------------------
+
+itemGeo :: CanvasItem w => Geometry -> Config w
+itemGeo (w,h,x,y) = coord [(x,y),(x+w,y+h)]
+
+getGeo :: CanvasItem w => w -> IO Geometry
+getGeo wd = getCoord wd >>= coordToGeo
+
+setGeo :: CanvasItem w => w -> Geometry -> IO w
+setGeo wd g = configure wd [itemGeo g]
+
+itemWidth :: CanvasItem w => Distance -> Config w
+itemWidth d item = getGeo item >>= \(_,h,x,y) -> setGeo item (d,h,x,y)
+
+getItemWidth :: CanvasItem w => w -> IO Distance
+getItemWidth item = getGeo item >>= \ (w,_,_,_) -> return w
+
+itemHeight :: CanvasItem w => Distance -> Config w
+itemHeight d item = getGeo item >>= \(w,_,x,y) -> setGeo item (w,d,x,y)
+
+getItemHeight :: CanvasItem w => w -> IO Distance
+getItemHeight item = getGeo item >>= \(w,h,x,y) -> return h
+
+itemSize :: CanvasItem w => Size -> Config w
+itemSize (w,h) item = getGeo item >>= \(_,_,x,y) -> setGeo item (w,h,x,y)
+
+getItemSize :: CanvasItem w => w -> IO (Distance,Distance)
+getItemSize item = getGeo item >>= \(w,h,x,y) -> return (w,h)
+
+itemPosition :: CanvasItem w => Position -> Config w
+itemPosition (x,y) item = getGeo item >>= \(w,h,_,_) -> setGeo item (w,h,x,y)
+
+getItemPosition :: CanvasItem w => w -> IO (Distance,Distance)
+getItemPosition item = getGeo item >>= \(w,h,x,y) -> return (x,y)
+
+itemPositionD2 :: CanvasItem w => Position -> Config w
+itemPositionD2 p = coord [p]
+
+getItemPositionD2 :: CanvasItem w => w -> IO (Distance,Distance)
+getItemPositionD2 w = getCoord w >>= return . head
+
+
+-- -----------------------------------------------------------------------
+-- auxiliary
+-- -----------------------------------------------------------------------
+
+createCanvasItem :: CanvasItem w => Canvas -> CanvasItemKind ->
+ (GUIOBJECT -> w) -> [Config w] ->
+ Coord -> IO w
+createCanvasItem cnv kind wrap ol co =
+ do
+ w <- createGUIObject (toGUIObject cnv) (CANVASITEM kind co)
+ canvasitemMethods
+ let ci = wrap w
+ configure ci ol
+
+coordToGeo ((x1,y1) :(x2,y2) : tl) = return (x2-x1,y2-y1,x1,y1)
+coordToGeo _ = raise (userError "illegal geometry specification")
+
+
+-- -----------------------------------------------------------------------
+-- canvas item methods
+-- -----------------------------------------------------------------------
+
+canvasitemMethods :: Methods
+canvasitemMethods = Methods tkGetCanvasItemConfig
+ tkSetCanvasItemConfigs
+ tkCreateCanvasItem
+ (packCmd voidMethods)
+ (gridCmd voidMethods)
+ tkDestroyCanvasItem
+ tkBindCanvasItem
+ tkUnbindCanvasItem
+ tkCleanupCanvasItem
+
+
+-- -----------------------------------------------------------------------
+-- unparsing of commands
+-- -----------------------------------------------------------------------
+
+tkCreateCanvasItem :: ObjectName -> ObjectKind -> ObjectName ->
+ ObjectID -> [ConfigOption] -> TclScript
+tkCreateCanvasItem _ k@(CANVASITEM _ cds)
+ (cinm @ (CanvasItemName cnm tid)) _ args =
+ declVar tid ++ [" set " ++ vname ++ " [" ++ cmd ++ "] "]
+ where vname = (drop 1 (show tid))
+ cmd = show cnm ++ " create " ++ show k ++ " " ++
+ show (toGUIValue cds) ++ " " ++ showConfigs args
+{-
+ cmd = show cnm ++ " create " ++ show k ++ " - coord " ++
+ show (toGUIValue cds) ++ " " ++ showConfigs args
+-}
+tkCreateCanvasItem _ _ _ _ _ = error "CanvasItemAux (tkCreateCanvasItem)"
+
+tkGetCanvasItemConfig :: ObjectName -> ConfigID -> TclScript
+tkGetCanvasItemConfig (CanvasItemName name tid) "coords" =
+ declVar tid ++ [show name ++ " coords " ++ show tid]
+tkGetCanvasItemConfig (CanvasItemName name tid) cid =
+ declVar tid ++ [show name ++ " itemcget " ++ show tid ++ " -" ++ cid]
+tkGetCanvasItemConfig _ _ = []
+
+tkSetCanvasItemConfigs (CanvasItemName name tid) args =
+ declVar tid ++ tagVariables args ++
+ [show name ++ " itemconfigure " ++ show tid ++ " " ++ showConfigs args]
+ where tagVariables ((cid, cval) : ol) =
+ case cid of
+ "tag" -> ["global \"" ++ (drop 3 (show cval))] ++
+ tagVariables ol
+ _ -> tagVariables ol
+ tagVariables _ = []
+tkSetCanvasItemConfigs _ _ = []
+
+tkDestroyCanvasItem :: ObjectName -> TclScript
+tkDestroyCanvasItem name@(CanvasItemName _ tid) =
+ declVar tid ++ [show name ++ " delete " ++ show tid]
+tkDestroyCanvasItem _ = []
+
+tkBindCanvasItem :: ObjectName -> BindTag -> [WishEvent] ->
+ EventInfoSet -> Bool -> TclScript
+tkBindCanvasItem (CanvasItemName cnvnm cid) bindTag wishEvents
+ eventInfoSet _ =
+ ["global " ++ drop 1 (show cid),
+ show cnvnm ++ " bind " ++ show cid ++ " " ++
+ delimitString (foldr (\ event soFar -> showP event soFar)
+ "" wishEvents) ++ " " ++
+ mkBoundCmdArg bindTag eventInfoSet False]
+
+tkUnbindCanvasItem :: ObjectName -> BindTag -> [WishEvent] -> Bool ->
+ TclScript
+tkUnbindCanvasItem (CanvasItemName cnvnm cid) bindTag wishEvents _ = []
+
+tkCleanupCanvasItem :: ObjectID -> ObjectName -> TclScript
+tkCleanupCanvasItem _ (CanvasItemName _ tid) =
+ declVar tid ++[" unset " ++ (drop 1 (show tid))]
+tkCleanupCanvasItem _ _ = []
diff --git a/HTk/Canvasitems/CanvasTag.hs b/HTk/Canvasitems/CanvasTag.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Canvasitems/CanvasTag.hs
@@ -0,0 +1,295 @@
+module HTk.Canvasitems.CanvasTag (
+
+ CanvasTag,
+
+ TaggedCanvasItem(..),
+
+ SearchSpec,
+ allItems,
+ aboveItem,
+ belowItem,
+ withTag,
+ closest,
+ enclosed,
+ overlapping,
+
+ createCanvasTag,
+
+ addCanvasTag,
+ removeCanvasTag,
+
+ (&#&),
+ (|#|),
+ (^#),
+ tagNot,
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Canvasitems.CanvasItem
+import HTk.Canvasitems.CanvasItemAux (canvasitemMethods)
+import Events.Destructible
+import Events.Synchronized
+import Util.Computation
+import HTk.Kernel.Geometry (Position,Distance)
+
+
+infixr 3 &#&
+infixr 2 |#|
+infixr 2 ^#
+
+
+-- -----------------------------------------------------------------------
+-- class TaggedCanvasItem
+-- -----------------------------------------------------------------------
+
+-- | A canvas item can have several tags (handlers for a set of canvas
+-- items).
+class CanvasItem w => TaggedCanvasItem w where
+ -- Sets the tags for the specified canvas item.
+ tags :: [CanvasTag] -> Config w
+ tags cts item =
+ mapM (\ct -> do
+ CanvasItemName name tid <-
+ getObjectName (toGUIObject ct)
+ cset item "tag" (show tid)) cts >> return item
+
+
+-- -----------------------------------------------------------------------
+-- tags
+-- -----------------------------------------------------------------------
+
+-- | The @CanvasTag@ datatype.
+newtype CanvasTag = CanvasTag GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- configuration options
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new canvas tag.
+createCanvasTag :: Canvas
+ -- ^ the parent canvas.
+ -> [Config CanvasTag]
+ -- ^ the list of configuration options for this canvas tag.
+ -> IO CanvasTag
+ -- ^ A canvas tag.
+createCanvasTag cnv cnf =
+ do
+ wid <- createGUIObject (toGUIObject cnv) (CANVASITEM CANVASTAG [])
+ tagMethods
+ configure (CanvasTag wid) cnf
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+{-
+instance Eq CanvasTag where
+ w1 == w2 = (toGUIObject w1) == (toGUIObject w2)
+-}
+
+-- | Internal.
+instance GUIObject CanvasTag where
+ toGUIObject (CanvasTag wid) = wid
+ cname _ = "CanvasTag"
+
+-- | A canvas tag can be destroyed.
+instance Destroyable CanvasTag where
+ -- Destroys a canvas tag.
+ destroy = destroy . toGUIObject
+
+-- | A canvas tag is a canvas item (any canvas item is an instance of the
+-- abstract @class CanvasItem@).
+instance CanvasItem CanvasTag
+
+-- | You can synchronize on a canvas tag.
+instance Synchronized CanvasTag where
+ -- Synchronizes on a canvas tag.
+ synchronize w = synchronize (toGUIObject w)
+
+
+-- -----------------------------------------------------------------------
+-- commands
+-- -----------------------------------------------------------------------
+
+-- | Adds the canvas items identified by the @SearchSpec@ to
+-- the tag.
+addCanvasTag :: SearchSpec
+ -- ^ the search specification.
+ -> CanvasTag
+ -- ^ the tag to add items to.
+ -> IO ()
+ -- ^ None.
+addCanvasTag spec@(SearchSpec cmd) tag =
+ do
+ spec' <- cmd
+ execMethod tag (\tnm -> tkAddTag tnm spec')
+
+-- | Removes a canvas item from a canvas tag.
+removeCanvasTag :: CanvasItem i => i
+ -- ^ the item to remove from the tag.
+ -> CanvasTag
+ -- ^ the tag to remove the item from.
+ -> IO ()
+ -- ^ None.
+removeCanvasTag item tag =
+ do
+ tnm <- getObjectName (toGUIObject tag)
+ execMethod item (\cnm -> tkDTag cnm tnm)
+
+
+-- -----------------------------------------------------------------------
+-- Logical combinations of canvas tags
+-- -----------------------------------------------------------------------
+
+-- | Forms the conjunction of two canvas tags
+(&#&) :: CanvasTag -> CanvasTag
+ -> IO CanvasTag -- ^ new canvas tag corresponding to (t1&&t2)
+(&#&) = complexCanvasTag CanvasTagAnd
+
+-- | Forms the disjunction of two canvas tags
+(|#|) :: CanvasTag -> CanvasTag
+ -> IO CanvasTag -- ^ new canvas tag corresponding to (t1||t2)
+(|#|) = complexCanvasTag CanvasTagOr
+
+-- | Forms "either - or" of two canvas tags
+(^#) :: CanvasTag -> CanvasTag
+ -> IO CanvasTag
+ -- ^ new canvas tag corresponding to (t1^t2)
+ -- equals (!t1&&t2)||(t1&&!t2)
+(^#) = complexCanvasTag CanvasTagXOr
+
+-- Forms the negation of a canvas tag
+tagNot :: CanvasTag
+ -> IO CanvasTag -- ^ new canvas tag corresponding to !t
+tagNot t = complexCanvasTag (\ x _ -> CanvasTagNot x) t t
+
+---
+-- auxilliary function for &#&,|#|,^# and tagNot
+complexCanvasTag :: (CanvasTagOrID -> CanvasTagOrID -> CanvasTagOrID)
+ -> CanvasTag -> CanvasTag -> IO CanvasTag
+complexCanvasTag f t1 t2
+ = do
+ CanvasItemName oid tid1 <- getObjectName (toGUIObject t1)
+ tid2 <- getCanvasTagOrID (toGUIObject t2)
+ Just par <- getParentObject (toGUIObject t1)
+ wid <- createGUIObject par
+ (CANVASITEM CANVASTAG [])
+ tagMethods
+ setObjectName wid (CanvasItemName oid (f tid1 tid2))
+ ct <- configure (CanvasTag wid) []
+ return ct
+
+-- -----------------------------------------------------------------------
+-- SearchSpec
+-- -----------------------------------------------------------------------
+
+-- | The @SearchSpec@ datatype
+-- (see 'CanvasTag.addCanvasTag').
+data SearchSpec = SearchSpec (IO String)
+
+-- | Adds all objects in the canvas.
+allItems :: SearchSpec
+ -- ^ A @SearchSpec@ object.
+allItems = SearchSpec (return "all")
+
+-- | Adds the item just above the given item in the display list.
+aboveItem :: CanvasItem item => item
+ -- ^ the item below the item to add.
+ -> SearchSpec
+ -- ^ A @SearchSpec@ object.
+aboveItem item = SearchSpec (do {
+ tid <- getCanvasTagOrID (toGUIObject item);
+ return ("above [" ++ declVarList tid ++ "; list " ++ show tid ++ "]")
+ })
+
+-- | Adds the item just below in the given item in the display list.
+belowItem :: CanvasItem item => item
+ -- ^ the item above the item to add.
+ -> SearchSpec
+ -- ^ A @SearchSpec@ object.
+belowItem item = SearchSpec (do {
+ tid <- getCanvasTagOrID (toGUIObject item);
+ return ("below [" ++ declVarList tid ++ "; list " ++ show tid ++ "]")
+ })
+
+-- | Adds the item(s) identified by the given handler (which can also be
+-- another canvas tag).
+withTag :: CanvasItem item => item
+ -- ^ the canvas item handler.
+ -> SearchSpec
+ -- ^ A @SearchSpec@ object.
+withTag item = SearchSpec (do {
+ tid <- getCanvasTagOrID (toGUIObject item);
+ return ("withtag [" ++ declVarList tid ++ "; list " ++ show tid ++ "]")
+ })
+
+-- | Adds the item closest to the given position.
+closest :: Position
+ -- ^ the concerned position.
+ -> SearchSpec
+ -- ^ A @SearchSpec@ object.
+closest pos@(x, y) =
+ SearchSpec (return ("closest " ++ show x ++ " " ++ show y))
+
+-- | Adds the items enclosed in the specified region.
+enclosed :: Position
+ -- ^ the upper left position of the region.
+ -> Position
+ -- ^ the lower right position of the region.
+ -> SearchSpec
+ -- ^ A @SearchSpec@ object.
+enclosed pos1 pos2 =
+ SearchSpec (return ("enclosed " ++ showPos pos1 ++ " " ++ showPos pos2))
+
+-- | Adds the items overpalling the specified region.
+overlapping :: Position
+ -- ^ the upper left position of the region.
+ -> Position
+ -- ^ the lower right position of the region.
+ -> SearchSpec
+ -- ^ A @SearchSpec@ object.
+overlapping pos1 pos2 =
+ SearchSpec (return ("overlapping " ++ showPos pos1 ++ " " ++ showPos pos2))
+
+showPos :: (Distance,Distance) -> String
+showPos (x,y) = " "++show x++" "++show y++" "
+
+
+getCanvasTagOrID :: GUIOBJECT -> IO CanvasTagOrID
+getCanvasTagOrID wid =
+ do
+ nm <- getObjectName wid
+ case nm of
+ CanvasItemName name tid -> return tid
+ _ -> error "CanvasTag (getCanvasTagOrID) : not a canvas item name"
+
+
+-- -----------------------------------------------------------------------
+-- methods
+-- -----------------------------------------------------------------------
+
+tagMethods = canvasitemMethods {createCmd = tkCreateTag}
+
+
+-- -----------------------------------------------------------------------
+-- unparsing of commands
+-- -----------------------------------------------------------------------
+
+tkCreateTag :: ObjectName -> ObjectKind -> ObjectName -> ObjectID ->
+ [ConfigOption] -> TclScript
+tkCreateTag _ (CANVASITEM CANVASTAG []) (CanvasItemName name tid) oid _ =
+ declVar tid ++ [" set " ++ vname ++ " t" ++ show oid]
+ where vname = (drop 1 (show tid))
+
+tkAddTag :: ObjectName -> String -> TclScript
+tkAddTag (CanvasItemName name tid) spec =
+ declVar tid ++ [show name ++ " addtag " ++ show tid ++ " " ++ spec]
+
+
+tkDTag :: ObjectName -> ObjectName -> TclScript
+tkDTag (CanvasItemName name cid) (CanvasItemName _ tid) =
+ declVar tid ++ declVar cid ++
+ [show name ++ " dtag " ++ show cid ++ " " ++ show tid]
diff --git a/HTk/Canvasitems/EmbeddedCanvasWin.hs b/HTk/Canvasitems/EmbeddedCanvasWin.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Canvasitems/EmbeddedCanvasWin.hs
@@ -0,0 +1,104 @@
+-- | HTk\'s /embedded canvas windows/.
+-- A container for widgets on a canvas widget.
+module HTk.Canvasitems.EmbeddedCanvasWin (
+ EmbeddedCanvasWin,
+ createEmbeddedCanvasWin
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses
+import HTk.Kernel.Configuration
+import HTk.Canvasitems.CanvasItem
+import HTk.Canvasitems.CanvasTag
+import HTk.Canvasitems.CanvasItemAux
+import Util.Computation
+import Events.Synchronized
+import Events.Destructible
+
+-- -----------------------------------------------------------------------
+-- embedded window
+-- -----------------------------------------------------------------------
+
+-- | The @EmbeddedCanvasWin@ datatype.
+newtype EmbeddedCanvasWin = EmbeddedCanvasWin GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- construction
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new embedded canvas window.
+createEmbeddedCanvasWin :: Widget w => Canvas
+ -- ^ the parent canvas.
+ -> w
+ -- ^ the child widget.
+ ->
+ [Config EmbeddedCanvasWin]
+ -- ^ the list of configuration options for this embedded
+ -- canvas window.
+ ->
+ IO EmbeddedCanvasWin
+ -- ^ An embedded canvas window.
+createEmbeddedCanvasWin cnv wid cnf =
+ do
+ cit <- createCanvasItem cnv EMBEDDEDCANVASWIN EmbeddedCanvasWin cnf
+ [(-1,-1)]
+ sub_nm <- getObjectName (toGUIObject wid)
+ CanvasItemName nm tid <- getObjectName (toGUIObject cit)
+ execTclScript ["global " ++ (drop 1 (show tid)),
+ show nm ++ " itemconfigure " ++ show tid ++
+ " -window " ++ show sub_nm]
+ return cit
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject EmbeddedCanvasWin where
+ toGUIObject (EmbeddedCanvasWin w) = w
+ cname _ = "EmbeddedCanvasWin"
+
+-- | An embedded canvas window can be destroyed.
+instance Destroyable EmbeddedCanvasWin where
+ -- Destroys an embedded canvas window.
+ destroy = destroy . toGUIObject
+
+-- | An embedded canvas window is a canvas item (any canvas item is an
+-- instance of the abstract @class CanvasItem@).
+instance CanvasItem EmbeddedCanvasWin
+
+-- | An embedded canvas window can have several tags (handlers for a set of
+-- canvas items).
+instance TaggedCanvasItem EmbeddedCanvasWin
+
+-- | You can specify the position of a bitmap item.
+instance HasPosition EmbeddedCanvasWin where
+ -- Sets the position of the embedded canvas window.
+ position = itemPositionD2
+ -- Gets the position of the embedded canvas window.
+ getPosition = getItemPositionD2
+
+-- | You can specify the size of an embedded canvas window.
+instance HasSize EmbeddedCanvasWin
+
+-- | Dummy instance.
+instance Widget EmbeddedCanvasWin where
+ cursor s w = return w
+ getCursor w = return cdefault
+ takeFocus b w = return w
+ getTakeFocus w = return cdefault
+
+-- | You can synchronize on an embedded canvas window.
+instance Synchronized EmbeddedCanvasWin where
+ -- Synchronizes on an embedded canvas window.
+ synchronize = synchronize . toGUIObject
+
+-- | You can specify the anchor position of an embedded canvas window.
+instance HasCanvAnchor EmbeddedCanvasWin where
+ -- Sets the anchor position of an embedded canvas window.
+ canvAnchor a w = cset w "anchor" a
+ -- Gets the anchor position of an embedded canvas window.
+ getCanvAnchor w = cget w "anchor"
diff --git a/HTk/Canvasitems/ImageItem.hs b/HTk/Canvasitems/ImageItem.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Canvasitems/ImageItem.hs
@@ -0,0 +1,87 @@
+-- | HTk\'s /image/ canvas item.
+-- An image object on a canvas widget.
+module HTk.Canvasitems.ImageItem (
+
+ ImageItem,
+ createImageItem
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.Configuration
+import HTk.Canvasitems.CanvasItem
+import HTk.Canvasitems.CanvasTag
+import HTk.Canvasitems.CanvasItemAux
+import HTk.Components.Image
+import Util.Computation
+import Events.Synchronized
+import Events.Destructible
+
+
+-- -----------------------------------------------------------------------
+-- ImageItem
+-- -----------------------------------------------------------------------
+
+-- | The @ImageItem@ datatype.
+newtype ImageItem = ImageItem GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- constructor
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new bitmap item.
+createImageItem :: Canvas
+ -- ^ the parent canvas.
+ -> [Config ImageItem]
+ -- ^ the list of configuration options for this image
+ -- item.
+ -> IO ImageItem
+ -- ^ An image item.
+createImageItem cnv cnf =
+ createCanvasItem cnv IMAGEITEM ImageItem cnf [(-1,-1)]
+
+
+-- -----------------------------------------------------------------------
+-- instantiations
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject ImageItem where
+ toGUIObject (ImageItem w) = w
+ cname _ = "ImageItem"
+
+-- | An image item can be destroyed.
+instance Destroyable ImageItem where
+ -- Destroys an image item.
+ destroy = destroy . toGUIObject
+
+-- | An image item is a canvas item (any canvas item is an instance of the
+-- abstract @class CanvasItem@).
+instance CanvasItem ImageItem
+
+-- | A image item can have several tags (handlers for a set of canvas
+-- items).
+instance TaggedCanvasItem ImageItem
+
+-- | You can specify the position of an image item.
+instance HasPosition ImageItem where
+ -- Sets the position of the image item.
+ position = itemPositionD2
+ -- Gets the position of the image item.
+ getPosition = getItemPositionD2
+
+-- | You can specify the anchor position of an image item.
+instance HasCanvAnchor ImageItem where
+ -- Sets the anchor position of an image item.
+ canvAnchor a w = cset w "anchor" a
+ -- Gets the anchor position of an image item.
+ getCanvAnchor w = cget w "anchor"
+
+-- | An image item is a container for an image object.
+instance HasPhoto ImageItem
+
+-- | You can synchronize on an image item.
+instance Synchronized ImageItem where
+ -- Synchronizes on an image item.
+ synchronize = synchronize . toGUIObject
diff --git a/HTk/Canvasitems/Line.hs b/HTk/Canvasitems/Line.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Canvasitems/Line.hs
@@ -0,0 +1,231 @@
+-- | HTk\'s /line/ canvas item.
+-- A line object on a canvas widget.
+module HTk.Canvasitems.Line (
+
+ ArrowHead(..),
+ CapStyle(..),
+ JoinStyle(..),
+
+ Line,
+ createLine,
+
+ arrowshape,
+ getArrowshape,
+
+ arrowstyle,
+ getArrowstyle,
+
+ capstyle,
+ getCapstyle,
+
+ joinstyle,
+ getJoinstyle
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.Configuration
+import HTk.Kernel.Geometry(Distance)
+import HTk.Canvasitems.CanvasItem
+import HTk.Canvasitems.CanvasTag
+import HTk.Canvasitems.CanvasItemAux
+import Data.Char
+import Events.Destructible
+import Util.Computation
+import Events.Synchronized
+
+
+-- -----------------------------------------------------------------------
+-- datatype
+-- -----------------------------------------------------------------------
+
+-- | The @Line@ datatype.
+newtype Line = Line GUIOBJECT deriving Eq
+
+-- | The @ArrowShape@ datatype.
+-- Describes the shape of an arrow at an end of a line.
+type ArrowShape = (Distance, Distance, Distance)
+
+
+-- -----------------------------------------------------------------------
+-- constructor
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new line item.
+createLine :: Canvas
+ -- ^ the parent canvas.
+ -> [Config Line]
+ -- ^ the list of configuration options for this line item.
+ -> IO Line
+ -- ^ A line item.
+createLine cnv cnf = createCanvasItem cnv LINE Line cnf [(-1,-1),(-1,-1)]
+
+
+-- -----------------------------------------------------------------------
+-- Instantiations
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject Line where
+ toGUIObject (Line w) = w
+ cname _ = "Line"
+
+-- | A line item can be destroyed.
+instance Destroyable Line where
+ -- Destroys a line item.
+ destroy = destroy . toGUIObject
+
+-- | A line item is a canvas item (any canvas item is an instance of the
+-- abstract @class CanvasItem@).
+instance CanvasItem Line
+
+-- | A line item can have several tags (handlers for a set of canvas items).
+instance TaggedCanvasItem Line
+
+-- | A line item has filling, outline width and stipple configurations.
+instance FilledCanvasItem Line where
+ -- Dummy.
+ outline c w = return w
+ -- Dummy.
+ getOutline w = return cdefault
+
+-- | A line is a segmented canvas item. It has a splinesteps and smooth
+-- configuration.
+instance SegmentedCanvasItem Line
+
+-- | You can synchronize on a line item.
+instance Synchronized Line where
+ -- Synchronizes on a line item.
+ synchronize w = synchronize (toGUIObject w)
+
+-- | You can specify the width of the line.
+instance HasSize Line where
+ -- Dummy.
+ height _ w = return w
+ -- Dummy.
+ getHeight _ = return cdefault
+
+
+-- -----------------------------------------------------------------------
+-- configuration options
+-- -----------------------------------------------------------------------
+
+-- | Sets the style of the arrows at the ends of a line.
+arrowstyle :: ArrowHead -> Config Line
+arrowstyle d w = cset w "arrow" d
+
+-- | Gets the style of the arrows at the ends of a line.
+getArrowstyle :: Line -> IO ArrowHead
+getArrowstyle w = cget w "arrow"
+
+-- | Sets the shape of the arrows at the ends of a line.
+arrowshape :: ArrowShape -> Config Line
+arrowshape (x,y,z) w = cset w "arrowshape" [x, y, z]
+
+-- | Gets the shape of the arrows at the end of a line.
+getArrowshape :: Line -> IO ArrowShape
+getArrowshape w = cget w "arrowshape" >>= next
+ where next (x:y:z:_) = return (x, y, z)
+ next _ = return (0, 0, 0)
+
+-- | Sets the capstyle at the ends of a line (butt, projecting or round).
+capstyle :: CapStyle -> Config Line
+capstyle d w = cset w "capstyle" d
+
+-- | Gets the capstyle at the ends of a line.
+getCapstyle :: Line -> IO CapStyle
+getCapstyle w = cget w "capstyle"
+
+-- | Sets the joinstyle between the line segments (bevel, miter or round).
+joinstyle :: JoinStyle -> Config Line
+joinstyle d w = cset w "joinstyle" d
+
+-- | Gets the joinstyle between the line segments.
+getJoinstyle :: Line -> IO JoinStyle
+getJoinstyle w = cget w "joinstyle"
+
+
+-- -----------------------------------------------------------------------
+-- ArrowHead
+-- -----------------------------------------------------------------------
+
+-- | The @ArrowHead@ datatype (see @Line.arrowstyle@).
+data ArrowHead =
+ BothEnds | LastEnd | FirstEnd | NoHead deriving (Eq,Ord,Enum)
+
+-- | Internal.
+instance GUIValue ArrowHead where
+ cdefault = NoHead
+
+-- | Internal.
+instance Read ArrowHead where
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ 'b':'o':'t':'h':xs -> [(BothEnds,xs)]
+ 'l':'a':'s':'t': xs -> [(LastEnd,xs)]
+ 'f':'i':'r':'s':'t':xs -> [(FirstEnd,xs)]
+ 'n':'o':'n':'e':xs -> [(NoHead,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show ArrowHead where
+ showsPrec d p r = (case p of
+ BothEnds -> "both"
+ LastEnd -> "last"
+ FirstEnd -> "first"
+ NoHead -> "none") ++ r
+
+
+-- -----------------------------------------------------------------------
+-- CapStyle
+-- -----------------------------------------------------------------------
+
+-- | The @CapStyle@ datatype (see @Line.capstyle@).
+data CapStyle = CapRound | CapProjecting | CapButt deriving (Eq,Ord,Enum)
+
+-- | Internal.
+instance GUIValue CapStyle where
+ cdefault = CapButt
+
+-- | Internal.
+instance Read CapStyle where
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ 'r':'o':'u':'n':'d':xs -> [(CapRound,xs)]
+ 'p':'r':'o':'j':'e':'c':'t':'i':'n':'g': xs -> [(CapProjecting,xs)]
+ 'b':'u':'t':'t':xs -> [(CapButt,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show CapStyle where
+ showsPrec d p r = (case p of
+ CapRound -> "round"
+ CapProjecting -> "projecting"
+ CapButt -> "butt") ++ r
+
+
+-- -----------------------------------------------------------------------
+-- JoinStyle
+-- -----------------------------------------------------------------------
+
+-- | The @JoinStyle@ datatype (see @Line.joinstyle@).
+data JoinStyle = JoinRound | JoinMiter | JoinBevel deriving (Eq,Ord,Enum)
+
+-- | Internal.
+instance GUIValue JoinStyle where
+ cdefault = JoinMiter
+
+-- | Internal.
+instance Read JoinStyle where
+ readsPrec p b = case dropWhile (isSpace) b of
+ 'r':'o':'u':'n':'d':xs -> [(JoinRound,xs)]
+ 'm':'i':'t':'e':'r': xs -> [(JoinMiter,xs)]
+ 'b':'e':'v':'e':'l':xs -> [(JoinBevel,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show JoinStyle where
+ showsPrec d p r = (case p of
+ JoinRound -> "round"
+ JoinMiter -> "miter"
+ JoinBevel -> "bevel") ++ r
diff --git a/HTk/Canvasitems/Oval.hs b/HTk/Canvasitems/Oval.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Canvasitems/Oval.hs
@@ -0,0 +1,100 @@
+-- | HTk\'s /oval/ canvas item.
+-- An oval object on a canvas widget.
+module HTk.Canvasitems.Oval (
+
+ Oval,
+ createOval
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.Configuration
+import HTk.Canvasitems.CanvasItem
+import HTk.Canvasitems.CanvasTag
+import HTk.Canvasitems.CanvasItemAux
+import Events.Destructible
+import Util.Computation
+import Events.Synchronized
+
+
+-- -----------------------------------------------------------------------
+-- datatype
+-- -----------------------------------------------------------------------
+
+-- | The @Oval@ datatype.
+newtype Oval = Oval GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- constructor
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new oval item.
+createOval :: Canvas
+ -- ^ the parent canvas.
+ -> [Config Oval]
+ -- ^ the list of configuration options for this oval item.
+ -> IO Oval
+ -- ^ An oval item.
+createOval cnv cnf = createCanvasItem cnv OVAL Oval cnf [(-1,-1),(-1,-1)]
+
+
+-- -----------------------------------------------------------------------
+-- Instantiations
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject Oval where
+ toGUIObject (Oval w) = w
+ cname _ = "Oval"
+
+-- | An oval item can be destroyed.
+instance Destroyable Oval where
+ -- Destroys an oval item.
+ destroy = destroy . toGUIObject
+
+-- | You can synchronize on an oval item.
+instance Synchronized Oval where
+ -- Synchronizes on an oval item.
+ synchronize = synchronize . toGUIObject
+
+-- | An oval item is a canvas item (any canvas item is an instance of the
+-- abstract @class CanvasItem@).
+instance CanvasItem Oval
+
+-- | An oval item can have several tags (handlers for a set of canvas
+-- items).
+instance TaggedCanvasItem Oval
+
+-- | An oval item is a filled canvas item (it has filling, outline,
+-- outline width, and stipple configurations).
+instance FilledCanvasItem Oval
+
+-- | An alternative way to specify an oval\'s coords.
+instance HasGeometry Oval where
+ -- Sets the oval\'s geometry (width, height, upper left position).
+ geometry = itemGeo
+ -- Gets the oval\'s geometry (width, height, upper left position).
+ getGeometry = getGeo
+
+-- | You can specify the (upper left) position of an oval.
+instance HasPosition Oval where
+ -- Sets the oval\'s (upper left) position.
+ position = itemPosition
+ -- Gets the (upper left) position of the oval item.
+ getPosition = getItemPosition
+
+-- | You can specify the size of an oval item.
+instance HasSize Oval where
+ -- Sets the width of an oval item.
+ width = itemWidth
+ -- Gets the width of an oval item.
+ getWidth = getItemWidth
+ -- Sets the height of an oval item.
+ height = itemHeight
+ -- Gets the height of an oval item.
+ getHeight = getItemHeight
+ -- Sets the size (width, height) of an oval item.
+ size = itemSize
+ -- Sets the size (width, height) of an oval item.
+ getSize = getItemSize
diff --git a/HTk/Canvasitems/Polygon.hs b/HTk/Canvasitems/Polygon.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Canvasitems/Polygon.hs
@@ -0,0 +1,76 @@
+-- | HTk\'s /polygon/ canvas item.
+-- A polygon object on a canvas widget.
+module HTk.Canvasitems.Polygon (
+
+ Polygon,
+ createPolygon
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Canvasitems.CanvasItem
+import HTk.Canvasitems.CanvasTag
+import HTk.Canvasitems.CanvasItemAux
+import Events.Synchronized
+import Util.Computation
+import Events.Destructible
+
+
+-- -----------------------------------------------------------------------
+-- Polygon
+-- -----------------------------------------------------------------------
+
+-- | The @Polygon@ datatype.
+newtype Polygon = Polygon GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- Constructor
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new polygon item.
+createPolygon :: Canvas
+ -- ^ the parent canvas.
+ -> [Config Polygon]
+ -- ^ the list of configuration options for this polygon
+ -- item.
+ -> IO Polygon
+ -- ^ A polygon item.
+createPolygon cnv cnf =
+ createCanvasItem cnv POLYGON Polygon cnf [(-1,-1),(-1,-1),(-1,-1)]
+
+
+-- -----------------------------------------------------------------------
+-- Instantiations
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject Polygon where
+ toGUIObject (Polygon w) = w
+ cname _ = "Polygon"
+
+-- | An polygon item can be destroyed.
+instance Destroyable Polygon where
+ -- Destroys a polygon item.
+ destroy = destroy . toGUIObject
+
+-- | You can synchronize on a polygon item.
+instance Synchronized Polygon where
+ -- Synchronizes on a polygon item.
+ synchronize w = synchronize (toGUIObject w)
+
+-- | A polygon item is a canvas item (any canvas item is an instance of the
+-- abstract @class CanvasItem@).
+instance CanvasItem Polygon
+
+-- | A polygon item can have several tags (handlers for a set of canvas
+-- items).
+instance TaggedCanvasItem Polygon
+
+-- | A polygon item is a filled canvas item (it has filling, outline,
+-- outline width, and stipple configurations).
+instance FilledCanvasItem Polygon
+
+-- | A line is a segmented canvas item. It has a splinesteps and smooth
+-- configuration.
+instance SegmentedCanvasItem Polygon
diff --git a/HTk/Canvasitems/Rectangle.hs b/HTk/Canvasitems/Rectangle.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Canvasitems/Rectangle.hs
@@ -0,0 +1,102 @@
+-- | HTk\'s /rectangle/ canvas item.
+-- A rectangle object on a canvas widget.
+module HTk.Canvasitems.Rectangle (
+
+ Rectangle,
+ createRectangle
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.Configuration
+import HTk.Canvasitems.CanvasItem
+import HTk.Canvasitems.CanvasTag
+import HTk.Canvasitems.CanvasItemAux
+import Events.Destructible
+import Util.Computation
+import Events.Synchronized
+
+
+-- -----------------------------------------------------------------------
+-- datatype
+-- -----------------------------------------------------------------------
+
+-- | The @Rectangle@ datatype.
+newtype Rectangle = Rectangle GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- construction
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new rectangle item.
+createRectangle :: Canvas
+ -- ^ the parent canvas.
+ -> [Config Rectangle]
+ -- ^ the list of configuration options for this rectangle
+ -- item.
+ -> IO Rectangle
+ -- ^ A rectangle item.
+createRectangle cnv cnf =
+ createCanvasItem cnv RECTANGLE Rectangle cnf [(-1,-1),(-1,-1)]
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject Rectangle where
+ toGUIObject (Rectangle w) = w
+ cname _ = "Rectangle"
+
+-- | A rectangle item can be destroyed.
+instance Destroyable Rectangle where
+ -- Destroys a rectangle item.
+ destroy = destroy . toGUIObject
+
+-- | You can synchronize on a rectangle item.
+instance Synchronized Rectangle where
+ -- Synchronize on a rectangle item.
+ synchronize = synchronize . toGUIObject
+
+-- | A rectangle item is a canvas item (any canvas item is an instance of
+-- the abstract @class CanvasItem@).
+instance CanvasItem Rectangle
+
+-- | A rectangle item can have several tags (handlers for a set of canvas
+-- items).
+instance TaggedCanvasItem Rectangle
+
+-- | A rectangle item is a filled canvas item (it has filling, outline,
+-- outline width, and stipple configurations).
+instance FilledCanvasItem Rectangle
+
+-- | An alternative way to specify a rectangle\'s coords.
+instance HasGeometry Rectangle where
+ -- Sets the geometry of a rectangle (width, height, upper left position).
+ geometry = itemGeo
+ -- Gets the geometry of a rectangle (width, height, upper left position).
+ getGeometry = getGeo
+
+-- | You can specify the (upper left) position of a rectangle.
+instance HasPosition Rectangle where
+ -- Sets the (upper left) position of a rectangle.
+ position = itemPosition
+ -- Gets the (upper left) position of a rectangle.
+ getPosition = getItemPosition
+
+-- | You can specify the size of an rectangle item.
+instance HasSize Rectangle where
+ -- Sets the width of a rectangle item.
+ width = itemWidth
+ -- Gets the width of a rectangle item.
+ getWidth = getItemWidth
+ -- Sets the height of a rectangle item.
+ height = itemHeight
+ -- Gets the height of a rectangle item.
+ getHeight = getItemHeight
+ -- Sets the size (width, height) of a rectangle item.
+ size = itemSize
+ -- Gets the size (width, height) of a rectangle item.
+ getSize = getItemSize
diff --git a/HTk/Canvasitems/TextItem.hs b/HTk/Canvasitems/TextItem.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Canvasitems/TextItem.hs
@@ -0,0 +1,117 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | HTk\'s /text/ canvas item.
+-- A text container on a canvas widget.
+module HTk.Canvasitems.TextItem (
+
+ TextItem,
+ createTextItem
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.Configuration
+import HTk.Canvasitems.CanvasItem
+import HTk.Canvasitems.CanvasTag
+import HTk.Canvasitems.CanvasItemAux
+import Util.Computation
+import Events.Destructible
+import Events.Synchronized
+
+
+-- -----------------------------------------------------------------------
+-- datatype
+-- -----------------------------------------------------------------------
+
+-- | The @TextItem@ datatype.
+newtype TextItem = TextItem GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- constructor
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new text item.
+createTextItem :: Canvas
+ -- ^ the parent canvas.
+ -> [Config TextItem]
+ -- ^ the list of configuration options for this text item.
+ -> IO TextItem
+ -- ^ A text item.
+createTextItem cnv cnf =
+ createCanvasItem cnv TEXTITEM TextItem cnf [(-1,-1)]
+
+
+-- -----------------------------------------------------------------------
+-- instantiations
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject TextItem where
+ toGUIObject (TextItem w) = w
+ cname _ = "TextItem"
+
+-- | A text item can be destroyed.
+instance Destroyable TextItem where
+ -- Destroys a text item.
+ destroy = destroy . toGUIObject
+
+-- | A text item is a canvas item (any canvas item is an instance of the
+-- abstract @class CanvasItem@).
+instance CanvasItem TextItem
+
+-- | An oval item is a filled canvas item (it has filling, outline width,
+-- and stipple configurations).
+instance FilledCanvasItem TextItem where
+ -- Dummy.
+ outline c w = return w
+ -- Dummy.
+ getOutline w = return cdefault
+
+-- | A text item can have several tags (handlers for a set of canvas
+-- items).
+instance TaggedCanvasItem TextItem
+
+-- | You can specify the position of a text item.
+instance HasPosition TextItem where
+ -- Sets the position of a text item.
+ position = itemPositionD2
+ -- Gets the position of a text item.
+ getPosition = getItemPositionD2
+
+-- | You can specify the width of a text item.
+instance HasSize TextItem where
+ -- Dummy.
+ height _ w = return w
+ -- Dummy.
+ getHeight _ = return 1
+
+-- | A text item has a configureable text justification.
+instance HasJustify TextItem
+
+-- | You can specify the font of a text item.
+instance HasFont TextItem
+
+-- | You can specify the anchor position of a text item.
+instance HasCanvAnchor TextItem where
+ -- Sets the anchor position of a text item.
+ canvAnchor a w = cset w "anchor" a
+ -- Gets the anchor position of a text item.
+ getCanvAnchor w = cget w "anchor"
+
+-- | You can synchronize on a text item.
+instance Synchronized TextItem where
+ -- Synchronizes on a text item.
+ synchronize = synchronize . toGUIObject
+
+-- | A text item is a container for text.
+instance GUIValue b => HasText TextItem b where
+ -- Sets the displayed text.
+ text t w = cset w "text" t
+ -- Gets the displayed text.
+ getText w = cget w "text"
+
+-- | An anchor defines where a text item is placed relative to the
+-- given position.
+instance HasAnchor TextItem
diff --git a/HTk/Components/BitMap.hs b/HTk/Components/BitMap.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Components/BitMap.hs
@@ -0,0 +1,232 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+-- | This module provides access to bitmap resources.
+module HTk.Components.BitMap (
+
+ BitMap,
+ newBitMap,
+
+ BitMapHandle(..),
+ HasBitMap(..),
+ BitMapDesignator(..),
+
+ errmap,
+ gray50,
+ gray25,
+ hourglass,
+ info,
+ questhead,
+ question,
+ warning,
+
+ setBitMapHandle,
+ getBitMapHandle,
+ stringToBitMapHandle
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import Data.Char(isDigit)
+import Util.Computation
+import Events.Synchronized
+import Events.Destructible
+
+-- -----------------------------------------------------------------------
+-- BitMap designators
+-- -----------------------------------------------------------------------
+
+-- | The @BitMapHandle@ datatype - a handle for a bitmap
+-- resource.
+data BitMapHandle =
+ Predefined String
+ | BitMapHandle BitMap
+ | BitMapFile String
+
+-- | Internal.
+class BitMapDesignator d where
+ toBitMap :: d -> BitMapHandle
+
+-- | Internal.
+instance BitMapDesignator BitMapHandle where
+ toBitMap = id
+
+-- | Internal.
+instance BitMapDesignator BitMap where
+ toBitMap h = BitMapHandle h
+
+-- | A string is a handle for a bitmap file.
+instance BitMapDesignator [Char] where
+ toBitMap h = BitMapFile h
+
+
+-- -----------------------------------------------------------------------
+-- BitMap'ed widgets
+-- -----------------------------------------------------------------------
+
+-- | Containers for bitmaps instantiate the @class HasBitMap@.
+class GUIObject w => HasBitMap w where
+ bitmap :: BitMapDesignator d => d -> Config w
+ getBitMap :: w -> IO BitMapHandle
+ bitmap d w = setBitMapHandle w "bitmap" (toBitMap d) True
+ getBitMap w = getBitMapHandle w "bitmap"
+
+
+-- -----------------------------------------------------------------------
+-- type BitMap
+-- -----------------------------------------------------------------------
+
+-- | The @BitMap@ datatype.
+newtype BitMap = BitMapWDG GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- commands
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new bitmap object and returns a handler.
+-- The bitmap object can be packed like a widget, then it is implicitely
+-- displayed inside a label widget.
+newBitMap :: [Config BitMap]
+ -- ^ the list of configuration options for this bitmap object.
+ -> IO BitMap
+ -- ^ A bitmap object.
+newBitMap confs =
+ do
+ w <- createWidget ROOT LABEL
+ configure (BitMapWDG w) confs
+
+
+-- -----------------------------------------------------------------------
+-- predefined Tk BitMaps
+-- -----------------------------------------------------------------------
+
+-- | A handle for the predefined \"error\" bitmap.
+errmap :: BitMapHandle
+errmap = Predefined "error"
+
+-- | A handle for the predefined \"gray50\" bitmap.
+gray50 :: BitMapHandle
+gray50 = Predefined "gray50"
+
+-- | A handle for the predefined \"gray25\" bitmap.
+gray25 :: BitMapHandle
+gray25 = Predefined "gray25"
+
+-- | A handle for the predefined \"hourglass\" bitmap.
+hourglass :: BitMapHandle
+hourglass = Predefined "hourglass"
+
+-- | A handle for the predefined \"info\" bitmap.
+info :: BitMapHandle
+info = Predefined "info"
+
+-- | A handle for the predefined \"questhead\" bitmap.
+questhead :: BitMapHandle
+questhead = Predefined "questhead"
+
+-- | A handle for the predefined \"question\" bitmap.
+question :: BitMapHandle
+question = Predefined "question"
+
+-- | A handle for the predefined \"warning\" bitmap.
+warning :: BitMapHandle
+warning = Predefined "warning"
+
+
+-- -----------------------------------------------------------------------
+-- configuration options
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject BitMap where
+ toGUIObject (BitMapWDG w) = w
+ cname _ = "BitMap"
+
+-- | A bitmap object can be destroyed.
+instance Destroyable BitMap where
+ -- Destroys a bitmap object.
+ destroy = destroy . toGUIObject
+
+-- | A bitmap object has standard widget properties
+-- (concerning focus, cursor \/ if implicitely displayed inside a label
+-- widget).
+instance Widget BitMap
+
+-- | A bitmap object has a configureable border (if implicitely displayed
+-- inside a label widget).
+instance HasBorder BitMap
+
+-- | A bitmap object has a configureable foreground and background colour
+-- (if implicitely displayed inside a label widget).
+instance HasColour BitMap where
+ legalColourID = hasForeGroundColour
+
+-- | You can specify the size of the containing label, if the bitmap is
+-- implicitely displayed inside a label widget.
+instance HasSize BitMap
+
+-- | Bitmaps can be read from files.
+instance HasFile BitMap where
+ -- Specifies the bitmap\'s file path.
+ filename fname w =
+ execTclScript [tkBitMapCreate no fname] >> cset w "image" no
+ where no = getObjectNo (toGUIObject w)
+ -- Gets the bitmap\'s file name.
+ getFileName w = evalTclScript [tkGetBitMapFile no]
+ where no = getObjectNo (toGUIObject w)
+
+-- | You can synchronize on a bitmap object.
+instance Synchronized BitMap where
+ -- Synchronizes on a bitmap object.
+ synchronize (BitMapWDG w) = synchronize w
+
+
+-- -----------------------------------------------------------------------
+-- auxiliary functions
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+setBitMapHandle :: GUIObject w => w -> ConfigID -> BitMapHandle ->
+ Bool -> IO w
+setBitMapHandle w cnm (Predefined d) _ = cset w cnm d
+setBitMapHandle w cnm (BitMapFile f) _ = cset w cnm ('@':f)
+setBitMapHandle w _ (BitMapHandle h) True =
+ cset w "image" (getObjectNo (toGUIObject h))
+setBitMapHandle w cnm (BitMapHandle h) False =
+ do
+ fname <- getFileName h
+ setBitMapHandle w cnm (BitMapFile fname) False
+ return w
+{-
+ the last parameter determines whether integer numbers are acceptable
+ as bitmap denotations or not. If not, we use the corresponding file
+ name associated with the widget! Numbers are allowed for labels and
+ buttons, but not for windows!
+-}
+
+-- | Internal.
+getBitMapHandle :: GUIObject w => w -> ConfigID -> IO BitMapHandle
+getBitMapHandle w cnm = cget w cnm >>= stringToBitMapHandle
+
+-- | Internal.
+stringToBitMapHandle :: String -> IO BitMapHandle
+stringToBitMapHandle "" = return (Predefined "")
+stringToBitMapHandle ('@':tl) = return (BitMapFile tl)
+stringToBitMapHandle (str @ (x:tl)) | isDigit x =
+ lookupGUIObject (read str) >>= return . BitMapHandle . BitMapWDG
+stringToBitMapHandle str = return (Predefined str)
+
+
+-- -----------------------------------------------------------------------
+-- Tk commands
+-- -----------------------------------------------------------------------
+
+tkBitMapCreate :: Int -> String -> String
+tkBitMapCreate no f = "image create bitmap " ++ show no ++ " -file " ++ show f
+{-# INLINE tkBitMapCreate #-}
+
+tkGetBitMapFile :: Int -> String
+tkGetBitMapFile no = (show no) ++ " cget -file "
+{-# INLINE tkGetBitMapFile #-}
diff --git a/HTk/Components/Focus.hs b/HTk/Components/Focus.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Components/Focus.hs
@@ -0,0 +1,265 @@
+-- | This module provides functionality on the current focus.
+module HTk.Components.Focus (
+
+ CurrentFocus,
+
+ FocusModel(..),
+ focusModel,
+ getFocusModel,
+ getFocus,
+ setFocus,
+ forceFocus,
+ getRecentFocus,
+
+ GrabStatus(..),
+
+ CurrentGrab(..),
+ grabLocal,
+ grabGlobal,
+ releaseGrab,
+ returnGrab,
+ getGrabStatus,
+ getCurrentGrab
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import Data.Char(isSpace)
+import Util.Computation
+import HTk.Containers.Window
+
+
+-- -----------------------------------------------------------------------
+-- Grab Status
+-- -----------------------------------------------------------------------
+
+-- | The @GrabStatus@ datatype.
+data GrabStatus = Local | Global deriving (Eq,Ord,Enum)
+
+
+-- -----------------------------------------------------------------------
+-- instantiations
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIValue GrabStatus where
+ cdefault = Local
+
+-- | Internal.
+instance Read GrabStatus where
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ 'l':'o':'c':'a':'l':xs -> [(Local,xs)]
+ 'g':'l':'o':'b':'a':'l':xs -> [(Global,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show GrabStatus where
+ showsPrec d p r = (case p of
+ Local -> "local"
+ Global -> "global") ++ r
+
+
+-- -----------------------------------------------------------------------
+-- current grab
+-- -----------------------------------------------------------------------
+
+-- | The @CurrentGrab@ datatype.
+data CurrentGrab = CurrentGrab GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- instantiations
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance Object CurrentGrab where
+ objectID (CurrentGrab obj) = objectID obj
+
+-- | Internal.
+instance GUIObject CurrentGrab where
+ toGUIObject (CurrentGrab obj) = obj
+ cname _ = ""
+
+-- | The current grab has standard widget properties
+-- (concerning focus, cursor).
+instance Widget CurrentGrab
+
+
+-- -----------------------------------------------------------------------
+-- window grabs
+-- -----------------------------------------------------------------------
+
+-- | Grabs the focus local.
+grabLocal :: Widget w => w
+ -- ^ the concerned widget.
+ -> IO ()
+ -- ^ None.
+grabLocal wid = execMethod wid (\name -> [tkGrabLocal name])
+
+-- | Grabs the focus global.
+grabGlobal :: Widget w => w
+ -- ^ the concerned widget.
+ -> IO ()
+ -- ^ None.
+grabGlobal wid =
+ execMethod wid (\name -> ["grab set -global " ++ show name])
+
+-- | Releases a focus grab.
+releaseGrab :: Widget w => w
+ -- ^ the concerned widget.
+ -> IO ()
+ -- ^ None.
+releaseGrab wid = execMethod wid (\name -> ["grab release " ++ show name])
+
+-- | Gets the grab status from a widget.
+getGrabStatus :: Widget w => w
+ -- ^ the concerned widget.
+ -> IO (Maybe GrabStatus)
+ -- ^ The current grab status (if available).
+getGrabStatus wid =
+ do
+ (RawData str) <- evalMethod wid (\nm -> ["grab status " ++ show nm])
+ case dropWhile isSpace str of
+ ('n':'o':'n':'e':_) -> return Nothing
+ s -> do {v <- creadTk s; return (Just v)}
+
+-- | Gets the current grab.
+getCurrentGrab :: IO (Maybe CurrentGrab)
+ -- ^ The current grab (if available).
+getCurrentGrab =
+ evalTclScript ["grab current "] >>= toCurrentGrab . WidgetName
+
+returnGrab :: Maybe CurrentGrab -> IO ()
+returnGrab Nothing = done
+returnGrab (Just g) = execMethod g (\name -> [tkGrabLocal name])
+
+toCurrentGrab :: WidgetName -> IO (Maybe CurrentGrab)
+toCurrentGrab name = do {
+ obj <- lookupGUIObjectByName name;
+ case obj of
+ Nothing -> return Nothing
+ (Just o) -> (return . Just . CurrentGrab) o
+}
+
+
+-- -----------------------------------------------------------------------
+-- Tk Commands
+-- -----------------------------------------------------------------------
+
+tkGrabLocal :: ObjectName -> TclCmd
+tkGrabLocal name = "grab set " ++ show name
+{-# INLINE tkGrabLocal #-}
+
+
+-- -----------------------------------------------------------------------
+-- FocusModel
+-- -----------------------------------------------------------------------
+
+-- | The @FocusModel@ datatype (focus model of a toplevel
+-- window).
+data FocusModel = ActiveFocus | PassiveFocus deriving (Eq,Ord,Enum)
+
+-- | Internal.
+instance GUIValue FocusModel where
+ cdefault = PassiveFocus
+
+-- | Internal.
+instance Read FocusModel where
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ 'a':'c':'t':'i':'v':'e':xs -> [(ActiveFocus,xs)]
+ 'p':'a':'s':'s':'i':'v':'e':xs -> [(PassiveFocus,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show FocusModel where
+ showsPrec d p r =
+ (case p of
+ ActiveFocus -> "active"
+ PassiveFocus -> "passive"
+ ) ++ r
+
+
+-- -----------------------------------------------------------------------
+-- window focus
+-- -----------------------------------------------------------------------
+
+-- | Sets a window\'s focus model.
+focusModel :: Window w => FocusModel -> Config w
+focusModel fm win = cset win "focusmodel" fm
+
+-- | Gets a window\'s focus model.
+getFocusModel :: Window w => w -> IO FocusModel
+getFocusModel win = cget win "focusmodel"
+
+
+-- -----------------------------------------------------------------------
+-- current focus
+-- -----------------------------------------------------------------------
+
+-- | The @CurrentFocus@ datatype.
+data CurrentFocus = CurrentFocus GUIOBJECT
+
+
+-- -----------------------------------------------------------------------
+-- instantiations
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance Object CurrentFocus where
+ objectID (CurrentFocus obj) = objectID obj
+
+-- | Internal.
+instance GUIObject CurrentFocus where
+ toGUIObject (CurrentFocus obj) = obj
+ cname _ = ""
+
+-- | The current focus is always a widget and has standard widget properties
+-- (concerning focus, cursor).
+instance Widget CurrentFocus
+
+
+-- -----------------------------------------------------------------------
+-- input focus
+-- -----------------------------------------------------------------------
+
+-- | Gets the current focus inside a window.
+getFocus :: Window w => w
+ -- ^ the concerned window.
+ -> IO (Maybe CurrentFocus)
+ -- ^ The current focus (if available).
+getFocus win =
+ evalMethod win (\wn -> ["focus -displayof " ++ show wn]) >>=
+ toCurrentFocus . WidgetName
+
+-- | Sets the current for the containing window.
+setFocus :: Widget w => w
+ -- ^ The widget to focus.
+ -> IO ()
+ -- ^ None.
+setFocus w = execMethod w (\wn -> ["focus " ++ show wn])
+
+-- | Forces the current focus for the containing window.
+forceFocus :: Widget w => w
+ -- ^ The widget to focus.
+ -> IO ()
+ -- ^ None.
+forceFocus w = execMethod w (\wn -> ["focus -force " ++ show wn])
+
+-- | Gets the last focused widget inside a window.
+getRecentFocus :: Window w => w
+ -- ^ the concerned window.
+ -> IO (Maybe CurrentFocus)
+ -- ^ The recent focus (if available).
+getRecentFocus w =
+ evalMethod w (\wn -> ["focus -lastfor " ++ show wn]) >>=
+ toCurrentFocus . WidgetName
+
+toCurrentFocus :: WidgetName -> IO (Maybe CurrentFocus)
+toCurrentFocus name =
+ do
+ obj <- lookupGUIObjectByName name
+ case obj of Nothing -> return Nothing
+ (Just o) -> (return . Just . CurrentFocus) o
diff --git a/HTk/Components/ICursor.hs b/HTk/Components/ICursor.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Components/ICursor.hs
@@ -0,0 +1,115 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | Basic types and classes concerning insertion cursors in entry and
+-- text fields.
+module HTk.Components.ICursor (
+ ICursor(..),
+ HasInsertionCursor,
+ HasInsertionCursorIndexGet(..),
+ HasInsertionCursorIndexSet(..),
+
+ insertOffTime,
+ getInsertOffTime,
+
+ insertOnTime,
+ getInsertOnTime
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import HTk.Kernel.Resources
+import HTk.Kernel.Colour(toColour)
+import Util.Computation
+
+
+-- -----------------------------------------------------------------------
+-- classes for insertion cursor
+-- -----------------------------------------------------------------------
+
+-- | Widgets with an insertion cursor instantiate the
+-- @class HasInsertionCursor@.
+class Widget w => HasInsertionCursor w
+
+-- | Widgets with an insertion cursor that can be set to a specific index
+-- instantiate the @class HasInsertionCursorIndexSet@.
+class HasInsertionCursor w => HasInsertionCursorIndexSet w i where
+ -- Sets the index of the insertion Cursor.
+ insertionCursor :: i -> Config w
+
+-- | Widgets from which you can get the index of the insertion cursor
+-- instantiate the @class HasInsertionCursorIndexSet@.
+class HasInsertionCursor w => HasInsertionCursorIndexGet w i where
+ getInsertionCursor :: w -> IO i
+
+
+-- -----------------------------------------------------------------------
+-- handle
+-- -----------------------------------------------------------------------
+
+-- | The @ICursor@ datatype.
+newtype ICursor w = ICursor w
+
+
+-- -----------------------------------------------------------------------
+-- instantiations
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject w => GUIObject (ICursor w) where
+ toGUIObject (ICursor w) = toGUIObject w
+ cname (ICursor w) = cname w
+
+-- | The insertion cursor has a configureable colour.
+instance (HasInsertionCursor w,Widget w) => HasColour (ICursor w) where
+ legalColourID = hasBackGroundColour
+ setColour w "bg" c = cset w "insertbackground" (toColour c)
+ setColour w _ _ = return w
+ getColour w "bg" = cget w "insertbackground"
+ getColour _ _ = return cdefault
+
+-- | The insertion cursor has a configureable borderwidth (width for three
+-- dimensional appearence).
+instance (HasInsertionCursor w,Widget w) => HasBorder (ICursor w) where
+ -- Sets the insertion cursor\'s borderwidth.
+ borderwidth s w = cset w "insertborderwidth" s
+ -- Gets the insertion cursor\'s borderwidth.
+ getBorderwidth w = cget w "insertborderwidth"
+ -- Dummy.
+ relief _ w = return w
+ -- Dummy.
+ getRelief _ = return Raised
+
+-- | The insertion cursor has a configureable width.
+instance (HasInsertionCursor w,Widget w) => HasSize (ICursor w) where
+ -- Sets the width of the insertion cursor.
+ width s w = cset w "insertwidth" s
+ -- Gets the width of the insertion cursor.
+ getWidth w = cget w "insertwidth"
+ -- Dummy.
+ height h w = return w
+ -- Dummy.
+ getHeight w = return cdefault
+
+
+-- -----------------------------------------------------------------------
+-- config options
+-- -----------------------------------------------------------------------
+
+-- | Sets the time the insertion cursor blinks off (in milliseconds, zero
+-- disables blinking).
+insertOffTime :: HasInsertionCursor w => Int -> Config (ICursor w)
+insertOffTime i w = cset w "insertofftime" i
+
+-- | Gets the time the insertion cursor blinks off.
+getInsertOffTime :: HasInsertionCursor w => ICursor w -> IO Int
+getInsertOffTime w = cget w "insertofftime"
+
+-- | Sets the time the insertion cursor blinks on (in milliseconds).
+insertOnTime :: HasInsertionCursor w => Int -> Config (ICursor w)
+insertOnTime i w = cset w "insertontime" i
+
+-- | Gets the time the insertion cursor blinks on.
+getInsertOnTime :: HasInsertionCursor w => (ICursor w) -> IO Int
+getInsertOnTime w = cget w "insertontime"
diff --git a/HTk/Components/Icon.hs b/HTk/Components/Icon.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Components/Icon.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | This module provides access to window icons.
+module HTk.Components.Icon (
+ Icon(..),
+ iconMask,
+ getIconMask
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.Configuration
+import HTk.Components.BitMap
+import Util.Computation
+import Events.Synchronized
+import HTk.Containers.Window
+
+-- -----------------------------------------------------------------------
+-- type icon's
+-- -----------------------------------------------------------------------
+
+-- | The @Icon@ datatype.
+data Window w => Icon w = Icon w deriving (Eq,Ord)
+
+
+-- -----------------------------------------------------------------------
+-- instantions
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance Window w => GUIObject (Icon w) where
+ toGUIObject (Icon win) = toGUIObject win
+ cname _ = "Icon"
+ cset (Icon win) cid val = cset win cid val >> return (Icon win)
+ cget (Icon win) cid = cget win cid
+
+{- only destroys the window, so this should not be necessary
+instance Window w => Destroyable (Icon w) where
+ destroy = destroy . toGUIObject
+-}
+
+-- | You can the the corresponding bitmap for an icon.
+instance Window w => HasBitMap (Icon w) where
+ bitmap s icon = setBitMapHandle icon "iconbitmap" (toBitMap s) False
+ getBitMap icon = getBitMapHandle icon "iconbitmap"
+
+-- | You can set the name on the icon.
+instance (Window w, GUIValue v) => HasText (Icon w) v where
+ -- Sets the name on the icon.
+ text s icon = cset icon "iconname" s
+ -- Gets the name on the icon.
+ getText icon = cget icon "iconname"
+
+-- | You can set the location of an icon.
+instance Window w => HasPosition (Icon w) where
+ -- Sets the location of the icon.
+ position p icon = cset icon "iconposition" p
+ -- Gets the location of the icon.
+ getPosition icon = cget icon "iconposition"
+
+-- | You can synchronize on an icon object.
+instance Window w => Synchronized (Icon w) where
+ -- Synchronizes on an icon object.
+ synchronize w = synchronize (toGUIObject w)
+
+
+-- -----------------------------------------------------------------------
+-- config options
+-- -----------------------------------------------------------------------
+
+-- | Sets the corresponding icon mask.
+iconMask :: (Window w, BitMapDesignator h) => h -> Config (Icon w)
+iconMask s icon = setBitMapHandle icon "iconmask" (toBitMap s) False
+
+-- | Gets the corresponding icon mask.
+getIconMask :: Window w => Icon w -> IO BitMapHandle
+getIconMask icon = getBitMapHandle icon "iconmask"
diff --git a/HTk/Components/Image.hs b/HTk/Components/Image.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Components/Image.hs
@@ -0,0 +1,199 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+-- | This module provides access to image resources from files or base64
+-- encoded strings.
+module HTk.Components.Image (
+
+ HasPhoto(..),
+ Image,
+ newImage,
+
+ intToImage,
+ imageToInt,
+
+ Format(..),
+ imgData,
+ imgGamma,
+ imgPalette
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import Util.Computation
+import Events.Synchronized
+import Events.Destructible
+
+-- -----------------------------------------------------------------------
+-- class image
+-- -----------------------------------------------------------------------
+
+-- | Image containers instantiate the @class HasPhoto@.
+class GUIObject w => HasPhoto w where
+ -- Associates an image container (e.g. a label) with the given image.
+ photo :: Image -> Config w
+ -- Gets the image associated with the given image container.
+ getPhoto :: w -> IO (Maybe Image)
+ photo img w = imageToInt img >>= cset w "image"
+ getPhoto w = cget w "image" >>= intToImage
+
+
+-- -----------------------------------------------------------------------
+-- type image
+-- -----------------------------------------------------------------------
+
+-- | The @Image@ datatype.
+newtype Image = Image GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- constructor
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new image object and returns a handler.
+-- The image object can be packed like a widget, then it is implicitely
+-- displayed inside a label widget.
+newImage :: [Config Image]
+ -- ^ the list of configuration options for this image
+ -- object.
+ -> IO Image
+ -- ^ An image object.
+newImage cnf =
+ do
+ w <- createWidget ROOT LABEL
+ configure (Image w) cnf
+
+-- | Sets the image data from a base64 encoded string.
+imgData :: Format -> String -> Config Image
+imgData f str w =
+ execTclScript [tkImageCreateFromData no f str] >> cset w "image" no
+ where no = getObjectNo (toGUIObject w)
+
+-- | The @Format@ datatype - represents the format of a base64
+-- encoded image (see @Image.imgData@).
+data Format = GIF | PPM | PGM
+
+formatToString :: Format -> String
+formatToString f =
+ case f of
+ GIF -> "GIF"
+ PPM -> "PPM"
+ _ -> "PGM"
+
+
+-- | The @gamma@ correction factor. Values less than one
+-- darken the image, values greater than one brighten up the image.
+imgGamma :: Double -> Config Image
+imgGamma g = tkImgConfig ("-gamma "++ show g)
+
+-- | The colour palette specifies a private palette for this image.
+-- You can either specify a grayscale palette (of n shades of grey), or an
+-- RGB triple.
+class PaletteSpec p where
+ -- Internal function only
+ tkShowPalette :: p-> String
+
+instance PaletteSpec Int where
+ tkShowPalette p = show p
+
+instance PaletteSpec (Int, Int, Int) where
+ tkShowPalette (r, g, b) = show r ++ "/"++ show g++ "/"++ show b
+
+imgPalette :: PaletteSpec p=> p-> Config Image
+imgPalette p = tkImgConfig ("-palette "++ tkShowPalette p)
+
+
+-- We leave the getImgGamma and getImgPalette functions as exercises
+-- to the interested reader of this source code.
+
+
+
+
+
+-- -----------------------------------------------------------------------
+-- instantiations
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject Image where
+ toGUIObject (Image w) = w
+ cname _ = "Image"
+
+-- | An image object can be destroyed.
+instance Destroyable Image where
+ -- Destroys an image object.
+ destroy = destroy . toGUIObject
+
+-- | An image object has standard widget properties
+-- (concerning focus, cursor \/ if implicitely displayed inside a label
+-- widget).
+instance Widget Image
+
+-- | An image object has a configureable border (if implicitely displayed
+-- inside a label widget).
+instance HasBorder Image
+
+-- | An image object has a configureable foreground and background colour
+-- (if implicitely displayed inside a label widget).
+instance HasColour Image where
+ legalColourID = hasForeGroundColour
+
+-- | You can specify the size of the containing label, if the image is
+-- implicitely displayed inside a label widget.
+instance HasSize Image
+
+-- | Images can be read from files.
+instance HasFile Image where
+ -- Specifies the image file path.
+ filename str w =
+ execTclScript [tkImageCreate no str] >> cset w "image" no
+ where no = getObjectNo (toGUIObject w)
+ -- Gets the image\'s file name.
+ getFileName w = evalTclScript [tkGetImageFile no]
+ where no = getObjectNo (toGUIObject w)
+
+-- | You can synchronize on an image object.
+instance Synchronized Image where
+ -- Synchronizes on an image object.
+ synchronize = synchronize . toGUIObject
+
+
+-- -----------------------------------------------------------------------
+-- auxiliary functions
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+intToImage :: Int -> IO (Maybe Image)
+intToImage 0 = return Nothing
+intToImage no = lookupGUIObject (ObjectID no) >>= return . Just . Image
+
+{- this function converts the Tk representation of an image to the HTK
+ representation. Needed by several other image retrieval function.
+-}
+
+-- | Internal.
+imageToInt :: Image -> IO Int
+imageToInt = return . getObjectNo . toGUIObject
+
+
+-- -----------------------------------------------------------------------
+-- Tk Commands
+-- -----------------------------------------------------------------------
+
+tkImageCreate :: Int -> String -> String
+tkImageCreate no file = "image create photo " ++ show no ++ " -file " ++ show file
+{-# INLINE tkImageCreate #-}
+
+tkGetImageFile :: Int -> String
+tkGetImageFile no = (show no) ++ " cget -file "
+{-# INLINE tkGetImageFile #-}
+
+tkImageCreateFromData :: Int -> Format -> String -> String
+tkImageCreateFromData no f dat = "image create photo " ++ show no ++ " -data " ++ show dat ++ " -format " ++ show (formatToString f)
+
+tkImgConfig :: String-> Config Image
+tkImgConfig cstr w =
+ do execTclScript [show no++ " configure "++ cstr]
+ return w
+ where no = getObjectNo (toGUIObject w)
+{-# INLINE tkImgConfig #-}
diff --git a/HTk/Components/Index.hs b/HTk/Components/Index.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Components/Index.hs
@@ -0,0 +1,125 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | This module exports basic types and classes on index positions, e.g.
+-- inside an editor or entry widget.
+module HTk.Components.Index (
+
+ EndOfText(..),
+ HasIndex(..),
+
+ BaseIndex(..),
+ Pixels(..),
+ First(..),
+ Last(..),
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.Geometry
+import Util.ExtendedPrelude
+import Data.Char
+
+
+-- -----------------------------------------------------------------------
+-- HasIndex
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+class HasIndex w i b where
+ getBaseIndex :: w -> i -> IO b
+
+
+-- -----------------------------------------------------------------------
+-- Index: End of text
+-- -----------------------------------------------------------------------
+
+-- | The @EndOfText@ datatype - a handle indexing the last
+-- position inside the concerned widget.
+data EndOfText = EndOfText deriving Eq
+
+-- | Internal.
+instance Show EndOfText where
+ showsPrec d _ r = "end" ++ r
+
+-- | Internal.
+instance Read EndOfText where
+ readsPrec p str =
+ case str of ('e':'n':'d':xs) -> [(EndOfText,xs)]
+ _ -> []
+
+-- | Internal.
+instance GUIValue EndOfText where
+ cdefault = EndOfText
+
+
+-- -----------------------------------------------------------------------
+-- Index: Pixels i.e. @x,y for listbox and text widgets
+-- -----------------------------------------------------------------------
+
+-- | The @Pixels@ datatype - a handle indexing a position inside
+-- a widget with its coordinates.
+data Pixels = Pixels Distance Distance
+
+-- | Internal.
+instance Show Pixels where
+ showsPrec d (Pixels x y) r = "@" ++ show x ++ "," ++ show y ++ r
+
+
+-- -----------------------------------------------------------------------
+-- Index: First, for entry and text widgets
+-- -----------------------------------------------------------------------
+
+-- | The @First@ datatype - a handle indexing the first entry
+-- e.g. inside a listbox.
+data First = First
+
+-- | Internal.
+instance Show First where
+ showsPrec d _ r = "first" ++ r
+
+
+-- -----------------------------------------------------------------------
+-- Index: Last, for entry and text widgets
+-- -----------------------------------------------------------------------
+
+-- | The @Last@ datatype - a handle indexing the last entry
+-- e.g. inside a listbox.
+data Last = Last
+
+-- | Internal.
+instance Show Last where
+ showsPrec d _ r = "first" ++ r
+
+
+-- -----------------------------------------------------------------------
+-- BaseIndex
+-- -----------------------------------------------------------------------
+
+-- | The @BaseIndex@ datatype - an index handle specified by
+-- an index number, an index position (line, char) or an index text (see
+-- text marks).
+data BaseIndex =
+ IndexNo Int -- ^ entries, listboxes
+ | IndexPos Position -- ^ text widgets
+ | IndexText String -- ^ listboxes, "end" etc.
+
+-- | Internal.
+instance GUIValue BaseIndex where
+ cdefault = IndexNo 0
+
+-- | Internal.
+instance Show BaseIndex where
+ showsPrec d c r = cshow c ++ r where
+ cshow (IndexNo i) = show i
+ cshow (IndexPos (x,y)) = show x ++ "." ++ show y
+ cshow (IndexText s) = s
+
+-- | Internal.
+instance Read BaseIndex where
+ readsPrec p str = [(cread str,[])] where
+ cread (s @ (x:l)) | isDigit x =
+ case map read (simpleSplit (== '.') s) of
+ [Distance i] -> IndexNo i
+ [x,y] -> IndexPos (x,y)
+ _ -> error "illegal index specification"
+ cread s = IndexText s
diff --git a/HTk/Components/Selection.hs b/HTk/Components/Selection.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Components/Selection.hs
@@ -0,0 +1,106 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | This module provides access to a widgets selection (e.g. inside a
+-- listbox, editor or entry widget).
+module HTk.Components.Selection (
+ Selection(..),
+ HasSelection(..),
+ HasSelectionIndex(..),
+ HasSelectionBaseIndex(..),
+ HasSelectionIndexRange(..),
+ HasSelectionBaseIndexRange(..)
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import HTk.Kernel.Resources
+import HTk.Kernel.Colour(toColour)
+import Util.Computation
+
+
+-- -----------------------------------------------------------------------
+-- selection classes
+-- -----------------------------------------------------------------------
+
+-- | A widget with a selectable content instantiates the @class
+-- HasSelection@.
+class GUIObject w => HasSelection w where
+ -- Clears the widgets selection.
+ clearSelection :: w -> IO ()
+
+-- | A widget with a indexable selection instantiates the @class
+-- HasSelectionIndex@.
+class HasSelectionIndex w i where
+ -- Selects the entry at the specified index.
+ selection :: i -> Config w
+ -- Queries if the entry at the given index is selected.
+ isSelected :: w -> i -> IO Bool
+
+-- | A widget with an indexable selection base instantiates the @class
+-- HasSelectionBaseIndex@.
+class HasSelectionBaseIndex w i where
+ -- Gets the selected base index (if something is selected).
+ getSelection :: w -> IO (Maybe i)
+
+-- | A widget with an indexable selection range instantiates the @class
+-- HasSelectionIndexRange@.
+class HasSelectionIndexRange w i1 i2 where
+ -- Selects the widget\'s entries in the specified range.
+ selectionRange :: i1 -> i2 -> Config w
+
+-- | A widget with an indexable selection index range instantiates the
+-- @class HasSelectionBaseIndexRange@.
+class HasSelectionIndex w i => HasSelectionBaseIndexRange w i where
+ -- Gets the selection start index.
+ getSelectionStart :: w -> IO (Maybe i)
+ -- Gets the selection end index.
+ getSelectionEnd :: w -> IO (Maybe i)
+ -- Gets the selection range.
+ getSelectionRange :: w -> IO (Maybe (i,i))
+ getSelectionRange w =
+ do
+ start <- getSelectionStart w
+ end <- getSelectionEnd w
+ case (start,end) of
+ ((Just start), (Just end)) -> return (Just (start,end))
+ _ -> return Nothing
+
+
+-- -----------------------------------------------------------------------
+-- handle
+-- -----------------------------------------------------------------------
+
+-- | The @Selection@ datatype.
+newtype Selection w = Selection w
+
+
+-- -----------------------------------------------------------------------
+-- instantiations
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject w => GUIObject (Selection w) where
+ toGUIObject (Selection w) = toGUIObject w
+ cname (Selection w) = cname w
+
+-- | The selected entries have a configureable foreground and background
+-- colour.
+instance (HasSelection w,Widget w) => HasColour (Selection w) where
+ legalColourID = hasForeGroundColour
+ setColour w "background" c = cset w "selectbackground" (toColour c)
+ setColour w "foreground" c = cset w "selectforeground" (toColour c)
+ setColour w _ _ = return w
+ getColour w "background" = cget w "selectbackground"
+ getColour w "foreground" = cget w "selectforeground"
+ getColour _ _ = return cdefault
+
+-- | The selection has a configureable border.
+instance (HasSelection w,Widget w) => HasBorder (Selection w) where
+ -- Specifies the size of the 3D border for selection highlight.
+ borderwidth s w = cset w "selectborderwidth" s
+ getBorderwidth w = cget w "selectborderwidth"
+ -- Dummy.
+ relief _ w = return w
+ getRelief _ = return Raised
diff --git a/HTk/Components/Slider.hs b/HTk/Components/Slider.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Components/Slider.hs
@@ -0,0 +1,66 @@
+-- | The @module Slider@ implements configuration options for
+-- widgets with sliders (scale widgets and scrollbars).
+module HTk.Components.Slider (
+
+ Slider(..),
+ HasSlider(..)
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.Configuration
+import Util.Computation
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Colour(toColour)
+
+
+-- -----------------------------------------------------------------------
+-- class HasSlider
+-- -----------------------------------------------------------------------
+
+-- | Widgets with sliders (scale widget, scrollbar) instantiate the
+-- @class HasSlider@.
+class Widget w => HasSlider w where
+ -- Sets the time period between auto-repeat events.
+ repeatInterval :: Int -> Config (Slider w)
+ -- Gets the time period between auto-repeat events.
+ getRepeatInterval :: (Slider w) -> IO Int
+ -- Sets the delay before auto-repeat starts (e.g. when mouse button is
+ -- pressed).
+ repeatDelay :: Int -> Config (Slider w)
+ -- Gets the delay before auto-repeat starts.
+ getRepeatDelay :: (Slider w) -> IO Int
+
+ repeatInterval c w = cset w "repeatinterval" c
+ getRepeatInterval w = cget w "repeatinterval"
+ repeatDelay c w = cset w "repeatdelay" c
+ getRepeatDelay w = cget w "repeatdelay"
+
+
+-- -----------------------------------------------------------------------
+-- datatype
+-- -----------------------------------------------------------------------
+
+-- | The @Slider@ datatype.
+newtype Slider w = Slider w
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject w => GUIObject (Slider w) where
+ toGUIObject (Slider w) = toGUIObject w
+ cname (Slider w) = cname w
+
+-- | The slider component has a configureable foreground and background
+-- colour.
+instance (HasSlider w,GUIObject w) => HasColour (Slider w) where
+ legalColourID = hasForeGroundColour
+ setColour w "foreground" c = cset w "troughcolor" (toColour c)
+ setColour w "background" c = cset w "activebackground" (toColour c)
+ setColour w _ _ = return w
+ getColour w "background" = cget w "troughcolor"
+ getColour w "foreground" = cget w "activebackground"
+ getColour _ _ = return cdefault
diff --git a/HTk/Containers/Box.hs b/HTk/Containers/Box.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Containers/Box.hs
@@ -0,0 +1,150 @@
+-- | A container widget with a preset packing orientation (for simple
+-- packing).
+module HTk.Containers.Box (
+
+ Box,
+
+ newBox,
+ newHBox,
+ newVBox,
+ newHFBox,
+ newVFBox
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import HTk.Kernel.Resources
+import Events.Destructible
+import Util.Computation
+import Events.Synchronized
+import HTk.Kernel.Packer
+
+
+-- -----------------------------------------------------------------------
+-- horizontal/vertical box
+-- -----------------------------------------------------------------------
+
+-- | The @Box@ datatype.
+data Box = Box GUIOBJECT
+
+
+-- -----------------------------------------------------------------------
+-- commands
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new box and returns a handler.
+newBox :: Container par => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> Flexibility
+ -- ^ the flexibility of the box.
+ -> [Config Box]
+ -- ^ the list of configuration options for this box.
+ -> IO Box
+ -- ^ A box.
+newBox par fl cnf =
+ do
+ w <- createWidget (toGUIObject par) (BOX cdefault fl)
+ configure (Box w) cnf
+
+-- | Constructs a new box with horizontal packing order and rigid
+-- flexibility and returns a handler.
+newHBox :: Container par => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> [Config Box]
+ -- ^ the list of configuration options for this box.
+ -> IO Box
+ -- ^ A box.
+newHBox par cnf = newBox par Rigid ((orient Horizontal) : cnf)
+
+-- | Constructs a new box with vertical packing order and rigid
+-- flexibility and returns a handler.
+newVBox :: Container par => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> [Config Box]
+ -- ^ the list of configuration options for this box.
+ -> IO Box
+ -- ^ A box.
+newVBox par cnf = newBox par Rigid ((orient Vertical) : cnf)
+
+-- | Constructs a new flexible box with horizontal packing order and returns
+-- a handler.
+newHFBox :: Container par => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> [Config Box]
+ -- ^ the list of configuration options for this box.
+ -> IO Box
+ -- ^ A box.
+newHFBox par cnf = newBox par Flexible ((orient Horizontal) : cnf)
+
+-- | Constructs a new flexible box with vertical packing order and returns
+-- a handler.
+newVFBox :: Container par => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> [Config Box]
+ -- ^ the list of configuration options for this box.
+ -> IO Box
+ -- ^ A box.
+newVFBox par cnf = newBox par Flexible ((orient Vertical) : cnf)
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance Eq Box where
+ w1 == w2 = (toGUIObject w1) == (toGUIObject w2)
+
+-- | Internal.
+instance GUIObject Box where
+ toGUIObject (Box w) = toGUIObject w
+ cname _ = "Box"
+
+-- | A box can be destroyed.
+instance Destroyable Box where
+ -- Destroys a box.
+ destroy = destroy . toGUIObject
+
+-- | You can synchronize on a box object.
+instance Synchronized Box where
+ -- Synchronizes on a box object.
+ synchronize = synchronize . toGUIObject
+
+-- | A box has standard widget properties
+-- (concerning focus, cursor).
+instance Widget Box
+
+-- | A box is a container for widgets. You can pack widgets to
+-- a box via pack or grid command in the @module Packer@.
+instance Container Box
+
+-- | A box has a configureable border.
+instance HasBorder Box
+
+-- | A box has a configureable background colour.
+instance HasColour Box where
+ legalColourID = hasBackGroundColour
+
+-- | A box\'es packing orientation is configureable.
+instance HasOrientation Box where
+ -- Sets the box\'es packing orientation.
+ orient or box@(Box w) =
+ do
+ BOX or' fl <- getObjectKind w
+ setObjectKind w (BOX or fl)
+ return box
+ -- Gets the box\'es packing orientation.
+ getOrient (Box w) =
+ do
+ BOX or _ <- getObjectKind w
+ return or
+
+-- | You can specify the size of a box.
+instance HasSize Box
diff --git a/HTk/Containers/Frame.hs b/HTk/Containers/Frame.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Containers/Frame.hs
@@ -0,0 +1,81 @@
+-- | HTk\'s /frame/ widget.
+-- A frame is a simple container for widgets.
+module HTk.Containers.Frame (
+
+ Frame,
+ newFrame
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import Util.Computation
+import Events.Synchronized
+import Events.Destructible
+import HTk.Kernel.Packer
+
+
+-- -----------------------------------------------------------------------
+-- type Frame
+-- -----------------------------------------------------------------------
+
+-- | The @Frame@ datatype.
+data Frame = Frame GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- creation
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new frame widget and returns a handler.
+newFrame :: Container par => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> [Config Frame]
+ -- ^ the list of configuration options for this frame.
+ -> IO Frame
+ -- ^ A frame widget.
+newFrame par confs =
+ do
+ w <- createWidget (toGUIObject par) FRAME
+ configure (Frame w) confs
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject Frame where
+ toGUIObject (Frame w) = w
+ cname _ = "Frame"
+
+-- | A frame widget can be destroyed.
+instance Destroyable Frame where
+ -- Destroys a frame widget.
+ destroy = destroy . toGUIObject
+
+-- | A frame widget has standard widget properties
+-- (concerning focus, cursor).
+instance Widget Frame
+
+-- | A frame widget is a container for widgets. You can pack widgets to
+-- a frame widget via pack or grid command in the
+-- @module HTk.Kernel.Packer@.
+instance Container Frame
+
+-- | A frame widget has a configureable border.
+instance HasBorder Frame
+
+-- | A frame widget has a background colour.
+instance HasColour Frame where
+ legalColourID = hasBackGroundColour
+
+-- | You can specify the size of a frame.
+instance HasSize Frame
+
+-- | You can synchronize on a frame object.
+instance Synchronized Frame where
+ -- Synchronizes on a frame object.
+ synchronize = synchronize . toGUIObject
diff --git a/HTk/Containers/Toplevel.hs b/HTk/Containers/Toplevel.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Containers/Toplevel.hs
@@ -0,0 +1,138 @@
+{-# LANGUAGE OverlappingInstances #-}
+
+-- | HTk\'s /toplevel/ widget.
+-- A toplevel widget is a toplevel container for widgets (a window).
+module HTk.Containers.Toplevel (
+
+ Toplevel(..),
+
+ createToplevel,
+
+ tkGetToplevelConfig,
+ tkSetToplevelConfigs
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses
+import Data.List
+import Util.Computation
+import Events.Destructible
+import Events.Synchronized
+import HTk.Containers.Window
+import HTk.Kernel.Packer
+
+
+-- -----------------------------------------------------------------------
+-- Toplevel widget
+-- -----------------------------------------------------------------------
+
+-- | The @Toplevel@ datatype.
+newtype Toplevel = Toplevel GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- creation commands
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new toplevel widget and returns a handler.
+createToplevel :: [Config Toplevel]
+ -- ^ the list of configuration options for this toplevel
+ -- widget.
+ -> IO Toplevel
+ -- ^ A toplevel widget.
+createToplevel cnf =
+ do
+ wid <- createGUIObject ROOT TOPLEVEL toplevelMethods
+ configure (Toplevel wid) cnf
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject Toplevel where
+ toGUIObject (Toplevel f) = f
+ cname _ = "Toplevel"
+
+-- | A toplevel widget can be destroyed.
+instance Destroyable Toplevel where
+ -- Destroys a toplevel widget.
+ destroy = destroy . toGUIObject
+
+-- | A toplevel widget has standard widget properties
+-- (concerning focus, cursor).
+instance Widget Toplevel
+
+-- | A toplevel widget is a container for widgets. You can pack widgets to
+-- a toplevel widget via pack or grid command in the
+-- @module HTk.Kernel.Packer@.
+instance Container Toplevel
+
+-- | You can synchronize on a toplevel object.
+instance Synchronized Toplevel where
+ -- Synchronizes on a toplevel object.
+ synchronize = synchronize . toGUIObject
+
+-- | A toplevel widget is a window (with various configurations and actions
+-- concerning its stacking order, display status, screen, aspect ratio
+-- etc.).
+instance Window Toplevel
+
+
+-- -----------------------------------------------------------------------
+-- toplevel methods
+-- -----------------------------------------------------------------------
+
+toplevelMethods = Methods tkGetToplevelConfig
+ tkSetToplevelConfigs
+ tkCreateToplevel
+ (packCmd voidMethods)
+ (gridCmd voidMethods)
+ (destroyCmd defMethods)
+ (bindCmd defMethods)
+ (unbindCmd defMethods)
+ (cleanupCmd defMethods)
+
+
+-- -----------------------------------------------------------------------
+-- Unparsing of Commands
+-- -----------------------------------------------------------------------
+
+tkCreateToplevel :: ObjectName -> ObjectKind -> ObjectName -> ObjectID ->
+ [ConfigOption] -> TclScript
+tkCreateToplevel _ kind name _ args =
+ [ show kind ++ " " ++ show name ++ " " ++ showConfigs cargs,
+ wmSetConfigs name wargs
+ ]
+ where (wargs,cargs) = partition (\(cid,_) -> isWMConfig cid) args
+{-# INLINE tkCreateToplevel #-}
+
+
+tkGetToplevelConfig :: ObjectName -> ConfigID -> TclScript
+tkGetToplevelConfig name cid | isWMConfig cid =
+ ["wm " ++ cid ++ " " ++ (show name)]
+tkGetToplevelConfig name cid =
+ [(show name) ++ " cget -" ++ cid]
+{-# INLINE tkGetToplevelConfig #-}
+
+tkSetToplevelConfigs :: ObjectName -> [ConfigOption] -> TclScript
+tkSetToplevelConfigs _ [] = []
+tkSetToplevelConfigs name args =
+ [cSetConfigs name cargs, wmSetConfigs name wargs]
+ where (wargs,cargs) = partition (\(cid,_) -> isWMConfig cid) args
+{-# INLINE tkSetToplevelConfigs #-}
+
+cSetConfigs :: ObjectName -> [ConfigOption] -> TclCmd
+cSetConfigs name [] = ""
+cSetConfigs name args = show name ++ " configure " ++ showConfigs args
+
+wmSetConfigs :: ObjectName -> [ConfigOption] -> TclCmd
+wmSetConfigs name [] = ""
+wmSetConfigs name ((cid,val) : args) =
+ wmSet name cid val ++ ";" ++ wmSetConfigs name args
+
+wmSet :: ObjectName -> ConfigID -> GUIVALUE -> TclCmd
+wmSet name "state" val = "wm " ++ show val ++ " " ++ show name
+wmSet name cid val = "wm " ++ cid ++ " " ++ show name ++ " " ++ show val
diff --git a/HTk/Containers/Window.hs b/HTk/Containers/Window.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Containers/Window.hs
@@ -0,0 +1,338 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | Basic types and classes concerning toplevel window resources.
+module HTk.Containers.Window (
+
+ Window(..),
+ Display,
+ maxSize,
+ getMaxSize,
+ minSize,
+ getMinSize,
+ raiseWin,
+ lowerWin,
+ WindowState(..),
+ AspectRatio,
+ Whom,
+ isWMConfig,
+
+) where
+
+import Util.Computation
+
+import HTk.Kernel.Geometry
+import HTk.Kernel.Configuration
+import HTk.Kernel.Core
+import Data.Char
+
+type Display = String
+
+
+-- -----------------------------------------------------------------------
+-- class Window
+-- -----------------------------------------------------------------------
+
+-- | Toplevel windows instantiate the @class Window@.
+class GUIObject w => Window w where
+ -- Iconifies the window.
+ iconify :: w -> IO ()
+ -- Deiconifies the window.
+ deiconify :: w -> IO ()
+ -- Withdraws the window.
+ withdraw :: w -> IO ()
+ -- Puts the window on top.
+ putWinOnTop :: w -> IO ()
+ -- Puts the window at bottom.
+ putWinAtBottom :: w -> IO ()
+ -- Sets the screen for this window.
+ screen :: Display -> Config w
+ -- Gets the screen from this window.
+ getScreen :: w -> IO (Display)
+ -- Returns the resource class of the given window.
+ getClassName :: w -> IO String
+ -- Gets the current window state.
+ getWindowState :: w -> IO WindowState
+ -- Sets the aspect ratio for the given window.
+ aspectRatio :: AspectRatio -> Config w
+ -- Gets the aspect ratio of the given window.
+ getAspectRatio :: w -> IO AspectRatio
+ -- Set \'@Whom@\' to be @Program@ or
+ -- @User@.
+ positionFrom :: Whom -> Config w
+ -- Gets the current setting.
+ getPositionFrom :: w -> IO Whom
+ -- Set \'@Whom@\' to be @Program@ or
+ sizeFrom :: Whom -> Config w
+ -- Gets the current setting.
+ getSizeFrom :: w -> IO Whom
+
+ iconify win = cset win "state" Iconified >> done
+ deiconify win = do {cset win "state" Deiconified; done}
+ withdraw win = do {cset win "state" Withdrawn; done}
+ putWinOnTop win = execMethod win (\nm -> [tkPutOnTop nm])
+ putWinAtBottom win = execMethod win (\nm -> [tkPutAtBottom nm])
+
+ screen "" win = cset win "screen" ":0.0"
+ screen scr win = cset win "screen" scr
+
+ getScreen win = cget win "screen"
+
+ getClassName win = evalMethod win (\nm -> [tkWInfoClass nm])
+
+ getWindowState win = cget win "state"
+
+ aspectRatio ratio win = cset win "aspect" ratio
+
+ getAspectRatio win = cget win "aspect"
+
+ positionFrom w win = cset win "positionfrom" w
+
+ getPositionFrom win = cget win "positionfrom"
+
+ sizeFrom w win = cset win "sizefrom" w
+
+ getSizeFrom win = cget win "sizefrom"
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | A window has a configureable size and anchor position (geometry).
+instance Window w => HasGeometry w where
+ -- Sets the window\'s geometry.
+ geometry g win = cset win "geometry" g
+ -- Gets the current geometry of the given window.
+ getGeometry win = cget win "geometry"
+
+-- | A window has a configureable size.
+instance Window w => HasSize w where
+ -- Sets the window\'s width.
+ width w win = getGeometry win >>= \(_,h,x,y) -> geometry (w,h,x,y) win
+ -- Gets the window\'s width.
+ getWidth win = getGeometry win >>= \ (w,_,_,_) -> return w
+ -- Sets the window\'s height.
+ height h win = getGeometry win >>= \(w,_,x,y) -> geometry (w,h,x,y) win
+ -- Gets the window\'s height.
+ getHeight win =
+ do
+ (_,h,_, _) <- getGeometry win
+ return h
+ -- Sets the window\'s width and height.
+ size (w,h) win =
+ do
+ (_,_,x,y) <- getGeometry win
+ geometry (w,h,x,y) win
+ -- Gets the window\'s width and height.
+ getSize win = getGeometry win >>= \(w,h,_,_) -> return (w,h)
+
+-- | A window has a position on the associated screen.
+instance Window w => HasPosition w where
+ -- Sets the window\'s position-
+ position (x,y) win =
+ do
+ (w, h, _, _) <- getGeometry win
+ geometry (w, h, x, y) win
+ -- Gets the window\'s position.
+ getPosition win =
+ do
+ (_, _, x, y) <- getGeometry win
+ return (x, y)
+
+-- | A window has a title.
+instance (Window w, GUIValue v) => HasText w v where
+ -- Sets the window\'s title.
+ text s win = cset win "iconname" s >> cset win "title" s
+ -- Gets the window\'s title.
+ getText win = cget win "title"
+
+
+-- -----------------------------------------------------------------------
+-- maximum and minimum size's
+-- -----------------------------------------------------------------------
+
+-- | Constraints the maximum size of the window.
+maxSize :: Window w => Size -> Config w
+maxSize s win = cset win "maxsize" s
+
+-- | Gets the maximum size of the window.
+getMaxSize :: Window w => w -> IO Size
+getMaxSize win = cget win "maxsize"
+
+-- | Constraints the minimum size of the window.
+minSize :: Window w => Size -> Config w
+minSize s win = cset win "minsize" s
+
+-- | Gets the minimum size of the window.
+getMinSize :: Window w => w -> IO Size
+getMinSize win = cget win "minsize"
+
+
+-- -----------------------------------------------------------------------
+-- stack order
+-- -----------------------------------------------------------------------
+
+-- | Puts the first given window just above the second given window
+-- in the stacking order.
+raiseWin :: (Window w1, Window w2) => w1
+ -- ^ the first window.
+ -> w2
+ -- ^ the second window.
+ -> IO ()
+ -- ^ None.
+raiseWin win1 win2 =
+ do
+ nm2 <- getObjectName (toGUIObject win2)
+ execMethod win1 (\nm1 -> [tkRaise nm1 nm2])
+
+-- | Puts the first given window just below the second given window
+-- in the stacking order.
+lowerWin :: (Window w1, Window w2) => w1
+ -- ^ the first window.
+ -> w2
+ -- ^ the second window.
+ -> IO ()
+ -- ^ None.
+lowerWin win1 win2 =
+ do
+ nm2 <- getObjectName (toGUIObject win2)
+ execMethod win1 (\nm1 -> [tkLower nm1 nm2])
+
+
+-- -----------------------------------------------------------------------
+-- WindowState
+-- -----------------------------------------------------------------------
+
+-- | The @WindowState@ datatype.
+data WindowState =
+ Deiconified | Iconified | Withdrawn deriving (Eq,Ord,Enum)
+
+-- | Internal.
+instance GUIValue WindowState where
+ cdefault = Deiconified
+
+-- | Internal.
+instance Read WindowState where
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ 'n':'o':'r':'m':'a':'l':xs -> [(Deiconified,xs)]
+ 'i':'c':'o':'n':'i':'c':xs -> [(Iconified,xs)]
+ 'w':'i':'t':'h':'d':'r':'a':'w':xs -> [(Withdrawn,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show WindowState where
+ showsPrec d p r =
+ (case p of
+ Deiconified -> "deiconify"
+ Iconified -> "iconic"
+ Withdrawn -> "withdraw") ++ r
+
+
+-- -----------------------------------------------------------------------
+-- AspectRatio
+-- -----------------------------------------------------------------------
+
+-- | The @AspectRatio@ datatype.
+data AspectRatio = AspectRatio Int Int Int Int deriving Eq
+
+-- | Internal.
+instance GUIValue AspectRatio where
+ cdefault = AspectRatio 0 0 0 0
+ toGUIValue v = GUIVALUE HaskellTk (show v)
+ maybeGUIValue (GUIVALUE _ s) =
+ case [x | (x,t) <- reads s, ("","") <- lex t] of
+ [x] -> Just x
+ _ -> Nothing
+
+-- | Internal.
+instance Show AspectRatio where
+ showsPrec d c r = cshow c ++ r
+ where cshow (AspectRatio xt yt xf yf) =
+ (show xt) ++ " " ++ (show yt) ++ " " ++
+ (show xf) ++ " " ++ (show yf)
+
+-- | Internal.
+instance Read AspectRatio where
+ readsPrec p str = [(cread str,[])]
+ where cread str = AspectRatio (read xt) (read yt) (read xf) (read yf)
+ [xt,yt,xf,yf] = words str
+
+
+-- -----------------------------------------------------------------------
+-- Whom
+-- -----------------------------------------------------------------------
+
+-- | The @Whom@ datatype.
+data Whom = Program | User deriving (Eq,Ord,Enum)
+
+-- | Internal.
+instance GUIValue Whom where
+ cdefault = Program
+
+-- | Internal.
+instance Read Whom where
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ 'u':'s':'e':'r':xs -> [(User,xs)]
+ 'p':'r':'o':'g':'r':'a':'m':xs -> [(Program,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show Whom where
+ showsPrec d p r =
+ (case p of
+ Program -> "program"
+ User -> "user") ++ r
+
+
+-- -----------------------------------------------------------------------
+-- auxiliary functions
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+isWMConfig :: ConfigID -> Bool
+isWMConfig "state" = True
+isWMConfig "geometry" = True
+isWMConfig "minsize" = True
+isWMConfig "maxsize" = True
+isWMConfig "aspect" = True
+isWMConfig "sizefrom" = True
+isWMConfig "positionfrom" = True
+isWMConfig "title" = True
+isWMConfig "transient" = True
+isWMConfig "group" = True
+isWMConfig "iconname" = True
+isWMConfig "iconbitmap" = True
+isWMConfig "iconposition" = True
+isWMConfig "iconmask" = True
+isWMConfig "focusmodel" = True
+isWMConfig _ = False
+
+
+-- -----------------------------------------------------------------------
+-- unparsing of commands
+-- -----------------------------------------------------------------------
+
+tkWInfoClass :: ObjectName -> TclCmd
+tkWInfoClass nm = "winfo class " ++ show nm
+{-# INLINE tkWInfoClass #-}
+
+tkPutOnTop :: ObjectName -> TclCmd
+tkPutOnTop win = "raise " ++ show win
+{-# INLINE tkPutOnTop #-}
+
+tkPutAtBottom :: ObjectName -> TclCmd
+tkPutAtBottom win = "lower " ++ show win
+{-# INLINE tkPutAtBottom #-}
+
+tkRaise :: ObjectName -> ObjectName -> TclCmd
+tkRaise win1 win2 = "raise " ++ show win1 ++ " " ++ show win2
+{-# INLINE tkRaise #-}
+
+tkLower :: ObjectName -> ObjectName -> TclCmd
+tkLower win1 win2 = "lower " ++ show win1 ++ " " ++ show win2
+{-# INLINE tkLower #-}
diff --git a/HTk/Devices/Bell.hs b/HTk/Devices/Bell.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Devices/Bell.hs
@@ -0,0 +1,35 @@
+-- | This module provides access to the terminal bell.
+module HTk.Devices.Bell (
+
+ ringBell,
+ bell
+
+) where
+
+import HTk.Containers.Window
+import HTk.Containers.Toplevel
+import HTk.Kernel.Core
+
+
+-- -----------------------------------------------------------------------
+-- Ring Bell
+-- -----------------------------------------------------------------------
+
+-- | Rings the bell for the given window.
+ringBell :: Window w => Maybe w -> IO ()
+ringBell Nothing = execTclScript [tkRing Nothing]
+ringBell (Just win) = execMethod win (\ nm -> [tkRing (Just nm)])
+
+-- | Rings the bell.
+bell :: IO ()
+bell = ringBell (Nothing :: Maybe Toplevel)
+
+
+-- -----------------------------------------------------------------------
+-- Unparsing of Commands
+-- -----------------------------------------------------------------------
+
+tkRing :: Maybe ObjectName -> TclCmd
+tkRing Nothing = "bell"
+tkRing (Just win) = "bell -displayof " ++ show win
+{-# INLINE tkRing #-}
diff --git a/HTk/Devices/Printer.hs b/HTk/Devices/Printer.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Devices/Printer.hs
@@ -0,0 +1,142 @@
+-- | This module provides funtionality for postscript export of the contents
+-- of canvas widgets.
+module HTk.Devices.Printer (
+
+ HasPostscript(..),
+
+ PostScript,
+ pageheight,
+ pagewidth,
+ pagex,
+ pagey,
+ rotate,
+ pageAnchor,
+ pswidth,
+ psheight,
+ pssize,
+ psfile,
+
+ ColourMode(..),
+ colourmode
+
+) where
+
+
+import Data.Char(isSpace)
+import Control.Exception (try)
+
+import HTk.Kernel.Core
+import HTk.Kernel.Geometry
+import HTk.Kernel.Resources
+
+-- -----------------------------------------------------------------------
+-- HasPostscript class
+-- -----------------------------------------------------------------------
+
+-- | Widgets that support postscript export instantiate the
+-- @class HasPostscript@.
+class GUIObject w => HasPostscript w where
+ -- Exports postscript from the given widget.
+ postscript :: w -> [CreationConfig PostScript] -> IO ()
+ postscript target confs =
+ do
+ confstr <- showCreationConfigs confs
+ try
+ (execMethod target (\nm -> [tkPostScript nm confstr]))
+ return ()
+ where tkPostScript :: ObjectName -> String -> TclCmd
+ tkPostScript name confstr =
+ show name ++ " postscript " ++ confstr
+
+
+-- -----------------------------------------------------------------------
+-- datatype
+-- -----------------------------------------------------------------------
+
+-- | The @PostScript@ datatype.
+data PostScript = PostScript
+
+
+-- -----------------------------------------------------------------------
+-- ColourModes
+-- -----------------------------------------------------------------------
+
+-- | The @ColourMode@ datatype.
+data ColourMode =
+ FullColourMode | GrayScaleMode | MonoChromeMode deriving (Eq,Ord,Enum)
+
+-- | Internal.
+instance GUIValue ColourMode where
+ cdefault = FullColourMode
+
+-- | Internal.
+instance Read ColourMode where
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ 'c':'o':'l':'o':'r':xs -> [(FullColourMode,xs)]
+ 'g':'r':'a':'y':xs -> [(GrayScaleMode,xs)]
+ 'm':'o':'n':'o':xs -> [(MonoChromeMode,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show ColourMode where
+ showsPrec d p r =
+ (case p of
+ FullColourMode -> "color"
+ GrayScaleMode -> "gray"
+ MonoChromeMode -> "mono"
+ ) ++ r
+
+
+-- -----------------------------------------------------------------------
+-- Configuation Options
+-- -----------------------------------------------------------------------
+
+-- | Sets the colourmode.
+colourmode :: ColourMode -> CreationConfig PostScript
+colourmode cmode = return ("colormode " ++ show cmode)
+
+-- | Sets the page height.
+pageheight :: Distance -> CreationConfig PostScript
+pageheight h = return ("pageheight " ++ show h)
+
+-- | Sets the page width.
+pagewidth :: Distance -> CreationConfig PostScript
+pagewidth h = return ("pagewidth " ++ show h)
+
+-- | Sets the output x coordinate of the anchor point.
+pagex :: Distance -> CreationConfig PostScript
+pagex h = return ("pagex " ++ show h)
+
+-- | Sets the output y coordinate of the anchor point.
+pagey :: Distance -> CreationConfig PostScript
+pagey h = return ("pagey " ++ show h)
+
+-- | If @True@, rotate so that X axis isthe long direction of the
+-- page.
+rotate :: Bool -> CreationConfig PostScript
+rotate r = return ("rotate" ++ show r)
+
+-- | Sets the page anchor.
+pageAnchor :: Anchor -> CreationConfig PostScript
+pageAnchor anch = return ("pageanchor" ++ show anch)
+
+-- | Sets the width of the area to print.
+pswidth :: Distance -> CreationConfig PostScript
+pswidth w = return ("width " ++ show w)
+
+-- | Sets the height of the area to print.
+psheight :: Distance -> CreationConfig PostScript
+psheight h = return ("height " ++ show h)
+
+-- | Sets the width and height of the area to print.
+pssize :: Size -> CreationConfig PostScript
+pssize (w, h) =
+ do
+ wstr <- pswidth w
+ hstr <- psheight h
+ return (wstr ++ " -" ++ hstr)
+
+-- | Sets the filename of the output file.
+psfile :: String -> CreationConfig PostScript
+psfile fnm = return ("file " ++ fnm)
diff --git a/HTk/Devices/Screen.hs b/HTk/Devices/Screen.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Devices/Screen.hs
@@ -0,0 +1,107 @@
+-- | The @module Screen@ exports general functionality on the
+-- screen\'s properties.
+module HTk.Devices.Screen (
+
+ Screen(..),
+ getScreenHeight,
+ getScreenWidth,
+ getScreenManager,
+
+ VisualClass(..),
+ getScreenVisual
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.Geometry(Distance)
+import Data.Char(isSpace)
+import HTk.Containers.Window
+
+
+-- -----------------------------------------------------------------------
+-- Screen
+-- -----------------------------------------------------------------------
+
+-- | The @Screen@ datatype.
+newtype Screen w = Screen w
+
+
+-- -----------------------------------------------------------------------
+-- Screen dimensions
+-- -----------------------------------------------------------------------
+
+-- | Gets the height of the screen.
+getScreenHeight :: Window a => Screen a
+ -- ^ the concerned screen.
+ -> IO Distance
+ -- ^ The screen\'s height.
+getScreenHeight scr@(Screen win) =
+ evalMethod win (\nm -> ["winfo screenheight " ++ show nm])
+
+-- | Gets the width of the screen.
+getScreenWidth :: Window a => Screen a
+ -- ^ the concerned screen.
+ -> IO Distance
+ -- ^ The screen\'s width.
+getScreenWidth scr@(Screen win)=
+ evalMethod win (\nm -> ["winfo screenwidth " ++ show nm])
+
+-- | Gets the visual properties of the screen.
+getScreenVisual :: Window a => Screen a
+ -- ^ the concerned screen.
+ -> IO VisualClass
+ -- ^ The visual properties.
+getScreenVisual scr@(Screen win) =
+ evalMethod win (\nm -> ["winfo screenvisual " ++ show nm])
+
+-- | Gets the screen manager from a screen.
+getScreenManager :: Window a => Screen a
+ -- ^ the concerned screen.
+ -> IO String
+ -- ^ A textual representation of the screen manager.
+getScreenManager (Screen win) =
+ evalMethod win (\nm -> ["winfo manager " ++ show nm])
+
+
+-- -----------------------------------------------------------------------
+-- Screen Colours
+-- -----------------------------------------------------------------------
+
+-- | The @VisualClass@ datatype (see
+-- @Screen.getScreenVisual@).
+data VisualClass =
+ DirectColour
+ | GrayScale
+ | PseudoColour
+ | StaticColour
+ | StaticGray
+ | TrueColour
+ deriving (Eq,Ord,Enum)
+
+-- | Internal.
+instance GUIValue VisualClass where
+ cdefault = DirectColour
+
+-- | Internal.
+instance Read VisualClass where
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ 'd':'i':'r':'e':'c':'t':'c':'o':'l':'o':'r':xs -> [(DirectColour,xs)]
+ 'g':'r':'a':'y':'s':'c':'a':'l':'e':xs -> [(GrayScale,xs)]
+ 'p':'s':'e':'u':'d':'o':'c':'o':'l':'o':'r':xs -> [(PseudoColour,xs)]
+ 's':'t':'a':'t':'i':'c':'c':'o':'l':'o':'r':xs -> [(StaticColour,xs)]
+ 's':'t':'a':'t':'i':'c':'g':'r':'a':'y':xs -> [(StaticGray,xs)]
+ 't':'r':'u':'e':'c':'o':'l':'o':'r':xs -> [(TrueColour,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show VisualClass where
+ showsPrec d p r =
+ (case p of
+ DirectColour -> "directcolor"
+ GrayScale -> "grayscale"
+ PseudoColour -> "pseudocolor"
+ StaticColour -> "staticcolor"
+ StaticGray -> "staticgray"
+ TrueColour -> "truecolor"
+ ) ++ r
diff --git a/HTk/Devices/XSelection.hs b/HTk/Devices/XSelection.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Devices/XSelection.hs
@@ -0,0 +1,64 @@
+-- | This module provides access to the X selection.
+module HTk.Devices.XSelection (
+ HasXSelection(..),
+
+ XSelection(..),
+
+ clearXSelection,
+ getXSelection,
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Components.Selection
+import HTk.Devices.Screen
+import Util.Computation
+
+-- -----------------------------------------------------------------------
+-- class HasXSelection
+-- -----------------------------------------------------------------------
+
+-- | Widgets that have an X selection instantiate the
+-- @class HasXSelection@.
+class HasSelection w => HasXSelection w where
+ -- Sets whether the selection should be exported or not.
+ exportSelection :: Bool -> Config w
+ -- Gets the current selection export setting.
+ getExportSelection :: w -> IO Bool
+ exportSelection b w = cset w "exportselection" b
+ getExportSelection w = cget w "exportselection"
+
+
+-- -----------------------------------------------------------------------
+-- types
+-- -----------------------------------------------------------------------
+
+-- | The @XSelection@ datatype.
+data XSelection = PRIMARY | CLIPBOARD deriving (Eq, Ord, Show, Read)
+
+type TargetType = String -- STRING, ATOM, INTEGER ...
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIValue XSelection where
+ cdefault = PRIMARY
+
+
+-- -----------------------------------------------------------------------
+-- XSelection commands
+-- -----------------------------------------------------------------------
+
+-- | Clears the X selection.
+clearXSelection :: GUIObject a => Screen a -> XSelection -> IO ()
+clearXSelection (Screen win) sel =
+ execMethod win (\nm -> ["selection clear -displayof " ++ show nm ++ " -selection " ++ show sel])
+
+-- | Gets the current X selection.
+getXSelection :: (GUIObject a, GUIValue b) =>
+ Screen a-> XSelection -> TargetType -> IO b
+getXSelection (Screen win) sel tp =
+ evalMethod win (\nm -> ["selection get -displayof " ++ show nm ++ " -selection " ++ show sel ++ " -type " ++ tp])
diff --git a/HTk/Kernel/BaseClasses.hs b/HTk/Kernel/BaseClasses.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Kernel/BaseClasses.hs
@@ -0,0 +1,30 @@
+-- | Basic types and classes.
+module HTk.Kernel.BaseClasses (
+
+ Widget(..)
+
+) where
+
+import HTk.Kernel.GUIObject
+import Util.Computation
+import HTk.Kernel.Cursor
+
+
+-- -----------------------------------------------------------------------
+-- class Widget
+-- -----------------------------------------------------------------------
+
+-- | Widgets instantiate the @class Widget@.
+class GUIObject w => Widget w where
+ -- Sets the mouse cursor for this widget.
+ cursor :: CursorDesignator ch => ch -> Config w
+ -- Gets the mouse cursor for this widget.
+ getCursor :: w -> IO Cursor
+ -- If @True@ the concerned widget can take the focus.
+ takeFocus :: Bool -> Config w
+ -- Gets the current setting.
+ getTakeFocus :: w -> IO Bool
+ cursor s w = cset w "cursor" (toCursor s)
+ getCursor w = cget w "cursor"
+ takeFocus b w = cset w "takefocus" b
+ getTakeFocus w = cget w "takefocus"
diff --git a/HTk/Kernel/ButtonWidget.hs b/HTk/Kernel/ButtonWidget.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Kernel/ButtonWidget.hs
@@ -0,0 +1,49 @@
+-- | This module provides general functionality on button widgets.
+module HTk.Kernel.ButtonWidget (
+
+ ButtonWidget(..),
+ buttonColours
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import Control.Exception (try)
+
+-- -----------------------------------------------------------------------
+-- class ButtonWidget
+-- -----------------------------------------------------------------------
+
+-- | Button widgets instantiate the @class ButtonWidget@.
+class Widget w => ButtonWidget w where
+ -- Flashes the given button widget.
+ flash :: w -> IO ()
+ -- Invokes the given button widget.
+ invoke :: w -> IO ()
+ flash w = do {try(execMethod w (\ nm -> tkFlash nm)); return ()}
+ invoke w = execMethod (toGUIObject w) (\ nm -> tkInvoke nm)
+
+tkFlash :: ObjectName -> TclScript
+tkFlash (MenuItemName name i) = []
+tkFlash name = [show name ++ " flash"]
+{-# INLINE tkFlash #-}
+
+tkInvoke :: ObjectName -> TclScript
+tkInvoke (MenuItemName name i) = [show name ++ " invoke " ++ (show i)]
+tkInvoke name = [show name ++ " invoke"]
+{-# INLINE tkInvoke #-}
+
+
+-- -----------------------------------------------------------------------
+-- aux. button commands
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+buttonColours :: HasColour w => w -> ConfigID -> Bool
+buttonColours w "background" = True
+buttonColours w "foreground" = True
+buttonColours w "activebackground" = True
+buttonColours w "activeforeground" = True
+buttonColours w "disabledforeground" = True
+buttonColours w _ = False
diff --git a/HTk/Kernel/CallWish.hs b/HTk/Kernel/CallWish.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Kernel/CallWish.hs
@@ -0,0 +1,47 @@
+-- | This is the bare-bones interface which actually calls the wish program.
+module HTk.Kernel.CallWish(
+ CalledWish, -- Type representing wish instance
+ callWish, -- :: IO CalledWish
+ -- callWish is used just once, to start the new wish.
+ sendCalledWish, -- :: CalledWish -> CStringLen -> IO ()
+ -- sendCalledWish is given the data as a CString.
+ readCalledWish, -- :: CalledWish -> IO String
+ destroyCalledWish, -- :: CalledWish -> IO ()
+ ) where
+
+import Foreign.C.String
+
+import Util.WBFiles
+
+import Events.Destructible
+
+import Posixutil.ChildProcess
+
+newtype CalledWish = CalledWish ChildProcess
+
+callWish :: IO CalledWish
+callWish =
+ do
+ wishPath <- getWishPath
+ childProcess <- newChildProcess wishPath [
+ linemode True,
+ challengeResponse challengeResponsePair,
+ toolName "wish"
+ ]
+ return (CalledWish childProcess)
+
+challengeResponsePair :: (String,String)
+challengeResponsePair = ("fconfigure stdout -translation lf;if {[info command button] == \"button\"} {puts \"This is wish \"} else {puts \"Is this tclsh?\"}","This is wish \n")
+
+sendCalledWish :: CalledWish -> CStringLen -> IO ()
+sendCalledWish (CalledWish childProcess) cStringLen =
+ sendMsgRaw childProcess cStringLen
+
+readCalledWish :: CalledWish -> IO String
+readCalledWish (CalledWish childProcess) = readMsg childProcess
+
+destroyCalledWish :: CalledWish -> IO ()
+destroyCalledWish (CalledWish childProcess) = destroy childProcess
+
+
+
diff --git a/HTk/Kernel/Colour.hs b/HTk/Kernel/Colour.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Kernel/Colour.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+-- | Basic types and classes for coloured resources.
+module HTk.Kernel.Colour (
+
+ ColourDesignator(..),
+ Colour(..)
+
+) where
+
+import HTk.Kernel.GUIValue
+import Data.Char
+
+
+-- -----------------------------------------------------------------------
+-- Colour Designator
+-- -----------------------------------------------------------------------
+
+-- | Datatypes that describe a colour instantiate the
+-- @class ColourDesignator@.
+class ColourDesignator c where
+ toColour :: c -> Colour
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | A colour itself describes a colour.
+instance ColourDesignator Colour where
+ -- Internal.
+ toColour = id
+
+-- | Strings like \"red\", \"blue\" etc. decribe colours.
+instance ColourDesignator [Char] where
+ -- Internal.
+ toColour = Colour
+
+-- | A tuple of rgb values describes a colour.
+instance ColourDesignator (Int,Int,Int) where
+ -- Internal.
+ toColour (r,g,b) = Colour (rgb r g b)
+
+-- | A tuple of rgb values describes a colour.
+instance ColourDesignator (Double,Double,Double) where
+ -- Internal.
+ toColour (r,g,b) = Colour (rgb (iround r) (iround g) (iround b))
+ where iround :: Double -> Int
+ iround x = round x
+
+
+-- -----------------------------------------------------------------------
+-- datatype
+-- -----------------------------------------------------------------------
+
+-- | The @Colour@ datatype.
+newtype Colour = Colour String
+
+-- | Internal.
+instance GUIValue Colour where
+ -- Internal.
+ cdefault = Colour "grey"
+
+-- | Internal.
+instance Read Colour where
+ -- Internal.
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ xs -> [(Colour (takeWhile (/= ' ') xs),"")]
+
+-- | Internal.
+instance Show Colour where
+ -- Internal.
+ showsPrec d (Colour p) r = p ++ r
+
+
+-- -----------------------------------------------------------------------
+-- Colour Codes
+-- -----------------------------------------------------------------------
+
+rgb :: Int -> Int -> Int -> String
+rgb r g b = "#" ++ concat (map (hex 2 "") [r,g,b]) where
+ hex 0 rs _ = rs
+ hex t rs 0 = hex (t-1) ('0':rs) 0
+ hex t rs i = let m = mod i 16
+ in hex (t-1)((chr (48+m+7*(div m 10))):rs)(div i 16)
+
+{- this function is borrowed from the implementation of tkGofer -}
diff --git a/HTk/Kernel/Configuration.hs b/HTk/Kernel/Configuration.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Kernel/Configuration.hs
@@ -0,0 +1,389 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | Basic types and classes concerning widget configuration.
+module HTk.Kernel.Configuration (
+
+ HasColour(..),
+
+ background,
+ getBackground,
+
+ foreground,
+ getForeground,
+
+ activeBackground,
+ getActiveBackground,
+
+ activeForeground,
+ getActiveForeground,
+
+ disabledForeground,
+ getDisabledForeground,
+
+ fg,
+ bg,
+
+ hasBackGroundColour,
+ hasForeGroundColour,
+
+ HasSize(..),
+ HasPosition(..),
+ HasGeometry(..),
+ HasCanvAnchor(..),
+ HasBorder(..),
+ HasValue(..),
+ HasText(..),
+ HasFont(..),
+ HasUnderline(..),
+ HasJustify(..),
+ HasGrid(..),
+ HasOrientation(..),
+ HasFile(..),
+ HasAlign(..),
+ HasIncrement(..),
+ HasEnable(..),
+ HasAnchor(..),
+ HasBBox(..)
+
+) where
+
+import HTk.Kernel.GUIObject
+import Util.Computation
+import HTk.Kernel.Geometry
+import HTk.Kernel.GUIValue
+import HTk.Kernel.Colour
+import HTk.Kernel.Font
+import HTk.Kernel.Resources
+
+
+-- -----------------------------------------------------------------------
+-- BBox
+-- -----------------------------------------------------------------------
+
+-- | Objects or sets of objects with a bounding box (e.g. canvas tags)
+-- instantiate the @class HasBBox@.
+class GUIObject w => HasBBox w i where
+ -- Returns the bounding box of the given object.
+ bbox :: w -> i -> IO (Maybe (Distance,Distance,Distance,Distance))
+
+
+-- -----------------------------------------------------------------------
+-- has anchor
+-- -----------------------------------------------------------------------
+
+-- | Objects that have an anchor position instantiate the
+-- @class HasAnchor@.
+class GUIObject w => HasAnchor w where
+ -- Sets the anchor position.
+ anchor :: Anchor -> Config w
+ -- Gets the anchor position.
+ getAnchor :: w -> IO Anchor
+ anchor a w = cset w "anchor" a
+ getAnchor w = cget w "anchor"
+
+
+-- -----------------------------------------------------------------------
+-- coloured
+-- -----------------------------------------------------------------------
+
+-- | Coloured objects instantiate the @class HasColour@.
+class GUIObject w => HasColour w where
+ legalColourID :: w -> ConfigID -> Bool
+ setColour :: w -> ConfigID -> Colour -> IO w
+ getColour :: w -> ConfigID -> IO Colour
+ legalColourID _ "background" = True
+ legalColourID _ _ = False
+ setColour w cid col =
+ if legalColourID w cid then cset w cid col else return w
+ getColour w cid =
+ if legalColourID w cid then cget w cid else return cdefault
+
+-- | Sets the background colour.
+background :: (ColourDesignator c, HasColour w) => c -> Config w
+background c w = setColour w "background" (toColour c)
+
+-- | Gets the background colour.
+getBackground :: HasColour w => w -> IO Colour
+getBackground w = getColour w "background"
+
+-- | Sets the foreground colour.
+foreground :: (ColourDesignator c, HasColour w) => c -> Config w
+foreground c w = setColour w "foreground" (toColour c)
+
+-- | Gets the foreground colour.
+getForeground :: HasColour w => w -> IO Colour
+getForeground w = getColour w "foreground"
+
+-- | Sets the active background colour.
+activeBackground :: (ColourDesignator c, HasColour w) => c -> Config w
+activeBackground c w = setColour w "activebackground" (toColour c)
+
+-- | Gets the active background colour.
+getActiveBackground :: HasColour w => w -> IO Colour
+getActiveBackground w = getColour w "activebackground"
+
+-- | Sets the active foreground colour.
+activeForeground :: (ColourDesignator c, HasColour w) => c -> Config w
+activeForeground c w = setColour w "activeforeground" (toColour c)
+
+-- | Gets the active foreground colour.
+getActiveForeground :: HasColour w => w -> IO Colour
+getActiveForeground w = getColour w "activeforeground"
+
+-- | Sets the disabled foreground colour.
+disabledForeground :: (ColourDesignator c, HasColour w) => c -> Config w
+disabledForeground c w = setColour w "disabledforeground" (toColour c)
+
+-- | Gets the disabled foreground colour.
+getDisabledForeground :: HasColour w => w -> IO Colour
+getDisabledForeground w = getColour w "disabledforeground"
+
+-- | Sets the foreground colour.
+fg :: (ColourDesignator c, HasColour w) => c -> Config w
+fg = foreground
+
+-- | Sets the background colour.
+bg :: (ColourDesignator c, HasColour w) => c -> Config w
+bg = background
+
+-- | Internal.
+hasBackGroundColour :: HasColour w => w -> ConfigID -> Bool
+hasBackGroundColour w "background" = True
+hasBackGroundColour w _ = False
+
+-- | Internal.
+hasForeGroundColour :: HasColour w => w -> ConfigID -> Bool
+hasForeGroundColour w "background" = True
+hasForeGroundColour w "foreground" = True
+hasForeGroundColour w _ = False
+
+
+-- -----------------------------------------------------------------------
+-- geometry
+-- -----------------------------------------------------------------------
+
+-- | Objects with a configureable size instantiate the
+-- @class HasSize@.
+class GUIObject w => HasSize w where
+ -- Sets the object\'s width.
+ width :: Distance -> Config w
+ -- Gets the object\'s width.
+ getWidth :: w -> IO Distance
+ -- Sets the object\'s height.
+ height :: Distance -> Config w
+ -- Gets the object\'s height.
+ getHeight :: w -> IO Distance
+ -- Sets the object\'s width and height.
+ size :: Size -> Config w
+ -- Gets the object\'s width and height.
+ getSize :: w -> IO Size
+ width s w = cset w "width" s
+ getWidth w = cget w "width"
+ height s w = cset w "height" s
+ getHeight w = cget w "height"
+ size (x,y) w = width x w >> height y w
+ getSize w =
+ getWidth w >>= \ x -> getHeight w >>= \ y -> return (x,y)
+
+-- | Objects with a configureable positon (e.g. canvas items) instantiate
+-- the @class HasPosition@.
+class GUIObject w => HasPosition w where
+ -- Gets the object\'s position.
+ position :: Position -> Config w
+ -- Sets the object\'s position.
+ getPosition :: w -> IO Position
+
+-- | Objects with a configureable size and position instantiate the
+-- @class HasGeometry@.
+class (HasSize w, HasPosition w) => HasGeometry w where
+ -- Sets the object\'s geometry.
+ geometry :: Geometry -> Config w
+ -- Gets the object\'s geometry.
+ getGeometry :: w -> IO Geometry
+
+-- | Canvasitems with an anchor position on the canvas instantiate the
+-- @class HasCanvAnchor@.
+class GUIObject w => HasCanvAnchor w where
+ -- Sets the anchor position on the canvas.
+ canvAnchor :: Anchor -> Config w
+ -- Gets the anchor position on the canvas.
+ getCanvAnchor :: w -> IO Anchor
+
+
+-- -----------------------------------------------------------------------
+-- has border
+-- -----------------------------------------------------------------------
+
+-- | Objects with a configureable border instantiate the
+-- @class HasBorder@.
+class GUIObject w => HasBorder w where
+ -- Sets the width of the object\'s border.
+ borderwidth :: Distance -> Config w
+ -- Gets the width of the object\'s border.
+ getBorderwidth :: w -> IO Distance
+ -- Sets the object\'s relief.
+ relief :: Relief -> Config w
+ -- Gets the object\'s relief.
+ getRelief :: w -> IO Relief
+ borderwidth s w = cset w "borderwidth" s
+ getBorderwidth w = cget w "borderwidth"
+ relief r w = cset w "relief" r
+ getRelief w = cget w "relief"
+
+
+-- -----------------------------------------------------------------------
+-- objects associated with a value
+-- -----------------------------------------------------------------------
+
+-- | Objects that have a value instantiate the
+-- @class HasValue@.
+class (GUIObject w, GUIValue v) => HasValue w v where
+ -- Sets the object\'s value.
+ value :: v -> Config w
+ -- Gets the object\'s value.
+ getValue :: w -> IO v
+ value v w = cset w "value" v >> return w
+ getValue w = cget w "value"
+
+
+-- -----------------------------------------------------------------------
+-- text labelled widgets
+-- -----------------------------------------------------------------------
+
+-- | Objects containing text instantiate the class
+-- @HasText@.
+class (GUIObject w, GUIValue v) => HasText w v where
+ -- Sets the object\'s text.
+ text :: v -> Config w
+ -- Gets the object\'s text.
+ getText :: w -> IO v
+ text t w = cset w "text" t
+ getText w = cget w "text"
+
+-- | Objects with a configureable font instantiate the
+-- @class HasFont@.
+class GUIObject w => HasFont w where
+ -- Sets the object\'s font.
+ font :: FontDesignator f => f -> Config w
+ -- Gets the object\'s font.
+ getFont :: w -> IO Font
+ font f w = cset w "font" (toFont f)
+ getFont w = cget w "font"
+
+-- | Objects that have a text underline configure option instantiate th
+-- @class HasUnderline@.
+class GUIObject w => HasUnderline w where
+ -- Sets the index position of the text character to underline.
+ underline :: Int -> Config w
+ -- Gets the index position of the text character to underline.
+ getUnderline :: w -> IO Int
+ -- Sets the maximum line length for text in screen units.
+ wraplength :: Int -> Config w
+ -- Gets the maximum line length for text in screen units.
+ getWraplength :: w -> IO Int
+ underline i w = cset w "underline" i
+ getUnderline w = cget w "underline"
+ wraplength l w = cset w "wraplength" l
+ getWraplength w = cget w "wraplength"
+
+-- | Objects that have a configureable text justification instantiate the
+-- @class HasJustify@.
+class GUIObject w => HasJustify w where
+ -- Sets the text justification.
+ justify :: Justify -> Config w
+ -- Gets the set text justification.
+ getJustify :: w -> IO Justify
+ justify js w = cset w "justify" js
+ getJustify w = cget w "justify"
+
+
+-- -----------------------------------------------------------------------
+-- grid
+-- -----------------------------------------------------------------------
+
+-- | Objects that support geometry gridding instantiate the
+-- @class HasGrid@.
+class GUIObject w => HasGrid w where
+ -- Enables geometry gridding.
+ setgrid :: Toggle -> Config w
+ -- Gets the current setting.
+ getGrid :: w -> IO Toggle
+ setgrid b w = cset w "setgrid" b
+ getGrid w = cget w "setgrid"
+
+
+-- -----------------------------------------------------------------------
+-- orientation
+-- -----------------------------------------------------------------------
+
+-- | Oriented objects instantiate the @class HasOrientation@.
+class GUIObject w => HasOrientation w where
+ -- Sets the object\'s orientation.
+ orient :: Orientation -> Config w
+ -- Gets the object\'s orientation.
+ getOrient :: w -> IO Orientation
+ orient o w = cset w "orient" o
+ getOrient w = cget w "orient"
+
+
+-- -----------------------------------------------------------------------
+-- file
+-- -----------------------------------------------------------------------
+
+-- | Objects associated with a file instantiate the
+-- @class HasFile@.
+class GUIObject w => HasFile w where
+ -- Sets the name of the associated file.
+ filename :: String -> Config w
+ -- Gets the name of the associated file.
+ getFileName :: w -> IO String
+
+
+-- -----------------------------------------------------------------------
+-- align
+-- -----------------------------------------------------------------------
+
+-- | Objects with a configureable alignment instantiate the
+-- @class HasAlign@.
+class GUIObject w => HasAlign w where
+ align :: Alignment -> Config w
+ getAlign :: w -> IO Alignment
+ align a w = cset w "align" a
+ getAlign w = cget w "align"
+
+
+-- -----------------------------------------------------------------------
+-- increment (canvas region, scales)
+-- -----------------------------------------------------------------------
+
+-- | Incrementable objects (e.g. scale wigdgets) instantiate the
+-- @class HasIncrement@.
+class HasIncrement w a where
+ -- Increments the object.
+ increment :: a -> Config w
+ -- Gets object\'s incrementation.
+ getIncrement :: w -> IO a
+
+
+-- -----------------------------------------------------------------------
+-- enabling and disabling of widgets
+-- -----------------------------------------------------------------------
+
+-- | Stateful objects that can be enabled or disabled instantiate the
+-- @class HasEnable@.
+class GUIObject w => HasEnable w where
+ -- Sets the objects state.
+ state :: State -> Config w
+ -- Gets the objects state.
+ getState :: w -> IO State
+ -- Disables the object.
+ disable :: Config w
+ -- Enables the object.
+ enable :: Config w
+ -- @True@ if the object is enabled.
+ isEnabled :: w -> IO Bool
+ state s w = cset w "state" s
+ getState w = cget w "state"
+ disable = state Disabled
+ enable = state Normal
+ isEnabled w = do {st <- getState w; return (st /= Disabled)}
diff --git a/HTk/Kernel/Core.hs b/HTk/Kernel/Core.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Kernel/Core.hs
@@ -0,0 +1,483 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE OverlappingInstances #-}
+
+module HTk.Kernel.Core (
+
+ Wish(..),
+ wish,
+
+ TclCmd,
+ TclScript,
+ TclMessageType(..),
+
+ execCmd,
+ evalCmd,
+ execTclScript,
+ evalTclScript,
+ execMethod,
+ evalMethod,
+ setTclVariable,
+ getTclVariable,
+
+
+-- * submodules
+
+ module HTk.Kernel.GUIValue,
+ module HTk.Kernel.GUIObjectName,
+ module HTk.Kernel.GUIObjectKind,
+
+
+-- * tool instance
+
+ GUI(..),
+ getGUI,
+
+
+-- * Widget configuration
+
+ ConfigOption,
+ ConfigID,
+
+ showConfigs,
+ showConfig,
+
+
+-- * enabling \/ disabling of widgets
+
+ HasEnable(..),
+
+
+-- * GUIObjects and methods (internal representation of Tk-Widgets)
+
+ GUIOBJECT(..),
+ OST(..), -- the gui objects state
+ GUIObject(..),
+
+ Object(..),
+ ObjectID(..),
+ getObjectNo,
+ getParentObjectID,
+
+ createGUIObject,
+ createHTkObject,
+ createWidget,
+
+ lookupGUIObjectByName,
+ lookupGUIObject,
+ getParentPathName,
+ getParentObject,
+
+ getObjectKind,
+ setObjectKind,
+
+ getObjectName,
+ setObjectName,
+
+ Methods(..),
+ defMethods,
+ voidMethods,
+ setMethods,
+
+
+-- * events
+
+ WishEvent(..),
+ WishEventType(..),
+ WishEventModifier(..),
+ KeySym(..),
+ bind,
+ bindSimple,
+ bindPath,
+ bindPathSimple,
+ HasCommand(..),
+
+-- needed to build bind and unbind methods in widget classes:
+ bindTagS,
+ showP,
+ mkBoundCmdArg,
+ BindTag,
+ EventInfoSet,
+
+
+-- * Tk variables
+
+ tkDeclVar,
+ tkUndeclVar,
+
+) where
+
+import qualified Data.Map as Map
+import Control.Concurrent
+import System.IO.Unsafe
+
+import Util.Computation
+
+import Events.GuardedEvents
+import Events.EqGuard
+import Events.Events
+import Util.Object
+
+import Reactor.ReferenceVariables
+import Events.Destructible
+
+import qualified Util.ExtendedPrelude as ExtendedPrelude(simpleSplit)
+
+import HTk.Kernel.GUIValue
+import HTk.Kernel.EventInfo
+import HTk.Kernel.GUIObjectName
+import HTk.Kernel.GUIObject
+import HTk.Kernel.GUIObjectKind
+import HTk.Kernel.Wish
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import HTk.Kernel.PackOptions
+import HTk.Kernel.GridPackOptions
+
+-- -----------------------------------------------------------------------
+-- base GUI object
+-- -----------------------------------------------------------------------
+
+instance GUIObject GUIOBJECT where
+ toGUIObject = id
+ cname _ = "GUIOBJECT"
+
+
+-- -----------------------------------------------------------------------
+-- destruction of GUI objects
+-- -----------------------------------------------------------------------
+
+instance GUIObject a => Destroyable a where
+ destroy wid =
+ do
+ let (GUIOBJECT oid ostref) = toGUIObject wid
+ meth <- withRef ostref methods
+ nm <- withRef ostref objectname
+ execTclScript ((destroyCmd meth) nm)
+
+
+-- -----------------------------------------------------------------------
+-- GUI / GUI State
+-- -----------------------------------------------------------------------
+
+data GUI = GUI GUIOBJECT (Ref GST)
+type GST = Map.Map ObjectID GUIOBJECT
+
+
+-- -----------------------------------------------------------------------
+-- GUI Instances
+-- -----------------------------------------------------------------------
+
+instance Object GUI where
+ objectID (GUI obj _) = objectID obj
+
+instance GUIObject GUI where
+ toGUIObject (GUI obj _) = obj
+ cname _ = "GUI"
+
+
+-- -----------------------------------------------------------------------
+-- GUI state
+-- -----------------------------------------------------------------------
+
+getGUI :: IO GUI -- IO because of old htk stuff, may change
+getGUI =
+ return (unsafePerformIO (do
+ wdg <- newRef Map.empty
+ obj <- newGUIObject ROOT SESSION defMethods
+ let gui = GUI obj wdg
+ return gui))
+
+applyGUI :: (GST -> GST) -> IO ()
+applyGUI f = getGUI >>= \ (GUI _ gui) -> changeRef gui f
+
+queryGUI :: (GST -> a) -> IO a
+queryGUI f = getGUI >>= \ (GUI _ gui) -> withRef gui f
+
+
+-- ----------------------------------------------------------------------
+-- GUIObject/Widget Creation
+-- ----------------------------------------------------------------------
+
+createGUIObject :: GUIOBJECT -> ObjectKind -> Methods -> IO GUIOBJECT
+createGUIObject par@(GUIOBJECT _ postref) kind meths =
+ do
+ guio@(GUIOBJECT oid ostref) <- newGUIObject par kind meths
+ GUI _ gstref <- getGUI
+ changeRef gstref (newObj guio)
+ name <- withRef ostref objectname
+ pname <- withRef postref objectname
+ execTclScript ((createCmd meths) pname kind name oid [])
+ return guio
+ where newObj guio @ (GUIOBJECT oid ost) wd = Map.insert oid guio wd
+createGUIObject ROOT kind meths =
+ do
+ guio@(GUIOBJECT oid ostref) <- newGUIObject ROOT kind meths
+ GUI _ gstref <- getGUI
+ changeRef gstref (newObj guio)
+ name <- withRef ostref objectname
+ execTclScript ((createCmd meths) (ObjectName ".") kind name oid [])
+ return guio
+ where newObj guio @ (GUIOBJECT oid ost) wd = Map.insert oid guio wd
+
+
+createHTkObject :: Methods -> IO GUIOBJECT
+createHTkObject meths =
+ do
+ oid <- newObject
+ ost <- newRef (OST ABSTRACT (ObjectName ".") oid meths)
+ return (GUIOBJECT oid ost)
+
+createWidget :: GUIOBJECT -> ObjectKind -> IO GUIOBJECT
+createWidget par kind = createGUIObject par kind defMethods
+
+
+-- -----------------------------------------------------------------------
+-- lookup object handle etc.
+-- -----------------------------------------------------------------------
+
+lookupGUIObject :: ObjectID -> IO GUIOBJECT
+lookupGUIObject key = do {
+ mwid <- queryGUI (\wd -> Map.lookup key wd);
+ case mwid of
+ Nothing ->
+ error "Haskell-Tk Error: gui object not found"
+ (Just wid) -> return wid
+ } -- TD ???
+
+getParentPathName :: GUIObject w => w -> IO (Maybe ObjectName)
+getParentPathName w =
+ do
+ par' <- getParentObject w
+ case par' of Nothing -> return Nothing
+ Just par -> do
+ nm <- getObjectName par
+ return (Just nm)
+
+lookupGUIObjectByName :: WidgetName -> IO (Maybe GUIOBJECT)
+lookupGUIObjectByName (WidgetName "") = return Nothing
+lookupGUIObjectByName (WidgetName str) =
+ queryGUI (\wd -> Map.lookup no wd)
+ where wnm =
+ head (reverse (ExtendedPrelude.simpleSplit (== '.') str))
+ no = ObjectID (read ( drop 1 wnm))
+
+getParentObject :: GUIObject w => w -> IO (Maybe GUIOBJECT)
+getParentObject w =
+ do
+ oid <- getParentObjectID (toGUIObject w)
+ queryGUI (\wd -> Map.lookup oid wd) -- TD ???
+
+getParentObjectID :: GUIOBJECT -> IO ObjectID
+getParentObjectID (GUIOBJECT _ ostref) = withRef ostref parentobj
+
+
+-- -----------------------------------------------------------------------
+-- instances (Show)
+-- -----------------------------------------------------------------------
+
+showConfig :: (ConfigID, GUIVALUE) -> String
+showConfig (cid, cval) =
+ "-" ++ cid ++ " " ++
+ case cid of
+ "tag" -> "\"" ++ (drop 2 (show cval))
+ _ -> show cval
+
+showConfigs :: [(ConfigID, GUIVALUE)] -> String
+showConfigs [] = " "
+showConfigs (x : ol) = (showConfig x) ++ " " ++ (showConfigs ol)
+
+
+-- -----------------------------------------------------------------------
+-- GUIObject default methods (for widgets and foreign objects mainly)
+-- -----------------------------------------------------------------------
+
+defMethods :: Methods
+defMethods = Methods tkGetWidgetConfig
+ tkSetWidgetConfigs
+ tkCreateWidget
+ tkPack
+ tkGrid
+ tkDestroyWidget
+ tkBindWidget
+ tkUnbindWidget
+ tkCleanupWidget
+
+voidMethods :: Methods
+voidMethods = Methods (\_ _ -> [])
+ (\_ _ -> [])
+ (\_ _ _ _ _ -> [])
+ (\_ _ -> [])
+ (\_ _ -> [])
+ (\_ -> [])
+ (\_ _ _ _ _ -> [])
+ (\_ _ _ _ -> [])
+ (\_ _ -> [])
+
+
+-- -----------------------------------------------------------------------
+-- unparsing of widget (default methods)
+-- -----------------------------------------------------------------------
+
+tkCreateWidget :: ObjectName -> ObjectKind -> ObjectName -> ObjectID ->
+ [ConfigOption] -> TclScript
+tkCreateWidget _ kind name _ opts =
+ [show kind ++ " " ++ show name ++ " " ++ showConfigs opts]
+
+tkPack :: ObjectName -> [PackOption] -> TclScript
+tkPack name opts = ["pack " ++ show name ++ " " ++ showPackOptions opts]
+
+tkGrid :: ObjectName -> [GridPackOption] -> TclScript
+tkGrid name opts =
+ ["grid " ++ show name ++ " " ++ showGridPackOptions opts]
+
+tkBindWidget :: ObjectName -> BindTag -> [WishEvent] ->
+ EventInfoSet -> Bool -> TclScript
+tkBindWidget nm bindTag wishEvents eventInfoSet bindToTag =
+ let evStr flag = delimitString (foldr (\ event soFar -> showP event soFar)
+ "" wishEvents) ++ " " ++
+ mkBoundCmdArg bindTag eventInfoSet flag
+ in if bindToTag then ["addtag " ++ show nm ++ " " ++ bindTagS bindTag,
+ "bind " ++ bindTagS bindTag ++ " " ++ evStr False]
+ else ["bind " ++ show nm ++ " " ++ evStr True]
+
+tkUnbindWidget :: ObjectName -> BindTag -> [WishEvent] -> Bool ->
+ TclScript
+tkUnbindWidget nm bindTag wishEvents boundToTag =
+ let evStr = delimitString (foldr (\ event soFar -> showP event soFar)
+ "" wishEvents) ++ " {}"
+ in if boundToTag then ["rmtag " ++ show nm ++ " " ++ bindTagS bindTag,
+ "bind " ++ bindTagS bindTag ++ " " ++ evStr]
+ else ["bind " ++ show nm ++ " " ++ evStr]
+
+tkDestroyWidget :: ObjectName -> TclScript
+tkDestroyWidget name = ["destroy " ++ show name]
+
+tkCleanupWidget :: ObjectID -> ObjectName -> TclScript
+tkCleanupWidget _ _ = []
+
+tkGetWidgetConfig :: ObjectName -> ConfigID -> TclScript
+tkGetWidgetConfig name cid = [(show name) ++ " cget -" ++ cid]
+
+tkSetWidgetConfigs :: ObjectName -> [ConfigOption] -> TclScript
+tkSetWidgetConfigs _ [] = []
+tkSetWidgetConfigs name args =
+ [show name ++ " configure " ++ showConfigs args]
+
+
+-- -----------------------------------------------------------------------
+-- widget commands
+-- -----------------------------------------------------------------------
+
+class GUIObject w => HasCommand w where
+ clicked :: w -> IO (Event ())
+ clicked w =
+ do
+ let (GUIOBJECT oid _) = toGUIObject w
+ cset w "command" (TkCommand ("puts \"CO " ++ show oid ++ "\""))
+ return (toEvent (listen (coQueue wish) |> Eq (CallBackId oid))
+ >>> return ())
+
+
+-- ---------------------------------------------------------------------
+-- bindings
+-- ---------------------------------------------------------------------
+
+doBind :: GUIObject wid => Bool -> wid -> [WishEvent] ->
+ IO (Event EventInfo,IO ())
+doBind bindToTag wid wishEvents =
+ do
+ -- Allocate a bindtag
+ let mVar = bindTags wish
+ bindTag <- takeMVar mVar
+ putMVar mVar (succBindTag bindTag)
+ -- do the binding
+ let (GUIOBJECT oid ostref) = toGUIObject wid
+ meth <- withRef ostref methods
+ nm <- getObjectName (toGUIObject wid)
+ execTclScript ((bindCmd meth) nm bindTag wishEvents
+ defaultEventInfoSet bindToTag)
+ let
+ event =
+ toEvent (listen (eventQueue wish) |> Eq bindTag)
+ >>>= (\ (_,eventInfoSet) -> return eventInfoSet)
+ unbind :: IO ()
+ unbind = execTclScript ((unbindCmd meth) nm bindTag wishEvents
+ bindToTag)
+ return (event,unbind)
+
+doBindSimple :: GUIObject wid => Bool -> wid -> WishEventType ->
+ IO (Event (),IO ())
+doBindSimple bindToTag wid wishEventType =
+ do
+ (event1, deregister) <-
+ doBind bindToTag wid [WishEvent [] wishEventType]
+ return (event1 >>> done, deregister)
+
+-- | Binds an event for this widget. The second action returned unbinds
+-- the event.
+bind :: GUIObject wid => wid -> [WishEvent] -> IO (Event EventInfo,IO ())
+bind = doBind True
+
+-- | Simple version of bind for only one event and without modifiers.
+bindSimple :: GUIObject wid => wid -> WishEventType ->
+ IO (Event (),IO ())
+bindSimple = doBindSimple True
+
+-- | Binds an event for this widget and its parent widgets. The second
+-- action returned unbinds the event.
+bindPath :: Widget wid => wid -> [WishEvent] -> IO (Event EventInfo,IO ())
+bindPath = doBind False
+
+-- | Simple version of bindPath for only one event and without modifiers.
+bindPathSimple :: Widget wid => wid -> WishEventType ->
+ IO (Event (), IO ())
+bindPathSimple = doBindSimple False
+
+
+
+-- -----------------------------------------------------------------------
+-- convenient execution of Tcl commands
+-- -----------------------------------------------------------------------
+
+evalMethod :: (GUIObject a, GUIValue b) =>
+ a -> (ObjectName -> TclScript) -> IO b
+evalMethod wid meth =
+ do
+ let (GUIOBJECT _ ostref) = toGUIObject wid
+ nm <- withRef ostref objectname
+ str <- evalTclScript (meth nm)
+ creadTk str
+
+execMethod :: GUIObject a => a -> (ObjectName -> TclScript) -> IO ()
+execMethod wid meth =
+ do
+ let (GUIOBJECT _ ostref) = toGUIObject wid
+ nm <- withRef ostref objectname
+ execTclScript (meth nm)
+
+
+-- -----------------------------------------------------------------------
+-- Tk variables (for internal use)
+-- -----------------------------------------------------------------------
+
+tkDeclVar :: String -> String -> TclScript
+tkDeclVar var val = ["global " ++ var, "set " ++ var ++ " " ++ val]
+
+tkUndeclVar :: String -> TclScript
+tkUndeclVar var = ["global " ++ var, "unset " ++ var]
+
+
+-- -----------------------------------------------------------------------
+-- Tcl variables
+-- -----------------------------------------------------------------------
+
+setTclVariable :: GUIValue a => String -> a -> IO ()
+setTclVariable name v =
+ execTclScript ["global " ++ name,
+ "set " ++ name ++ " " ++ show (toGUIValue v)]
+
+getTclVariable :: GUIValue a => String -> IO a
+getTclVariable name =
+ evalTclScript ["global " ++ name ++ "; set res $" ++ name] >>= creadTk
+
diff --git a/HTk/Kernel/Cursor.hs b/HTk/Kernel/Cursor.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Kernel/Cursor.hs
@@ -0,0 +1,231 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+-- | Basic types and classes associated with the mouse cursor.
+module HTk.Kernel.Cursor (
+
+ CursorDesignator(..),
+
+ Cursor(..),
+ XCursor(..),
+ BCursor(..),
+
+ arrow,
+ circle,
+ clock,
+ diamondCross,
+ dot,
+ drapedBox,
+ exchange,
+ fleur,
+ gobbler,
+ gumby,
+ hand1,
+ hand2,
+ pencil,
+ plus,
+ spraycan,
+ tcross,
+ watch,
+ xterm
+
+) where
+
+import HTk.Kernel.GUIValue
+import HTk.Kernel.Colour
+import Data.Char
+
+-- -----------------------------------------------------------------------
+-- Cursor Type
+-- -----------------------------------------------------------------------
+
+-- | The general @Cursor@ datatype.
+newtype Cursor = Cursor String
+
+-- | The @XCursor@ dataype for predefined X cursors.
+data XCursor = XCursor String (Maybe Colour) (Maybe Colour)
+
+-- | The @BCursor@ datatype for bitmap cursors.
+data BCursor = BCursor String (Maybe String) Colour (Maybe Colour)
+
+
+-- -----------------------------------------------------------------------
+-- Cursor Handle
+-- -----------------------------------------------------------------------
+
+-- | Datatypes that describe cursors instantiate the
+-- @class CursorDesignator@.
+class CursorDesignator ch where
+ toCursor :: ch -> Cursor
+
+-- | A @Cursor@ object itself describes a cursor.
+instance CursorDesignator Cursor where
+ -- Internal.
+ toCursor = id
+
+-- | An @XCursor@ object describes a cursor (see type).
+instance CursorDesignator XCursor where
+ -- Internal.
+ toCursor = Cursor . show
+
+-- | A @BCursor@ object describes a cursor (see type).
+instance CursorDesignator BCursor where
+ -- Internal.
+ toCursor = Cursor . show
+
+-- | A @String@ describes a standard X cursor.
+instance CursorDesignator String where
+ -- Internal.
+ toCursor nm = toCursor (XCursor nm Nothing Nothing)
+
+-- | A tuple of @(String,Colour)@ describes a coloured standard
+-- X cursor.
+instance CursorDesignator (String,Colour) where
+ -- Internal.
+ toCursor (nm,fg) = toCursor (XCursor nm (Just fg) Nothing)
+
+-- | A tuple of @(String,Colour,Colour)@ describes a standard
+-- X cursor with foreground and background colour.
+instance CursorDesignator (String,Colour,Colour) where
+ -- Internal.
+ toCursor (nm,fg,bg) = toCursor (XCursor nm (Just fg) (Just bg))
+
+-- | A tuple of @(String,String,Colour,Colour)@ describes a
+-- bitmap cursor with its X bitmap filename, mask filename, foreground
+-- and background colour.
+instance CursorDesignator ([Char],[Char],Colour,Colour) where
+ -- Internal.
+ toCursor (bfile,mfile,fg,bg) =
+ toCursor (BCursor bfile (Just mfile) fg (Just bg))
+
+
+-- -----------------------------------------------------------------------
+-- Standard X Cursors
+-- -----------------------------------------------------------------------
+
+-- | A standard X cursor.
+arrow :: Cursor
+arrow = Cursor "arrow"
+
+-- | A standard X cursor.
+circle :: Cursor
+circle = Cursor "circle"
+
+-- | A standard X cursor.
+clock :: Cursor
+clock = Cursor "clock"
+
+-- | A standard X cursor.
+diamondCross :: Cursor
+diamondCross = Cursor "diamondcross"
+
+-- | A standard X cursor.
+dot :: Cursor
+dot = Cursor "dot"
+
+-- | A standard X cursor.
+drapedBox :: Cursor
+drapedBox = Cursor "drapedbox"
+
+-- | A standard X cursor.
+exchange :: Cursor
+exchange = Cursor "exchange"
+
+-- | A standard X cursor.
+fleur :: Cursor
+fleur = Cursor "fleur"
+
+-- | A standard X cursor.
+gobbler :: Cursor
+gobbler = Cursor "gobbler"
+
+-- | A standard X cursor.
+gumby :: Cursor
+gumby = Cursor "gumby"
+
+-- | A standard X cursor.
+hand1 :: Cursor
+hand1 = Cursor "hand1"
+
+-- | A standard X cursor.
+hand2 :: Cursor
+hand2 = Cursor "hand2"
+
+-- | A standard X cursor.
+pencil :: Cursor
+pencil = Cursor "pencil"
+
+-- | A standard X cursor.
+plus :: Cursor
+plus = Cursor "plus"
+
+-- | A standard X cursor.
+spraycan :: Cursor
+spraycan = Cursor "spraycan"
+
+-- | A standard X cursor.
+tcross :: Cursor
+tcross = Cursor "tcross"
+
+-- | A standard X cursor.
+watch :: Cursor
+watch = Cursor "watch"
+
+-- | A standard X cursor.
+xterm :: Cursor
+xterm = Cursor "xterm"
+
+
+-- -----------------------------------------------------------------------
+-- Parsing/Unparsing
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIValue Cursor where
+ -- Internal.
+ cdefault = Cursor "xterm"
+
+-- | Internal.
+instance Read Cursor where
+ -- Internal.
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ ('{':xs) -> [(Cursor ("{" ++ (takeWhile (/= '}') xs) ++ "}"),"")]
+ xs -> [(Cursor (takeWhile (/= ' ') xs),"")]
+
+-- | Internal.
+instance Show Cursor where
+ -- Internal.
+ showsPrec d (Cursor p) r = p ++ r
+
+
+-- -----------------------------------------------------------------------
+-- XCursor
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance Show XCursor where
+ -- Internal.
+ showsPrec d c r = cshow c ++ r
+ where
+ cshow (XCursor s Nothing Nothing) = s
+ cshow (XCursor s (Just fg) Nothing) =
+ "{" ++ s ++ " " ++ show fg ++ "}"
+ cshow (XCursor s (Just fg) (Just bg)) =
+ "{" ++ s ++ " " ++ show fg ++ " " ++ show bg ++ "}"
+
+
+-- -----------------------------------------------------------------------
+-- BCursor
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance Show BCursor where
+ -- Internal.
+ showsPrec d c r = cshow c ++ r
+ where
+ cshow (BCursor fname Nothing fg Nothing) =
+ "{@" ++ fname ++ " " ++ show fg ++ "}"
+ cshow (BCursor fname (Just bname) fg (Just bg)) =
+ "{" ++ fname ++ " " ++ bname ++ " " ++ show fg ++
+ " " ++ show bg ++ "}"
diff --git a/HTk/Kernel/EventInfo.hs b/HTk/Kernel/EventInfo.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Kernel/EventInfo.hs
@@ -0,0 +1,109 @@
+-- | Encapsulation of Event parameters used in TkCommands.
+module HTk.Kernel.EventInfo(
+ EventParameter(..), -- Type of wish event information
+ -- epToChar/epFromChar convert to and from Wish's 1-character
+ -- names for this information.
+ epToChar, -- :: EventParameter -> Char
+ epFromChar, -- :: Char -> EventParameter
+
+
+ EventInfoSet, -- Describes what event information we are interested in.
+ emptyEventInfoSet, -- :: EventInfoSet
+ mkEventInfoSet, -- :: [EventParameter] -> EventInfoSet
+ listEventInfoSet, -- :: EventInfoSet -> [EventParameter]
+ addEventInfoSet, -- :: EventInfoSet -> [EventParameter] -> EventInfoSet
+ delEventInfoSet, -- :: EventInfoSet -> [EventParameter] -> EventInfoSet
+
+ EventInfo(..), -- Information for a particular event.
+ mkEventInfo, -- :: [(EventParameter,String)] -> EventInfo
+ -- getEventPar, -- :: EventInfo -> EventParameter -> String
+
+ -- restrict, -- :: EventInfo -> EventInfoSet -> Maybe EventInfo
+ -- Checks that all the information in the specified set
+ -- is present and restricts the EventInfo to that.
+
+ defaultEventInfoSet
+ ) where
+
+import qualified Data.Set as Set
+
+import HTk.Kernel.Geometry(Distance)
+
+
+-- --------------------------------------------------------------
+-- Datatypes
+-- --------------------------------------------------------------
+
+newtype EventInfoSet = EventInfoSet (Set.Set EventParameter)
+
+data EventInfo = EventInfo { x :: Distance,
+ y :: Distance,
+ xRoot :: Distance,
+ yRoot :: Distance,
+ button :: Int
+ -- more to come!
+ }
+
+defaultEventInfoSet :: EventInfoSet
+defaultEventInfoSet = mkEventInfoSet [Px, Py, PX, PY, Pb]
+
+
+-- --------------------------------------------------------------
+-- Event Parameters
+-- --------------------------------------------------------------
+
+-- Types of information that come with Events.
+-- (page 298)
+-- The names of these constructors all begin with P followed by
+-- the %keyword required, except for # which is done by HASH
+-- EventParameter needs to instance Ord for WishBasics.
+data EventParameter =
+ HASH | Pa | Pb | Pc | Pd | Pf | Ph | Pk | Pm | Po | Pp |
+ Ps | Pt | Pv | Pw | Px | Py | PA | PB | PE | PK | PN |
+ PR | PS | PT | PW | PX | PY deriving (Eq,Ord,Show,Read)
+
+epToChar :: EventParameter -> Char
+epToChar ep =
+ -- avert your eyes, if of sensitive disposition
+ case show ep of
+ ['P',c] -> c
+ "HASH" -> '#'
+
+epFromChar :: Char -> EventParameter
+epFromChar ch =
+ -- avert your eyes again please!
+ case ch of
+ '#' -> HASH
+ other -> read ['P',other]
+
+
+-- --------------------------------------------------------------
+-- Functions
+-- --------------------------------------------------------------
+
+listEventInfoSet :: EventInfoSet -> [EventParameter]
+listEventInfoSet (EventInfoSet set) = Set.toList set
+
+mkEventInfoSet :: [EventParameter] -> EventInfoSet
+mkEventInfoSet eventPars = EventInfoSet (Set.fromList eventPars)
+
+emptyEventInfoSet :: EventInfoSet
+emptyEventInfoSet = mkEventInfoSet []
+
+addEventInfoSet :: EventInfoSet -> [EventParameter] -> EventInfoSet
+addEventInfoSet (EventInfoSet set) eventPars =
+ EventInfoSet(Set.union set (Set.fromList eventPars))
+
+delEventInfoSet :: EventInfoSet -> [EventParameter] -> EventInfoSet
+delEventInfoSet (EventInfoSet set) eventPars =
+ EventInfoSet(Set.difference set (Set.fromList eventPars))
+
+mkEventInfo :: [(EventParameter,String)] -> EventInfo
+mkEventInfo settings =
+ foldl getEvPar (EventInfo 0 0 0 0 0) settings
+ where getEvPar i (Px, val) = i {x= read val}
+ getEvPar i (Py, val) = i {y= read val}
+ getEvPar i (Pb, val) = i {button= read val}
+ getEvPar i (PX, val) = i {xRoot = read val}
+ getEvPar i (PY, val) = i {yRoot = read val}
+
diff --git a/HTk/Kernel/Font.hs b/HTk/Kernel/Font.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Kernel/Font.hs
@@ -0,0 +1,360 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+-- | The @module Font@ export basic types and classes concerning
+-- font resources.
+module HTk.Kernel.Font (
+
+ FontDesignator(..),
+
+ Font(..),
+ XFont(..),
+
+ xfont,
+
+ FontFamily(..),
+ FontWeight(..),
+ FontSlant(..),
+ FontWidth(..),
+ FontSpacing(..)
+
+) where
+
+import HTk.Kernel.GUIValue
+import Data.Char
+import Util.ExtendedPrelude(simpleSplit)
+
+-- -----------------------------------------------------------------------
+-- Font
+-- -----------------------------------------------------------------------
+
+-- | The general @Font@ datatype.
+newtype Font = Font String
+
+-- | The @XFont@ datatype - representing the elements of an
+-- X font string.
+data XFont =
+ XFont { foundry :: String,
+ family :: Maybe FontFamily,
+ weight :: Maybe FontWeight,
+ slant :: Maybe FontSlant,
+ fontwidth :: Maybe FontWidth,
+ pixels :: (Maybe Int),
+ points :: (Maybe Int),
+ xres :: (Maybe Int),
+ yres :: (Maybe Int),
+ spacing :: Maybe FontSpacing,
+ charwidth :: (Maybe Int),
+ charset :: Maybe String }
+ | XFontAlias String
+
+
+-- -----------------------------------------------------------------------
+-- Font
+-- -----------------------------------------------------------------------
+
+-- | Datatypes that describe a font instantiate the
+-- @class FontDesignator@.
+class FontDesignator fh where
+ toFont :: fh -> Font
+
+-- | A @Font@ object itself represents a font.
+instance FontDesignator Font where
+ -- Internal.
+ toFont = id
+
+-- | An X font string represents a font.
+instance FontDesignator String where
+ -- Internal.
+ toFont = Font
+
+-- | An @XFont@ object (see type) represents a font.
+instance FontDesignator XFont where
+ -- Internal.
+ toFont = Font . show
+
+-- | A @FontFamily@ object describes a font (default values
+-- set for other parameters).
+instance FontDesignator FontFamily where
+ -- Internal.
+ toFont ch = toFont (xfont {family = Just ch})
+
+-- | A tuple of @(FontFamily,Int)@ describes a font with
+-- its font family and points.
+instance FontDesignator (FontFamily,Int) where
+ -- Internal.
+ toFont (ch,s) = toFont (xfont {family = Just ch, points = (Just s)})
+
+-- | A tuple of @(FontFamily,FontWeight,Int)@ describes a font
+-- with its font family, font weight and points.
+instance FontDesignator (FontFamily,FontWeight,Int) where
+ -- Internal.
+ toFont (ch, w, po) =
+ toFont (xfont {family = Just ch, weight = Just w, points = (Just po)})
+
+-- | A tuple of @(FontFamily,FontSlant,Int)@ describes a font
+-- with its font family, font slant and points.
+instance FontDesignator (FontFamily,FontSlant,Int) where
+ -- Internal.
+ toFont (ch, sl, po) =
+ toFont (xfont {family = Just ch, slant = Just sl, points = (Just po)})
+
+
+-- -----------------------------------------------------------------------
+-- X Font Construction
+-- -----------------------------------------------------------------------
+
+-- | Standard font.
+xfont :: XFont
+xfont = XFont {
+ foundry = "Adobe",
+ family = Just Helvetica,
+ weight = Just NormalWeight,
+ slant = Nothing,
+ fontwidth = Just NormalWidth,
+ pixels = Nothing,
+ points = Just 120,
+ xres = Nothing,
+ yres = Nothing,
+ spacing = Nothing,
+ charwidth = Nothing,
+ charset = Nothing
+ }
+
+
+-- -----------------------------------------------------------------------
+-- Font Instantations
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIValue Font where
+ -- Internal.
+ cdefault = toFont xfont
+
+-- | Internal.
+instance Show Font where
+ -- Internal.
+ showsPrec d (Font c) r = c ++ r
+
+-- | Internal.
+instance Read Font where
+ -- Internal.
+ readsPrec p str = [(Font str,[])]
+
+
+-- -----------------------------------------------------------------------
+-- XFont Instantations
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIValue XFont where
+ -- Internal.
+ cdefault = read "-Adobe-Helvetica-Normal-R-Normal-*-*-120-*-*-*-*-*-*"
+
+-- | Internal.
+instance Show XFont where
+ -- Internal.
+ showsPrec d c r = cshow c ++ r
+ where
+ cshow (XFont fo fa we sl sw pi po xr yr sp cw cs) =
+ hy ++ fo ++ hy ++ mshow fa ++ hy ++ mshow we ++ hy ++
+ mshow sl ++ hy ++ mshow sw ++ hy ++ mshow pi ++ hy ++
+ mshow po ++ hy ++ mshow xr ++ hy ++ mshow yr ++ hy ++
+ mshow sp ++ hy ++ mshow cw ++ hy ++ mshow cs ++ hy ++ "*"
+ where hy = "-"
+ cshow (XFontAlias str) = str
+
+-- | Internal.
+instance Read XFont where
+ -- Internal.
+ readsPrec p str = [(cread (dropWhile isSpace str),[])]
+ where
+ cread s@('-':str) = toXFont (simpleSplit (== '-') str)
+ cread str = XFontAlias str
+ toXFont (fo : fa : we : sl : sw : pi : po : xr : yr : sp : cw : cs : y : _) =
+ XFont fo (mread fa) (mread we) (mread sl) (mread sw)
+ (mread pi) (mread po) (mread xr) (mread yr)
+ (mread sp) (mread cw) (mread cs)
+
+
+mshow :: Show a => Maybe a -> String
+mshow Nothing = "*"
+mshow (Just a) = show a
+
+mread :: Read a => String -> Maybe a
+mread "*" = Nothing
+mread str = Just (read str)
+
+
+-- -----------------------------------------------------------------------
+-- FontWeight
+-- -----------------------------------------------------------------------
+
+-- | The @FontWeight@ datatype.
+data FontWeight = NormalWeight | Medium | Bold
+
+-- | Internal.
+instance Read FontWeight where
+ -- Internal.
+ readsPrec p b =
+ case dropWhile (isSpace) (map toLower b) of
+ 'n':'o':'r':'m':'a':'l':xs -> [(NormalWeight,xs)]
+ 'm':'e':'d':'i':'u':'m':xs -> [(Medium,xs)]
+ 'b':'o':'l':'d':xs -> [(Bold,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show FontWeight where
+ -- Internal.
+ showsPrec d p r =
+ (case p of
+ NormalWeight -> "Normal"
+ Medium -> "Medium"
+ Bold -> "Bold"
+ ) ++ r
+
+-- | Internal.
+instance GUIValue FontWeight where
+ -- Internal.
+ cdefault = NormalWeight
+
+
+-- -----------------------------------------------------------------------
+-- FontFamily
+-- -----------------------------------------------------------------------
+
+-- | The @FontFamily@ datatype.
+data FontFamily =
+ Lucida
+ | Times
+ | Helvetica
+ | Courier
+ | Symbol
+ | Other String
+
+-- | Internal.
+instance Read FontFamily where
+ -- Internal.
+ readsPrec p b =
+ case dropWhile (isSpace) (map toLower b) of
+ 'l':'u':'c':'i':'d':'a':xs -> [(Lucida,xs)]
+ 't':'i':'m':'e':'s':xs -> [(Times,xs)]
+ 'h':'e':'l':'v':'e':'t':'i':'c':'a':xs -> [(Helvetica,xs)]
+ 'c':'o':'u':'r':'i':'e':'r':xs -> [(Courier,xs)]
+ 's':'y':'m':'b':'o':'l':xs -> [(Symbol,xs)]
+ fstr -> [(Other fstr, [])]
+
+-- | Internal.
+instance Show FontFamily where
+ -- Internal.
+ showsPrec d p r =
+ (case p of
+ Lucida -> "Lucida"
+ Times -> "Times"
+ Helvetica -> "Helvetica"
+ Courier -> "Courier"
+ Symbol -> "Symbol"
+ Other fstr -> fstr
+ ) ++ r
+
+-- | Internal.
+instance GUIValue FontFamily where
+ -- Internal.
+ cdefault = Courier
+
+
+-- -----------------------------------------------------------------------
+-- FontSlant
+-- -----------------------------------------------------------------------
+
+-- | The @FontSlant@ datatype.
+data FontSlant = Roman | Italic | Oblique
+
+-- | Internal.
+instance Read FontSlant where
+ -- Internal.
+ readsPrec p b =
+ case dropWhile (isSpace) (map toLower b) of
+ 'r':xs -> [(Roman,xs)]
+ 'i':xs -> [(Italic,xs)]
+ 'o':xs -> [(Oblique,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show FontSlant where
+ -- Internal.
+ showsPrec d p r =
+ (case p of
+ Roman -> "R"
+ Italic -> "I"
+ Oblique -> "O"
+ ) ++ r
+
+-- | Internal.
+instance GUIValue FontSlant where
+ -- Internal.
+ cdefault = Roman
+
+
+-- -----------------------------------------------------------------------
+-- FontWidth
+-- -----------------------------------------------------------------------
+
+-- | The @FontWidth@ datatype.
+data FontWidth = NormalWidth | Condensed | Narrow
+
+-- | Internal.
+instance Read FontWidth where
+ -- Internal.
+ readsPrec p b =
+ case dropWhile (isSpace) (map toLower b) of
+ 'n':'o':'r':'m':'a':'l':xs -> [(NormalWidth,xs)]
+ 'c':'o':'n':'d':'e':'n':'s':'e':'d':xs -> [(Condensed,xs)]
+ 'n':'a':'r':'r':'o':'w':xs -> [(Narrow,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show FontWidth where
+ -- Internal.
+ showsPrec d p r =
+ (case p of
+ NormalWidth -> "Normal"
+ Condensed -> "Condensed"
+ Narrow -> "Narrow"
+ ) ++ r
+
+-- | Internal.
+instance GUIValue FontWidth where
+ -- Internal.
+ cdefault = NormalWidth
+
+
+-- -----------------------------------------------------------------------
+-- FontSpacing
+-- -----------------------------------------------------------------------
+
+-- | The @FontSpacing@ datatype.
+data FontSpacing = MonoSpace | Proportional
+
+-- | Internal.
+instance Read FontSpacing where
+ -- Internal.
+ readsPrec p b =
+ case dropWhile (isSpace) (map toLower b) of
+ 'm':xs -> [(MonoSpace,xs)]
+ 'p':xs -> [(Proportional,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show FontSpacing where
+ -- Internal.
+ showsPrec d p r =
+ (case p of
+ MonoSpace -> "M"
+ Proportional -> "P"
+ ) ++ r
+
+-- | Internal.
+instance GUIValue FontSpacing where
+ -- Internal.
+ cdefault = MonoSpace
diff --git a/HTk/Kernel/GUIObject.hs b/HTk/Kernel/GUIObject.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Kernel/GUIObject.hs
@@ -0,0 +1,232 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE OverlappingInstances #-}
+
+module HTk.Kernel.GUIObject(
+
+ GUIObject(..),
+ GUIOBJECT(..),
+ newGUIObject,
+ setObjectKind,
+ setObjectName,
+ getMethods,
+ setMethods,
+ getObjectName,
+ getObjectNo,
+ getObjectKind,
+ OST(..),
+ ConfigID,
+ ConfigOption,
+ Methods(..)
+
+) where
+
+import Reactor.ReferenceVariables
+import Events.Synchronized
+import HTk.Kernel.GUIObjectKind
+import HTk.Kernel.GUIObjectName
+import Util.Object
+import HTk.Kernel.Wish
+import HTk.Kernel.EventInfo
+import HTk.Kernel.GUIValue
+import HTk.Kernel.PackOptions
+import HTk.Kernel.GridPackOptions
+
+
+-- -----------------------------------------------------------------------
+-- class GUIObject
+-- -----------------------------------------------------------------------
+
+class GUIObject w where
+ toGUIObject :: w -> GUIOBJECT
+ cname :: w -> String
+ cset :: GUIValue a => w -> ConfigID -> a -> IO w
+ cget :: GUIValue a => w -> ConfigID -> IO a
+ cset w cid v = setConfig (toGUIObject w) cid v >> return w
+ cget w cid = getConfig (toGUIObject w) cid
+
+instance GUIObject w => Eq w where
+ w1 == w2 = toGUIObject w1 == toGUIObject w2
+
+setConfig :: GUIValue a => GUIOBJECT -> ConfigID -> a -> IO ()
+setConfig (GUIOBJECT _ ostref) cid val =
+ do
+ ost <- getRef ostref
+ execTclScript
+ ((csetCmd (methods ost)) (objectname ost) [(cid, toGUIValue val)])
+
+getConfig :: GUIValue a => GUIOBJECT -> ConfigID -> IO a
+getConfig (GUIOBJECT _ ostref) cid =
+ do
+ ost <- getRef ostref
+ resp <- evalTclScript ((cgetCmd (methods ost)) (objectname ost) cid)
+ creadTk resp
+
+
+-- -----------------------------------------------------------------------
+-- internal GUI object
+-- -----------------------------------------------------------------------
+
+data GUIOBJECT = GUIOBJECT ObjectID (Ref OST) | ROOT
+
+data OST = -- GUI Object State
+ OST { objectkind :: ObjectKind,
+ objectname :: ObjectName,
+ parentobj :: ObjectID,
+ methods :: Methods }
+
+
+-- -----------------------------------------------------------------------
+-- GUIOBJECT instances
+-- -----------------------------------------------------------------------
+
+instance Eq GUIOBJECT where
+ (GUIOBJECT key1 _) == (GUIOBJECT key2 _) = key1 == key2
+ wid1 /= wid2 = not (wid1 == wid2)
+
+instance Ord GUIOBJECT where
+ (GUIOBJECT key1 _) <= (GUIOBJECT key2 _) = key1 <= key2
+
+instance Object GUIOBJECT where
+ objectID (GUIOBJECT oid _) = oid
+
+instance Synchronized GUIOBJECT where
+ synchronize (GUIOBJECT _ ostref) = synchronize ostref
+
+
+-- -----------------------------------------------------------------------
+-- object creation
+-- -----------------------------------------------------------------------
+
+-- do not call directly / use createGUIObject instead
+newGUIObject :: GUIOBJECT -> ObjectKind -> Methods -> IO GUIOBJECT
+newGUIObject par@(GUIOBJECT parId parostref) kind meths =
+ do
+ oid <- newObject
+ parnm <- withRef parostref objectname
+ case kind of
+ TEXTTAG _ -> do
+ ost <- newRef (OST kind (TextPaneItemName parnm
+ (TextTagID oid))
+ parId meths)
+ return (GUIOBJECT oid ost)
+ EMBEDDEDTEXTWIN _ _ -> do
+ ost <- newRef (OST kind (TextPaneItemName parnm
+ (TextTagID oid))
+ parId meths)
+ return (GUIOBJECT oid ost)
+ MENUITEM _ i -> do
+ ost <- newRef (OST kind (MenuItemName parnm i)
+ parId meths)
+ return (GUIOBJECT oid ost)
+ CANVASITEM _ _ -> do
+ ost <- newRef
+ (OST kind (CanvasItemName
+ parnm
+ (CanvasTagOrID oid))
+ parId meths)
+ return (GUIOBJECT oid ost)
+ NOTEBOOKPAGE _ -> do
+ ost <- newRef (OST kind (NoteBookPageName oid)
+ parId meths)
+ return (GUIOBJECT oid ost)
+ WINDOWPANE -> do
+ ost <- newRef (OST kind (PaneName oid)
+ parId meths)
+ return (GUIOBJECT oid ost)
+ LABELFRAME -> do
+ let nm = show parnm ++
+ (if show parnm == "." then "" else ".") ++
+ show oid
+ ost <- newRef (OST kind (LabelFrameName
+ (ObjectName nm) oid)
+ parId meths)
+ return (GUIOBJECT oid ost)
+ SUBWIDGET subKind megaName ->
+ do let objName = "["++show kind++"]"
+ ost <- newRef (OST subKind (ObjectName objName) parId meths)
+ return (GUIOBJECT oid ost)
+ _ -> do
+ let nm = show parnm ++
+ (if show parnm == "." then "" else ".") ++ show oid
+ ost <- newRef (OST kind (ObjectName nm) parId meths)
+ return (GUIOBJECT oid ost)
+newGUIObject ROOT kind meths =
+ do
+ oid <- newObject
+ ost <- newRef (OST kind (ObjectName ("." ++ show oid)) oid meths)
+ return (GUIOBJECT oid ost)
+
+
+-- -----------------------------------------------------------------------
+-- GUI object identity
+-- -----------------------------------------------------------------------
+
+getObjectNo :: GUIOBJECT -> Int
+getObjectNo (GUIOBJECT (ObjectID i) _) = i
+{-# INLINE getObjectNo #-}
+
+
+-- -----------------------------------------------------------------------
+-- GUIObject methods
+-- -----------------------------------------------------------------------
+
+getMethods :: GUIOBJECT -> IO Methods
+getMethods (GUIOBJECT _ ostref) = withRef ostref methods
+
+setMethods :: GUIOBJECT -> Methods -> IO ()
+setMethods (GUIOBJECT _ ostref) meth =
+ changeRef ostref (\o -> o{methods = meth})
+
+
+-- -----------------------------------------------------------------------
+-- Object Kind
+-- -----------------------------------------------------------------------
+
+getObjectKind :: GUIOBJECT -> IO ObjectKind
+getObjectKind (GUIOBJECT _ ostref) = withRef ostref objectkind
+
+setObjectKind :: GUIOBJECT -> ObjectKind -> IO ()
+setObjectKind (GUIOBJECT _ ostref) kind =
+ changeRef ostref (\o -> o{objectkind = kind})
+
+
+-- -----------------------------------------------------------------------
+-- Object Name Related Functions
+-- -----------------------------------------------------------------------
+
+getObjectName :: GUIOBJECT -> IO ObjectName
+getObjectName (GUIOBJECT _ ostref) = withRef ostref objectname
+
+setObjectName :: GUIOBJECT -> ObjectName -> IO ()
+setObjectName (GUIOBJECT _ ostref) name =
+ changeRef ostref (\o -> o{objectname = name})
+
+
+-- -----------------------------------------------------------------------
+-- configuration options
+-- -----------------------------------------------------------------------
+
+type ConfigID = String
+type ConfigOption = (ConfigID, GUIVALUE)
+
+
+-- -----------------------------------------------------------------------
+-- Methods
+-- -----------------------------------------------------------------------
+
+data Methods =
+ Methods { cgetCmd :: ObjectName -> ConfigID -> TclScript,
+ csetCmd :: ObjectName -> [ConfigOption] -> TclScript,
+ createCmd :: ObjectName -> ObjectKind -> ObjectName ->
+ ObjectID -> [ConfigOption] -> TclScript,
+ packCmd :: ObjectName -> [PackOption] -> TclScript,
+ gridCmd :: ObjectName -> [GridPackOption] -> TclScript,
+ destroyCmd :: ObjectName -> TclScript,
+ bindCmd :: ObjectName -> BindTag -> [WishEvent] ->
+ EventInfoSet -> Bool -> TclScript,
+ unbindCmd :: ObjectName -> BindTag -> [WishEvent] ->
+ Bool -> TclScript,
+ cleanupCmd :: ObjectID -> ObjectName -> TclScript }
+
+
diff --git a/HTk/Kernel/GUIObjectKind.hs b/HTk/Kernel/GUIObjectKind.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Kernel/GUIObjectKind.hs
@@ -0,0 +1,125 @@
+module HTk.Kernel.GUIObjectKind (
+
+ ObjectKind(..),
+ CanvasItemKind(..),
+ MenuItemKind(..)
+
+) where
+
+import HTk.Kernel.GUIValue
+import HTk.Kernel.Geometry
+import HTk.Kernel.Resources
+import HTk.Kernel.GUIObjectName
+
+
+-- -----------------------------------------------------------------------
+-- OBJECT Kind
+-- -----------------------------------------------------------------------
+
+data ObjectKind =
+ FRAME
+ | LABEL
+ | MESSAGE
+ | BUTTON
+ | CHECKBUTTON
+ | RADIOBUTTON
+ | MENUBUTTON
+ | MENU
+ | MENUITEM MenuItemKind Int -- Tcl ID
+ | OPTIONMENU [GUIVALUE] -- unpacked elements
+ | LISTBOX [GUIVALUE] -- unpacked elements
+ | SEPARATOR
+ | ENTRY
+ | TEXT GUIVALUE -- unpacked lines of text
+ | CANVAS
+ | SCALE
+ | SCROLLBAR
+ | TOPLEVEL
+ | TEXTTAG [GUIVALUE]
+ | EMBEDDEDTEXTWIN GUIVALUE ObjectName
+ | CANVASITEM CanvasItemKind Coord
+ | POSTSCRIPT
+ | SESSION
+ | GRAPH
+ | ABSTRACT
+ | WIDGET String
+ | NOTEBOOK
+ | NOTEBOOKPAGE String -- title
+ | LABELFRAME
+ | PANEDWINDOW Orientation -- orientation of panes
+ | WINDOWPANE
+ | COMBOBOX Bool -- editable
+ | BOX Orientation Flexibility
+ | SUBWIDGET ObjectKind String
+
+data CanvasItemKind =
+ ARC
+ | LINE
+ | POLYGON
+ | RECTANGLE
+ | OVAL
+ | BITMAPITEM
+ | IMAGEITEM
+ | TEXTITEM
+ | CANVASTAG
+ | EMBEDDEDCANVASWIN
+
+data MenuItemKind =
+ MENUCASCADE
+ | MENUCOMMAND
+ | MENUCHECKBUTTON
+ | MENURADIOBUTTON
+ | MENUSEPARATOR
+
+
+-- -----------------------------------------------------------------------
+-- Unparsing of Widget Kind
+-- -----------------------------------------------------------------------
+
+instance Show ObjectKind where
+ showsPrec d p r =
+ (case p of
+ FRAME -> "frame"
+ LABEL -> "label"
+ MESSAGE -> "message"
+ CHECKBUTTON -> "checkbutton"
+ BUTTON -> "button"
+ RADIOBUTTON -> "radiobutton"
+ MENUBUTTON -> "menubutton"
+ MENU -> "menu"
+ (OPTIONMENU _) -> "tk_optionMenu"
+ (LISTBOX _) -> "listbox"
+ SEPARATOR -> "separator"
+ ENTRY -> "entry"
+ (TEXT _) -> "text"
+ CANVAS -> "canvas"
+ SCALE -> "scale"
+ SCROLLBAR -> "scrollbar"
+ TOPLEVEL -> "toplevel"
+ (CANVASITEM ARC _) -> "arc"
+ (CANVASITEM LINE _) -> "line"
+ (CANVASITEM POLYGON _) -> "polygon"
+ (CANVASITEM RECTANGLE _) -> "rectangle"
+ (CANVASITEM OVAL _) -> "oval"
+ (CANVASITEM BITMAPITEM _) -> "bitmap"
+ (CANVASITEM IMAGEITEM _) -> "image"
+ (CANVASITEM TEXTITEM _) -> "text"
+ (CANVASITEM CANVASTAG _) -> "tag"
+ (CANVASITEM EMBEDDEDCANVASWIN _) -> "window"
+ (MENUITEM MENUCASCADE _) -> "cascade"
+ (MENUITEM MENUCOMMAND _) -> "command"
+ (MENUITEM MENUCHECKBUTTON _) -> "checkbutton"
+ (MENUITEM MENURADIOBUTTON _) -> "radiobutton"
+ (MENUITEM MENUSEPARATOR _) -> "separator"
+ (EMBEDDEDTEXTWIN _ _) -> "window"
+ (TEXTTAG _) -> "tag"
+ (WIDGET kind) -> kind
+ NOTEBOOK -> "tixNoteBook"
+ NOTEBOOKPAGE _ -> ""
+ LABELFRAME -> "tixLabelFrame"
+ PANEDWINDOW _ -> "tixPanedWindow"
+ COMBOBOX _ -> "tixComboBox"
+ WINDOWPANE -> ""
+ BOX _ _ -> "frame"
+ SUBWIDGET subKind megaName -> megaName ++ " subwidget " ++ show subKind)
+ ++ r
diff --git a/HTk/Kernel/GUIObjectName.hs b/HTk/Kernel/GUIObjectName.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Kernel/GUIObjectName.hs
@@ -0,0 +1,100 @@
+module HTk.Kernel.GUIObjectName (
+
+ ObjectName(..),
+ TextItemName(..),
+ WidgetName(..),
+ CanvasTagOrID(..),
+ toWidgetName
+
+) where
+
+import Util.Object(ObjectID(..))
+import HTk.Kernel.GUIValue
+
+
+-- -----------------------------------------------------------------------
+-- Object Name
+-- -----------------------------------------------------------------------
+
+data ObjectName =
+ ObjectName String -- widget
+ | MenuItemName ObjectName Int -- menu item
+ | CanvasItemName ObjectName CanvasTagOrID -- canvas item
+ | TextPaneItemName ObjectName TextItemName -- text item
+ | NoteBookPageName ObjectID
+ | LabelFrameName ObjectName ObjectID
+ | PaneName ObjectID
+
+data TextItemName =
+ TextTagID ObjectID
+ | TextItemPosition GUIVALUE -- Point actually
+ | EmbeddedWindowName ObjectName
+
+data CanvasTagOrID = CanvasTagOrID ObjectID
+ | CanvasTagNot CanvasTagOrID
+ | CanvasTagAnd CanvasTagOrID CanvasTagOrID
+ | CanvasTagOr CanvasTagOrID CanvasTagOrID
+ | CanvasTagXOr CanvasTagOrID CanvasTagOrID
+
+toWidgetName :: ObjectName -> WidgetName
+toWidgetName (ObjectName s) = WidgetName s
+{-# INLINE toWidgetName #-}
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+instance Show ObjectName where
+ showsPrec d p r =
+ (case p of
+ ObjectName s -> s
+ MenuItemName s _ -> show s
+ TextPaneItemName s _ -> show s
+ CanvasItemName s _ -> show s
+ NoteBookPageName oid ->
+ "[global v" ++ show oid ++ ";set dummy $v" ++ show oid ++ "]"
+ LabelFrameName _ oid ->
+ "[global v" ++ show oid ++ ";set dummy $v" ++ show oid ++
+ "]"
+ PaneName oid ->
+ "[global v" ++ show oid ++ ";set dummy $v" ++ show oid ++ "]") ++ r
+
+instance Show TextItemName where
+ showsPrec d p r =
+ (case p of
+ (TextTagID (ObjectID i)) -> "tag" ++ show i
+ (TextItemPosition p) -> show p
+ (EmbeddedWindowName p) -> show p
+ ) ++ r
+
+
+instance Show CanvasTagOrID where
+ showsPrec d (CanvasTagOrID i) r = "$v" ++ show i ++ r
+ showsPrec d (CanvasTagAnd t1 t2) r = abr $ show t1 ++ "&&" ++ show t2 ++ r
+ showsPrec d (CanvasTagOr t1 t2) r = abr $ show t1 ++ "||" ++ show t2 ++ r
+ showsPrec d (CanvasTagXOr t1 t2) r = abr $ show t1 ++ "^" ++ show t2 ++ r
+ showsPrec d (CanvasTagNot t1) r = abr $ "!"++ show t1 ++ r
+
+abr :: String -> String
+abr s = "("++s++")"
+
+-- -----------------------------------------------------------------------
+-- widget path names
+-- -----------------------------------------------------------------------
+
+data WidgetName = WidgetName String
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+instance GUIValue WidgetName where
+ cdefault = WidgetName "."
+
+instance Read WidgetName where
+ readsPrec p b = [(WidgetName b,[])]
+
+instance Show WidgetName where
+ showsPrec d (WidgetName p) r = p ++ r
diff --git a/HTk/Kernel/GUIValue.hs b/HTk/Kernel/GUIValue.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Kernel/GUIValue.hs
@@ -0,0 +1,282 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverlappingInstances #-}
+
+module HTk.Kernel.GUIValue (
+ Generator(..),
+
+ GUIVALUE(..),
+ GUIValue(..),
+
+ RawData(..),
+
+ TkCommand(..),
+
+ creadTk,
+ toTkString,
+ escapeString,
+ delimitString,
+
+ illegalGUIValue
+ ) where
+
+import Data.Char
+import Data.Maybe(isJust)
+import Data.List (find)
+
+-- --------------------------------------------------------------------------
+-- Options
+-- --------------------------------------------------------------------------
+
+data GUIVALUE = GUIVALUE Generator String
+
+data Generator = HaskellTk | Tk
+
+
+-- --------------------------------------------------------------------------
+-- Value Conversions
+-- --------------------------------------------------------------------------
+
+class (Show a, Read a) => GUIValue a where
+ cdefault :: a
+ toGUIValue :: a -> GUIVALUE
+ maybeGUIValue :: GUIVALUE -> (Maybe a)
+ fromGUIValue :: GUIVALUE -> a
+ toGUIValue v =
+ GUIVALUE HaskellTk (toTkString (show v))
+ maybeGUIValue (GUIVALUE HaskellTk s) =
+ case [x | (x,t) <- reads (fromTkString s), ("","") <- lex t] of
+ [x] -> Just x
+ _ -> Nothing
+ maybeGUIValue (GUIVALUE Tk s) =
+ case [x | (x,t) <- reads s, ("","") <- lex t] of
+ [x] -> Just x
+ _ -> Nothing
+
+ fromGUIValue val = case (maybeGUIValue val) of (Just a) -> a
+
+
+creadTk :: GUIValue a => String -> IO a
+creadTk s =
+ case maybeGUIValue (GUIVALUE Tk (restoreNL s)) of
+-- Nothing -> return cdefault
+ Nothing -> do {
+ print ("NO PARSE: " ++ s);
+ ioError illegalGUIValue
+ }
+ (Just v) -> return v
+ where restoreNL [] = []
+ restoreNL ('\\':'n':str) = '\n' : restoreNL str
+ restoreNL (x:str) = x : restoreNL str
+
+
+
+illegalGUIValue :: IOError
+illegalGUIValue = userError "illegal GUI value"
+
+
+-- --------------------------------------------------------------------------
+-- GUIVALUE
+-- --------------------------------------------------------------------------
+
+instance GUIValue GUIVALUE where
+ cdefault = GUIVALUE HaskellTk ""
+ toGUIValue = id
+ maybeGUIValue = Just . id
+
+instance Read GUIVALUE where
+ readsPrec p b =
+ case b of
+ xs -> [(GUIVALUE HaskellTk xs,[])]
+
+instance Show GUIVALUE where
+ showsPrec d (GUIVALUE _ p) r = p ++ r
+
+
+
+-- --------------------------------------------------------------------------
+-- ()
+-- --------------------------------------------------------------------------
+
+instance GUIValue () where
+ cdefault = ()
+ maybeGUIValue _ = Just ()
+
+
+-- --------------------------------------------------------------------------
+-- Raw Data
+-- --------------------------------------------------------------------------
+
+newtype RawData = RawData String
+
+instance Read RawData where
+ readsPrec p b = [(RawData b,[])]
+
+instance Show RawData where
+ showsPrec d (RawData p) r = p ++ r
+
+instance GUIValue RawData where
+ cdefault = RawData ""
+
+
+-- --------------------------------------------------------------------------
+-- String
+-- --------------------------------------------------------------------------
+
+instance GUIValue [Char] where
+ cdefault = []
+ toGUIValue str = GUIVALUE HaskellTk (toTkString str)
+ maybeGUIValue (GUIVALUE HaskellTk str) = Just (read (fromTkString str))
+ maybeGUIValue (GUIVALUE Tk str) = Just str
+ {- tk delivers raw, unquoted strings - great !! -}
+
+
+-- --------------------------------------------------------------------------
+-- [String]
+-- --------------------------------------------------------------------------
+
+instance GUIValue [[Char]] where
+ cdefault = []
+ toGUIValue l = GUIVALUE HaskellTk (toTkString (unlines l))
+ maybeGUIValue (GUIVALUE HaskellTk str) = Just (breakStr (read (fromTkString str)))
+ maybeGUIValue (GUIVALUE Tk str) = Just (breakStr str)
+
+
+-- Tk's lists lists of strings separated by blanks, but strings containing
+-- blanks are enclosed by braces. Hence this:
+breakStr :: String-> [String]
+breakStr str = brk (dropWhile (' ' ==) str) where
+ brk [] = [[]]
+ brk (x:xs) = if x == '{' then let (c, r) = break ('}' ==) xs
+ in c:brk (dropWhile ('}' ==) r)
+ else let (c, r) = break (' ' ==) xs
+ in (x:c):brk (dropWhile (' ' ==) r)
+
+
+-- --------------------------------------------------------------------------
+-- Command
+-- --------------------------------------------------------------------------
+
+newtype TkCommand = TkCommand String
+
+instance GUIValue TkCommand where
+ cdefault = TkCommand "skip"
+ toGUIValue c = GUIVALUE HaskellTk (show c)
+
+instance Show TkCommand where
+ showsPrec d (TkCommand s) r = "{" ++ s ++ "}" ++ r
+
+instance Read TkCommand where
+ readsPrec p b = [(TkCommand cmd,[])]
+ where cmd = take (length b - 2) (drop 1 b)
+
+
+-- --------------------------------------------------------------------------
+-- Bool
+-- --------------------------------------------------------------------------
+
+instance GUIValue Bool where
+ cdefault = False
+ toGUIValue False = GUIVALUE HaskellTk "0"
+ toGUIValue True = GUIVALUE HaskellTk "1"
+ maybeGUIValue (GUIVALUE _ "0") = Just False
+ maybeGUIValue (GUIVALUE _ "1") = Just True
+ maybeGUIValue (GUIVALUE _ _ ) = Nothing
+
+
+-- --------------------------------------------------------------------------
+-- Int
+-- --------------------------------------------------------------------------
+
+instance GUIValue Int where
+ cdefault = 0
+
+
+-- --------------------------------------------------------------------------
+-- Double
+-- --------------------------------------------------------------------------
+
+instance GUIValue Double where
+ cdefault = 0.0
+
+-- --------------------------------------------------------------------------
+-- Tuples
+-- --------------------------------------------------------------------------
+
+instance (GUIValue a, GUIValue b)=> GUIValue (a, b) where
+ cdefault = (cdefault, cdefault)
+
+
+
+-- --------------------------------------------------------------------------
+-- Tk String Conversion
+-- --------------------------------------------------------------------------
+
+-- Conversion to Tk: escape and quote
+toTkString :: String -> String
+toTkString = quoteString . escapeString
+
+-- escapeString quotes the special characters inside String.
+escapeString :: String -> String
+escapeString = concat . (map quoteChar)
+
+-- quote places quotes around a String
+quoteString :: String -> String
+quoteString str = '\"':(str++"\"")
+
+-- delimitString places quotes around a String, if it contains
+-- spaces, making it possible to use it as a single argument.
+delimitString :: String -> String
+delimitString "" = "\"\""
+delimitString str =
+ if isJust (find isSpace str)
+ then quoteString str else str
+
+
+
+-- quoteChar quotes characters special to Tcl, but not %.
+quoteChar :: Char -> String
+quoteChar ch =
+ case ch of
+ '\\' -> "\\\\"
+ '\"' -> "\\\""
+ '\n' -> "\\n"
+ '{' -> "\\{"
+ '}' -> "\\}"
+ '$' -> "\\$"
+ '[' -> "\\["
+ ']' -> "\\]"
+ ';' -> "\\;"
+ other ->
+ if isPrint ch
+ then
+ [ch]
+ else
+ let
+ nchar = ord ch
+ in
+ if (nchar<0 || nchar >=256)
+ then
+ error "TclSyntax: bad char"
+ else
+ let
+ (hi,lo) = nchar `divMod` 16
+ in
+ ['\\','x',intToDigit hi,intToDigit lo]
+
+
+fromTkString :: String-> String
+
+fromTkString [] = []
+-- fromTkString ('\"':str) = fromTkString str
+fromTkString ('\\':'\\':str) = '\\' : fromTkString str
+fromTkString ('\\':'n':str) = '\n' : fromTkString str
+fromTkString ('\\':'t':str) = '\t' : fromTkString str
+fromTkString ('\\':'[':str) = '[' : fromTkString str
+fromTkString ('\\':']':str) = ']' : fromTkString str
+fromTkString ('\\':'{':str) = '{' : fromTkString str
+fromTkString ('\\':'}':str) = '}' : fromTkString str
+fromTkString ('\\':'$':str) = '$' : fromTkString str
+fromTkString ('\\':';':str) = ';' : fromTkString str
+fromTkString ('\\':'\"':str) = '\"' : fromTkString str
+fromTkString (x:str) = x : fromTkString str
+
diff --git a/HTk/Kernel/Geometry.hs b/HTk/Kernel/Geometry.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Kernel/Geometry.hs
@@ -0,0 +1,288 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+-- | The @module Geometry@ exports basic geometric types and
+-- functionality.
+module HTk.Kernel.Geometry (
+
+ Distance(..),
+
+ Size,
+ Coord,
+ Position,
+ Geometry,
+
+ cm, pp, mm, ic, tocm, toinch
+
+) where
+
+import HTk.Kernel.GUIValue
+import Data.Char
+
+
+-- -----------------------------------------------------------------------
+-- Position/Size
+-- -----------------------------------------------------------------------
+
+-- | The @Position@ - a pair of two @Distance@ values.
+type Position = (Distance, Distance)
+
+-- | The @Size@ datatype - a pair of two @Distance@
+-- values.
+type Size = (Distance, Distance)
+
+-- | The @Point@ datatype.
+data Point = Point (Distance, Distance)
+
+-- | Internal.
+instance GUIValue (Distance,Distance) where
+ -- Internal.
+ cdefault = (cdefault,cdefault)
+ -- Internal.
+ toGUIValue v = GUIVALUE HaskellTk (show (Point v))
+ -- Internal.
+ maybeGUIValue (GUIVALUE _ s) =
+ case [x | (Point x,t) <- reads s, ("","") <- lex t] of
+ [x] -> Just x
+ _ -> Nothing
+
+-- | Internal.
+instance Read Point where
+ -- Internal.
+ readsPrec p b =
+ case (readsPrec p b) of
+ [(x,xs)] -> (case (readsPrec p xs) of
+ [(y,ys)] -> [(Point (x,y),ys)]
+ _ -> []
+ )
+ _ -> []
+
+-- | Internal.
+instance Show Point where
+ showsPrec d (Point (x,y)) r = show x ++ " " ++ show y ++ r
+
+
+-- -----------------------------------------------------------------------
+-- Geometry
+-- -----------------------------------------------------------------------
+
+-- | The Geometry datatype - normally representing position, width and
+-- height.
+type Geometry = (Distance, Distance, Distance, Distance)
+
+data Geometry' = Geometry' Geometry
+
+-- | Internal.
+instance GUIValue (Distance, Distance, Distance, Distance) where
+ cdefault = (cdefault, cdefault, cdefault, cdefault)
+ toGUIValue v = GUIVALUE HaskellTk (show (Geometry' v))
+ maybeGUIValue (GUIVALUE _ s) =
+ case [x | (Geometry' x,t) <- reads s, ("","") <- lex t] of
+ [x] -> Just x
+ _ -> Nothing
+
+-- | Internal.
+instance Show Geometry' where
+ -- Internal.
+ showsPrec d (Geometry' (w, h, x, y)) r =
+ show w ++ "x" ++ show h ++ "+" ++ show x ++ "+" ++ show y ++ r
+
+-- | Internal.
+instance Read Geometry' where
+ -- Internal.
+ readsPrec p str =
+ case readsPrec p str of
+ [(w,s')] -> readsPrecX1 p s' w
+ _ -> []
+ where
+ readsPrecX1 p s w =
+ case (dropWhile isSpace s) of
+ ('x':s') -> readsPrecH p s' w
+ s' -> readsPrecH p s' w
+ readsPrecH p s w =
+ case readsPrec p s of
+ [(h,s')] -> readsPrecP1 p s' w h
+ _ -> []
+ readsPrecP1 p s w h =
+ case (dropWhile isSpace s) of
+ ('+':s') -> readsPrecX p s' w h
+ s' -> readsPrecX p s' w h
+ readsPrecX p s w h =
+ case readsPrec p s of
+ [(x,s')] -> readsPrecP2 p s' w h x
+ _ -> []
+ readsPrecP2 p s w h x =
+ case (dropWhile isSpace s) of
+ ('+':s') -> readsPrecY p s' w h x
+ s' -> readsPrecY p s' w h x
+ readsPrecY p s w h x =
+ case readsPrec p s of
+ [(y,s')] -> [(Geometry' (w,h,x,y),s')]
+ _ -> []
+
+
+-- -----------------------------------------------------------------------
+-- Coordinates
+-- -----------------------------------------------------------------------
+
+-- | The @Coord@ datatype - e.g. representing the coords of
+-- a canvas item.
+type Coord = [Position]
+
+-- | Internal.
+data Coord' = Coord' Coord
+
+-- | Internal.
+instance GUIValue [(Distance,Distance)] where
+ cdefault = []
+ toGUIValue v = GUIVALUE HaskellTk (show (Coord' v))
+ maybeGUIValue (GUIVALUE _ s) =
+ case [x | (Coord' x,t) <- reads s, ("","") <- lex t] of
+ [x] -> Just x
+ _ -> Nothing
+
+-- | Internal.
+instance Show Coord' where
+ -- Internal.
+ showsPrec d (Coord' []) r =
+ r
+ showsPrec d (Coord' (x:l)) r =
+ show (toGUIValue x) ++ " " ++ showsPrec d (Coord' l) r
+
+-- | Internal.
+instance Read Coord' where
+ readsPrec p s =
+ case (dropWhile isSpace s) of
+ [] -> [(Coord' [],[])]
+ s' -> readsPrecElem p s'
+ where
+ readsPrecElem p s =
+ case (readsPrec p s) of
+ [(Point pos,s')] -> readsPrecTail p s' pos
+ _ -> []
+ readsPrecTail p s pos =
+ case (readsPrec p s) of
+ [(Coord' l,s')] -> [(Coord' (pos:l),s')]
+ _ -> []
+
+
+-- -----------------------------------------------------------------------
+-- Distance
+-- -----------------------------------------------------------------------
+
+-- | The @Distance@ datatype - general representation of
+-- distances in HTk.
+newtype Distance = Distance Int deriving (Eq, Ord)
+
+-- | Internal.
+instance Show Distance where
+ -- Internal.
+ showsPrec d (Distance i) r = showsPrec d i r
+
+-- | Internal.
+instance Read Distance where
+ -- Internal.
+ readsPrec p b =
+ case (readsPrec p b) of
+ [(i,xs)] -> [(Distance (round (i::Double)),xs)]
+ _ -> []
+
+-- | Internal.
+instance GUIValue Distance where
+ cdefault = Distance (-100)
+
+-- | Internal.
+instance Enum Distance where
+ fromEnum (Distance d)= d
+ toEnum d = Distance d
+
+-- | Internal.
+instance Num Distance where
+ (Distance p1) + (Distance p2) = Distance (p1 + p2)
+ (Distance p1) * (Distance p2) = Distance (p1 * p2)
+ negate (Distance p) = Distance (negate p)
+ abs (Distance p) = Distance (abs p)
+ -- Internal.
+ signum (Distance p) = Distance (signum p)
+ -- Internal.
+ fromInteger i = Distance (fromInteger i)
+
+-- | Internal.
+instance Real Distance where
+ -- Internal.
+ toRational (Distance i) = toRational i
+
+-- | Internal.
+instance Integral Distance where
+ -- Internal.
+ toInteger (Distance i) = toInteger i
+ -- Internal.
+ (Distance d1) `quotRem` (Distance d2) = (Distance q, Distance d)
+ where (q, d)= d1 `quotRem` d2
+
+-- -----------------------------------------------------------------------
+-- Distance List
+-- -----------------------------------------------------------------------
+
+data Distances = Distances [Distance]
+
+-- | Internal.
+instance GUIValue [Distance] where
+ -- Internal.
+ cdefault = []
+ -- Internal.
+ toGUIValue v = GUIVALUE HaskellTk (show (Distances v))
+ -- Internal.
+ maybeGUIValue (GUIVALUE _ s) =
+ case [x | (Distances x,t) <- reads s, ("","") <- lex t] of
+ [x] -> Just x
+ _ -> Nothing
+
+instance Show Distances where
+ showsPrec d (Distances []) r =
+ r
+ showsPrec d (Distances (x:l)) r =
+ show x ++ " " ++ showsPrec d (Distances l) r
+
+instance Read Distances where
+ readsPrec p s =
+ case (dropWhile isSpace s) of
+ [] -> [(Distances [],[])]
+ s' -> readsPrecElem p s'
+ where
+ readsPrecElem p s =
+ case (readsPrec p s) of
+ [(d,s')] -> readsPrecTail p s' d
+ _ -> []
+ readsPrecTail p s d =
+ case (readsPrec p s) of
+ [(Distances l,s')] -> [(Distances (d:l),s')]
+ _ -> []
+
+
+-- -----------------------------------------------------------------------
+-- Conversion
+-- -----------------------------------------------------------------------
+
+-- | Conversion from cm to @Distance@.
+cm :: Double -> Distance
+cm c = (Distance . round) (c * 35.4)
+
+-- | Conversion from points to @Distance@.
+pp :: Double -> Distance
+pp i = ic (i / 72)
+
+-- | Conversion from mm to @Distance@.
+mm :: Double -> Distance
+mm i = cm (i / 10)
+
+-- | Conversion from inch to @Distance@.
+ic :: Double -> Distance
+ic i = (Distance . round) (i * 90.0)
+
+-- | Conversion from @Distance@ to cm.
+tocm :: Distance -> Double
+tocm (Distance p) = (fromIntegral p) / 35.4
+
+-- | Conversion from @Distance@ to inch.
+toinch :: Distance -> Double
+toinch (Distance p) = (fromIntegral p) / 90.0
diff --git a/HTk/Kernel/GridPackOptions.hs b/HTk/Kernel/GridPackOptions.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Kernel/GridPackOptions.hs
@@ -0,0 +1,71 @@
+-- | Pack options for the grid geometry manager.
+module HTk.Kernel.GridPackOptions (
+
+ GridPackOption(..),
+ StickyKind(..),
+ showGridPackOptions
+
+) where
+
+
+-- -----------------------------------------------------------------------
+-- grid pack options
+-- -----------------------------------------------------------------------
+
+-- | Various pack options of the grid geometry manager.
+data GridPackOption =
+ Column Int -- ^ the column to pack the widget
+ | Row Int -- ^ the row to pack the widget
+ | GridPos (Int, Int) -- ^ row column and row to pack the widget
+ | Sticky StickyKind -- ^ pack widgets sticky to the grid (see type StickyKind)
+ | Columnspan Int -- ^ columnspan like HTML
+ | Rowspan Int -- ^ rowspan like HTML
+ | GridPadX Int -- ^ horizontal pad
+ | GridPadY Int -- ^ vertical pad
+ | GridIPadX Int -- ^ inner horizontal pad
+ | GridIPadY Int -- ^ inner vertical pad
+
+-- | Internal.
+instance Show GridPackOption where
+ showsPrec d (Row i) r = "row " ++ show i ++ r
+ showsPrec d (Column i) r = "column " ++ show i ++ r
+ showsPrec d (GridPos (i, j)) r =
+ "column " ++ show i ++ " -row " ++ show j ++ r
+ showsPrec d (Sticky kind) r = "sticky " ++ show kind ++ r
+ showsPrec d (Columnspan i) r = "columnspan " ++ show i ++ r
+ showsPrec d (Rowspan i) r = "rowspan " ++ show i ++ r
+ showsPrec d (GridPadX i) r = "padx " ++ show i ++ r
+ showsPrec d (GridPadY i) r = "pady " ++ show i ++ r
+ showsPrec d (GridIPadX i) r = "ipadx " ++ show i ++ r
+ showsPrec d (GridIPadY i) r = "ipady " ++ show i ++ r
+
+-- | The @StickyKind@ datatype - sticky packing to the grid.
+data StickyKind =
+ N | S | E | W
+ | NS | NE | NW | SE | SW | EW
+ | NSE | NSW | NEW | SEW
+ | NSEW
+
+-- | Internal.
+instance Show StickyKind where
+ showsPrec d N r = "n"
+ showsPrec d S r = "s"
+ showsPrec d E r = "e"
+ showsPrec d W r = "w"
+ showsPrec d NS r = "ns"
+ showsPrec d NE r = "ne"
+ showsPrec d NW r = "nw"
+ showsPrec d SE r = "se"
+ showsPrec d SW r = "sw"
+ showsPrec d EW r = "ew"
+ showsPrec d NSE r = "nse"
+ showsPrec d NSW r = "nsw"
+ showsPrec d NEW r = "new"
+ showsPrec d SEW r = "sew"
+ showsPrec d NSEW r = "nsew"
+
+-- | Internal.
+showGridPackOptions :: [GridPackOption] -> String
+showGridPackOptions [] = ""
+showGridPackOptions (opt : opts) =
+ "-" ++ show opt ++ " " ++ showGridPackOptions opts
diff --git a/HTk/Kernel/PackOptions.hs b/HTk/Kernel/PackOptions.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Kernel/PackOptions.hs
@@ -0,0 +1,67 @@
+-- | Packing options for the pack geometry manager.
+module HTk.Kernel.PackOptions (
+
+ PackOption(..),
+ SideSpec(..), -- left, right, top, bottom
+ FillSpec(..),
+ showPackOptions
+
+) where
+
+import HTk.Kernel.Resources
+import HTk.Kernel.Geometry
+
+
+-- -----------------------------------------------------------------------
+-- standard pack options
+-- -----------------------------------------------------------------------
+
+-- | The @SideSpec@ datatype.
+data SideSpec = AtLeft | AtRight | AtTop | AtBottom
+
+-- | The @FillSpec@ datatype.
+data FillSpec = X | Y | Both | None
+
+-- | Internal.
+instance Show SideSpec where
+ -- Internal.
+ showsPrec d AtLeft r = "left" ++ r
+ showsPrec d AtRight r = "right" ++ r
+ showsPrec d AtTop r = "top" ++ r
+ showsPrec d AtBottom r = "bottom" ++ r
+
+-- | Internal.
+instance Show FillSpec where
+ -- Internal.
+ showsPrec d X r = "x" ++ r
+ showsPrec d Y r = "y" ++ r
+ showsPrec d Both r = "both" ++ r
+ showsPrec d None r = "none" ++ r
+
+data PackOption =
+ Side SideSpec -- ^ side to pack the widget
+ | Fill FillSpec -- ^ orientations to fill.
+ | Expand Toggle -- ^ expand toggle
+ | IPadX Distance -- ^ inner horizontal pad
+ | IPadY Distance -- ^ inner vertical pad
+ | PadX Distance -- ^ horizontal pad
+ | PadY Distance -- ^ vertical pad
+ | Anchor Anchor -- ^ anchor position
+
+-- | Internal.
+instance Show PackOption where
+ -- Internal.
+ showsPrec d (Side spec) r = "side " ++ show spec ++ r
+ showsPrec d (Fill spec) r = "fill " ++ show spec ++ r
+ showsPrec d (Expand t) r = "expand " ++ show t ++ r
+ showsPrec d (IPadX i) r = "ipadx " ++ show i ++ r
+ showsPrec d (IPadY i) r = "ipady " ++ show i ++ r
+ showsPrec d (PadX i) r = "padx " ++ show i ++ r
+ showsPrec d (PadY i) r = "pady " ++ show i ++ r
+ showsPrec d (Anchor a) r = "anchor " ++ show a ++ r
+
+-- | Internal.
+showPackOptions :: [PackOption] -> String
+showPackOptions [] = ""
+showPackOptions (opt : opts) =
+ "-" ++ show opt ++ " " ++ showPackOptions opts
diff --git a/HTk/Kernel/Packer.hs b/HTk/Kernel/Packer.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Kernel/Packer.hs
@@ -0,0 +1,96 @@
+-- | Packing of widgets - HTk supports Tk\'s standard packer and grid packer.
+module HTk.Kernel.Packer (
+
+ Container,
+
+ --standard packer
+ pack,
+
+ --grid packer
+ grid,
+
+ AbstractWidget(..)
+
+) where
+
+import HTk.Kernel.GUIObject
+import HTk.Kernel.Resources
+import HTk.Kernel.BaseClasses(Widget)
+import Reactor.ReferenceVariables
+import HTk.Kernel.PackOptions
+import HTk.Kernel.GridPackOptions
+import HTk.Kernel.Core
+
+
+-- -----------------------------------------------------------------------
+-- abstract class Container
+-- -----------------------------------------------------------------------
+
+-- | Container widgets instantiate the abstract @class Container@
+-- to enable packing.
+class GUIObject a => Container a
+
+
+-- -----------------------------------------------------------------------
+-- grid packer
+-- -----------------------------------------------------------------------
+
+-- | Packs a widget via the grid geometry manager.
+grid :: Widget w => w
+ -- ^ the widget to pack.
+ -> [GridPackOption]
+ -- ^ the grid pack options.
+ -> IO ()
+ -- ^ None.
+grid wid opts =
+ do
+ let (GUIOBJECT _ ostref) = toGUIObject wid
+ ost <- getRef ostref
+ meth <- withRef ostref methods
+ execTclScript ((gridCmd meth) (objectname ost) opts)
+
+
+-- -----------------------------------------------------------------------
+-- standard packer
+-- -----------------------------------------------------------------------
+
+-- | Packs a widget via the pack geometry manager.
+pack :: Widget w => w
+ -- ^ the widget to pack.
+ -> [PackOption]
+ -- ^ the pack options.
+ -> IO ()
+ -- ^ None.
+pack wid opts =
+ do
+ let obj = toGUIObject wid
+ meth <- getMethods obj
+ nm <- getObjectName obj
+ pobj' <- getParentObject wid
+ case pobj' of
+ Nothing -> execTclScript ((packCmd meth) nm opts)
+ Just pobj ->
+ do
+ kind <- getObjectKind pobj
+ case kind of
+ BOX Vertical Rigid ->
+ execTclScript ((packCmd meth) nm (opts ++ [Side AtTop]))
+ BOX Horizontal Rigid ->
+ execTclScript ((packCmd meth) nm (opts ++
+ [Side AtLeft]))
+ BOX Vertical Flexible ->
+ execTclScript ((packCmd meth) nm (opts ++
+ [Side AtTop, Fill Both,
+ Expand On]))
+ BOX Horizontal Flexible ->
+ execTclScript ((packCmd meth) nm (opts ++
+ [Side AtLeft, Fill Both,
+ Expand On]))
+ _ -> execTclScript ((packCmd meth) nm opts)
+
+
+data AbstractWidget = NONE
+instance GUIObject AbstractWidget where
+ toGUIObject _ = ROOT
+ cname _ = "AbstractWidget"
+instance Container AbstractWidget
diff --git a/HTk/Kernel/Resources.hs b/HTk/Kernel/Resources.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Kernel/Resources.hs
@@ -0,0 +1,305 @@
+-- | Basic resources used with object configuration options.
+module HTk.Kernel.Resources (
+
+ State(..),
+ Justify(..),
+ Relief(..),
+ Anchor(..),
+ Toggle(..),
+ toggle,
+ Orientation(..),
+ Alignment(..),
+ Flexibility(..),
+
+ CreationConfig,
+ showCreationConfigs
+
+) where
+
+import HTk.Kernel.GUIValue
+import Data.Char
+
+
+-- -----------------------------------------------------------------------
+-- creation configs
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+type CreationConfig w = IO String
+
+-- | Internal.
+showCreationConfigs :: [CreationConfig a] -> IO String
+showCreationConfigs (c : cs) =
+ do
+ str <- c
+ rest <- showCreationConfigs cs
+ return ("-" ++ str ++ " " ++ rest)
+showCreationConfigs _ = return ""
+
+
+-- -----------------------------------------------------------------------
+-- state
+-- -----------------------------------------------------------------------
+
+-- | The @State@ datatype - the state of certain widgets
+-- can be normal, disabled or active.
+data State = Disabled | Active | Normal deriving (Eq,Ord,Enum)
+
+-- | Internal.
+instance GUIValue State where
+ -- Internal.
+ cdefault = Disabled
+
+-- | Internal.
+instance Read State where
+ -- Internal.
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ 'd':'i':'s':'a':'b':'l':'e':'d': xs -> [(Disabled,xs)]
+ 'a':'c':'t':'i':'v':'e': xs -> [(Active,xs)]
+ 'n':'o':'r':'m':'a':'l': xs -> [(Normal,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show State where
+ -- Internal.
+ showsPrec d p r =
+ (case p of
+ Disabled -> "disabled"
+ Active -> "active"
+ Normal -> "normal"
+ ) ++ r
+
+
+-- -----------------------------------------------------------------------
+-- Justify
+-- -----------------------------------------------------------------------
+
+-- | The @Justify@ datatype - representing a text justification.
+data Justify = JustLeft | JustCenter | JustRight deriving (Eq,Ord,Enum)
+
+
+-- | Internal.
+instance GUIValue Justify where
+ -- Internal.
+ cdefault = JustLeft
+
+-- | Internal.
+instance Read Justify where
+ -- Internal.
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ 'l':'e':'f':'t':xs -> [(JustLeft,xs)]
+ 'c':'e':'n':'t':'e':'r':xs -> [(JustCenter,xs)]
+ 'r':'i':'g':'h':'t':xs -> [(JustRight,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show Justify where
+ -- Internal.
+ showsPrec d p r =
+ (case p of
+ JustLeft -> "left"
+ JustCenter -> "center"
+ JustRight -> "right") ++ r
+
+
+-- -----------------------------------------------------------------------
+-- relief
+-- -----------------------------------------------------------------------
+
+-- | The @Relief@ datatype - represents the relief of certain
+-- widgets.
+data Relief =
+ Groove | Ridge | Flat | Sunken | Raised deriving (Eq,Ord,Enum)
+
+-- | Internal.
+instance GUIValue Relief where
+ -- Internal.
+ cdefault = Flat
+
+-- | Internal.
+instance Read Relief where
+ -- Internal.
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ 'g':'r':'o':'o':'v':'e':xs -> [(Groove,xs)]
+ 'r':'i':'d':'g':'e':xs -> [(Ridge,xs)]
+ 'f':'l':'a':'t':xs -> [(Flat,xs)]
+ 's':'u':'n':'k':'e':'n':xs -> [(Sunken,xs)]
+ 'r':'a':'i':'s':'e':'d':xs -> [(Raised,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show Relief where
+ -- Internal.
+ showsPrec d p r =
+ (case p of
+ Groove -> "groove"
+ Ridge -> "ridge"
+ Flat -> "flat"
+ Sunken -> "sunken"
+ Raised -> "raised") ++ r
+
+
+-- -----------------------------------------------------------------------
+-- Orientation
+-- -----------------------------------------------------------------------
+
+-- | The @Orientation@ datatype - used for different purposes.
+data Orientation = Horizontal | Vertical deriving (Eq,Ord,Enum)
+
+-- | Internal.
+instance GUIValue Orientation where
+ -- Internal.
+ cdefault = Horizontal
+
+-- | Internal.
+instance Read Orientation where
+ -- Internal.
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ 'h':'o':'r':'i':'z':'o':'n':'t':'a':'l':xs -> [(Horizontal,xs)]
+ 'v':'e':'r':'t':'i':'c':'a':'l':xs -> [(Vertical,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show Orientation where
+ -- Internal.
+ showsPrec d p r =
+ (case p of
+ Horizontal -> "horizontal"
+ Vertical -> "vertical") ++ r
+
+
+-- -----------------------------------------------------------------------
+-- Toggle
+-- -----------------------------------------------------------------------
+
+-- | A simple @Toggle@ datatype - used for different purposes.
+data Toggle = Off | On deriving (Eq,Ord)
+
+-- | Internal.
+instance GUIValue Toggle where
+ -- Internal.
+ cdefault = Off
+
+-- | Internal.
+instance Read Toggle where
+ -- Internal.
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ '0':xs -> [(Off,xs)]
+ '1':xs -> [(On,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show Toggle where
+ -- Internal.
+ showsPrec d p r =
+ (case p of
+ Off -> "0"
+ On -> "1") ++ r
+
+toggle :: Toggle -> Toggle
+toggle On = Off
+toggle Off = On
+
+
+-- -----------------------------------------------------------------------
+-- Flexibility
+-- -----------------------------------------------------------------------
+
+-- | The @Flexibility@ datatype - used in the context of boxes
+-- (see containers).
+data Flexibility = Rigid | Flexible
+
+
+-- -----------------------------------------------------------------------
+-- Alignment
+-- -----------------------------------------------------------------------
+
+-- | The @Alignment@ datatype - widget alignment etc.
+data Alignment = Top | InCenter | Bottom | Baseline deriving (Eq,Ord,Enum)
+
+-- | Internal.
+instance GUIValue Alignment where
+ -- Internal.
+ cdefault = Top
+
+-- | Internal.
+instance Read Alignment where
+ -- Internal.
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ 'c':'e':'n':'t':'e':'r':xs -> [(InCenter,xs)]
+ 't':'o':'p': xs -> [(Top,xs)]
+ 'b':'o':'t':'t':'o':'m':xs -> [(Bottom,xs)]
+ 'b':'a':'s':'e':'l':'i':'n':'e':xs -> [(Baseline,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show Alignment where
+ -- Internal.
+ showsPrec d p r =
+ (case p of
+ Top -> "top"
+ InCenter -> "center"
+ Bottom -> "bottom"
+ Baseline -> "baseline") ++ r
+
+
+-- -----------------------------------------------------------------------
+-- Anchor
+-- -----------------------------------------------------------------------
+
+-- | The @Anchor@ datatype - used for different purposes, e.g.
+-- text anchors or anchor positions of canvas items.
+data Anchor =
+ SouthEast
+ | South
+ | SouthWest
+ | East
+ | Center
+ | West
+ | NorthEast
+ | North
+ | NorthWest
+ deriving (Eq,Ord,Enum)
+
+-- | Internal.
+instance GUIValue Anchor where
+ -- Internal.
+ cdefault = Center
+
+-- | Internal.
+instance Read Anchor where
+ -- Internal.
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ 's':'e':xs -> [(SouthEast,xs)]
+ 's':'w':xs -> [(SouthWest,xs)]
+ 'c':'e':'n':'t':'e':'r':xs -> [(Center,xs)]
+ 'n':'e':xs -> [(NorthEast,xs)]
+ 'n':'w':xs -> [(NorthWest,xs)]
+ 'e':xs -> [(East,xs)]
+ 'n':xs -> [(North,xs)]
+ 'w':xs -> [(West,xs)]
+ 's': xs -> [(South,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show Anchor where
+ -- Internal.
+ showsPrec d p r =
+ (case p of
+ SouthEast -> "se"
+ South -> "s"
+ SouthWest -> "sw"
+ East -> "e"
+ Center -> "center"
+ West -> "w"
+ NorthEast -> "ne"
+ North -> "n"
+ NorthWest -> "nw"
+ ) ++ r
diff --git a/HTk/Kernel/TkVariables.hs b/HTk/Kernel/TkVariables.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Kernel/TkVariables.hs
@@ -0,0 +1,68 @@
+-- | -----------------------------------------------------------------------
+-- -
+-- - module HTk.Kernel.TkVariables
+-- -
+-- - author: ludi
+-- -
+-- - --------------------------------------------------------------------
+
+module HTk.Kernel.TkVariables (
+
+ TkVariable(..),
+ HasVariable(..),
+
+ createTkVariable,
+ readTkVariable,
+ setTkVariable
+
+) where
+
+import HTk.Kernel.Core
+import Util.Computation
+import Util.Object
+
+
+-- -----------------------------------------------------------------------
+-- type
+-- -----------------------------------------------------------------------
+
+newtype GUIValue a => TkVariable a = TkVariable ObjectID
+
+
+-- -----------------------------------------------------------------------
+-- creation
+-- -----------------------------------------------------------------------
+
+createTkVariable :: GUIValue a => a -> IO (TkVariable a)
+createTkVariable val =
+ do
+ oid <- newObject
+ execTclScript ["global v" ++ show oid,
+ "set v" ++ show oid ++ " " ++ show (toGUIValue val)]
+ return (TkVariable oid)
+
+
+-- -----------------------------------------------------------------------
+-- reading and writing
+-- -----------------------------------------------------------------------
+
+readTkVariable :: GUIValue a => TkVariable a -> IO a
+readTkVariable (TkVariable oid) =
+ do
+ str <- evalCmd ("global v" ++ show oid ++ "; set v" ++ show oid)
+ creadTk str
+
+setTkVariable :: GUIValue a => TkVariable a -> a -> IO ()
+setTkVariable (TkVariable oid) val =
+ execTclScript ["global v" ++ show oid,
+ "set v" ++ show oid ++ " " ++ show (toGUIValue val)]
+
+
+-- -----------------------------------------------------------------------
+-- HasVariable
+-- -----------------------------------------------------------------------
+
+class (GUIObject w {-, GUIValue v-}) => HasVariable w {- (TkVariable v)-} where
+ variable :: TkVariable v -> Config w
+ variable (TkVariable oid) w =
+ cset w "variable" ("v" ++ show oid) >> return w
diff --git a/HTk/Kernel/Tooltip.hs b/HTk/Kernel/Tooltip.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Kernel/Tooltip.hs
@@ -0,0 +1,43 @@
+module HTk.Kernel.Tooltip (
+
+ HasTooltip(..)
+
+) where
+
+import HTk.Kernel.Wish
+import HTk.Kernel.GUIObject
+import Util.Computation
+
+
+-- -----------------------------------------------------------------------
+-- Tooltips (tix balloons, only available if using tixwish)
+-- -----------------------------------------------------------------------
+
+-- destruction is ignored, if no tooltip is defined
+
+-- | Widgets can have tooltips (if you are using tixwish).
+class GUIObject w => HasTooltip w where
+ -- Sets the tooltip text for the given widget.
+ tooltip :: String -> w -> IO w
+ -- Destroys the tooltip of the given widget (if exists).
+ destroyTooltip :: w -> IO ()
+
+ tooltip str w =
+ do tixAvailable <- isTixAvailable
+ (if tixAvailable then
+ do
+ nm <- getObjectName (toGUIObject w)
+ execTclScript
+ ["destroy " ++ show nm ++ "ttip",
+ "tixBalloon " ++ show nm ++ "ttip",
+ show nm ++ "ttip bind " ++ show nm ++" -msg \"" ++
+ str ++ "\""]
+ else done) >> return w
+
+ destroyTooltip w =
+ do tixAvailable <- isTixAvailable
+ (if tixAvailable then
+ do
+ nm <- getObjectName (toGUIObject w)
+ execTclScript ["destroy " ++ show nm ++ "ttip"]
+ else done)
diff --git a/HTk/Kernel/Wish.hs b/HTk/Kernel/Wish.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Kernel/Wish.hs
@@ -0,0 +1,711 @@
+{-# LANGUAGE CPP #-}
+
+-- | HTk - a GUI toolkit for Haskell - (c) Universitaet Bremen
+-- -----------------------------------------------------------------------
+module HTk.Kernel.Wish (
+
+ wish,
+
+ evalTclScript,
+ execTclScript,
+ execCmd,
+ evalCmd,
+ -- escape,
+ -- delimitString,
+ Wish(..),
+ TclCmd,
+ TclScript,
+ TclMessageType(..),
+ BindTag,
+ bindTagS,
+ succBindTag,
+ WishEvent(..),
+ WishEventModifier(..),
+ WishEventType(..),
+ mkBoundCmdArg,
+ KeySym(..),
+ CallBackId(..),
+ showP,
+
+ requirePackage, -- :: String -> IO(Bool). Try to load a package.
+ forgetPackage, -- :: String -> IO(). Forget a package.
+ isPackageAvailable, -- :: String -> IO(Bool). True if package loaded.
+ isTixAvailable, -- :: IO Bool. True if we are using tixwish, which
+ -- means it was successfully loaded with requirePackage
+ cleanupWish,
+
+ delayWish, -- :: IO a -> IO a
+ -- delayWish does an action, with the proviso that wish commands
+ -- executed within the action by this or any other thread
+ -- may be delayed. This can (allegedly) be faster.
+
+) where
+
+-- The preprocessor symbol ASYNC_WISH_ERRORS, if non-zero, causes wish
+-- errors to be handled asynchronously. This is done by default unless DEBUG
+-- is set.
+-- This is an optimisation. The possible bad consequences are that should
+-- wish itself produce an error,
+-- (1) we may execute some additional wish commands before detecting it.
+-- (2) it is hard to associate the error with the command which provoked it.
+-- On the other hand, it saves us having to wait for acknowledgment of
+-- commands, which particularly on Windows (where we have to access wish output
+-- by polling with the current version of ghc, 5.02.2) should save a lot of
+-- time.
+#ifndef ASYNC_WISH_ERRORS
+#ifdef DEBUG
+#define ASYNC_WISH_ERRORS 0
+#else
+#define ASYNC_WISH_ERRORS 1
+#endif
+#endif
+
+
+import Data.List(union,delete)
+
+import Control.Concurrent
+import Foreign.C.String
+import System.IO.Unsafe
+import Control.Exception
+
+import Util.Object
+import Util.Computation
+
+import Events.Events
+import Events.GuardedEvents
+import Events.EqGuard
+import Events.Destructible
+import Events.Synchronized
+
+import Reactor.BSem
+import Reactor.InfoBus
+
+import Reactor.ReferenceVariables
+import HTk.Kernel.EventInfo
+
+import HTk.Kernel.GUIValue
+import HTk.Kernel.CallWish
+
+-- -----------------------------------------------------------------------
+-- basic execution of Tcl commands
+-- -----------------------------------------------------------------------
+
+---
+-- evalCmd is used for commands which expect an answer,
+-- and calls evalTclScript.
+evalCmd :: TclCmd -> IO String
+evalCmd cmd = evalTclScript [cmd]
+
+---
+-- Used for commands which expect an answer.
+evalTclScript :: TclScript -> IO String
+evalTclScript script =
+ do
+ let buffer = bufferedCommands wish
+ -- (1) look at the buffer, execute the contents, and empty it.
+ bufferContents <- takeMVar buffer
+ case bufferContents of
+ (0,_) -> putMVar buffer bufferContents
+ (n,[]) -> putMVar buffer bufferContents
+ (n,script) ->
+ do
+ putMVar buffer (n,[])
+ execCmdInner (reverse script)
+ -- (2) execute the command
+ response <- evalCmdInner script
+ doResponse response
+
+
+---
+-- execCmd is used for commands which don't expect an answer
+-- and calls execTclScript
+execCmd :: TclCmd -> IO ()
+execCmd cmd = execTclScript [cmd]
+
+---
+-- Used for commands which do not expect an answer
+execTclScript :: TclScript -> IO ()
+execTclScript script =
+ do
+ let buffer = bufferedCommands wish
+ bufferContents <- takeMVar buffer
+ case bufferContents of
+ (0,_) -> -- just do it
+ do
+ putMVar buffer (0,[])
+ execCmdInner script
+ done
+ (n,buffered) -> -- don't do it
+ do
+ let
+ revAppend [] ys = ys
+ revAppend (x:xs) ys = revAppend xs (x:ys)
+ putMVar buffer (n,revAppend script buffered)
+
+---
+-- delayWish does an action, with the proviso that wish commands
+-- executed within the action by this or any other thread
+-- may be delayed. This can (allegedly) be faster.
+delayWish :: IO a -> IO a
+delayWish action =
+ do
+ beginBuffering
+ tried <- Control.Exception.try action
+ endBuffering
+ propagate tried
+
+---
+-- beginBuffering begins buffering commands (if we aren't already).
+beginBuffering :: IO ()
+beginBuffering =
+ do
+ let buffer = bufferedCommands wish
+ bufferContents <- takeMVar buffer
+ case bufferContents of
+ (n,script) -> putMVar buffer (n+1,script)
+
+---
+-- unbuffercommands undoes a beginBuffering, and flushes the current buffer.
+endBuffering :: IO ()
+endBuffering =
+ do
+ let buffer = bufferedCommands wish
+ bufferContents <- takeMVar buffer
+ case bufferContents of
+ (n,script) ->
+ do
+ execCmdInner (reverse script)
+ putMVar buffer (n-1,[])
+
+---
+-- evalCmdInner takes a (possibly empty) TclScript and executes it,
+-- returning a response. It does not look at the buffer, so should
+-- not be called from outside.
+evalCmdInner :: TclScript -> IO TclResponse
+evalCmdInner [] = return (OK "")
+evalCmdInner tclScript =
+ do
+ let
+ scriptString = foldr1 (\ cmd s -> cmd ++ (';':s)) tclScript
+ cmdString = "evS " ++ escape scriptString ++"\n"
+
+ withCStringLen cmdString evalCmdPrim
+
+---
+-- This is the most primitive command evaluator and does not
+-- look at the buffer. So it shouldn't be called from outside.
+evalCmdPrim :: CStringLen -> IO TclResponse
+evalCmdPrim cStringLen =
+ do
+ let
+ rWish = readWish wish
+ wWish = writeWish wish
+ synchronize (wishLock wish) (
+ do
+ wWish cStringLen
+ sync(
+ toEvent (rWish |> Eq OKType) >>>=
+ (\ (_,okString) -> return (OK okString))
+#if ! ASYNC_WISH_ERRORS
+ +> toEvent (rWish |> Eq ERType) >>>=
+ (\ (_,erString) -> return (ER erString))
+#endif
+ )
+ )
+
+#if ASYNC_WISH_ERRORS
+---
+-- execCmdInner corresponds to evalCmdInner, but does not return a response.
+execCmdInner :: TclScript -> IO ()
+execCmdInner [] = done
+execCmdInner tclScript =
+ do
+ let
+ scriptString = foldr1 (\ cmd s -> cmd ++ (';':s)) tclScript
+ cmdString = "exS " ++ escape scriptString ++"\n"
+ -- The difference is we call "exS" and not "evS".
+
+ withCStringLen cmdString execCmdPrim
+
+---
+-- execCmdPrim corresponds to evalCmdPrim, but does not wait for a response.
+execCmdPrim :: CStringLen -> IO ()
+execCmdPrim cStringLen = writeWish wish cStringLen
+
+#else
+
+execCmdInner :: TclScript -> IO ()
+execCmdInner script =
+ do
+ response <- evalCmdInner script
+ doResponse1 response
+ done
+
+#endif
+
+
+doResponse :: TclResponse -> IO String
+doResponse (OK res) = return res
+#if ! ASYNC_WISH_ERRORS
+doResponse (ER err) = error err
+#endif
+
+doResponse1 :: TclResponse -> IO ()
+doResponse1 (OK res) = return ()
+#if ! ASYNC_WISH_ERRORS
+doResponse1 (ER err) =
+ do
+ fingersCrossed err
+ done
+#endif
+
+fingersCrossed :: String -> IO ()
+fingersCrossed err =
+ putStrLn ("Unexpected error " ++ err ++ " returned from wish\n"
+ ++ "Continuing, with fingers crossed")
+
+-- -----------------------------------------------------------------------
+-- wish datatypes
+-- -----------------------------------------------------------------------
+
+data Wish = Wish {
+ wishLock :: BSem,
+ -- this locks wish when a command has been sent but not answer
+ -- received, as yet.
+
+ eventQueue :: EqGuardedChannel BindTag EventInfo,
+ -- Wish puts events here, parameterised by the
+ -- widget tag, which for us is always a widget id.
+ -- The events will be taken off by the event dispatcher.
+
+ coQueue :: EqGuardedChannel CallBackId (),
+ -- CO events, produced by the relay command, go here.
+ -- (These are used for Widgets with actions attached,
+ -- EG for buttons with "Click me" on them.),
+
+-- callBackIds :: MVar CallBackId,
+
+ bindTags :: MVar BindTag,
+
+ readWish ::
+ GuardedEvent (EqMatch TclMessageType) (TclMessageType,String),
+ -- Wish output sorted by prefix.
+
+ writeWish :: CStringLen -> IO (),
+ -- Command to execute a Wish command.
+
+ destroyWish :: IO (), -- Command to destroy this Wish instance.
+
+
+ bufferedCommands :: MVar (Int,TclScript),
+ -- The integer indicates if buffering is going on.
+ -- If non-zero it is. When we start new buffering, we
+ -- increment the integer.
+ -- The TclScript contains the current contents of the buffer
+ -- IN REVERSE ORDER.
+ -- If the integer is 0, the TclScript is [].
+ oID :: ObjectID
+ }
+
+type TclCmd = String
+type TclScript = [TclCmd]
+
+#if ASYNC_WISH_ERRORS
+newtype TclResponse = OK String
+#else
+data TclResponse = OK String | ER String
+#endif
+
+data TclMessageType = OKType | ERType | COType | EVType deriving (Eq,Ord,Show)
+
+
+-- ----------------------------------------------------------------
+-- wish instances
+-- ----------------------------------------------------------------
+
+instance Object Wish where
+ objectID wish = oID wish
+
+instance Destroyable Wish where
+ destroy wish = destroyWish wish
+
+
+-- ----------------------------------------------------------------
+-- running the wish
+-- ----------------------------------------------------------------
+
+wish :: Wish
+wish = unsafePerformIO newWish
+{-# NOINLINE wish #-}
+
+cleanupWish :: IO ()
+cleanupWish = destroy wish
+
+newWish :: IO Wish
+newWish =
+ do
+ calledWish <- callWish
+ let
+ writeWish = sendCalledWish calledWish
+
+ -- Set up initial wish procedures.
+ wishHeader =
+ "proc ConvertTkValue val {" ++
+ -- The "regsub" commands replace \ by \\ and newline by \\.
+ "regsub -all {\\\\} $val {\\\\\\\\} res1;" ++
+ "regsub -all \\n $res1 {\\\\n} res;" ++
+ "return $res" ++
+ "};" ++
+-- Execute the command, returning the result.
+ "proc evS x {" ++
+ "set status [catch {eval $x} res];" ++
+ "set val [ConvertTkValue $res];" ++
+ "if {$status == 0} {puts \"OK $val\"} else {puts \"ER $val\"}" ++
+ "};" ++
+#if ASYNC_WISH_ERRORS
+-- Execute the command, not returning the result.
+ "proc exS x {" ++
+ "set status [catch {eval $x} res];" ++
+ "if {$status} {puts [concat \"EX \" [ConvertTkValue $res]]}" ++
+ "};" ++
+#endif
+ "proc relay {evId val} {" ++
+ "set res [ConvertTkValue $val];" ++
+ "puts \"CO $evId $res\"" ++
+ "};" ++
+ -- The following Tcl functions adds and removes bindings for
+ -- a widget.
+ -- ldelete deletes an item from a list
+ -- (Stolen from Tcl book page 58)
+ "proc ldelete {list value} {" ++
+ "set ix [lsearch -exact $list $value];" ++
+ "if {$ix >=0 } {" ++
+ "return [lreplace $list $ix $ix]" ++
+ "} else {return $list}};" ++
+ -- addtag adds a bind tag for a widget
+ "proc addtag {widget tag} {" ++
+ "set x [bindtags $widget];" ++
+ "lappend x $tag;" ++
+ "bindtags $widget $x};" ++
+ -- rmtag removes a bind tag from a widget
+ "proc rmtag {widget tag} {" ++
+ "bindtags $widget [ldelete [bindtags $widget] $tag]}\n"
+
+ withCStringLen wishHeader writeWish
+
+ -- get readWish reactor going.
+ (readWish,destroyReadWish) <- readWishEvent calledWish
+ -- set up the channels
+ wishLock <- newBSem
+ eventQueue <- newEqGuardedChannel
+ coQueue <- newEqGuardedChannel
+ bindTags <- newMVar nullBindTag
+ let
+ destroyWish1 =
+ do
+ destroyReadWish
+ destroyCalledWish calledWish
+ -- Wish reactor will be garbage collected.
+ destroyWish <- doOnce destroyWish1
+ bufferedCommands <- newMVar (0,[])
+ oID <- newObject
+ let
+ wish = Wish {
+ wishLock = wishLock,
+ eventQueue = eventQueue,
+ coQueue = coQueue,
+ bindTags = bindTags,
+ readWish = readWish,
+ writeWish = writeWish,
+ destroyWish = destroyWish,
+ bufferedCommands = bufferedCommands,
+ oID = oID
+ }
+ _ <- spawnEvent eventForwarder
+
+ registerToolDebug "Wish" wish -- so that shutdown works.
+
+ return wish
+
+eventForwarder :: Event ()
+eventForwarder = forever handleEvent
+ where
+ rWish = readWish wish
+
+ -- event that passes on EV and CO events.
+ handleEvent :: Event ()
+ handleEvent =
+ (do
+ -- Pass on ev events.
+ (_,evString) <- toEvent (rWish |> Eq EVType)
+ noWait(send (eventQueue wish) (parseEVString evString))
+ )
+ +> (do
+ -- Handle co events
+ (_,coString) <- toEvent (rWish |> Eq COType)
+ noWait(send (coQueue wish) (parseCallBack coString))
+ )
+#if ASYNC_WISH_ERRORS
+ +> (do
+ -- Handle wish errors
+ (_,erString) <- toEvent (rWish |> Eq ERType)
+ always (fingersCrossed erString)
+ )
+#endif
+
+
+readWishEvent :: CalledWish
+ -> IO (GuardedEvent (EqMatch TclMessageType) (TclMessageType,String),
+ IO())
+readWishEvent calledWish =
+ do
+ wishInChannel <- newEqGuardedChannel
+ destroy <- spawnEvent(forever(
+ do
+ next <-
+ always (Control.Exception.catch (readCalledWish calledWish) (\_-> return "OK Terminated"))
+ send wishInChannel (typeWishAnswer next)
+ ))
+ return (listen wishInChannel,destroy)
+
+-- typeWishAnswer parses answers from Wish.
+-- The format of messages from Wish, after we've defined the first
+-- few procedures, is
+-- OK [escaped string]
+-- for a successfully completed command with this result.
+-- ER [escaped string]
+-- for an unsuccessful command with this result.
+-- CO [escaped string]
+-- for an output of the "relay" procedure, which we use in commands
+-- attached to Tcl widgets. (EG it might be the text the user
+-- has typed into a text widget.)
+-- We will break this up further with splitCO, which expects to
+-- find a space.
+-- EV [non-escaped string]
+-- for an event. This is set up by the bind command in
+-- TkCommands.hs. (We don't need to escape this as it can't
+-- contain funny characters.)
+-- We parse this, unescaping the Strings where necessary.
+typeWishAnswer :: String -> (TclMessageType,String)
+-- typeWishAnswer returns the type, and the unescaped String.
+typeWishAnswer str =
+ case str of
+ 'O':'K':' ':rest -> (OKType,unEscape rest)
+ 'E':'R':' ':rest -> (ERType,unEscape rest)
+ 'C':'O':' ':rest -> (COType,unEscape rest)
+ 'E':'V':' ':rest -> (EVType,rest)
+ _ -> parseError str
+ where
+ unEscape "" = ""
+ unEscape ('\\':'n':rest) = '\n':unEscape rest
+ unEscape ('\\':'\\':rest) = '\\':unEscape rest
+ unEscape ('\\':_:rest) = parseError str
+ unEscape (ch:rest) =ch:unEscape rest
+
+parseError :: String -> a
+parseError str = error ("Wish: couldn't parse wish response "++ (show str))
+
+
+-- -----------------------------------------------------------------------
+-- Interface to wish packages
+-- -----------------------------------------------------------------------
+
+loadedPackages :: Ref [String]
+loadedPackages = unsafePerformIO (newRef [])
+{-# NOINLINE loadedPackages #-}
+
+-- Require a package, returning flag for success
+requirePackage :: String -> IO (Bool)
+requirePackage package =
+ do response <- evalCmd ("package require " ++ package)
+ if response == ("can't find package " ++ package)
+ then return False
+ else do loaded <- getRef loadedPackages
+ setRef loadedPackages ([package] `union` loaded)
+ return True
+
+forgetPackage :: String -> IO ()
+forgetPackage package =
+ do evalCmd ("package forget " ++ package)
+ loaded <- getRef loadedPackages
+ setRef loadedPackages (delete package loaded)
+ return ()
+
+-- isPackageAvailable is used to determine if a package is loaded
+-- (must use requirePackage to load it first, if desired)
+isPackageAvailable :: String -> IO Bool
+isPackageAvailable package =
+ do loaded <- getRef loadedPackages
+ return (package `elem` loaded)
+
+-- isTixAvailable is used to determine if Tix is available . . .
+isTixAvailable :: IO Bool
+isTixAvailable = isPackageAvailable "Tix"
+
+
+-- -----------------------------------------------------------------------
+-- BindCmd and its cousins
+-- -----------------------------------------------------------------------
+
+newtype BindTag = BindTag Int deriving (Eq,Ord)
+
+bindTagS :: BindTag -> String
+bindTagS (BindTag i) = show i
+
+bindTagR :: String -> BindTag
+bindTagR str =
+ case reads str of
+ [(i,"")] -> BindTag i
+ _ -> error ("Can't parse bind tag "++str++".")
+
+nullBindTag :: BindTag
+nullBindTag = BindTag 0
+
+succBindTag :: BindTag -> BindTag
+succBindTag (BindTag n) = BindTag (n+1)
+
+
+-- -----------------------------------------------------------------------
+-- Bind Event Data
+-- -----------------------------------------------------------------------
+
+-- We do not allow general Bind commands. All bind commands simply
+-- put the result to stdout in the following format:
+-- "EV [bindTag]( [id][value])*"
+-- where
+-- [bindTag] is our tag for the binding.
+-- [id] is a single character identifying the information
+-- [value] is the String value
+-- In the above, (...)* means that the syntax within brackets can be
+-- repeated any number n>=0 times.
+-- We also assume that all the strings ([widgetTag], [String]) do not
+-- contain any spaces funny escape characters. This can be deduced from
+-- page 298 and the fact that bindTags are in fact just going to
+-- be lists of numbers separated by period.
+mkBoundCmdArg :: BindTag -> EventInfoSet -> Bool-> String
+-- Make the command to be passed as ?bindstr? for "bi".
+-- (See notes at the head of this section.)
+-- Adding a "break" statement behind the puts prevents the binding from being
+-- processed further. That means we override earlier/default bindings.
+mkBoundCmdArg bindTag eventInfoSet break =
+ let bindStr = "EV " ++ bindTagS bindTag ++
+ foldr (\ par soFar -> let tag = epToChar par
+ in ' ':tag:'%':tag:soFar)
+ "" (listEventInfoSet eventInfoSet)
+ in "{puts " ++ (delimitString bindStr) ++
+ if break then "; break}" else "}"
+
+parseEVString :: String -> (BindTag,EventInfo)
+-- parseEVString parses the resulting String, EXCEPT for the
+-- initial "EV ", which are stripped off before they get this far.
+parseEVString str =
+ let
+ bindTagStr:settings = words str
+ eventInfo = mkEventInfo
+ (map (\ (tag:rest) -> (epFromChar tag,rest)) settings)
+ in
+ (bindTagR bindTagStr,eventInfo)
+
+-- -----------------------------------------------------------------------
+-- Wish events
+-- These also have to implement Eq and Ord for the benefit of
+-- the Widget dispatcher, which needs to handle finite maps on them.
+-- NB - we won't encourage people to get hold of Wish's current
+-- name for an event, since this is hard to reconcile to our
+-- encapsulation (EG it probably involves detailed knowledge of
+-- local keysyms to do it properly).
+-- -----------------------------------------------------------------------
+
+data WishEvent = WishEvent [WishEventModifier] WishEventType
+ deriving (Ord,Eq)
+
+instance Show WishEvent where
+ -- We specify that the resulting String is already escaped
+ -- as necessary.
+ showsPrec _ (WishEvent modifiers wishEventType) acc =
+ '<' :
+ (foldr
+ (\ modifier soFar -> showP modifier ('-':soFar))
+ (typeToStringP wishEventType ('>':acc))
+ modifiers
+ )
+
+-- page 290 except that we merge keysyms (page 291) into the KeyPress and
+-- KeyRelease type.
+data WishEventType =
+ Activate |
+ ButtonPress (Maybe BNo) | ButtonRelease (Maybe BNo) |
+ Circulate |
+ Colormap | Configure | Deactivate | Destroy | Enter | Expose |
+ FocusIn | FocusOut | Gravity |
+ KeyPress (Maybe KeySym) | KeyRelease (Maybe KeySym)|
+ Motion | Leave | Map | Property | Reparent | Unmap |
+ Visibility deriving (Show,Eq,Ord)
+ -- the Show instance won't work for KeySyms, so we fix up later
+
+newtype KeySym = KeySym String deriving (Show,Ord,Eq)
+-- A KeySym can be a single character representing a key. However others
+-- are defined, and depend on the window implementation. For example,
+-- on this machine the Return key is called "Return", and the
+-- Enter key "KP_Enter". Page291 has a wish binding for determining
+-- the keysym for a key.
+-- The KeySym is escaped as necessary before being fed to Wish;
+-- for example KeySym ['\n'] works.
+
+ksToStringP :: Maybe KeySym -> String -> String
+ksToStringP Nothing acc = acc
+ksToStringP (Just (KeySym keySym)) acc =
+ '-':((escapeString keySym)++acc)
+
+type BNo = Int -- used for buttons
+
+bNoToStringP :: Maybe BNo -> String -> String
+bNoToStringP Nothing acc = acc
+bNoToStringP (Just bNo) acc = '-':(showP bNo acc)
+
+typeToStringP :: WishEventType -> String -> String
+typeToStringP (ButtonPress bNo) acc =
+ "ButtonPress" ++ (bNoToStringP bNo acc)
+typeToStringP (ButtonRelease bNo) acc =
+ "ButtonRelease" ++ (bNoToStringP bNo acc)
+typeToStringP (KeyPress ks) acc = "KeyPress" ++ (ksToStringP ks acc)
+typeToStringP (KeyRelease ks) acc = "KeyRelease" ++ (ksToStringP ks acc)
+typeToStringP other acc = showP other acc
+
+-- page 294
+-- We rename "Command" "CommandKey" to avoid conflicts with the
+-- Command attribute.
+data WishEventModifier =
+ Control | Shift | Lock | CommandKey | Meta | M | Alt | Mod1 |
+ Mod2 | Mod3 | Mod4 | Mod5 |
+ Button1 | Button2 | Button3 | Button4 | Button5 |
+ Double | Triple deriving (Show,Ord,Eq)
+
+
+-- -----------------------------------------------------------------------
+-- CallBackId's identify callbacks.
+-- -----------------------------------------------------------------------
+
+newtype CallBackId = CallBackId ObjectID deriving (Eq,Ord,Show)
+
+parseCallBack :: String -> (CallBackId, ())
+parseCallBack str =
+ case reads str of
+ [(i, _)] -> (CallBackId i, ())
+ _ -> error ("Couldn't parse Wish callback "++str)
+
+showCallBackId :: CallBackId -> String
+showCallBackId (CallBackId nm) = show nm
+
+
+-- -----------------------------------------------------------------------
+-- General abbreviations
+-- -----------------------------------------------------------------------
+
+-- Like toTkString, except it only places quotes if necessary
+escape :: String-> String
+escape = delimitString . escapeString
+
+-- Convenient abbreviation
+showP :: Show a => a -> String -> String
+showP val acc = showsPrec 0 val acc
diff --git a/HTk/Menuitems/Indicator.hs b/HTk/Menuitems/Indicator.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Menuitems/Indicator.hs
@@ -0,0 +1,77 @@
+-- | HTk\'s menuitem /indicators/.
+-- Indicators are displayed with menu checkbuttons, menu buttons and
+-- menu radiobuttons.
+module HTk.Menuitems.Indicator (
+ Indicator(..),
+
+ HasColour(..),
+ HasPhoto(..),
+ SelectButton(..),
+ HasIndicator(..)
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Components.Image
+import HTk.Menuitems.MenuItem
+import Util.Computation
+import HTk.Kernel.Resources
+import HTk.Kernel.Colour
+
+
+-- -----------------------------------------------------------------------
+-- handle
+-- -----------------------------------------------------------------------
+
+-- | The @Indicator@ datatype.
+data Indicator a = Indicator a
+
+
+-- -----------------------------------------------------------------------
+-- class HasIndicator
+-- -----------------------------------------------------------------------
+
+-- | Menu items that can have an indicator instantiate the
+-- @class HasIndicator@.
+class GUIObject w => HasIndicator w where
+ -- Displays\/unmaps the items indicator.
+ indicator :: Toggle -> Config w
+ -- @On@ if an indicator is displayed with the item, otherwise
+ -- @Off@.
+ getIndicator :: w -> IO Toggle
+ indicator i w = cset w "indicatoron" i
+ getIndicator w = cget w "indicatoron"
+
+
+-- -----------------------------------------------------------------------
+-- instantiations
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance HasIndicator w => GUIObject (Indicator w) where
+ toGUIObject (Indicator w) = toGUIObject w
+ cname _ = "Indicator"
+
+-- | You can specify the colour for the selector of menu checkbuttons and
+-- menu radiobuttons.
+instance (HasIndicator w, SelectButton w) => HasColour (Indicator w) where
+ -- Sets the colour for the selector.
+ setColour w _ c = cset w "selectcolor" (toColour c)
+ -- Gets the colour for the selector.
+ getColour w _ = cget w "selectcolor"
+
+-- | You can specify specify an alternate image for the selector of menu
+-- checkbuttons and menu radiobuttons.
+instance (HasIndicator w, SelectButton w) => HasPhoto (Indicator w) where
+ -- Sets the alternate image for the selector.
+ photo i w = imageToInt i >>= cset w "selectimage"
+ -- Gets the alternate image for the selector.
+ getPhoto w = cget w "selectimage" >>= intToImage
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance HasIndicator GUIOBJECT
diff --git a/HTk/Menuitems/Menu.hs b/HTk/Menuitems/Menu.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Menuitems/Menu.hs
@@ -0,0 +1,207 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE OverlappingInstances #-}
+
+-- | HTk\'s /menus/.
+-- A @Menu@ is a container for menu structures.
+module HTk.Menuitems.Menu (
+
+ Menu(..),
+ HasMenu(..),
+
+ createMenu,
+ popup,
+
+ post,
+ unpost,
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import HTk.Kernel.Resources
+import HTk.Kernel.Geometry
+import Reactor.ReferenceVariables
+import Events.Destructible
+import Events.Synchronized
+import Util.Computation
+import HTk.Containers.Window
+
+
+-- -----------------------------------------------------------------------
+-- Menu
+-- -----------------------------------------------------------------------
+
+-- | The @Menu@ datatype.
+data Menu = Menu GUIOBJECT (Ref Int)
+
+
+-- -----------------------------------------------------------------------
+-- class HasMenu
+-- -----------------------------------------------------------------------
+
+-- | Containers for menus (toplevel windows and menubuttons) instantiate the
+-- @class HasMenu@.
+class GUIObject w => HasMenu w where
+ menu :: Menu -> Config w
+ menu m w =
+ do
+ let (GUIOBJECT _ mostref) = toGUIObject m
+ most <- getRef mostref
+ cset w "menu" (show (objectname most))
+
+-- | Windows are containers for menus.
+instance Window w => HasMenu w
+
+
+-- -----------------------------------------------------------------------
+-- Menu Creation Command
+-- -----------------------------------------------------------------------
+
+createMenu :: GUIObject par => par
+ -- ^ tearoff. If True, means menu will be displayed in a
+ -- separate top-level window.
+ -> Bool
+ -> [Config Menu]
+ -> IO Menu
+createMenu par to ol =
+ do
+ w <- createGUIObject (toGUIObject par) MENU menuMethods
+ r <- newRef (if to then 1 else 0)
+ configure (Menu w r) (tearOff (if to then On else Off) : ol)
+
+
+-- -----------------------------------------------------------------------
+-- Popup Menu
+-- -----------------------------------------------------------------------
+
+-- | Posts a menu (e.g. in respose of a keystroke or mousebutton press).
+popup :: GUIObject i => Menu
+ -- ^ The menu to post.
+ -> Position
+ -- ^ The position to pop-up.
+ -> Maybe i
+ -- ^ An optional entry to activate when the menu pops-up.
+ -> IO ()
+ -- ^ None.
+popup m pos@(x,y) ent@Nothing =
+ execMethod m (\nm -> tkPopup nm x y "")
+popup m pos@(x,y) ent@(Just entry) =
+ do
+ name <- getObjectName (toGUIObject entry)
+ case name of
+ ObjectName s -> execMethod m (\nm -> tkPopup nm x y s)
+ MenuItemName _ i -> execMethod m (\nm -> tkPopup nm x y (show i))
+ _ -> done
+
+tkPopup :: ObjectName -> Distance -> Distance -> String -> TclScript
+tkPopup wn x y ent = ["tk_popup " ++ show wn ++ " " ++
+ show x ++ " " ++ show y ++ " " ++ ent]
+{-# INLINE tkPopup #-}
+
+
+-- -----------------------------------------------------------------------
+-- menu instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance Eq Menu where
+ w1 == w2 = toGUIObject w1 == toGUIObject w2
+
+-- | Internal.
+instance GUIObject Menu where
+ toGUIObject (Menu w _) = w
+ cname _ = "Menu"
+
+-- | A menu can be destroyed.
+instance Destroyable Menu where
+ -- Destroys a menu.
+ destroy = destroy . toGUIObject
+
+-- | A menu has standard widget properties
+-- (concerning focus, cursor).
+instance Widget Menu
+
+-- | You can synchronize on a menu object.
+instance Synchronized Menu where
+ -- Synchronizes on a menu object.
+ synchronize w = synchronize (toGUIObject w)
+
+-- | A menu has a configureable border.
+instance HasBorder Menu
+
+-- | A menu has a normal foreground and background colour and an
+-- active\/disabled foreground and background colour.
+instance HasColour Menu where
+ legalColourID w "background" = True
+ legalColourID w "foreground" = True
+ legalColourID w "activebackground" = True
+ legalColourID w "activeforeground" = True
+ legalColourID w _ = False
+
+-- | You can specify the font of a menu.
+instance HasFont Menu
+
+
+-- -----------------------------------------------------------------------
+-- config options
+-- -----------------------------------------------------------------------
+
+-- | A tear-off entry can be displayed with a menu.
+tearOff :: Toggle
+ -- ^ @On@ if you wish to display a tear-off
+ -- entry, otherwise @Off@.
+ -> Config Menu
+ -- ^ The conerned menu.
+tearOff tg mn = cset mn "tearoff" tg
+
+
+-- -----------------------------------------------------------------------
+-- Posting and Unposting Menues
+-- -----------------------------------------------------------------------
+
+-- | Displays a menu at the specified position.
+post :: Menu
+ -- ^ the menu to post.
+ -> Position
+ -- ^ the position to post the menu at.
+ -> IO ()
+ -- ^ None.
+post mn pos@(x, y) = execMethod mn (\name -> tkPost name x y)
+
+-- | Unmaps the menu.
+unpost :: Menu
+ -- ^ the menu to unmap.
+ -> IO ()
+ -- ^ None.
+unpost mn = execMethod mn (\name -> tkUnPost name)
+
+
+-- -----------------------------------------------------------------------
+-- Menu methods
+-- -----------------------------------------------------------------------
+
+menuMethods = defMethods{ createCmd = tkCreateMenu,
+ packCmd = packCmd voidMethods }
+
+
+-- -----------------------------------------------------------------------
+-- Unparsing of Menu Commands
+-- -----------------------------------------------------------------------
+
+tkCreateMenu :: ObjectName -> ObjectKind -> ObjectName -> ObjectID ->
+ [ConfigOption] -> TclScript
+tkCreateMenu _ _ nm oid cnf =
+ ["menu " ++ show nm ++ " " ++ showConfigs cnf]
+
+tkPost :: ObjectName -> Distance -> Distance -> TclScript
+tkPost name @ (ObjectName _) x y = [show name ++ " post " ++ show x ++ " " ++ show y]
+tkPost name @ (MenuItemName mn i) _ _ = [show mn ++ " postcascade " ++ (show i)]
+tkPost _ _ _ = []
+{-# INLINE tkPost #-}
+
+tkUnPost :: ObjectName -> TclScript
+tkUnPost (MenuItemName _ _) = []
+tkUnPost name = [show name ++ " unpost "]
+{-# INLINE tkUnPost #-}
diff --git a/HTk/Menuitems/MenuCascade.hs b/HTk/Menuitems/MenuCascade.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Menuitems/MenuCascade.hs
@@ -0,0 +1,135 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | HTk\'s /menu cascade item/.
+-- A containers for cascaded menus.
+module HTk.Menuitems.MenuCascade (
+
+ MenuCascade,
+ createMenuCascade,
+ createPulldownMenu
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.Configuration
+import HTk.Components.BitMap
+import HTk.Menuitems.Menu
+import HTk.Menuitems.MenuItem
+import HTk.Menuitems.Indicator
+import Events.Synchronized
+import Util.Computation
+
+
+-- -----------------------------------------------------------------------
+-- MenuCascade type
+-- -----------------------------------------------------------------------
+
+-- | The @MenuCascade@ datatype.
+newtype MenuCascade = MenuCascade GUIOBJECT
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | A @MenuCascade@ item is a container for a sub-menu.
+instance HasMenu MenuCascade
+
+
+-- -----------------------------------------------------------------------
+-- commands
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new menu cascasde item and returns a handler.
+createMenuCascade :: Menu
+ -- ^ the parent menu.
+ -> [Config MenuCascade]
+ -- ^ the list of configuration options for this menu
+ -- cascade item.
+ -> IO MenuCascade
+ -- ^ A menu cascade item.
+createMenuCascade m cnf = createMenuItem m MENUCASCADE MenuCascade cnf
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | A menu cascade item is a menu item (any menu item instantiates the
+-- abstract @class MenuItem@).
+instance MenuItem MenuCascade
+
+-- | Internal.
+instance Eq MenuCascade where
+ w1 == w2 = (toGUIObject w1) == (toGUIObject w2)
+
+-- | Internal.
+instance GUIObject MenuCascade where
+ toGUIObject (MenuCascade w) = w
+ cname _ = "MenuCascade"
+
+-- | You can synchronize on a menu cascade item.
+instance Synchronized MenuCascade where
+ -- Synchronizes on a menu cascade item.
+ synchronize = synchronize . toGUIObject
+
+-- | A menu cascade item has an optional text to display as a reminder
+-- about a keystroke binding.
+instance HasAccelerator MenuCascade
+
+-- | A menu cascade item can contain a bitmap (instead of text or an image).
+instance HasBitMap MenuCascade
+
+-- | A menu cascade item has a configureable border.
+instance HasBorder MenuCascade
+
+-- | A menu cascade item has a normal foreground and background colour and
+-- an active\/disabled foreground and background colour.
+instance HasColour MenuCascade where
+ legalColourID = buttonColours
+
+-- | A menu cascade item is a stateful object, it can be enabled or
+-- disabled.
+instance HasEnable MenuCascade
+
+-- | You can specify the font of a menu cascade item.
+instance HasFont MenuCascade
+
+-- | A menu cascade item has a configureable text justification.
+instance HasJustify MenuCascade
+
+-- | You can display an indicator with a menu cascade item.
+instance HasIndicator MenuCascade
+
+-- | A menu cascade item can contain an image (instead of text or a bitmap).
+instance HasPhoto MenuCascade
+
+-- | You can specify the size of a menu cascade item.
+instance HasSize MenuCascade
+
+-- | A menu cascade item can contain text (instead of an image or bitmap).
+instance GUIValue v => HasText MenuCascade v where
+ -- Sets the text to display.
+ text str w = cset w "label" str >> return w
+ -- Gets the displayed text.
+ getText w = cget w "label"
+
+-- | You can set the index of a text character to underline.
+instance HasUnderline MenuCascade
+
+
+-- | Utility function: create a pulldown menu
+--
+createPulldownMenu :: Menu
+ -- ^ the parent menu.
+ -> [Config MenuCascade]
+ -- ^ the list of configuration options for this pulldown menu
+ -> IO Menu
+ -- ^ A menu cascade item.
+createPulldownMenu mpar conf =
+ do pd <- createMenuCascade mpar conf
+ m <- createMenu mpar False []
+ pd # menu m
+ return m
+
diff --git a/HTk/Menuitems/MenuCheckButton.hs b/HTk/Menuitems/MenuCheckButton.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Menuitems/MenuCheckButton.hs
@@ -0,0 +1,125 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | HTk\'s /menu checkbutton/.
+-- A simple checkbutton inside a menu associated with a polymorphic
+-- variable.
+module HTk.Menuitems.MenuCheckButton (
+
+ MenuCheckButton,
+ createMenuCheckButton
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.Configuration
+import HTk.Components.BitMap
+import HTk.Menuitems.Menu
+import HTk.Menuitems.MenuItem
+import HTk.Menuitems.Indicator
+import Events.Synchronized
+import Util.Computation
+import HTk.Kernel.TkVariables
+
+
+-- -----------------------------------------------------------------------
+-- MenuCascade type
+-- -----------------------------------------------------------------------
+
+-- | The @MenuCheckButton@ datatype.
+newtype MenuCheckButton = MenuCheckButton GUIOBJECT
+
+
+-- -----------------------------------------------------------------------
+-- commands
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new menu checkbutton and returns a handler.
+createMenuCheckButton :: Menu
+ -- ^ the parent menu.
+ -> [Config MenuCheckButton]
+ -- ^ the list of configuration options for this menu
+ -- checkbutton.
+ ->
+ IO MenuCheckButton
+ -- ^ A menu checkbutton.
+createMenuCheckButton m cnf =
+ createMenuItem m MENUCHECKBUTTON MenuCheckButton cnf
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | A menu checkbutton is a menu item (any menu item instantiates the
+-- abstract @class MenuItem@).
+instance MenuItem MenuCheckButton
+
+-- | Internal.
+instance Eq MenuCheckButton where
+ w1 == w2 = (toGUIObject w1) == (toGUIObject w2)
+
+-- | Internal.
+instance GUIObject MenuCheckButton where
+ toGUIObject (MenuCheckButton w) = w
+ cname _ = "MenuCheckButton"
+
+-- | You can synchronize on a menu checkbutton.
+instance Synchronized MenuCheckButton where
+ -- Synchronizes on a menu checkbutton.
+ synchronize = synchronize . toGUIObject
+
+-- | A menu checkbutton has an optional text to display as a reminder
+-- about a keystroke binding.
+instance HasAccelerator MenuCheckButton
+
+-- | A menu checkbutton can contain a bitmap (instead of text or an image).
+instance HasBitMap MenuCheckButton
+
+-- | A menu checkbutton has a configureable border.
+instance HasBorder MenuCheckButton
+
+-- | A menu checkbutton has a normal foreground and background colour and
+-- an active\/disabled foreground and background colour.
+instance HasColour MenuCheckButton where
+ legalColourID = buttonColours
+
+-- | A menu checkbutton is a stateful object, it can be enabled or
+-- disabled.
+instance HasEnable MenuCheckButton
+
+-- | You can specify the font of a menu checkbutton.
+instance HasFont MenuCheckButton
+
+-- | A menu checkbutton has a configureable text justification.
+instance HasJustify MenuCheckButton
+
+-- | You can display an indicator with a menu checkbutton.
+instance HasIndicator MenuCheckButton
+
+-- | A menu checkbutton can contain an image (instead of text or a bitmap).
+instance HasPhoto MenuCheckButton
+
+-- | You can specify the size of a menu checkbutton.
+instance HasSize MenuCheckButton
+
+-- | A menu checkbutton can contain text (instead of an image or bitmap).
+instance GUIValue v => HasText MenuCheckButton v where
+ -- Sets the text to display.
+ text str w = cset w "label" str >> return w
+ -- Gets the displayed text.
+ getText w = cget w "label"
+
+-- | You can set the index of a text character to underline.
+instance HasUnderline MenuCheckButton
+
+-- | The polymorphic variable the menu checkbutton\'s value is associated
+-- with.
+instance HasVariable MenuCheckButton
+
+-- | A menu checkbutton has a value, that corresponds to a polymorphic
+-- @TkVariable@.
+instance GUIValue v => HasValue MenuCheckButton v
+
+-- | When a menu checkbutton is clicked, a corresponding event is invoked.
+instance HasCommand MenuCheckButton
diff --git a/HTk/Menuitems/MenuCommand.hs b/HTk/Menuitems/MenuCommand.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Menuitems/MenuCommand.hs
@@ -0,0 +1,113 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | HTk\'s /menu command/.
+-- A simple command inside a menu.
+module HTk.Menuitems.MenuCommand (
+
+ MenuCommand,
+ createMenuCommand
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.Configuration
+import HTk.Components.BitMap
+import HTk.Menuitems.Menu
+import HTk.Menuitems.MenuItem
+import HTk.Menuitems.Indicator
+import Events.Synchronized
+import Util.Computation
+
+
+-- -----------------------------------------------------------------------
+-- MenuCommand type
+-- -----------------------------------------------------------------------
+
+-- | The @MenuCommand@ datatype.
+newtype MenuCommand = MenuCommand GUIOBJECT
+
+
+-- -----------------------------------------------------------------------
+-- commands
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new menu command and returns a handler.
+createMenuCommand :: Menu
+ -- ^ the parent menu.
+ -> [Config MenuCommand]
+ -- ^ the list of configuration options for this menu
+ -- command.
+ -> IO MenuCommand
+ -- ^ A menu command.
+createMenuCommand m cnf = createMenuItem m MENUCOMMAND MenuCommand cnf
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | A menu command is a menu item (any menu item instantiates the
+-- abstract @class MenuItem@).
+instance MenuItem MenuCommand
+
+-- | Internal.
+instance Eq MenuCommand where
+ w1 == w2 = (toGUIObject w1) == (toGUIObject w2)
+
+-- | Internal.
+instance GUIObject MenuCommand where
+ toGUIObject (MenuCommand w) = w
+ cname _ = "MenuCommand"
+
+-- | You can synchronize on a menu command.
+instance Synchronized MenuCommand where
+ -- Synchronizes on a menu command.
+ synchronize = synchronize . toGUIObject
+
+-- | A menu command has an optional text to display as a reminder
+-- about a keystroke binding.
+instance HasAccelerator MenuCommand
+
+-- | A menu command can contain a bitmap (instead of text or an image).
+instance HasBitMap MenuCommand
+
+-- | A menu command has a configureable border.
+instance HasBorder MenuCommand
+
+-- | A menu command has a normal foreground and background colour and
+-- an active\/disabled foreground and background colour.
+instance HasColour MenuCommand where
+ legalColourID = buttonColours
+
+-- | A menu command is a stateful object, it can be enabled or
+-- disabled.
+instance HasEnable MenuCommand
+
+-- | You can specify the font of a menu command.
+instance HasFont MenuCommand
+
+-- | A menu command has a configureable text justification.
+instance HasJustify MenuCommand
+
+-- | You can display an indicator with a menu command.
+instance HasIndicator MenuCommand
+
+-- | A menu command can contain an image (instead of text or a bitmap).
+instance HasPhoto MenuCommand
+
+-- | You can specify the size of a menu command.
+instance HasSize MenuCommand
+
+-- | A menu command can contain text (instead of an image or bitmap).
+instance GUIValue v => HasText MenuCommand v where
+ -- Sets the text to display.
+ text str w = cset w "label" str >> return w
+ -- Gets the displayed text.
+ getText w = cget w "label"
+
+-- | You can set the index of a text character to underline.
+instance HasUnderline MenuCommand
+
+-- | When a menu command is clicked, a corresponding event is invoked.
+instance HasCommand MenuCommand
diff --git a/HTk/Menuitems/MenuItem.hs b/HTk/Menuitems/MenuItem.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Menuitems/MenuItem.hs
@@ -0,0 +1,199 @@
+-- | The @module MenuItem@ exports general resources for menu
+-- items.
+module HTk.Menuitems.MenuItem (
+
+ MenuItem,
+ createMenuItem,
+ menuItemMethods,
+
+ HasColour(..),
+ HasPhoto(..),
+
+ SelectButton(..),
+ ToggleButton(..),
+ HasAccelerator(..),
+
+ buttonColours
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.ButtonWidget
+import HTk.Kernel.Configuration
+import HTk.Kernel.Resources
+import HTk.Components.Image
+import Reactor.ReferenceVariables
+import Util.Computation
+import Events.Events
+import HTk.Menuitems.Menu
+
+
+-- -----------------------------------------------------------------------
+-- class MenuContainer
+-- -----------------------------------------------------------------------
+
+-- | Menu items instantiate the abstract @class MenuItem@.
+class GUIObject w => MenuItem w
+
+
+-- -----------------------------------------------------------------------
+-- SelectButton
+-- -----------------------------------------------------------------------
+
+-- | A select button can be selected or not selected.
+class ButtonWidget w => SelectButton w where
+ -- Sets the selection state of the select button.
+ selectionState :: Toggle -> Config w
+ -- Gets the selection state of the select button
+ getSelectionState :: w -> IO Toggle
+ -- Returns an event for selection actions.
+ selectionStateSet :: w -> Event Toggle
+
+ selectionState On w =
+ execMethod (toGUIObject w) (\ nm -> tkSelect nm) >> return w
+
+ selectionState Off w =
+ execMethod (toGUIObject w) (\ nm -> tkDeselect nm) >> return w
+
+
+-- -----------------------------------------------------------------------
+-- Accelerator
+-- -----------------------------------------------------------------------
+
+-- | Menu items can have an optional text to display as a reminder
+-- about a keystroke binding.
+class GUIObject w => HasAccelerator w where
+ -- Sets the accelerator text.
+ accelerator :: String -> Config w
+ -- Gets the accelerator text.
+ getAccelerator :: w -> IO String
+ accelerator s w = cset w "accelerator" s
+ getAccelerator w = cget w "accelerator"
+
+
+-- -----------------------------------------------------------------------
+-- Toggle buttons
+-- -----------------------------------------------------------------------
+
+-- | The state of a @ToggleButton@ can be toggled.
+class SelectButton w => ToggleButton w where
+ -- Toggles the state of a toggle button.
+ toggleButton :: w -> IO ()
+ toggleButton w =
+ execMethod (toGUIObject w) (\ nm -> tkToggle nm)
+
+
+-- -----------------------------------------------------------------------
+-- Unparsing of Button Commands
+-- -----------------------------------------------------------------------
+
+tkSelect :: ObjectName -> TclScript
+tkSelect (MenuItemName name i) = []
+tkSelect name = [show name ++ " select"]
+{-# INLINE tkSelect #-}
+
+tkDeselect :: ObjectName -> TclScript
+tkDeselect (MenuItemName name i) = []
+tkDeselect name = [show name ++ " deselect"]
+{-# INLINE tkDeselect #-}
+
+tkToggle :: ObjectName -> TclScript
+tkToggle (MenuItemName name i) = []
+tkToggle name = [show name ++ " toggle"]
+{-# INLINE tkToggle #-}
+
+tkButtonCmd :: ObjectID -> TclCmd
+tkButtonCmd key = "Clicked " ++ show key
+{-# INLINE tkButtonCmd #-}
+
+
+-- -----------------------------------------------------------------------
+-- MenuItem creation
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+createMenuItem :: MenuItem w => Menu -> MenuItemKind ->
+ (GUIOBJECT -> w) -> [Config w] -> IO w
+createMenuItem menu@(Menu _ r) kind wrap ol =
+ do
+ i <- getRef r
+ setRef r (i + 1)
+ w <- createGUIObject (toGUIObject menu) (MENUITEM kind i)
+ menuItemMethods
+ let mi = wrap w
+ configure mi ol
+
+
+-- -----------------------------------------------------------------------
+-- item methods
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+menuItemMethods :: Methods
+menuItemMethods = Methods tkGetMenuItemConfig
+ tkSetMenuItemConfigs
+ tkCreateMenuItem
+ (packCmd voidMethods)
+ (gridCmd voidMethods)
+ (destroyCmd voidMethods)
+ (bindCmd voidMethods)
+ (unbindCmd voidMethods)
+ (cleanupCmd defMethods)
+
+
+-- -----------------------------------------------------------------------
+-- unparsing of menu commands
+-- -----------------------------------------------------------------------
+
+tkCreateMenuItem :: ObjectName -> ObjectKind -> ObjectName -> ObjectID ->
+ [ConfigOption] -> TclScript
+tkCreateMenuItem nm kind _ {-nm-} _ args = tkCreateMenuItem' kind nm args'
+ where args' = filter (not . isIllegalMenuItemConfig . first) args
+
+tkCreateMenuItem' :: ObjectKind -> ObjectName -> [ConfigOption] ->
+ TclScript
+tkCreateMenuItem' kind menu opts =
+ [show menu ++ " add " ++ (show kind) ++ " " ++ (showECO opts)]
+
+tkGetMenuItemConfig :: ObjectName -> ConfigID -> TclScript
+tkGetMenuItemConfig (MenuItemName name i) "text" =
+ [(show name) ++ " entrycget " ++ (show i) ++ " -label"]
+tkGetMenuItemConfig (MenuItemName name i) cid
+ | (isIllegalMenuItemConfig cid ) = []
+tkGetMenuItemConfig (MenuItemName name i) cid =
+ [show name ++ " entrycget " ++ show i ++ " -" ++ cid]
+tkGetMenuItemConfig _ _ = []
+
+tkSetMenuItemConfigs :: ObjectName -> [ConfigOption] -> TclScript
+tkSetMenuItemConfigs (MenuItemName name i) args =
+ [show name ++ " entryconfigure " ++ (show i) ++ " " ++ showECO args]
+tkSetMenuItemConfigs _ _ = []
+
+showECO :: [ConfigOption] -> String
+showECO [] = ""
+showECO (("text",v) : ecl) = showConfig ("label", v) ++ " " ++ showECO ecl
+showECO (x : ecl) = showConfig x ++ " " ++ showECO ecl
+
+first (a, b) = a
+
+
+-- -----------------------------------------------------------------------
+-- filtering of configs
+-- -----------------------------------------------------------------------
+
+isIllegalMenuItemConfig :: ConfigID -> Bool
+isIllegalMenuItemConfig "indicatoron" = True
+isIllegalMenuItemConfig "disabledforeground" = True
+isIllegalMenuItemConfig "borderwidth" = True
+isIllegalMenuItemConfig "relief" = True
+isIllegalMenuItemConfig "cursor" = True
+isIllegalMenuItemConfig "takefocus" = True
+isIllegalMenuItemConfig "highlightbackground" = True
+isIllegalMenuItemConfig "highlightcolor" = True
+isIllegalMenuItemConfig "highlightthickness" = True
+isIllegalMenuItemConfig "width" = True
+isIllegalMenuItemConfig "height" = True
+isIllegalMenuItemConfig "wraplength" = True
+isIllegalMenuItemConfig "anchor" = True
+isIllegalMenuItemConfig "justify" = True
+isIllegalMenuItemConfig _ = False
diff --git a/HTk/Menuitems/MenuRadioButton.hs b/HTk/Menuitems/MenuRadioButton.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Menuitems/MenuRadioButton.hs
@@ -0,0 +1,121 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | HTk\'s /menu radiobutton/.
+-- A simple radiobutton inside a menu associated with a polymorphic
+-- variable.
+module HTk.Menuitems.MenuRadioButton (
+
+ MenuRadioButton,
+ createMenuRadioButton
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.Configuration
+import HTk.Components.BitMap
+import HTk.Menuitems.Menu
+import HTk.Menuitems.MenuItem
+import HTk.Menuitems.Indicator
+import Events.Synchronized
+import Util.Computation
+import HTk.Kernel.TkVariables
+
+
+-- -----------------------------------------------------------------------
+-- datatype
+-- -----------------------------------------------------------------------
+
+-- | The @MenuRadioButton@ datatype.
+newtype MenuRadioButton = MenuRadioButton GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- commands
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new menu radiobutton and returns a handler.
+createMenuRadioButton :: Menu
+ -- ^ the parent menu.
+ -> [Config MenuRadioButton]
+ -- ^ the list of configuration options for this menu
+ -- radiobutton.
+ ->
+ IO MenuRadioButton
+ -- ^ A menu radiobutton.
+createMenuRadioButton m cnf =
+ createMenuItem m MENURADIOBUTTON MenuRadioButton cnf
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | A menu radiobutton is a menu item (any menu item instantiates the
+-- abstract @class MenuItem@).
+instance MenuItem MenuRadioButton
+
+-- | Internal.
+instance GUIObject MenuRadioButton where
+ toGUIObject (MenuRadioButton w) = w
+ cname _ = "MenuRadioButton"
+
+-- | You can synchronize on a menu radiobutton.
+instance Synchronized MenuRadioButton where
+ -- Synchronizes on a menu radiobutton.
+ synchronize = synchronize . toGUIObject
+
+-- | A menu radiobutton has an optional text to display as a reminder
+-- about a keystroke binding.
+instance HasAccelerator MenuRadioButton
+
+-- | A menu radiobutton can contain a bitmap (instead of text or an image).
+instance HasBitMap MenuRadioButton
+
+-- | A menu radiobutton has a configureable border.
+instance HasBorder MenuRadioButton
+
+-- | A menu radiobutton has a normal foreground and background colour and
+-- an active\/disabled foreground and background colour.
+instance HasColour MenuRadioButton where
+ legalColourID = buttonColours
+
+-- | A menu radiobutton is a stateful object, it can be enabled or
+-- disabled.
+instance HasEnable MenuRadioButton
+
+-- | You can specify the font of a menu radiobutton.
+instance HasFont MenuRadioButton
+
+-- | A menu radiobutton has a configureable text justification.
+instance HasJustify MenuRadioButton
+
+-- | You can display an indicator with a menu radiobutton.
+instance HasIndicator MenuRadioButton
+
+-- | You can specify the size of a menu radiobutton.
+instance HasPhoto MenuRadioButton
+
+-- | You can specify the size of a menu radiobutton.
+instance HasSize MenuRadioButton
+
+-- | A menu radiobutton can contain text (instead of an image or bitmap).
+instance GUIValue v => HasText MenuRadioButton v where
+ -- Sets the text to display.
+ text str w = cset w "label" str >> return w
+ -- Gets the displayed text.
+ getText w = cget w "label"
+
+-- | You can set the index of a text character to underline.
+instance HasUnderline MenuRadioButton
+
+-- | The polymorphic variable the menu radiobutton\'s value is associated
+-- with.
+instance HasVariable MenuRadioButton
+
+-- | A menu radiobutton has a value, that corresponds to a polymorphic
+-- @TkVariable@.
+instance GUIValue v => HasValue MenuRadioButton v
+
+-- | When a menu radiobutton is clicked, a corresponding event is invoked.
+instance HasCommand MenuRadioButton
diff --git a/HTk/Menuitems/MenuSeparator.hs b/HTk/Menuitems/MenuSeparator.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Menuitems/MenuSeparator.hs
@@ -0,0 +1,71 @@
+-- | HTk\'s /menu separator/.
+-- A simple separator to group menu entries.
+module HTk.Menuitems.MenuSeparator (
+
+ MenuSeparator,
+ createMenuSeparator
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.Configuration
+import HTk.Kernel.Resources
+import HTk.Menuitems.MenuItem
+import HTk.Menuitems.Menu
+import Events.Synchronized
+import Util.Computation
+
+
+-- -----------------------------------------------------------------------
+-- datatype
+-- -----------------------------------------------------------------------
+
+-- | The @MenuSeparator@ datatype.
+data MenuSeparator = MenuSeparator GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- creation
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new menu separator and returns a handler.
+createMenuSeparator :: Menu
+ -- ^ the parent menu.
+ -> [Config MenuSeparator]
+ -- ^ the list of configuration options for this menu
+ -- separator.
+ -> IO MenuSeparator
+ -- ^ A menu separator.
+createMenuSeparator m cnf =
+ createMenuItem m MENUSEPARATOR MenuSeparator cnf
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | A menu separator is a menu item (any menu item instantiates the
+-- abstract @class MenuItem@).
+instance MenuItem MenuSeparator
+
+-- | Internal.
+instance GUIObject MenuSeparator where
+ toGUIObject (MenuSeparator w) = w
+ cname w = "MenuSeparator"
+
+-- | You can synchronize on a menu separator.
+instance Synchronized MenuSeparator where
+ -- Synchronizes on a menu separator.
+ synchronize = synchronize . toGUIObject
+
+-- | A menu separator has a configureable border.
+instance HasBorder MenuSeparator
+
+-- | A menu separator has either a vertival or a horizontal orientation.
+instance HasOrientation MenuSeparator where
+ -- Sets the menu separators orientation.
+ orient Horizontal s = configure s [height 2] >> return s
+ orient Vertical s = configure s [width 2] >> return s
+
+-- | You can specify the size of a menu separator.
+instance HasSize MenuSeparator
diff --git a/HTk/Textitems/EmbeddedTextWin.hs b/HTk/Textitems/EmbeddedTextWin.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Textitems/EmbeddedTextWin.hs
@@ -0,0 +1,157 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+-- | HTk\'s /embedded windows/ inside an editor widget.
+module HTk.Textitems.EmbeddedTextWin (
+
+ EmbeddedTextWin,
+ createEmbeddedTextWin,
+
+ stretch,
+ getStretch
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Widgets.Editor
+import HTk.Components.Index
+import Util.Computation
+import Events.Synchronized
+import HTk.Kernel.Resources
+import Events.Destructible
+import HTk.Kernel.Geometry
+import HTk.Kernel.BaseClasses(Widget)
+
+-- -----------------------------------------------------------------------
+-- type EmbeddedTextWin
+-- -----------------------------------------------------------------------
+
+-- | The @EmbeddedTextWin@ datatype.
+newtype EmbeddedTextWin = EmbeddedTextWin GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- creation
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new embedded window inside an editor widget and returns
+-- a handler.
+createEmbeddedTextWin :: (HasIndex Editor i BaseIndex, Widget w) =>
+ Editor
+ -- ^ the parent editor widget.
+ -> i
+ -- ^ the editor\'s index to place the embedded window.
+ -> w
+ -- ^ the contained widget.
+ ->
+ [Config EmbeddedTextWin]
+ -- ^ the list of configuration options for this embedded
+ -- text window.
+ -> IO EmbeddedTextWin
+ -- ^ An embedded window inside an editor widget.
+createEmbeddedTextWin ed i w cnf =
+ do
+ binx <- getBaseIndex ed i
+ pos <- getBaseIndex ed (binx::BaseIndex)
+ nm <- getObjectName (toGUIObject w)
+ wid <- createGUIObject (toGUIObject ed)
+ (EMBEDDEDTEXTWIN (unparse pos) nm) winMethods
+ configure (EmbeddedTextWin wid) cnf
+ where unparse :: Position -> GUIVALUE
+ unparse (x,y) = toGUIValue (RawData (show x ++ "." ++ show y))
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject EmbeddedTextWin where
+ toGUIObject (EmbeddedTextWin w) = w
+ cname _ = "EmbeddedTextWin"
+
+-- | An embedded text window can be destroyed.
+instance Destroyable EmbeddedTextWin where
+ -- Destroys an embedded text window.
+ destroy = destroy . toGUIObject
+
+-- | You can synchronize on an embedded text window object.
+instance Synchronized EmbeddedTextWin where
+ -- Synchronizes on an embedded text window object.
+ synchronize = synchronize . toGUIObject
+
+
+-- -----------------------------------------------------------------------
+-- widget specific configuration options
+-- -----------------------------------------------------------------------
+
+-- | If set the contained widget is stretched vertically to match the
+-- spacing of the line.
+stretch :: Toggle -> Config EmbeddedTextWin
+stretch t w = cset w "stretch" t
+
+-- | Gets the current stretch setting.
+getStretch :: EmbeddedTextWin -> IO Toggle
+getStretch ew = cget ew "stretch"
+
+
+-- -----------------------------------------------------------------------
+-- index
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance HasIndex Editor EmbeddedTextWin BaseIndex where
+ getBaseIndex tp win =
+ synchronize win
+ (do
+ name <- getObjectName (toGUIObject win)
+ case name of
+ (TextPaneItemName pnm (EmbeddedWindowName wnm)) ->
+ do
+ str <- evalTclScript (tkWinIndex pnm wnm)
+ return (read str))
+
+
+-- -----------------------------------------------------------------------
+-- Text Item Methods
+-- -----------------------------------------------------------------------
+
+winMethods =
+ Methods tkGetTextWinConfig
+ tkSetTextWinConfigs
+ tkCreateTextWin
+ (packCmd voidMethods)
+ (gridCmd voidMethods)
+ (destroyCmd voidMethods)
+ (bindCmd voidMethods)
+ (unbindCmd voidMethods)
+ (cleanupCmd defMethods)
+
+
+-- -----------------------------------------------------------------------
+-- Unparsing of Text Window Commands
+-- -----------------------------------------------------------------------
+
+tkGetTextWinConfig :: ObjectName -> ConfigID -> TclScript
+tkGetTextWinConfig (TextPaneItemName name qual) cid =
+ [show name ++ " window cget " ++ show qual ++ " -" ++ cid]
+tkGetTextWinConfig _ _ = [] -- unclear case
+{-# INLINE tkGetTextWinConfig #-}
+
+tkSetTextWinConfigs :: ObjectName -> [ConfigOption] -> TclScript
+tkSetTextWinConfigs (TextPaneItemName name qual) args =
+ [show name ++ " window configure " ++ show qual ++ " " ++
+ showConfigs args]
+tkSetTextWinConfigs _ _ = []
+{-# INLINE tkSetTextWinConfigs #-}
+
+tkCreateTextWin :: ObjectName -> ObjectKind -> ObjectName -> ObjectID ->
+ [ConfigOption] -> TclScript
+tkCreateTextWin _ (EMBEDDEDTEXTWIN pos wid) (TextPaneItemName name qual) _
+ confs =
+ [show name ++ " window create " ++ show pos ++ " -window " ++ show wid]
+{-# INLINE tkCreateTextWin #-}
+
+tkWinIndex :: ObjectName -> ObjectName -> TclScript
+tkWinIndex pnm wnm = [show pnm ++ " index " ++ show wnm]
+{-# INLINE tkWinIndex #-}
diff --git a/HTk/Textitems/Mark.hs b/HTk/Textitems/Mark.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Textitems/Mark.hs
@@ -0,0 +1,177 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+-- | This module provides access to text marks inside an editor widget.
+module HTk.Textitems.Mark (
+
+ Gravity(..),
+
+ Mark(..),
+ createMark,
+ setMarkGravity,
+
+ setMark,
+ unsetMark,
+
+ getCurrentMarks
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Components.Index
+import HTk.Components.ICursor
+import HTk.Components.Selection
+import HTk.Widgets.Editor
+import Data.Char(isSpace)
+import Events.Synchronized
+
+
+-- -----------------------------------------------------------------------
+-- type Mark
+-- -----------------------------------------------------------------------
+
+-- | The @Mark@ datatype.
+data Mark = Mark Editor String deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- creation
+-- -----------------------------------------------------------------------
+
+-- | Creates a text mark inside an editor widget and returns a handler.
+createMark :: HasIndex Editor i BaseIndex =>
+ Editor
+ -- ^ the concerned editor widget.
+ -> String
+ -- ^ the name of the text mark to create.
+ -> i
+ -- ^ the text marks index position inside the editor
+ -- widget.
+ -> IO Mark
+ -- ^ A text mark.
+createMark ed name i =
+ synchronize ed (do
+ ix <- getBaseIndex ed i
+ execMethod ed (\nm -> tkMarkSet nm name ix)
+ return (Mark ed name))
+
+
+-- -----------------------------------------------------------------------
+-- Mark Operations
+-- -----------------------------------------------------------------------
+
+-- | Sets the gravity of the given text mark.
+setMarkGravity :: Mark
+ -- ^ the concerned text mark.
+ -> Gravity
+ -- ^ the gravity to set.
+ -> IO ()
+ -- ^ None.
+setMarkGravity mark @ (Mark tp name) grav =
+ execMethod tp (\nm -> tkSetMarkGravity nm name grav)
+ where tkSetMarkGravity tnm mnm g =
+ [show tnm ++ " mark gravity " ++ show mnm ++ " " ++ show g]
+
+-- | Gets the gravity from the given text mark.
+getMarkGravity :: Mark
+ -- ^ the concerned text mark.
+ -> IO Gravity
+ -- ^ The current gravity setting.
+getMarkGravity mark @ (Mark tp name) =
+ evalMethod tp (\nm -> tkGetMarkGravity nm name)
+ where tkGetMarkGravity tnm mnm =
+ [show tnm ++ " mark gravity " ++ show mnm]
+
+-- | Unsets a text mark inside an editor widget.
+unsetMark :: Mark
+ -- ^ the concerned text mark.
+ -> IO ()
+ -- ^ None.
+unsetMark mark@(Mark tp name) = execMethod tp (\nm -> tkMarkUnset nm name)
+ where tkMarkUnset nm mname = [show nm ++ " mark unset " ++ show mname]
+
+-- | Sets the index position of the text mark.
+setMark :: HasIndex Editor i BaseIndex => Mark
+ -- ^ the concerned tex mark.
+ -> i
+ -> IO ()
+ -- ^ None.
+setMark mark@(Mark tp name) i =
+ do
+ binx <- getBaseIndex tp i
+ execMethod tp (\nm -> tkMarkSet nm name binx)
+
+-- | Gets the current marks from an editor widget.
+getCurrentMarks :: Editor
+ -- ^ the concerned editor widget.
+ -> IO [Mark]
+ -- ^ A list of text marks.
+getCurrentMarks ed =
+ do
+ str <- evalMethod ed (\nm -> [show nm ++ " mark names "])
+ return (map (Mark ed) (words str))
+
+
+-- -----------------------------------------------------------------------
+-- Index
+-- -----------------------------------------------------------------------
+
+-- | The @MousePosition@ datatype.
+data MousePosition = MousePosition Editor
+
+-- | Internal.
+instance HasIndex Editor Mark BaseIndex where
+ getBaseIndex w (Mark _ str) = return (IndexText str)
+
+-- | Internal.
+instance HasIndex Editor (Selection Editor) BaseIndex where
+ getBaseIndex w p = return (IndexText "sel")
+
+-- | Internal.
+instance HasIndex Editor (ICursor Editor) BaseIndex where
+ getBaseIndex w p = return (IndexText "insert")
+
+-- | Internal.
+instance HasIndex Editor MousePosition BaseIndex where
+ getBaseIndex w p = return (IndexText "current")
+
+
+-- -----------------------------------------------------------------------
+-- Gravity
+-- -----------------------------------------------------------------------
+
+-- | The @Gravity@ datatype.
+data Gravity = ToLeft | ToRight deriving (Eq,Ord,Enum)
+
+-- | Internal.
+instance Read Gravity where
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ 'l':'e':'f':'t':xs -> [(ToLeft,xs)]
+ 'r':'i':'g':'h':'t':xs -> [(ToRight,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show Gravity where
+ showsPrec d p r =
+ (case p of
+ ToLeft -> "left"
+ ToRight -> "right"
+ ) ++ r
+
+-- | Internal.
+instance GUIValue Gravity where
+ cdefault = ToLeft
+
+
+-- -----------------------------------------------------------------------
+-- unparsing of Mark commands
+-- -----------------------------------------------------------------------
+
+tkMarkSet :: ObjectName -> String -> BaseIndex -> TclScript
+tkMarkSet tname mname ix =
+ [show tname ++ " mark set " ++ show mname ++ " " ++ ishow ix]
+
+ishow :: BaseIndex -> String
+ishow i = "{" ++ show i ++ "}"
diff --git a/HTk/Textitems/TextTag.hs b/HTk/Textitems/TextTag.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Textitems/TextTag.hs
@@ -0,0 +1,382 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+-- | This module provides access to text tags inside an editor widget.
+module HTk.Textitems.TextTag (
+ TextTag,
+ createTextTag,
+
+ addTextTag,
+ lowerTextTag,
+ raiseTextTag,
+ removeTextTag,
+
+ lmargin1,
+ getLmargin1,
+
+ lmargin2,
+ getLmargin2,
+
+ rmargin,
+ getRmargin,
+
+ offset,
+ getOffset,
+
+ overstrike,
+ getOverstrike,
+
+ underlined,
+ getUnderlined,
+
+ bgstipple,
+ getBgstipple,
+
+ fgstipple,
+ getFgstipple
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.Resources
+import HTk.Kernel.Geometry
+import HTk.Kernel.Configuration
+import HTk.Widgets.Editor
+import HTk.Components.BitMap
+import HTk.Components.Index
+import Util.Computation
+import Events.Synchronized
+import Events.Destructible
+
+-- -----------------------------------------------------------------------
+-- TextTag type
+-- -----------------------------------------------------------------------
+
+-- | The @TextTag@ datatype.
+data TextTag = TextTag Editor GUIOBJECT
+
+
+-- -----------------------------------------------------------------------
+-- construction
+-- -----------------------------------------------------------------------
+
+-- | Creates a text tag inside an editor widget and returns a handler.
+createTextTag :: (HasIndex Editor i1 BaseIndex,
+ HasIndex Editor i2 BaseIndex) =>
+ Editor
+ -- ^ the concerned editor widget.
+ -> i1
+ -- ^ the start index.
+ -> i2
+ -- ^ the end index.
+ -> [Config TextTag]
+ -- ^ the list of configuration options for this text tag.
+ -> IO TextTag
+ -- ^ A text tag.
+createTextTag ed i1 i2 cnf =
+ do
+ bi1 <- getBaseIndex ed i1
+ bi2 <- getBaseIndex ed i2
+ w <- createGUIObject (toGUIObject ed)
+ (TEXTTAG (map unparse [bi1::BaseIndex,bi2]))
+ tagMethods
+ configure (TextTag ed w) cnf
+ where unparse (IndexNo _) = GUIVALUE HaskellTk ""
+ unparse (IndexText s) = GUIVALUE HaskellTk ("{" ++ s ++ "}")
+ unparse p = GUIVALUE HaskellTk (show p ++ " ")
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance Eq TextTag where
+ (TextTag _ w1) == (TextTag _ w2) = (toGUIObject w1) == (toGUIObject w2)
+
+-- | Internal.
+instance GUIObject TextTag where
+ toGUIObject (TextTag _ w) = w
+ cname _ = "TextTag"
+
+-- | A text tag can be destroyed.
+instance Destroyable TextTag where
+ -- Destroys a text tag.
+ destroy = destroy . toGUIObject
+
+-- | A text tag has a configureable border.
+instance HasBorder TextTag
+
+-- | A text tag has a configureable foregroud and background colour.
+instance HasColour TextTag where
+ legalColourID = hasForeGroundColour
+
+-- | A text tag has a configureable font.
+instance HasFont TextTag
+
+-- | A text tag has a configureable text justification.
+instance HasJustify TextTag
+
+-- | A text tag has a configureable line spacing.
+instance HasLineSpacing TextTag
+
+-- | A text tag has adjustable tab stops.
+instance HasTabulators TextTag
+
+-- | You can synchronize on a text tag object.
+instance Synchronized TextTag where
+ -- Synchronizes on a text tag object.
+ synchronize = synchronize . toGUIObject
+
+
+-- -----------------------------------------------------------------------
+-- Tag Commands
+-- -----------------------------------------------------------------------
+
+-- | Adds the specified text range to a text tag.
+addTextTag :: (HasIndex Editor i1 BaseIndex,
+ HasIndex Editor i2 BaseIndex) =>
+ TextTag
+ -- ^ the concerned text tag.
+ -> i1
+ -- ^ the start index.
+ -> i2
+ -- ^ the end index.
+ -> IO ()
+ -- ^ None.
+addTextTag tag@(TextTag tp _) start end =
+ synchronize tag (
+ do
+ start' <- getBaseIndex tp start
+ end' <- getBaseIndex tp end
+ execMethod tag (\nm -> tkTagAdd nm start' end')
+ )
+
+-- | Removes the specified text range from a text tag.
+removeTextTag :: (HasIndex Editor i1 BaseIndex,
+ HasIndex Editor i2 BaseIndex) =>
+ TextTag
+ -- ^ the concerned text tag.
+ -> i1
+ -- ^ the start index.
+ -> i2
+ -- ^ the end index.
+ -> IO ()
+ -- ^ None.
+removeTextTag tag @ (TextTag tp _) start end =
+ synchronize tag (
+ do
+ start' <- getBaseIndex tp start
+ end' <- getBaseIndex tp end
+ execMethod tag (\nm -> tkTagRemove nm start' end')
+ )
+
+-- | Lowers the text tag.
+lowerTextTag :: TextTag
+ -- ^ the concerned text tag.
+ -> IO ()
+ -- ^ None.
+lowerTextTag tag = execMethod tag (\nm -> tkTagLower nm)
+
+-- | Raises the given text tag.
+raiseTextTag :: TextTag
+ -- ^ the concerned text tag.
+ -> IO ()
+ -- ^ None.
+raiseTextTag tag = execMethod tag (\nm -> tkTagRaise nm)
+
+
+-- -----------------------------------------------------------------------
+-- tag configure options
+-- -----------------------------------------------------------------------
+
+-- | Sets the normal left intend for a line.
+lmargin1 :: Distance -> Config TextTag
+lmargin1 s tag = cset tag "lmargin1" s
+
+-- | Gets the normal left intend for a line.
+getLmargin1 :: TextTag -> IO Distance
+getLmargin1 tag = cget tag "lmargin1"
+
+-- | Sets the intend for a part of a line that gets wrapped.
+lmargin2 :: Distance -> Config TextTag
+lmargin2 s tag = cset tag "lmargin2" s
+
+-- | Gets the intend for a part of a line that gets wrapped.
+getLmargin2 :: TextTag -> IO Distance
+getLmargin2 tag = cget tag "lmargin2"
+
+-- | Sets the right-hand margin.
+rmargin :: Distance -> Config TextTag
+rmargin s tag = cset tag "rmargin" s
+
+-- | Gets the right-hand margin.
+getRmargin :: TextTag -> IO Distance
+getRmargin tag = cget tag "rmargin"
+
+-- | Sets the baseline offset (positive for superscripts).
+offset :: Distance -> Config TextTag
+offset s tag = cset tag "offset" s
+
+-- | Gets the baseline offset.
+getOffset :: TextTag -> IO Distance
+getOffset tag = cget tag "offset"
+
+-- | If @True@, the text is drawn with a horizontal line through
+-- it.
+overstrike :: Toggle -> Config TextTag
+overstrike s tag = cset tag "overstrike" s
+
+-- | Gets the current overstrike setting.
+getOverstrike :: TextTag -> IO Toggle
+getOverstrike tag = cget tag "overstrike"
+
+-- | If @True@, the text is underlined.
+underlined :: Toggle -> Config TextTag
+underlined s tag = cset tag "underline" s
+
+-- | Gets the current underline setting.
+getUnderlined :: TextTag -> IO Toggle
+getUnderlined tag = cget tag "underline"
+
+-- | Sets a stipple pattern for the background colour.
+bgstipple :: BitMapHandle -> Config TextTag
+bgstipple s tag = setBitMapHandle tag "bgstipple" s False
+
+-- | Gets the stipple pattern for the background colour.
+getBgstipple ::TextTag -> IO BitMapHandle
+getBgstipple tag = getBitMapHandle tag "bgstipple"
+
+-- | Sets a stipple pattern for the foreground colour.
+fgstipple :: BitMapHandle -> Config TextTag
+fgstipple s tag = setBitMapHandle tag "fgstipple" s False
+
+-- | Gets the stipple pattern for the foreground colour.
+getFgstipple :: TextTag -> IO BitMapHandle
+getFgstipple tag = getBitMapHandle tag "fgstipple"
+
+
+-- -----------------------------------------------------------------------
+-- Index: Tag First and Last
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance HasIndex Editor (TextTag, First) BaseIndex where
+ getBaseIndex tp (tag,_) =
+ synchronize tag (
+ do
+ (pnm, tnm) <- getTagName tag
+ return (IndexText (show tnm ++ ".first"))
+ )
+
+-- | Internal.
+instance HasIndex Editor (TextTag, Last) BaseIndex where
+ getBaseIndex tp (tag,_) =
+ synchronize tag (
+ do
+ (pnm, tnm) <- getTagName tag
+ return (IndexText (show tnm ++ ".last"))
+ )
+
+getTagName :: GUIObject w => w -> IO (ObjectName, TextItemName)
+getTagName tag =
+ do
+ TextPaneItemName pnm tid <- getObjectName (toGUIObject tag)
+ return (pnm, tid)
+
+
+-- -----------------------------------------------------------------------
+-- tag methods
+-- -----------------------------------------------------------------------
+
+tagMethods =
+ Methods
+ tkGetTextTagConfig
+ tkSetTextTagConfigs
+ tkCreateTextTag
+ (packCmd voidMethods)
+ (gridCmd voidMethods)
+ tkTagDelete
+ tkBindTextTag
+ tkUnbindTextTag
+ (cleanupCmd defMethods)
+
+
+
+-- -----------------------------------------------------------------------
+-- unparsing of tag commands
+-- -----------------------------------------------------------------------
+
+tkGetTextTagConfig :: ObjectName -> ConfigID -> TclScript
+tkGetTextTagConfig (TextPaneItemName name tnm) cid =
+ [(show name) ++ " tag cget " ++ (show tnm) ++ " -" ++ cid]
+tkGetTextTagConfig _ _ = []
+{-# INLINE tkGetTextTagConfig #-}
+
+tkSetTextTagConfigs :: ObjectName -> [ConfigOption] -> TclScript
+tkSetTextTagConfigs _ [] = []
+tkSetTextTagConfigs (TextPaneItemName name (tnm @ (TextTagID k))) args =
+ [show name ++ " tag configure " ++ show tnm ++ " " ++ showConfigs args]
+tkSetTextTagConfigs _ _ = []
+{-# INLINE tkSetTextTagConfigs #-}
+
+tkCreateTextTag :: ObjectName -> ObjectKind -> ObjectName -> ObjectID ->
+ [ConfigOption] -> TclScript
+tkCreateTextTag _ (TEXTTAG il) (TextPaneItemName name tnm) _ args =
+ [show name ++ " tag add " ++ show tnm ++ " " ++
+ concat (map unfold il) ++ " " ++ (showConfigs args)]
+ where unfold (GUIVALUE _ str) = str ++ " "
+--tkCreateTextTag _ _ _ _ _ = []
+{-# INLINE tkCreateTextTag #-}
+
+tkTagAdd :: ObjectName -> BaseIndex -> BaseIndex -> TclScript
+tkTagAdd (TextPaneItemName name tnm) start end =
+ [show name ++ " tag add " ++ show tnm ++ " " ++ show start ++ " " ++
+ show end]
+tkTagAdd _ _ _ = []
+{-# INLINE tkTagAdd #-}
+
+tkTagDelete :: ObjectName -> TclScript
+tkTagDelete (TextPaneItemName name tnm) =
+ [show name ++ " tag delete " ++ show tnm]
+tkTagDelete _ = []
+{-# INLINE tkTagDelete #-}
+
+tkBindTextTag :: ObjectName -> BindTag -> [WishEvent] -> EventInfoSet ->
+ Bool -> TclScript
+tkBindTextTag (TextPaneItemName name tnm) bindTag wishEvents
+ eventInfoSet _ =
+ let doBind = show name ++ " tag bind " ++ show tnm ++ " " ++
+ delimitString (foldr (\ event soFar -> showP event soFar)
+ "" wishEvents) ++ " " ++
+ mkBoundCmdArg bindTag eventInfoSet False
+ in [doBind]
+{-# INLINE tkBindTextTag #-}
+
+tkUnbindTextTag :: ObjectName -> BindTag -> [WishEvent] -> Bool ->
+ TclScript
+tkUnbindTextTag (TextPaneItemName name tnm) bindTag wishEvents _ =
+ [show name ++ " tag bind " ++ show tnm ++ " " ++
+ delimitString (foldr (\ event soFar -> showP event soFar)
+ "" wishEvents) ++ " {}"]
+{-# INLINE tkUnbindTextTag #-}
+
+tkTagLower :: ObjectName -> TclScript
+tkTagLower (TextPaneItemName name tnm) =
+ [show name ++ " tag lower " ++ show tnm]
+tkTagLower _ = []
+{-# INLINE tkTagLower #-}
+
+tkTagRaise :: ObjectName -> TclScript
+tkTagRaise (TextPaneItemName name tnm) =
+ [show name ++ " tag raise " ++ show tnm]
+tkTagRaise _ = []
+{-# INLINE tkTagRaise #-}
+
+tkTagRemove :: ObjectName -> BaseIndex -> BaseIndex -> TclScript
+tkTagRemove (TextPaneItemName name tnm) start end =
+ [show name ++ " tag remove " ++ show tnm ++ " " ++ show start ++ " " ++
+ show end]
+tkTagRemove _ _ _ = []
+{-# INLINE tkTagRemove #-}
diff --git a/HTk/Tix/LabelFrame.hs b/HTk/Tix/LabelFrame.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Tix/LabelFrame.hs
@@ -0,0 +1,197 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | HTk\'s /LabelFrame/ widget.
+-- A labelled container for widgets. This widget is from the Tix library
+-- and therefore only available if Tix is installed. When Tix is not
+-- available, a normal frame widget will be used instead.
+module HTk.Tix.LabelFrame (
+
+ LabelFrame,
+ newLabelFrame,
+
+ labelSide,
+ getLabelSide,
+ LabelSide(..)
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import Util.Computation
+import Events.Synchronized
+import Events.Destructible
+import HTk.Kernel.Packer
+import Data.Char
+import HTk.Kernel.PackOptions
+import HTk.Kernel.GridPackOptions
+import HTk.Kernel.Tooltip
+
+-- -----------------------------------------------------------------------
+-- type LabelFrame
+-- -----------------------------------------------------------------------
+
+-- | The @LabelFrame@ datatype.
+newtype LabelFrame = LabelFrame GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- labelled frame creation
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new label frame and returns it as a value.
+newLabelFrame :: Container par => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> [Config LabelFrame]
+ -- ^ the list of configuration options for this labelled
+ -- frame.
+ ->
+ IO LabelFrame
+ -- ^ A labelled frame.
+newLabelFrame par cnf =
+ do
+ w <- createGUIObject (toGUIObject par) LABELFRAME labelFrameMethods
+ configure (LabelFrame w) cnf
+
+
+-- -----------------------------------------------------------------------
+-- widget specific configuration options
+-- -----------------------------------------------------------------------
+
+-- | You can specify the side to display the label.
+labelSide :: LabelSide -> Config LabelFrame
+labelSide ls w = cset w "labelside" ls
+
+-- | Gets the side where the label is displayed.
+getLabelSide :: LabelFrame -> IO LabelSide
+getLabelSide w = cget w "labelside"
+
+-- | The @LabelSide@ datatype.
+data LabelSide =
+ TopLabel | LeftLabel | RightLabel | BottomLabel | NoLabel
+ | AcrossTopLabel
+
+-- | Internal.
+instance Read LabelSide where
+ readsPrec p b =
+ case dropWhile isSpace b of
+ 't':'o':'p': xs -> [(TopLabel,xs)]
+ 'l':'e':'f':'t': xs -> [(LeftLabel, xs)]
+ 'r':'i':'g':'h':'t': xs -> [(RightLabel, xs)]
+ 'b':'o':'t':'t':'o':'m': xs -> [(BottomLabel, xs)]
+ 'n':'o':'n':'e': xs -> [(NoLabel, xs)]
+ 'a':'c':'r':'o':'s':'s':'t':'o':'p': xs -> [(AcrossTopLabel, xs)]
+ _ -> []
+
+-- | Internal.
+instance Show LabelSide where
+ showsPrec d p r =
+ (case p of TopLabel -> "top"
+ LeftLabel -> "left"
+ RightLabel -> "right"
+ BottomLabel -> "bottom"
+ NoLabel -> "none"
+ AcrossTopLabel -> "acrosstop") ++ r
+
+-- | Internal.
+instance GUIValue LabelSide where
+ cdefault = TopLabel
+
+
+-- -----------------------------------------------------------------------
+-- labelled frame methods
+-- -----------------------------------------------------------------------
+
+labelFrameMethods = Methods tkGetLabelFrameConfig
+ tkSetLabelFrameConfigs
+ tkCreateLabelFrame
+ tkPackLabelFrame
+ tkGridLabelFrame
+ (destroyCmd defMethods)
+ (bindCmd defMethods)
+ (unbindCmd defMethods)
+ (cleanupCmd defMethods)
+
+
+-- -----------------------------------------------------------------------
+-- unparsing of labelled frame commands
+-- -----------------------------------------------------------------------
+
+tkGetLabelFrameConfig :: ObjectName -> ConfigID -> TclScript
+tkGetLabelFrameConfig (LabelFrameName nm oid) cid =
+ [show nm ++ " cget -" ++ cid]
+{-# INLINE tkGetLabelFrameConfig #-}
+
+tkSetLabelFrameConfigs :: ObjectName -> [ConfigOption] -> TclScript
+tkSetLabelFrameConfigs (LabelFrameName nm oid) args =
+ [show nm ++ " configure " ++ showConfigs args]
+tkSetLabelFrameConfigs _ _ = []
+{-# INLINE tkSetLabelFrameConfigs #-}
+
+tkCreateLabelFrame :: ObjectName -> ObjectKind -> ObjectName ->
+ ObjectID -> [ConfigOption] -> TclScript
+tkCreateLabelFrame parnm _ nm oid args =
+ ["tixLabelFrame " ++ show parnm ++ "." ++ show oid ++ " "++
+ showConfigs args,
+ "global v" ++ show oid,
+ "set v" ++ show oid ++ " [" ++ show parnm ++ "." ++ show oid ++ " subwidget frame]"]
+{-# INLINE tkCreateLabelFrame #-}
+
+tkPackLabelFrame :: ObjectName -> [PackOption] -> TclScript
+tkPackLabelFrame (LabelFrameName nm _) opts =
+ ["pack " ++ show nm ++ " " ++ showPackOptions opts]
+
+tkGridLabelFrame :: ObjectName -> [GridPackOption] -> TclScript
+tkGridLabelFrame (LabelFrameName nm _) opts =
+ ["grid " ++ show nm ++ " " ++ showGridPackOptions opts]
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject LabelFrame where
+ toGUIObject (LabelFrame w) = w
+ cname _ = "LabelFrame"
+
+-- | A labelled frame can be destroyed.
+instance Destroyable LabelFrame where
+ -- Destroys a labelled frame widget.
+ destroy = destroy . toGUIObject
+
+-- | A labelled frame has standard widget properties
+-- (concerning focus, cursor).
+instance Widget LabelFrame
+
+-- | A labelled frame is a container for widgets. You can pack widgets to
+-- a labelled frame via pack or grid command in the
+-- @module HTk.Kernel.Packer@.
+instance Container LabelFrame
+
+-- | A labelled frame has a configureable border.
+instance HasBorder LabelFrame
+
+-- | A labelled frame has a background colour.
+instance HasColour LabelFrame where
+ legalColourID = hasBackGroundColour
+
+-- | A labelled frame can have a tooltip.
+instance HasTooltip LabelFrame
+
+-- | You can specify the size of a labelled frame.
+instance HasSize LabelFrame
+
+-- | Sets and gets the string to display as a label for the frame.
+instance GUIValue v => HasText LabelFrame v where
+ -- Sets the text to display with the frame.
+ text s w = cset w "label" s
+ -- Returns the displayed text.
+ getText w = cget w "label"
+
+-- | You can synchronize on a labelled frame (in JAVA style).
+instance Synchronized LabelFrame where
+ -- Synchronizes on a label object.
+ synchronize = synchronize . toGUIObject
diff --git a/HTk/Tix/NoteBook.hs b/HTk/Tix/NoteBook.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Tix/NoteBook.hs
@@ -0,0 +1,194 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | HTk\'s /notebook/ and
+-- /notebook pages/.
+-- This widget is from the Tix library and therefore only available if
+-- you are using tixwish.
+module HTk.Tix.NoteBook (
+
+ NoteBook,
+ NoteBookPage,
+
+ newNoteBook,
+ createNoteBookPage
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import Util.Computation
+import Events.Synchronized
+import Events.Destructible
+import HTk.Kernel.Packer
+import HTk.Kernel.Tooltip
+
+-- -----------------------------------------------------------------------
+-- type NoteBook
+-- -----------------------------------------------------------------------
+
+-- | The @NoteBook@ datatype.
+newtype NoteBook = NoteBook GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- notebook creation
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new notebook widget and returns it as a value.
+newNoteBook :: Container par => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> [Config NoteBook]
+ -- ^ the list of configuration options for this notebook.
+ -> IO NoteBook
+ -- ^ A notebook widget.
+newNoteBook par cnf =
+ do
+ w <- createWidget (toGUIObject par) NOTEBOOK
+ configure (NoteBook w) cnf
+
+
+-- -----------------------------------------------------------------------
+-- notebook instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject NoteBook where
+ toGUIObject (NoteBook w) = w
+ cname _ = "NoteBook"
+
+-- | You can specify the size of a notebook widget.
+instance HasSize NoteBook
+
+-- | A notebook widget has standard widget properties (focus, cursor, ...).
+instance Widget NoteBook
+
+-- | A notebook widget can be destroyed.
+instance Destroyable NoteBook where
+ -- Destroys a notebook widget.
+ destroy = destroy . toGUIObject
+
+-- | You can synchronize on a notebook object (in JAVA style).
+instance Synchronized NoteBook where
+ -- Synchronizes on a notebook object.
+ synchronize = synchronize . toGUIObject
+
+
+
+-- -----------------------------------------------------------------------
+-- type NoteBookPage
+-- -----------------------------------------------------------------------
+
+-- | The @NoteBookPage@ datatype - a single page of a notebook.
+newtype NoteBookPage = NoteBookPage GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- notebook page creation
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new page inside a notebook widget and returns it as a
+-- value.
+createNoteBookPage :: NoteBook
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> String
+ -- ^ the list of configuration options for this notebook
+ -- page.
+ -> [Config NoteBookPage]
+ ->
+ IO NoteBookPage
+ -- ^ A notebook page.
+createNoteBookPage nb title cnf =
+ do
+ w <- createGUIObject (toGUIObject nb) (NOTEBOOKPAGE title) pageMethods
+ configure (NoteBookPage w) cnf
+
+
+-- -----------------------------------------------------------------------
+-- notebook page methods
+-- -----------------------------------------------------------------------
+
+pageMethods = Methods tkGetNoteBookPageConfig
+ tkSetNoteBookPageConfigs
+ tkCreateNoteBookPage
+ (packCmd voidMethods)
+ (gridCmd voidMethods)
+ (destroyCmd defMethods)
+ (bindCmd defMethods)
+ (unbindCmd defMethods)
+ (cleanupCmd defMethods)
+
+
+-- -----------------------------------------------------------------------
+-- unparsing of notebook page commands
+-- -----------------------------------------------------------------------
+
+tkGetNoteBookPageConfig :: ObjectName -> ConfigID -> TclScript
+tkGetNoteBookPageConfig (NoteBookPageName oid) cid =
+ ["global v" ++ show oid,
+ "$v" ++ show oid ++ " cget -" ++ cid]
+{-# INLINE tkGetNoteBookPageConfig #-}
+
+tkSetNoteBookPageConfigs :: ObjectName -> [ConfigOption] -> TclScript
+tkSetNoteBookPageConfigs (NoteBookPageName oid) args =
+ ["global v" ++ show oid,
+ "$v" ++ show oid ++ " configure " ++ showConfigs args]
+tkSetNoteBookPageConfigs _ _ = []
+{-# INLINE tkSetNoteBookPageConfigs #-}
+
+tkCreateNoteBookPage :: ObjectName -> ObjectKind -> ObjectName ->
+ ObjectID -> [ConfigOption] -> TclScript
+tkCreateNoteBookPage parnm (NOTEBOOKPAGE title) _ oid args =
+ [show parnm ++ " add " ++ show oid ++ " -label \"" ++ title ++ "\" " ++
+ showConfigs args,
+ "global v" ++ show oid,
+ "set v" ++ show oid ++ " [" ++ show parnm ++ " subwidget " ++
+ show oid ++ "]"]
+{-# INLINE tkCreateNoteBookPage #-}
+
+
+-- -----------------------------------------------------------------------
+-- notebook page instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject NoteBookPage where
+ toGUIObject (NoteBookPage w) = w
+ cname _ = "NoteBookPage"
+
+-- | A notebook page can be destroyed.
+instance Destroyable NoteBookPage where
+ -- Destroys a notebook page.
+ destroy = destroy . toGUIObject
+
+-- | A notebook page has standard widget properties
+-- (concerning focus, cursor).
+instance Widget NoteBookPage
+
+-- | A notebook page is a container for widgets. You can pack widgets to
+-- a notebook page via pack or grid command in the
+-- @module HTk.Kernel.Packer@.
+instance Container NoteBookPage
+
+-- | A notebook page has a text label.
+instance GUIValue a => HasText NoteBookPage a where
+ text s w = cset w "label" s
+ getText w = cget w "label"
+
+-- | A notebook page has a configureable border.
+instance HasBorder NoteBookPage
+
+-- | A notebook page can have a tooltip.
+instance HasTooltip NoteBookPage
+
+-- | A notebook page has a background colour.
+instance HasColour NoteBookPage where
+ legalColourID = hasBackGroundColour
+
+-- | You can synchronize on a notebook page (in JAVA style).
+instance Synchronized NoteBookPage where
+ -- Synchronizes on a notebook page object.
+ synchronize = synchronize . toGUIObject
diff --git a/HTk/Tix/PanedWindow.hs b/HTk/Tix/PanedWindow.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Tix/PanedWindow.hs
@@ -0,0 +1,265 @@
+-- | HTk\'s /PanedWindow/.
+-- A paned window is a container widget, that is divided into scaleable
+-- horizontal or vertical panes.
+module HTk.Tix.PanedWindow (
+
+ PanedWindow,
+ newPanedWindow,
+
+ Pane,
+ createPane,
+
+ after,
+ before,
+ at,
+ expand,
+ minsize,
+ maxsize,
+ initsize
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import HTk.Kernel.Resources
+import Util.Computation
+import Events.Synchronized
+import Events.Destructible
+import HTk.Kernel.Packer
+
+-- -----------------------------------------------------------------------
+-- type PanedWindow
+-- -----------------------------------------------------------------------
+
+-- | The @PanedWindow@ datatype.
+newtype PanedWindow = PanedWindow GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- paned window creation
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new paned window and returns it as a value.
+newPanedWindow :: Container par => par
+ -- ^ the list of configuration options for this
+ -- paned window.
+ -> Orientation
+ ->
+ [Config PanedWindow]
+ -> IO PanedWindow
+ -- ^ A paned window.
+newPanedWindow par or cnf =
+ do
+ w <- createGUIObject (toGUIObject par) (PANEDWINDOW or)
+ panedWindowMethods
+ configure (PanedWindow w) cnf
+
+
+-- -----------------------------------------------------------------------
+-- paned window methods
+-- -----------------------------------------------------------------------
+
+panedWindowMethods :: Methods
+panedWindowMethods = Methods (cgetCmd defMethods)
+ (csetCmd defMethods)
+ tkCreatePanedWindow
+ (packCmd defMethods)
+ (gridCmd defMethods)
+ (destroyCmd defMethods)
+ (bindCmd defMethods)
+ (unbindCmd defMethods)
+ (cleanupCmd defMethods)
+
+tkCreatePanedWindow :: ObjectName -> ObjectKind -> ObjectName ->
+ ObjectID -> [ConfigOption] -> TclScript
+tkCreatePanedWindow _ (PANEDWINDOW or) name _ opts =
+ ["tixPanedWindow " ++ show name ++ " -orientation " ++ show or ++ " " ++
+ showConfigs opts]
+tkCreatePanedWindow _ _ _ _ _ = []
+{-# INLINE tkCreatePanedWindow #-}
+
+
+-- -----------------------------------------------------------------------
+-- paned window instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject PanedWindow where
+ toGUIObject (PanedWindow f) = f
+ cname _ = "PanedWindow"
+
+-- | You can specify the size of a paned window.
+instance HasSize PanedWindow
+
+-- | A paned window can be destroyed.
+instance Destroyable PanedWindow where
+ -- Destroys a paned window.
+ destroy = destroy . toGUIObject
+
+-- | A paned window has standard widget properties (focus, cursor, ...).
+instance Widget PanedWindow
+
+-- | You can synchronize on a paned window object (in JAVA style).
+instance Synchronized PanedWindow where
+ -- Synchronizes on a paned window object.
+ synchronize = synchronize . toGUIObject
+
+
+-- -----------------------------------------------------------------------
+-- type Pane
+-- -----------------------------------------------------------------------
+
+-- | The @Pane@ datatype - a pane inside a paned window.
+newtype Pane = Pane GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- pane creation
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new pane inside a paned window and returns it as a
+-- value.
+createPane :: PanedWindow
+ -- ^ the parent widget, which has to be a paned window.
+ -> [CreationConfig Pane]
+ -- ^ the list of configuration options for this pane.
+ -> [Config Pane]
+ ->
+ IO Pane
+ -- ^ A window pane.
+createPane nb ccnf cnf =
+ do
+ ccnfstr <- showCreationConfigs ccnf
+ w <- createGUIObject (toGUIObject nb) WINDOWPANE
+ (windowPaneMethods ccnfstr)
+ configure (Pane w) cnf
+
+
+-- -----------------------------------------------------------------------
+-- pane creation options
+-- -----------------------------------------------------------------------
+
+-- | Specifies that the new pane should be placed after pane in the list of
+-- panes in this PanedWindow widget
+-- (this is an initial configuration that cannot be changed later).
+after :: Pane -> CreationConfig Pane
+after pane =
+ do nm <- getObjectName (toGUIObject pane)
+ return ("after " ++ show nm)
+
+-- | Specifies that the new pane should be placed before pane in the list of
+-- panes in this PanedWindow widget
+-- (this is an initial configuration that cannot be changed later).
+before :: Pane -> CreationConfig Pane
+before pane =
+ do nm <- getObjectName (toGUIObject pane)
+ return ("before " ++ show nm)
+
+-- | Specifies the position of the new pane in the list of panes in this
+-- PanedWindow widget. 0 means the first position, 1 means the second,
+-- and so on.
+at :: Int -> CreationConfig Pane
+at n = return ("at " ++ show n)
+
+-- | Specifies the expand\/shrink factor of this pane as a non-negative
+-- floating point number. The default value is 0.0. The expand\/shrink
+-- factor is used to calculate how much each pane should grow or shrink
+-- when the size of the PanedWindow main window is changed. When the main
+-- window expands\/shrinks by n pixels, then pane i will grow\/shrink by
+-- about n \* factor(i) \/ summation(factors), where factor(i) is the
+-- expand\/shrink factor of pane i and summation(factors) is the summation
+-- of the expand\/shrink factors of all the panes. If summation(factors)
+-- is 0.0, however, only the last visible pane will be grown or shrunk.
+expand :: Double -> CreationConfig Pane
+expand d = return ("expand " ++ show d)
+
+-- | Specifies the minimum size, in pixels, of the new pane; the default
+-- is 0.
+minsize :: Int -> CreationConfig Pane
+minsize i = return ("min " ++ show i)
+
+-- | Specifies the maximum size, in pixels, of the new pane; the default is
+-- 10000.
+maxsize :: Int -> CreationConfig Pane
+maxsize i = return ("max " ++ show i)
+
+-- | Specifies the size, in pixels, of the new pane; if the -size option is
+-- not given, the PanedWindow widget will use the natural size of the pane
+-- subwidget.
+initsize :: Int -> CreationConfig Pane
+initsize i = return ("size " ++ show i)
+
+
+-- -----------------------------------------------------------------------
+-- window pane methods
+-- -----------------------------------------------------------------------
+
+windowPaneMethods ccnf = Methods tkGetPaneConfig
+ tkSetPaneConfigs
+ (tkCreatePane ccnf)
+ (packCmd voidMethods)
+ (gridCmd voidMethods)
+ (destroyCmd defMethods)
+ (bindCmd defMethods)
+ (unbindCmd defMethods)
+ (cleanupCmd defMethods)
+
+
+-- -----------------------------------------------------------------------
+-- unparsing of pane commands
+-- -----------------------------------------------------------------------
+
+tkGetPaneConfig :: ObjectName -> ConfigID -> TclScript
+tkGetPaneConfig (PaneName oid) cid =
+ ["global v" ++ show oid,
+ "$v" ++ show oid ++ " cget -" ++ cid]
+{-# INLINE tkGetPaneConfig #-}
+
+tkSetPaneConfigs :: ObjectName -> [ConfigOption] -> TclScript
+tkSetPaneConfigs (PaneName oid) args =
+ ["global v" ++ show oid,
+ "$v" ++ show oid ++ " configure " ++ showConfigs args]
+tkSetNoteBookPageConfigs _ _ = []
+{-# INLINE tkSetPaneConfigs #-}
+
+tkCreatePane :: String -> ObjectName -> ObjectKind -> ObjectName ->
+ ObjectID -> [ConfigOption] -> TclScript
+tkCreatePane ccnfstr parnm WINDOWPANE _ oid _ =
+ [show parnm ++ " add " ++ show oid ++ " " ++ ccnfstr,
+ "global v" ++ show oid,
+ "set v" ++ show oid ++ " [" ++ show parnm ++ " subwidget " ++
+ show oid ++ "]"]
+tkCreatePane _ _ _ _ _ _ = []
+{-# INLINE tkCreatePane #-}
+
+
+-- -----------------------------------------------------------------------
+-- window pane instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject Pane where
+ toGUIObject (Pane f) = f
+ cname _ = "Pane"
+
+-- | A pane can be destroyed.
+instance Destroyable Pane where
+ -- Destroys a pane.
+ destroy = destroy . toGUIObject
+
+-- | A pane has standard widget properties (focus, cursor...).
+instance Widget Pane
+
+-- | A pane has a background colour.
+instance HasColour Pane where
+ legalColourID = hasBackGroundColour
+
+-- | A pane is a container for widgets. You can pack widgets to a pane via
+-- the pack or grid command in the @module Packer@.
+instance Container Pane
+
+-- | You can synchronize on a pane object (in JAVA style).
+instance Synchronized Pane where
+ -- Synchronizes on a pane object.
+ synchronize = synchronize . toGUIObject
diff --git a/HTk/Tix/Subwidget.hs b/HTk/Tix/Subwidget.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Tix/Subwidget.hs
@@ -0,0 +1,43 @@
+module HTk.Tix.Subwidget (
+
+ CanBeSubwidget (..),
+ createSubwidget
+
+) where
+
+import HTk.Kernel.Core
+ (ObjectKind (..),createGUIObject,ObjectName,ObjectID,TclScript,
+ ConfigOption, Methods (..), GUIOBJECT,getObjectName,getParentObject)
+import HTk.Kernel.BaseClasses (Widget)
+
+-- | Using the function createSubwidget, instantiating the
+-- @class CanBeSubwidget@
+-- should be easy, compare as an example instantiation of the @Entry@ widget.
+createSubwidget :: ObjectKind -> Methods -> GUIOBJECT -> IO GUIOBJECT
+createSubwidget kind meths megawidget
+ = do mwName <- getObjectName megawidget
+ Just parent <- getParentObject megawidget
+ let megaName = show mwName
+ createGUIObject parent (SUBWIDGET kind megaName)
+ (meths { createCmd = tkDoNothing })
+
+-- ---------------------------------------------------------
+-- TkDoNothing: There is nothing to do to create Subwidgets.
+-- ---------------------------------------------------------
+
+tkDoNothing::ObjectName->ObjectKind->ObjectName->ObjectID->[ConfigOption]
+ ->TclScript
+tkDoNothing _ _ _ _ _ = []
+{-# INLINE tkDoNothing #-}
+
+-- | Tix mega widgets are composed of several subwidgets.
+-- As it is sometimes important to access these subwidgets, there
+-- is a way in Htk of creating widgets as subwidgets by instanciating the
+-- @class CanBeSubwidget@.
+
+-- | Use createAsSubwidget instead of the normal constructor new[WidgetName].
+class Widget w => CanBeSubwidget w where
+ createAsSubwidget :: GUIOBJECT -> IO w
+ -- The only parameter is a reference to the mega widget the subwidget
+ -- is part of.
+
diff --git a/HTk/Toolkit/CItem.hs b/HTk/Toolkit/CItem.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/CItem.hs
@@ -0,0 +1,21 @@
+-- | Objects with a name and an icon (used for several purposes).
+module HTk.Toolkit.CItem (
+
+ CItem(..)
+
+) where
+
+import HTk.Toplevel.HTk
+import HTk.Toolkit.Name
+
+
+------------------------------------------------------------
+-- class CItem collects all properties items need to have --
+------------------------------------------------------------
+
+-- | Objects with a name and an icon.
+class Eq c => CItem c where
+ -- Gets the object\'s name.
+ getName :: c -> IO Name
+ -- Gets the object\'s icon.
+ getIcon :: c -> IO Image
diff --git a/HTk/Toolkit/DialogWin.hs b/HTk/Toolkit/DialogWin.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/DialogWin.hs
@@ -0,0 +1,473 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | Basic dialog window and a couple of predefined abstractions.
+module HTk.Toolkit.DialogWin (
+ Dialog,
+
+ dialog,
+
+ createAlertWin,
+ createErrorWin,
+ createWarningWin,
+ createConfirmWin,
+ createMessageWin,
+ createAlertWin',
+ createErrorWin',
+ createWarningWin',
+ createConfirmWin',
+ createMessageWin',
+ createDialogWin,
+ createDialogWin',
+
+ loadHTkImages,
+
+ questionImg,
+
+ useHTk,
+ ) where
+
+import Data.Maybe(fromMaybe)
+
+import System.IO.Unsafe
+
+import Util.Messages
+import Util.ExtendedPrelude (newFallOut,mkBreakFn)
+import Util.Computation
+
+import Events.Events
+
+import HTk.Kernel.Core
+import qualified HTk.Toplevel.HTk as HTk (font)
+import HTk.Toplevel.HTk hiding (font)
+import HTk.Widgets.Space
+import HTk.Toolkit.SelectBox
+import HTk.Toolkit.ModalDialog
+import HTk.Toolkit.MarkupText
+import HTk.Toolkit.Separator
+
+-- --------------------------------------------------------------------------
+-- Types
+-- --------------------------------------------------------------------------
+
+-- | A @Choice@ represents the name of a button (@String@) and the
+-- value returned when this button is pressed.
+type Choice a = (String,a)
+
+-- | The @Dialog@ datatype.
+data Dialog a = Dialog {
+ fWindow :: Toplevel,
+ fEditor :: Maybe Editor, -- we only have
+ fMsg :: Maybe Message, -- one of these two
+ fLabel :: Label,
+ fSelectBox :: SelectBox,
+ fEvents :: (Event a)
+ }
+
+-- --------------------------------------------------------------------------
+-- Instances
+-- --------------------------------------------------------------------------
+-- | Internal.
+instance GUIObject (Dialog a) where
+ toGUIObject dlg = toGUIObject (fWindow dlg)
+ cname dlg = cname (fWindow dlg)
+
+-- | A dialog can have an image
+instance HasPhoto (Dialog a) where
+ photo p dlg = do {fLabel dlg # photo p; return dlg}
+
+-- | The programm message is displayed as @MarkupText@
+instance HasMarkupText (Dialog a) where
+ new t dlg =
+ case fEditor dlg of
+ Just e -> do {e # new t; return dlg}
+ _ -> return dlg
+ insertAt _ _ _ = error
+ "HTk.Toolkit.DialogWin.instance HasMarkupText (Dialog a) insertAt"
+ clear = error
+ "HTk.Toolkit.DialogWin.instance HasMarkupText (Dialog a) clear"
+
+
+-- | The message displayed as plain text.
+instance GUIValue v=> HasText (Dialog a) v where
+ text t dlg =
+ case fMsg dlg of
+ Just l -> do {l # text t; return dlg}
+ _ -> return dlg
+
+
+-- | Returns configuration option for dialogs that displays text using a
+-- scrollbox if it is bigger than the default size (currently (60,6).
+-- It also returns a Bool which indicates if we are to use createDialogWin
+-- (False) or createDialogWin' (True).
+
+scrollText :: String -> (Config (Dialog a),Bool)
+scrollText = scrollText1 (60,6)
+
+
+-- | Configuration option for dialogs that displays text using a scrollbox
+-- if it is bigger than the given size.
+--
+-- NB. The argument (39,6) to scrollMarkupText cannot be increased without
+-- increasing the size of the message window, which is hardcoded into this
+-- module.
+scrollText1 :: Size -> String -> (Config (Dialog a),Bool)
+scrollText1 size str =
+ if biggerThan size str
+ then
+ (new [scrollMarkupText (39,6) [prose str]],True)
+ else
+ (text str,False)
+ where
+ biggerThan (xMax,yMax) str =
+ let
+ strl = lines str
+ in
+ length strl > fromIntegral yMax
+ || any (\ line -> length line > fromIntegral xMax) strl
+
+-- --------------------------------------------------------------------------
+-- Derived Dialog Window
+-- --------------------------------------------------------------------------
+
+-- | Constructs an alert window with the given text
+createAlertWin :: String
+ -- ^ the text to be displayed
+ -> [Config Toplevel]
+ -> IO ()
+createAlertWin str wol =
+ do
+ catchDestroyedFallOut (createFn choices Nothing confs (defs ++ wol))
+ done
+ where
+ choices = [("Continue",())]
+ defs = [text "Alert Window"]
+
+ (scrollConf,complex) = scrollText str
+ confs = [scrollConf,photo warningImg]
+ createFn = if complex then createDialogWin' else createDialogWin
+
+-- | Constructs an alert window with the given markuptext
+createAlertWin' :: [MarkupText]
+ -- ^ the markuptext to be displayed
+ -> [Config Toplevel]
+ -> IO ()
+createAlertWin' str wol =
+ do
+ catchDestroyedFallOut (
+ createDialogWin' choices Nothing (confs++[photo warningImg])
+ (defs ++ wol)
+ )
+ done
+ where choices = [("Continue",())]
+ defs = [text "Alert Window"]
+ confs = [new str]
+
+-- | Constructs an error window with the given text
+createErrorWin :: String
+ -- ^ the text to be displayed
+ -> [Config Toplevel]
+ -> IO ()
+createErrorWin str wol =
+ do
+ catchDestroyedFallOut (createFn choices Nothing confs (defs++wol))
+ done
+ where
+ choices = [("Continue",())]
+ defs = [text "Error Message"]
+
+ (scrollConf,complex) = scrollText str
+ confs = [scrollConf,photo errorImg]
+ createFn = if complex then createDialogWin' else createDialogWin
+
+-- | Constructs an error window with the given markuptext
+createErrorWin' :: [MarkupText]
+ -- ^ the markuptext to be displayed
+ -> [Config Toplevel]
+ -> IO ()
+createErrorWin' str wol =
+ do
+ catchDestroyedFallOut (
+ createDialogWin' choices Nothing (confs++[photo errorImg]) (defs++wol)
+ )
+ done
+ where choices = [("Continue",())]
+ defs = [text "Error Message"]
+ confs = [new str]
+
+
+-- | Constructs an warning window with the given text
+createWarningWin :: String
+ -- ^ the text to be displayed
+ -> [Config Toplevel]
+ -> IO ()
+createWarningWin str confs = createAlertWin str (text "Warning Message": confs)
+
+-- | Constructs an warning window with the given markuptext
+createWarningWin' :: [MarkupText]
+ -- ^ the markuptext to be displayed
+ -> [Config Toplevel]
+ -> IO ()
+createWarningWin' str confs =
+ createAlertWin' str (text "Warning Message": confs)
+
+-- | Constructs an confirm window with the given text
+createConfirmWin :: String
+ -- ^ the text to be displayed
+ -> [Config Toplevel]
+ -> IO Bool
+ -- ^ True(Ok) or False(Cancel)
+createConfirmWin str wol =
+ do
+ bOpt <- catchDestroyedFallOut (
+ createFn choices (Just 0) confs (defs ++ wol)
+ )
+ return (fromMaybe False bOpt)
+ where
+ choices = [("Ok",True),("Cancel",False)]
+ defs = [text "Confirm Window"]
+
+ (scrollConf,complex) = scrollText str
+ confs = [scrollConf,photo questionImg]
+ createFn = if complex then createDialogWin' else createDialogWin
+
+-- | Constructs an confirm window with the given markuptext
+createConfirmWin' :: [MarkupText]
+ -- ^ the markuptext to be displayed
+ -> [Config Toplevel]
+ -> IO Bool
+ -- ^ True(Ok) or False(Cancel)
+createConfirmWin' str wol =
+ do
+ bOpt <- catchDestroyedFallOut (
+ createDialogWin' choices (Just 0) (confs++[photo questionImg])
+ (defs ++ wol)
+ )
+ return (fromMaybe False bOpt)
+ where choices = [("Ok",True),("Cancel",False)]
+ defs = [text "Confirm Window"]
+ confs = [new str]
+
+-- | Constructs a message (info) window with the given markuptext
+createMessageWin' :: [MarkupText]
+ -- ^ the markup text to be displayed
+ -> [Config Toplevel]
+ -> IO ()
+ -- ^ ()
+createMessageWin' str wol =
+ do
+ catchDestroyedFallOut (
+ createDialogWin' [("Dismiss", ())] Nothing
+ [new str, photo infoImg]
+ (text "Information": wol)
+ )
+ done
+
+
+
+-- | Constructs a message (info) window with the given string.
+createMessageWin :: String
+ -- ^ the string to be displayed
+ -> [Config Toplevel]
+ -> IO ()
+ -- ^ ()
+createMessageWin str wol =
+ do
+ catchDestroyedFallOut (
+ createFn [("Dismiss", ())] Nothing confs (text "Information": wol)
+ )
+ done
+ where
+ (scrollConf,complex) = scrollText str
+ confs = [scrollConf,photo infoImg]
+ createFn = if complex then createDialogWin' else createDialogWin
+
+
+-- | Constructs a new dialogue window for plain text
+createDialogWin :: [Choice a]
+ -- ^ the available buttons in this window
+ -> Maybe Int
+ -- ^ default button
+ -> [Config (Dialog a)]
+ -- ^ the list of configuration options for this separator
+ -> [Config Toplevel]
+ -- ^ the list of configuration options for the window
+ -> IO a
+ -- ^
+createDialogWin choices def confs wol =
+ do
+ dlg <- dialog True choices def confs wol
+ result <- modalInteraction (fWindow dlg) True True (fEvents dlg)
+ return result
+
+-- | Constructs a new dialow window for markup text
+createDialogWin' :: [Choice a]
+ -- ^ the available buttons in this window
+ -> Maybe Int
+ -- ^ default button
+ -> [Config (Dialog a)]
+ -- ^ the list of configuration options for this separator
+ -> [Config Toplevel]
+ -- ^ the list of configuration options for the window
+ -> IO a
+ -- ^
+createDialogWin' choices def confs wol =
+ do
+ dlg <- dialog False choices def confs wol
+ result <- modalInteraction (fWindow dlg) True True (fEvents dlg)
+ return result
+
+
+-- --------------------------------------------------------------------------
+-- Base Dialog Window
+-- --------------------------------------------------------------------------
+-- | Creates a new dialogue with its label, text and buttons.
+dialog :: Bool
+ -- ^ the available button in this window
+ -> [Choice a]
+ -- ^ true if we just want a label to display message, false if we want a fancy read-only text editor
+ -> Maybe Int
+ -- ^ default button
+ -> [Config (Dialog a)]
+ -- ^ the list of configuration options for this separator
+ -> [Config Toplevel]
+ -- ^ the list of configuration options for the window
+ -> IO (Dialog a)
+ -- ^ a dialog
+dialog plain choices def confs tpconfs =
+ do
+ (tp, emsg, lmsg, lbl, sb, ev) <- delayWish $
+ do
+ tp <- createToplevel tpconfs
+ pack tp [Expand On, Fill Both]
+
+ b <- newVBox tp []
+ pack b [Expand On, Fill Both]
+
+ b2 <- newHBox b []
+ pack b2 [Expand On, Fill Both]
+
+ lbl <- newLabel b2 []
+ pack lbl [Expand On, Fill Both, PadX (cm 0.5), PadY (cm 0.5)]
+
+ (lmsg, emsg) <-
+ if plain then
+ do l <- newMessage b2 [borderwidth 0,
+ justify JustCenter,
+ aspect 750,
+ HTk.font (Helvetica, Roman, 18::Int)]
+ pack l [Expand On, Fill Both, PadX (cm 0.5), PadY (cm 0.5)]
+ return (Just l, Nothing)
+ else do msg <- newEditor b2 [size (30,5), borderwidth 0,
+ state Disabled, wrap WordWrap,
+ HTk.font (Helvetica, Roman, 18::Int)]
+ pack msg [Expand On, Fill Both, PadX (cm 0.5),
+ PadY (cm 0.5)]
+ return (Nothing, Just msg)
+
+ sp1 <- newSpace b (cm 0.15) []
+ pack sp1 [Expand Off, Fill X, Side AtBottom]
+
+ newHSeparator b
+
+ sp2 <- newSpace b (cm 0.15) []
+ pack sp2 [Expand Off, Fill X, Side AtBottom]
+
+ sb <- newSelectBox b Nothing []
+ pack sb [Expand Off, Fill X, Side AtBottom]
+
+ events0 <- mapM (createChoice sb) choices
+ let ev0 = choose events0
+
+ -- Arrange for escape when the user destroys the window
+ (destroyEvent,unbindAction) <- bindSimple tp Destroy
+
+ let
+ ev =
+ (do
+ result <- ev0
+ always unbindAction
+ return result
+ )
+ +> (do
+ destroyEvent
+ always unbindAction
+ destroyedFallOut
+ )
+
+ return (tp, emsg, lmsg, lbl,sb,ev)
+ dlg <- configure (Dialog tp emsg lmsg lbl sb ev) confs
+ return dlg
+ where createChoice :: SelectBox -> Choice a -> IO (Event a)
+ createChoice sb (str,val) =
+ do
+ but <- addButton sb [text str] [Expand On, Side AtRight]
+ clickedbut <- clicked but
+ return (clickedbut >> (always (return val)))
+
+
+destroyedFallOutPair :: (ObjectID,IO a -> IO (Either String a))
+destroyedFallOutPair = unsafePerformIO newFallOut
+{-# NOINLINE destroyedFallOutPair #-}
+
+destroyedFallOut :: a
+destroyedFallOut = mkBreakFn (fst destroyedFallOutPair) "DESTROYED"
+
+catchDestroyedFallOut :: IO a -> IO (Maybe a)
+catchDestroyedFallOut act =
+ do
+ strOrA <- (snd destroyedFallOutPair) act
+ return (case strOrA of
+ Left "DESTROYED" -> Nothing
+ Right a -> Just a
+ )
+
+-- --------------------------------------------------------------------------
+-- The useHTk function
+-- --------------------------------------------------------------------------
+
+htkMessFns :: MessFns
+htkMessFns = MessFns {
+ alertFn = (\ mess -> createAlertWin mess []),
+ errorFn = (\ mess -> createErrorWin mess []),
+ warningFn = (\ mess -> createWarningWin mess []),
+ confirmFn = (\ mess -> createConfirmWin mess []),
+ messageFn = (\ mess -> createMessageWin mess []),
+ htkPres = True
+ }
+
+useHTk :: IO ()
+useHTk = setMessFns htkMessFns
+
+-- Deprecate the alternative
+{-# DEPRECATED createAlertWin,createErrorWin,createWarningWin,
+ createConfirmWin,createMessageWin
+ "Please use the functions in util/Messages instead"
+ #-}
+
+-- --------------------------------------------------------------------------
+-- Images for the various Dialog Windows
+-- --------------------------------------------------------------------------
+
+loadHTkImages :: ()
+loadHTkImages = foldr seq () [errorImg,warningImg,questionImg,infoImg]
+
+-- It's important that we create these with unsafePerformIO, this lets
+-- Tk reuse the definition-- otherwise we send the whole image data
+-- over to the wish again every time somebody opens one of these windows.
+
+errorImg :: Image
+errorImg = unsafePerformIO (newImage [imgData GIF "R0lGODlhMAAwAPU6AAAAAA0PEBkIBxgYGCkNCzQOCjcRDjYSECcnJzU1NUETD0kXE1kbFm4ZD2odFXkeFWsjHn0jHHcnIUhISFRUVGVlZX5+fpYfEYglHJkmGoosJY84MpktJJwyKZ47M6YmGLYnFqItIqUzKKU9NMcqGNYqFd8wHOktFeoyG/s2GsF4Lv9AHtSNHc2GIsGBOMmdNM6jOt2sK9WnNt6wOeKuI+GyM8+lQNWrRN+0Rf7+/v///wAAAAAAAAAAAAAAAAAAACH5BAFkADoALAAAAAAwADAAAAb+QJ1Op9PpdDqdTqfT6XQ6nU6n0+l0Op1Op9PpdDqdTqfT6XQ6nU6n0+l0Op1Op9PpdDqdTqfT6YA6nU6n0+l0Op1Op9PpdDqdTqfT6XQ6nU6n0+l0Op1Op9PpdDqdTqfT6XQ6nU6n0+l0Op1Op9MBdTqdTqfT6XQ6nU6n0+l0Op1Op9PpdDqdTqfT6XQ6nU6n0+l0Op1Op9PpdDqdTqfT6XQ6nU6nA+p0Op1Op9PpdDqdTqfT6XQ6nU6n0+l0Op1Op9PpdDqdTqfT6XQ6nU6n0+l0Op1Op9PpdDqdTgfU6XQ6nU6n0+l0Op1Op9PpdDqdTqfT6XQ6nU6n0+l0Op3+TqfT6XQ6nU6n0+l0Op1Op9PpdDqdDqjT6XQ6nU6n0+l0Op1Op9PpdDqdTqfT6XQ6nU6n0+l0Op1Op9PpdDqdTqfT6XQ6nU6n0+l0Oh1Qp9PpdDqdTqfT6XQ6nU6n0+l0Op1Op9PpdLpUKpVKnVCoEwoF0Ol0Op1Op9PpdDqdTqfT6XQ6oE6n0+l0Op1Op9PpUqnUqUQCgUAgEAhEIpFIAJ1Op9PpdDqdTqfT6XQ6nU6n0+l0Op1Op9OlUsATCQQCXT6XzOfz+YBAIBAAoNPpdDqdTqfT6XQ6nU6n0+l0Op1Op0ulTiDQ5wICXS6fz+fz+XyAnw/ogwHodDqdTqf+0+l0Op1Op9PpdDqdTqdLpUog0AV0AX0ul8/n8/mEPp/QJ/SJAAA6nU6n0wF1Op1Op9PpdDqdTqdLpUogEAh0uYA+l8/n8/mIRJ/P5xMKZRgAgE6n0+l0Op1Op9PpdDqdTrcCpkqgC+hy+YAun0/m8/l8PiJR6JP5fDgYAUCn0+l0Op1Op9PpdDqdTqdLnUCfzwUE+oBAn8/nA8x8Ph+QSDQKfTifjCMA0Ol0Op1Op9PpdDqdTqdLnUCgz+fzAX0+HxDo8/lkMp/PJyQShUKfUAZoCAB0Op1Op9PpdDqdTqfTpUog0Af0+Vwyoo9I9Pl8PplMJhQKiUShUIjDAAD+ADqdTqfT6XQ6HVCn06FSINDlcvl8Lp+PSCQSfT6hTyaTCYVCo1EoxIkIAgCdTqfT6XQ6nU6n06VKoAsIdPl8Ph/gByQSjUShT+iTyWRCn9BoFBJhCgGATqfT6XQ6nU6n0wFSJRCLRqPRaDRaLBaLzXAzWUwWk71kQJkMpgqFNApAAKDT6XQ6nU6n0+kAKdCFRqPRaDQaLRaLxWKz2Uwmk8lkMhkMBguFOAtAAKDT6YA6nU6n0+l0gBPoQqPRarRYjBaLxWIxmWwmk8lkMhnMBrOJOhwGIIDQ6XQ6nU6n0+l0gBMIRKMBY7RaLRaLxWKxmEwmk8lkMpns9Xq9RBz+DgMQGOh0Op1Op9PpdDoACvSh0WKx2GwWi8VisphM9gK+ZLfbTQaz2WyijmYBAAx0Op1Op9PpdDodAAX60GK0WCw2w8VisthLJpPJXjDZ7Qaz2WyijkYBBAAGOp1Op9PpdDqdDkACfVq1WCwWi81qspjs9ZLJZLIXDHa72WwuUUdCAAQGOZ1Op9PpdDqdDggAgT6fz+fzyWRCI9EnFMpkQhlOiMPpdEaiTocDAQACg5xOp9PpdDqdTgdokEKhz+fz+WQyIREwFAqFMpoQJ9TphDqikaejYQAAAUROp9PpdDqdTqcDBECgTyj0CYVCmQxHxAmFQhgNhyPidDoiYGf+1JEIAIBAQqfT6XQ6nU6n0wECDdDn8wl9QqEQJyQacUIcDkfE6Yg6HZHHs1kAAIABRafT6XRAnU6n0+l0AAAmFPqEQp/Qh5MJjUKcUEjU4XA6ok6no4EIAIAAIqfT6XQ6nU6n0+l0AIDg8wl9gKFQKBTiZEKjUCgk6nQ4nY6o05EQAABAYJLT6XQ6nU6n0+l0Oh0AYMiEOKFQKBQKiUQjj4bTEQE7nU6ns5EcAIBAAGHR6XQ6nU6n0+l0Op0OAAAUMJwQhxMKhUIdjmfD6YhEnc5GAzkAAADAgJID6nQ6nU6n0+l0Op1Op0sAAARHJhMKcUSikIjjGXU6nc5GwxD+AAAAwGCS0+l0Op1Op9PpdDqdTgfU6QAAAECB4XA4Ik6n0+mMOp2NBrIIAAAAQCCRy+l0Op1Op9PpdDqdTqfT6QAAAAAgMEAwGg0HyOloNBoJ4yAAAAAAQCBhyel0Op1Op9PpdDqdTqfT6XQ6AAAAAAAAgoNi4WAsFAUBAAAAAACAATBhyel0Op1Op9PpdDqdTqfT6XQ6nU4HAAQAAAAAAAAAAAAAAAAAAAABRCWX0+l0Op1Op9PpdDqgTqfT6XQ6nU6n0wEQgwAAAAAAAAAAAAAABAIDiiWX0+l0Op1Op9PpdDqdTqfT6XQ6nU6n0+l0QABgEAAEAgAAIBAIBBD+E0sup9PpdDqdTqfT6XQ6nU6n0+l0Op1Op9PpdDqdTgdIIAaDwWCASFCAuVxOp9PpdDqdTqfT6XQ6nU6n0+l0Op1Op9PpdDqdTqfT6XQ6nS6Xy+l0Op1Op9PpdDqdTqfTAXU6nU6n0+l0Op1Op9PpdDqdTqfT6XQ6nU6n0+l0Op1Op9PpdDqdTqfT6XQ6nU6n0+l0Op1OpwPqdDqdTqfT6XQ6nU6n0+l0Op1Op9PpdDqdTqfT6XQ6nU6n0+l0Op1Op9PpdDqdTqfT6XQ6nU4H1Ol0Op1Op9PpdDqdTqfT6XQ6nU6n0+l0Op1Op9PpdDqdTqfT6XQ6nU6n0+l0Op0TTqfT6XQ6nQ6o0+l0Op1Op9MFAQA7"])
+{-# NOINLINE errorImg #-}
+
+warningImg :: Image
+warningImg = unsafePerformIO (newImage [imgData GIF "R0lGODlhMAAwAPU3AAAAABYKAhoUARQUFCcIBiUdAz0MCCsiAzUpBSsrK0YNCE0QDFIOB1wSC0U1BlE/B2kTC3QVDXgYEVJAB2hRCnNZC3thC4gYDYcbEpQbD5weFKQdDqEdEbMfD7IfELkgD7khEatCFrFAELpbEr9vFpJPSMkjEdYlE+opFPUqE8JtFMd+FbmTDr2TEsyHFMObD8ebE9GKE9uqFt+xEuCuEuCyE4CAgP///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAFkADcALAAAAAAwADAAAAb+wNvtdrvdbrfb7Xa73W632+12u91ut9vtdrvdbrfb7Xa73W632+12u91ut9vtdrvdbrfb7Xa73YC32+12u91ut9vtdrvdbrfb7Xa73W632+12u91ut9vtdrvdbrfb7Xa73W632+12u91ut9vtdrsBb7fb7Xa73W632+12u91ut9vtdrvdbrfb7Xa73W632+12u91ut9vtdrvdbrfb7Xa73W632+12A95ut9vtdrvdbrfb7Xa73W632+12u91ut9vtdrvdbrfb7Xa73W632+12u91ut9vtdrvdbrfb7Qa83W632+12u91ut9vtdrvdbrfb7Xa73W632+12u91ut9v+7Xa73W632+12u91ut9vtdrvdbrfbDXi73W632+12u91ut9vtdrvdbrfb7Xa73W632+12u91ut9vtdrvdbrfb7Xa7oVKmjO12u91utxvwdrvdbrfb7Xa73W632+12u91ut9vtdrvdbrfb7Xa7oVKnzQUAuN1ut9vtdrvdbrfb7Xa73W434O12u91ut9vtdrvdbrfb7Xa7bVKnzSYDAQBut9vtdrvdbrfb7Xa73W632+12u91ut9vtdrvdbsDb7Xa7bVKoz2bDuRAGgNvtdrvdbrfb7Xa73W632+12u91ut9vtdrvdbrfb7Xa7pVKdzQa0yUCAAMDtdrvdbrfb7Xb+u91ut9vtdrvdbrfb7Xa73W632+12u21Sps1mRNpsMgYA4Ha73W632+12uwFvt9vtdrvdbrfb7Xa73W632+12u21Sp81mM5ttNhsJAAC43W632+12u91ut9vtdrvdbrfb7XYD3m632+12u91QqM5mM5vNYhtOZgEA3G632+12u91ut9vtdrvdbrfb7Xa73W632+12u21Sps1GBZzNZjMOhxMBAAC32+12u91ut9vtdrvdbrfb7Xa73W632+12u21SqM1mQ5uxZDLXRpNZAAC32w14u91ut9vtdrvdbrfb7Xa73W632+12u91Qqc5mE3sBAo6ZbLPRSAAAwO12u93+brfb7Xa73W63G/B2u91ut9vtdrvdNqnTZrOZWQABwIzm2mgwCwDgdrvdbrfb7Xa73W632+12u91ut9vtdrvdUCigZ7OZzQ4AgGBGk2k2GgkAALjdbrfb7Xa73W632+12u91ut9vtdrvdNinTZhOj0Q4AQIEmk7k2QI1mAQDcbrfb7Xa73W632+12u91ut9vtdrvdNqnTZrOh0WgFgMAhk8lkGo1GAgAAbrfb7Xa73YC32+12u91ut9vtdrvdbhFUZ7OJ0Wi0B8DhkMlkMpdGg1kAALfb7Xa73W632+12u91ut9vtdrsBb5vUabPZ0Gi0mQBQcMhoMplMo9FAAAD+wO12u91ut9vtdrvdbrfb7Xa73W4oFGizqdVmslkAEAAWZDKZTObSaCQEAOB2u91ut9vtdrvdbrfb7Xa73W4b1GmzidFqspkMEAAgZDKZTCbTaDQNwAAAvN1ut9vtdrvdbrfb7Xa73W43FArE2cxqsplsBggAJjKZTCaTuTQayQAAuN1ut9vtdrvdbrfbDXi73W63DerE4cRmNBlNNkNMBBWZTCaTyWQaDWYBANxut9vtdrvdbrfb7Xa73W43FOqz2cxmMxlwJpO1KIeWTCaTyWQyl0YjAQAAt9vtdrvdbrfb7Xa73W63Deq02cRmMtlMJpPJZDKZTCaTyWQyoAz+o8EsAIDb7Xa73W632+12u91utxsKBdJsZjIaTSaTyWCHQksmk8lkMpmMpNE0AADA7Xa73W7A2+12u91ut9sGddpsYjSajCaTyWQPAIAik8lkMplM5tJoJAQA4Ha73W632+12u91ut1sJBeJsgDJajSaTyWQyBCBQkclkMplMJpNpNJgFAHC73W632+12u91ut9sGddpwXDVaTSaTyWSyFsIikwFlMplMJpPJSBoNBDAA3G632+12u91ut9stggJtOBsOh8PhjFQul0wmk8lkMplMJpPBSCWNhAAAJm632+12u91ut9vtpjBtOBwOh8PhcDQcDkej0Wg0Go1Go9H+aDQajQazAAAAt9vtdrvdbrfb7QYMSBqRSOSCyWg0Go1Go+FoNBqNRqPRaDQajUajaQAAgNvtdrvdbrfb7XYDAACAAIFgWDQaDYgEKJFgMBgMBoPBSCQYDAYjkSwAA8Dtdrvdbrfb7Xa7AQAAAAAAAAAAAECAQCAQFAaDQmEwJAwGA9BgMBAGAADgdrvdbrfb7Xa73QAAAAAAAAAAAAAAAAAAAAAAAAAAAAYAAGAAAAwAAADgdrvdbjfg7Xa73W43AAAAGAQAAAAAAAAAAAAAAAAAAAAAwAAAAAAAAAAAcLvdbrfb7Xa73W632+12AwAAQAAAAAAAAIPAAAAAAAD+AAAAAAAAAAAAAAC43W632+12u91ut9vtdrvdbrfb7Xa7AQAAAAAAAACAAAAAAAAAAAAAAHC73W632+12u91ut9vtdrvdbrfb7Xa73W632+12u91ut9vtdrvdbrfb7Xa7AW+32+12u91ut9vtdrvdbrfb7Xa73W632+12u91ut9vtdrvdbrfb7Xa73W632+12u91ut9vtdgPebrfb7Xa73W632+12u91ut9vtdrvdbrfb7Xa73W632+12u91ut9vtdrvdbrfb7Xa73W632+0GvN1ut9vtdrvdbrfb7Xa73W632+12u91ut9vtdrvdbrfb7Xa73W632+12u91ut9sT7Xa73W632w14u91ut9vtdrsFAQA7"])
+{-# NOINLINE warningImg #-}
+
+questionImg :: Image
+questionImg = unsafePerformIO (newImage [imgData GIF "R0lGODlhMAAwAPUxAAAAABkVDRYWFiIcEjk5OSs9YTVFZGVPJG1VJ3FYKHNfO3xiLX9pQWNjY35+f4FlLopsMZZ2N6J/O5J8UqeDPKaHSKSMWbONQL2URL6bU7+iZ76icsCXRcOfVsmkW9eqTtisWtixX8WmaMmsc9e0a9m6effDWvfJbffPfqqqqti+htzElPfUjPfYmfferffiuPflwP///////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAFkADIALAAAAAAwADAAAAb+QJlMJpPJZDKZTCaTyWQymUwmk8lkMplMJpPJZDKZTCaTyWQymUwmk8lkMplMJpPJZDKZTCaTyYAymUwmk8lkMplMJpPJZDKZTCaTyWQymUwmk8lkMplMJpPJZDKZTCaTyWQymUwmk8lkMplMJpMBZTKZTCaTyWQymUwmk8lkMplMJpPJZDKZTCaTyWQymUwmk8lkMplMJpPJZDKZTCaTyWQymUwmA8pkMplMJpPJZDKZTCaTyWQymUwmk8lkMplMJpPJZDKZTCaTyWQymUwmk8lkMplMJpPJZDKZTAaUyWQymUwmk8lkMplMJpPJZDKZTCaTyWQymUwmk8lkMpn+TCaTyWQymUwmk8lkMplMJpPJZDKZDCiTyWQymUwmk8lkMplMJpPJZDKZTCaTyWQymUwmk8lkMplMJpPJZDKZTCaTyWQymUwmk8lkMhlQJpPJZDKZTCaTyWQymUwmk8lkMplMJpPJZLIAAAAAAAAAAEAmk8lkMplMJpPJZDKZTCaTyWQyoEwmk8lkMplMJpPJZDIAAEDBfCKUBQAAAMhkMplMJpPJZDKZTCaTyWQymUwmk8lkMplMJpPJZEAA4NNqvVqlUilDAQAAMplMJpPJZDKZTCaTyWQymUwmk8lkMplMJpPJZACA6QVrsUwmE6pEoiCAAIBMJpPJZDKZTCb+k8lkMplMJpPJZDKZTCaTyWQBgMnlMlUiEYrJhCKFKAAAQCaTyWQymUwmkwFlMplMJpPJZDKZTCaTyWQygKb1MkUAAAAgYjKdQqEHACCQyWQymUwmk8lkMplMJpPJZDKZTCYDymSyAOD0QkUAAEABAOiYUJ8QBQAAyGQymUwmk8lkMplMJpPJZDKZTCaTyWQygIX1+gAAAIPDAQRYTKfQhwIAAGIymUwmk8lkMplMJpPJZDKZTCaTyWQyGeDDMlEAAIMjFgNYTifS5wEAAFIxmQwok8lkMplMJpPJZDKZTCaTyWQymQxgYpkoAIAjFpMBLCYS6XMAAACpmEwmk8n+ZDKZTCaTyWQyGVAmk8lkMplMBiCRMA8AwBGTAQCiU+lTAQAAjlRMJpPJZDKZTCaTyWQymUwmk8lkMplMBgAAAAAgAOCIyQAQkir0SQAAAEcqJpPJZDKZTCaTyWQymUwmk8lkMplMJgMAAAAAQOCIAQAYlurDAQAAQIAjJpPJZDKZTCaTyWQymUwmk8lkMplMJpPJABOHxeFwAACXk+rzAQAAAEcqJpPJZDKZTCaTyYAymUwmk8lkMplMJpPJZDKAw+FwxAAAE4sEigAAAEEqJpPJZDKZTCaTyWQymUwmk8lkMplMJpMBZTKZTCaTyQCIzqo0EgUAAIEjFZPJZDL+mUwmk8lkMplMJpPJZDKZTCaTyWQymUwmk8kADxLJIwJOAACAIxWTyWQymUwmk8lkMplMJpPJZDKZTCaTyWQymUwmk8lkgEiJBNoAAABHKiaTyWQymUwGlMlkMplMJpPJZDKZTCaTyWQymUwmk8lkMgCnRAJNAACAIyaTyWQymUwmk8lkMplMJpPJZDKZDCiTyWQymUwmk8lkMhngoyJ9FACAIxWTyWQymUwmk8lkMplMJpPJZDKZTCaTyWQymUwmk8lkMhkQkCl9MAAAIBWTyWQymUwmk8lkMplMJpPJZDKZTCaTyWQymUwmk8lkMpkMUKlQFgAAIBWTyWQyoEz+JpPJZDKZTCaTyWQymUwmk8lkMplMJpPJZDKZTAYQEAAAACCVislkMplMJpPJZDKZTCaTyWRAmUwmk8lkMplMJpPJZDKZTCYDAAAAAADgiMlkMplMJpPJZDKZTCaTyWQymUwmk8lkMplMJpPJgDKZTCaTyQAWR8PhSMVkMplMJpPJZDKZTCaTyWQymUwmk8lkMplMJpPJZDKZTCaTyQYAAAAAiAFlMplMJpPJZDKZTCaTyWQymUwmk8lkMplMJpPJZDKZTCaTyQAlFAsDAABkMplMJpPJZDKZTCYDymQymUwmk8lkMplMJpPJZDKZTCaTyWQAVKsFAgAAMplMJpP+yWQymUwmk8lkMplMJpPJZDKZTAaUyWQymUwmk8lkMgCLFcIAAIBUTCaTyWQymUwmk8lkMplMJpPJZDKZTCaTyWQymUwmk8lkMgALSPpgAABAKiaTyWQymUwmk8lkMplMJpPJZDKZTCaTyWQymUwmk8lkMhngQ+IkAABAKiaTyWQyGVAmk8lkMplMJpPJZDKZTCaTyWQymUwmk8lkMplMBgAAAAAAIBWTyWQymUwmk8lkMplMJpPJZDKgTCaTyWQymUwmk8lkMplMJgMAAAAAwJGKyWQymUwmk8lkMplMJpPJZDKZTCaTyWQymUwmk8lkQJlMJpPJAAAAIOVIxWT+MplMJpPJZDKZTCaTyWQymUwmk8lkMplMJpPJZDKZTCaTyWQAh8ORismAMplMJpPJZDKZTCaTyWQymUwmk8lkMplMJpPJZDKZTCaTyWQymUwmk8lkMplMJpPJZDKZTCaTAWUymUwmk8lkMplMJpPJZDKZTCaTyWQymUwmk8lkMplMJpPJZDKZTCaTyWQymUwmk8lkMplMJgPKZDKZTCaTyWQymUwmk8lkMplMJpPJZDKZTCaTyWQymUwmk8lkMplMJpPJZDKZTCaTyWQymUwGlMlkMplMJpPJZDKZTCaTyWQymUwmk8lkMplMJpPJZDKZTCaTyWQymUwmk8lkMpkTTCaTyWQymQwok8lkMplMJpMFAQA7"])
+{-# NOINLINE questionImg #-}
+
+infoImg :: Image
+infoImg = unsafePerformIO (newImage [imgData GIF "R0lGODdhRQBCAMYAAP///+Dg6Mja7NjY4JCgtZClwICgwYGYuoGNoISMvLC+0JCgqPDw8Njo5sDI1YCgtm6Qr4io0ZioyJ+wyJ6wwNjg6XiWvGiQvXiYyHigyJCwzqiwwOjs72iHrXig03CXyoCo1KCou9jg32+YwKi91WCMwoCw2GiXyoCYr3ilslyMfICgqNDY3XigqFCggFCwgFCgiEikfj+ObkiIeISYoGCwmGjgrXDwuDh0YF27mFvInXD/uDBkUG2In2jErGDVpHD/wHWws1CPgXCkuHS+tHDQsFjAkHCipdDQ23CwqPD//2jWrmyUnFimjGOlmFC5jEOYeGN9iGCIkYiWrUCYcGyAoGCAsXDItGjvtmCBpXDQuGCIsXiQrVV4qmB4ll2JiGB4qFCYhVyUlMDQ2rbCyODg4MDQzgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwAAAAARQBCAAAH/oAAgoOEhYaHiImKi4yNjo+QkZKTlJWWl5iGAQIDnJ4DmaGFnAQFBgcIBwkFqwQKC50MopUNDg8QCREHuqYFvhITwRMFFAqgs48VBBYXGBnPugYGvQUTGsITChsbBMfIiRwbHR4fIB/PGbvT077V18Eb2goUISLfhwoWIx4e5ui7B6S1IwZMGIl48bRt4HBPEAMCJTyY6FcOXbR1A61hk5dQAYEG9zgkOCGRIgh06QRKQ5FCxQoCGuFxlEeABbIBEPjxM+fvmTppLVy8gBFDxgwa2CZImBlvqagG43TyPGdRmoEaL2zc2HrDBY5q2BDOpOAgE4eoO8tRhWY1h44b/jt2cL3BA2xSpvNsWmLQ4wM/tT2dZbDq48cOIHG52viatLEwj94mFfgAuCLKlAaC2ADCOfFWHUIovHPcmICsSQ4sVD6ZAYPgIVaJ3OCMWO4NGzFauIvZeAMF374nMTiQgedlZ86sGihyuLPcH0aOECOmQbToDdWrT6fgC4mkDRYuo3OdXHmSuTZ+6Kihm7v77fDfcyegBBIDCILHk89gQbnVFkUEuAR7A8kX33QDFUBAWY9sYEBrrkHYGmbK9YLRQCs8cOB7CZaiIQGQPJAfcs5c5B9G6zzARBNCydAeggm2o+GMBAjgCAsiPoOcAf2daJWFQTjB4hM2aAVFFDEm/jhjATMe8EAIjphyYkA+qhQkVjpoZdsNUEiRpIxMMunkmFM48kCVaGaWgxE/2NCcZ1wiGeM0GiYw5gMHDGGBnfYswsEUaZ5YABFt0kZbXLZR4aWSYeLpqCp7qqIAIwpIGahKWhl6qGdQqMBok3jqmcCeEJQK4iIKXOpfAUkUqimiW3XpC51iPiqqBaXmegAjElh6aS+tbvaqbbLSauejo46aKwQdQFAFIyGoWuE0K7g5bKxS0PoonskuC4EVF3TQQX2KlCItigUUMZuhsB7Z6J2QKptrB+FeUAVDiviqqoVXrLupXIrWCe+tEODKbL3iBrCIuediRAQWw8rl7rbx/uKKK8L1ZoFvItGiSaWgBjysaW03yCAFqHnuaTEEGNPbQRa8ShnQzKfU/PGPso2MqKy2qpxryxlTqhzNRNusnBb+/muyrZAWXLDLCJewBReMOHBA0QH1h3VsSTu3Q5fwJmsx1FCXUEKZi/DF49r9tb120Qb0q3NcS49JsAXgkn1BCSN0MSkjBGTN9uBu06zuyLWBHWrTY2OcwAgldNHnIhQQbnnhpxw+d91DMP50y5CX4IUjA/Rw+elXM4d4XC58MabYTh9cdt9Qmun27adbYO3cMHwRqs+NQ/14CWAo7Eg+F2SQ/PLKny7s3EaEkWfFn5Mdeg+QKNGB8twzz7zb/gZAvPoOOszQ+d0s6813F3o9ogAEz5zzgffc9zeEFs3N3ZUYXFBvgd4diNyuJHGAC8gvA/Kj3xAyhTiSYcEITSiYsi6mty0UbxI4QaAGE9g9/DXQOVxpHey+JbtwbWEDlaBA8jywQQ1yTwsfBOFWnjAD4JWKbFtAALkoARGSkKSFymsTFopExCKmJz0/MBnsKGjCKhivEgx4QAky4AEfHjADEAiDFrcYBhd0MQxCACMYmXCrCUKtCpGBYgdOQEUqnoCDzUie/abXOaahj4RVYJBZEjBFFlbxit+j4/TsaENnjQEZDChAH90Ix+adT5BMG2EPQHKPCWwhIm1s5AUEglnHgcXrACvY2D1EcIAusJGFVAnkIym2uAc8gAw7bIggHACuEQBSeZCE16MQsIEyyPIQHFBAKSE3P+Vh4JGd3BYxKPnLRAwAT/RqxhyTWYAeKIgFomymIpTQiSlMQSlcqAIXqkEAAphhAMzUJiVYwAIkZFOd8IynPOdJz3ra856DCAQAOw=="])
+{-# NOINLINE infoImg #-}
diff --git a/HTk/Toolkit/FileDialog.hs b/HTk/Toolkit/FileDialog.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/FileDialog.hs
@@ -0,0 +1,743 @@
+-- | HTk\'s /file dialog box/.
+module HTk.Toolkit.FileDialog (
+ fileDialogStr,
+ newFileDialogStr,
+
+ fileDialog,
+ newFileDialog
+) where
+
+
+import System.Directory as Directory
+import System.IO.Error
+
+import qualified Data.List as List(sort)
+
+import Control.Exception
+
+import Util.FileNames
+import Util.Messages
+import Util.Computation
+
+import Events.Events
+import Events.Channels
+import Events.Synchronized
+
+import Reactor.ReferenceVariables
+
+import HTk.Toplevel.HTk
+import HTk.Toolkit.ModalDialog (modalDialog)
+
+debugMsg :: String-> IO ()
+debugMsg str = done -- putStr (">>> " ++ str ++ "\n")
+
+
+-- Display a warning window with a meaningful error message
+ioErrorWindow :: Exception -> IO ()
+ioErrorWindow excep =
+ warningMess ("Error while reading directory:\n"++
+ case ioErrors excep of
+ Just ioe ->
+ ioeGetErrorString ioe++"\n"++
+ case ioeGetFileName ioe of
+ Just fn -> "with file "++fn++"\n"
+ Nothing -> ""
+ Nothing -> "Exception: "++show excep++"\n"
+ )
+
+tryGetFilesAndFolders :: FilePath -> Bool -> IO (Either Exception
+ ([FilePath], [FilePath]))
+tryGetFilesAndFolders path showhidden =
+ do
+ debugMsg ("getting directory contents of " ++ path)
+ dc <- Control.Exception.try (getDirectoryContents path)
+ case dc of
+ Left exn -> do debugMsg "... error!"
+ return (Left exn)
+ Right dcontents -> do debugMsg "...ok\n"
+ c<- sort dcontents [] [] path
+ return (Right c)
+ where sort :: [FilePath] -> [FilePath] -> [FilePath] -> FilePath ->
+ IO ([FilePath], [FilePath])
+ sort (f : fs) files folders abs =
+ if f == "." || f == ".." || (hidden f && not showhidden) then
+ sort fs files folders abs
+ else
+ do
+ fileIsDir <- doesDirectoryExist (abs ++ f)
+ if fileIsDir
+ then
+ sort fs files ((f ++ "/") : folders) abs
+ else
+ sort fs (f : files) folders abs
+ sort _ files folders _ =
+ return (List.sort files,
+ if path == "/" then List.sort folders
+ else ".." : (List.sort folders))
+ hidden :: FilePath -> Bool
+ hidden f = head f == '.'
+
+getFilesAndFolders :: FilePath -> Bool -> IO ([FilePath], [FilePath])
+getFilesAndFolders path showhidden =
+ do dc <- tryGetFilesAndFolders path showhidden
+ case dc of
+ Left ioe-> do ioErrorWindow ioe
+ return ([], [".."])
+ Right cont-> return cont
+
+
+dropLast :: FilePath -> FilePath
+dropLast [] = []
+dropLast path = dropLast' (tail (reverse path))
+ where dropLast' :: String -> String
+ dropLast' (c : cs) =
+ if c == '/' then reverse (c : cs) else dropLast' cs
+ dropLast' _ = []
+
+updPathMenu :: MenuButton -> Ref (Maybe Menu) ->
+ FilePath -> Ref [FilePath] -> Ref [FilePath] ->
+ Ref FilePath -> ListBox FilePath ->
+ ListBox FilePath -> TkVariable String ->
+ Label -> Ref Bool -> IO ()
+updPathMenu pathmenubutton menuref path foldersref filesref pathref
+ folderslb fileslb file_var status showhiddenref =
+ do
+ pathmenubutton # text path
+ m <- getRef menuref
+ case m of
+ Just m' -> destroy m'
+ _ -> done
+ pathmenu <- createMenu pathmenubutton False []
+ pathmenubutton # menu pathmenu
+ let paths = upperPaths path
+ mapM (createNewMenuItem pathmenu) paths
+ setRef menuref (Just pathmenu)
+ where upperPaths :: FilePath -> [FilePath]
+ upperPaths "/" = ["/"]
+ upperPaths p = p : upperPaths (dropLast p)
+ createNewMenuItem :: Menu -> FilePath -> IO ()
+ createNewMenuItem pathmenu fp =
+ do
+ item <- createMenuCommand pathmenu [text fp]
+ clickeditem <- clicked item
+ _ <- spawnEvent (forever (clickeditem >> always (selected fp)))
+ done
+ selected :: FilePath -> IO ()
+ selected fp =
+ do
+ status # text "Reading... "
+ showhidden <- getRef showhiddenref
+ success <- changeToFolder fp foldersref filesref
+ pathref folderslb fileslb file_var showhidden
+ (if success then
+ do
+ status # text "Reading...ready"
+ nupath <- getRef pathref
+ updPathMenu pathmenubutton menuref nupath foldersref
+ filesref pathref folderslb fileslb file_var status
+ showhiddenref
+ else
+ status # text "Permission denied!" >> done)
+
+changeToFolder :: FilePath -> Ref [FilePath] -> Ref [FilePath] ->
+ Ref FilePath -> ListBox FilePath ->
+ ListBox FilePath -> TkVariable String -> Bool ->
+ IO Bool
+changeToFolder path foldersref filesref pathref folderslb fileslb
+ file_var showhidden =
+ let path' = if path == "" then "/" else path
+ in do debugMsg "getting files and folders"
+ st <- tryGetFilesAndFolders path' showhidden
+ case st of
+ Right (files, folders) ->
+ do setRef pathref path
+ debugMsg "got files and folders"
+ setRef filesref files
+ setRef foldersref folders
+ fileslb # value files
+ folderslb # value folders
+ setTkVariable file_var ""
+ return True
+ Left excep ->
+ case ioErrors excep of
+ Just error | isPermissionError error -> return False
+ Nothing ->
+ do
+ ioErrorWindow excep
+ return False
+
+up :: Ref [FilePath] -> Ref [FilePath] -> Ref FilePath ->
+ ListBox FilePath -> ListBox FilePath -> TkVariable String ->
+ Label -> Bool -> IO Bool
+up foldersref filesref pathref folderslb fileslb file_var status
+ showhidden =
+ do
+ path <- getRef pathref
+ (if path /= "" && path /= "/" then
+ do
+ status # text "Reading... "
+ changeToFolder (dropLast path) foldersref filesref pathref
+ folderslb fileslb file_var showhidden
+ else return True)
+
+selectedFolder :: Int -> Ref [FilePath] -> Ref [FilePath] ->
+ Ref FilePath -> ListBox FilePath ->
+ ListBox FilePath -> TkVariable String -> Bool ->
+ IO Bool
+selectedFolder i foldersref filesref pathref folderslb fileslb file_var
+ showhidden =
+ do
+ folders <- getRef foldersref
+ path <- getRef pathref
+ let
+ trimmedPath = trimDir path
+
+ nupath = if (folders !! i) == ".."
+ then
+ dropLast trimmedPath
+ else
+ combineNames trimmedPath (folders !! i)
+ changeToFolder nupath foldersref filesref pathref folderslb fileslb
+ file_var showhidden
+
+refresh :: Ref [FilePath] -> Ref [FilePath] -> Ref FilePath ->
+ ListBox FilePath -> ListBox FilePath -> Bool -> IO ()
+refresh foldersref filesref pathref folderslb fileslb showhidden =
+ do
+ folders <- getRef foldersref
+ files <- getRef filesref
+ path <- getRef pathref
+ (files, folders) <- getFilesAndFolders path showhidden
+ setRef filesref files
+ setRef foldersref folders
+ folderslb # value folders
+ fileslb # value files
+ done
+
+selectFile :: Int -> Ref [FilePath] -> TkVariable String -> IO ()
+selectFile i filesref file_var =
+ do
+ files <- getRef filesref
+ setTkVariable file_var (files !! i)
+
+createFolder :: Toplevel -> Ref (Maybe Toplevel) -> Ref (Maybe String) ->
+ IO ()
+createFolder par childwindow ret =
+ synchronize par
+ (do
+ (w, h, x, y) <- getGeometry par
+ let w' = 400
+ h' = 100
+ main <- createToplevel [text "Create a new folder",
+ geometry (w', h',
+ x + (div w 2) - (div w' 2),
+ y + (div h 2) - (div h' 2))]
+ setRef childwindow (Just main)
+ (main_destr, main_destr_ub) <- bindSimple main Destroy
+
+ entnlab <- newFrame main []
+
+ lab <- newLabel entnlab [font (Lucida, 12::Int),
+ text "Enter name:"]
+
+ ent_var <- createTkVariable ""
+ ent <- newEntry entnlab [bg "white", width 40, variable ent_var]
+ :: IO (Entry String)
+ buttons <- newFrame main []
+ ok <- newButton buttons [text "Ok", width 12]
+ quit <- newButton buttons [text "Cancel", width 12]
+
+ pack entnlab [PadX 10, PadY 5]
+ pack lab []
+ pack ent [PadX 10, PadY 5]
+ pack buttons [PadX 10, PadY 5, Side AtBottom]
+ pack ok [PadX 5, Side AtLeft]
+ pack quit [PadX 5, Side AtLeft]
+
+ clickedok <- clicked ok
+ clickedquit <- clicked quit
+
+ let cleanUp :: IO ()
+ cleanUp = main_destr_ub >> setRef childwindow Nothing
+
+ listenDialog :: Event ()
+ listenDialog =
+ (clickedquit >> always (cleanUp >> destroy main))
+ +> (clickedok >> always (do
+ cleanUp
+ nm <- readTkVariable ent_var
+ setRef ret (Just nm)
+ destroy main))
+ +> (main_destr >> always (cleanUp))
+
+ modalDialog main True listenDialog)
+
+confirmDeleteFile :: Toplevel -> FilePath -> Ref (Maybe Toplevel) ->
+ Ref Bool -> IO ()
+confirmDeleteFile par fp childwindow ret =
+ synchronize par
+ (do
+ (w, h, x, y) <- getGeometry par
+ let w' = 400
+ h' = 100
+ main <- createToplevel [text "Delete file",
+ geometry (w', h',
+ x + (div w 2) - (div w' 2),
+ y + (div h 2) - (div h' 2))]
+ setRef childwindow (Just main)
+ (main_destr, main_destr_ub) <- bindSimple main Destroy
+
+ lab <- newLabel main
+ [font (Lucida, 12::Int),
+ text ("Do you really want to delete the file \n'" ++
+ fp ++ "' ?")]
+ pack lab [PadX 10, PadY 5]
+
+ buttons <- newFrame main []
+ pack buttons [PadX 10, PadY 5, Side AtBottom]
+
+ ok <- newButton buttons [text "Ok", width 15]
+ pack ok [PadX 5, Side AtLeft]
+
+ quit <- newButton buttons [text "Cancel", width 15]
+ pack quit [PadX 5, Side AtLeft]
+
+ clickedok <- clicked ok
+ clickedquit <- clicked quit
+
+ let cleanUp :: IO ()
+ cleanUp = main_destr_ub >> setRef childwindow Nothing
+
+ listenDialog :: Event ()
+ listenDialog =
+ (clickedok >> always (cleanUp >> setRef ret True >>
+ destroy main))
+ +> (clickedquit >> always (setRef ret False >> cleanUp >>
+ destroy main))
+ +> (main_destr >> always (cleanUp))
+
+ modalDialog main True listenDialog)
+
+
+-- | Opens a file dialog box for a file which is to be created.
+newFileDialogStr :: String
+ -- ^ the window title of the file dialog box.
+ -> FilePath
+ -- ^ the filepath to browse.
+ -> IO (Event (Maybe FilePath))
+ -- ^ An event (returning the selected FilePath if
+ -- available) that is invoked when the file dialog is
+ -- finished.
+newFileDialogStr title fp = do pr <- newRef fp
+ fileDialog' True title pr
+
+-- | Opens a file dialog box for a file which should already exist.
+fileDialogStr :: String
+ -- ^ the window title of the file dialog box.
+ -> FilePath
+ -- ^ the filepath to browse.
+ -> IO (Event (Maybe FilePath))
+ -- ^ An event (returning the selected FilePath if
+ -- available) that is invoked when the file dialog is
+ -- finished.
+fileDialogStr title fp = do pr <- newRef fp
+ fileDialog' False title pr
+
+-- | Opens a file dialog box for a file which is to be created.
+newFileDialog :: String
+ -- ^ the window title of the file dialog box.
+ -> Ref FilePath
+ -- ^ refernce to filepath to browse.
+ -> IO (Event (Maybe FilePath))
+ -- ^ An event (returning the selected FilePath if
+ -- available) that is invoked when the file dialog is
+ -- finished.
+newFileDialog = fileDialog' True
+
+-- | Opens a file dialog box for a file which should already exist.
+fileDialog :: String
+ -- ^ the window title of the file dialog box.
+ -> Ref FilePath
+ -- ^ reference to filepath to browse.
+ -> IO (Event (Maybe FilePath))
+ -- ^ An event (returning the selected FilePath if
+ -- available) that is invoked when the file dialog is
+ -- finished.
+fileDialog = fileDialog' False
+
+
+-- | Opens a file dialog box.
+fileDialog' :: Bool
+ -- ^ True if the file is new, False if it should already exist.
+ -> String
+ -- ^ the window title of the file dialog box.
+ -> Ref FilePath
+ -- ^ reference to the filepath to browse.
+ -> IO (Event (Maybe FilePath))
+ -- ^ An event (returning the selected FilePath if
+ -- available) that is invoked when the file dialog is
+ -- finished.
+fileDialog' isNew title pathref =
+ do
+ fp <- getRef pathref
+ -- check wether we got a directory or directory/filename
+ isDir <- doesDirectoryExist fp
+ let (path,fn) =
+ if isDir
+ then (if last fp == '/' then fp else fp ++ "/","")
+ else (\ (x,y) -> (x++"/",y)) (splitName fp)
+ setRef pathref path
+ childwindow <- newRef Nothing
+
+ main <- createToplevel [text title]
+ (main_destr, main_destr_ub) <- bindSimple main Destroy
+
+ let w' = 680
+ h' = 400
+ w <- getScreenWidth (Screen main)
+ h <- getScreenHeight (Screen main)
+ main # geometry (w', h', (div w 2) - (div w' 2),
+ (div h 2) - (div h' 2))
+
+ (files, folders) <- getFilesAndFolders path False
+
+{- pathref <- newRef path -}
+ filesref <- newRef files
+ foldersref <- newRef folders
+ showhiddenref <- newRef False
+
+ actions <- newFrame main []
+
+ pathmenubutton <- newMenuButton actions [text path, width 50,
+ relief Raised]
+
+ upImg' <- upImg
+ refreshImg' <- refreshImg
+ newFolderImg' <- newFolderImg
+ deleteFileImg' <- deleteFileImg
+
+ upbutton <- newButton actions [photo upImg']
+ refreshbutton <- newButton actions [photo refreshImg']
+ newfolderbutton <- newButton actions [photo newFolderImg']
+ deletefilebutton <- newButton actions [photo deleteFileImg']
+ showHiddenFiles <- newCheckButton actions [text "hidden files"]
+ menuref <- newRef Nothing
+
+ boxesnmsg <- newFrame main []
+
+ boxes <- newFrame boxesnmsg []
+ folderslist <- newFrame boxes []
+ folderslb <- newListBox folderslist [value folders, size (35, 15),
+ bg "white",
+ font (Lucida, 12::Int)]
+ foldersscb <- newScrollBar folderslist []
+ fileslist <- newFrame boxes []
+ fileslb <- newListBox fileslist [value files, size (35, 15),
+ bg "white", font (Lucida, 12::Int)]
+ filesscb <- newScrollBar fileslist []
+ status <- newLabel boxesnmsg [text "Welcome", relief Raised,
+ font (Lucida, 12::Int), anchor Center]
+ file_var <- createTkVariable fn
+ fileEntry <- newEntry main [bg "white", variable file_var]
+ :: IO (Entry String)
+ buttons <- newFrame main []
+ ok <- newButton buttons [text "Ok", width 12]
+ quit <- newButton buttons [text "Cancel", width 12]
+ msgQ <- newChannel
+
+ pack actions [PadY 10]
+ pack pathmenubutton [PadX 10, Side AtLeft]
+ pack upbutton [PadX 2, Side AtLeft]
+ pack refreshbutton [PadX 2, Side AtLeft]
+ pack newfolderbutton [PadX 2, Side AtLeft]
+ pack deletefilebutton [PadX 2, Side AtLeft]
+ pack showHiddenFiles [PadX 10, Side AtLeft]
+ pack boxesnmsg [PadX 10, Expand On]
+
+ pack boxes [PadX 10, Fill X, Expand On]
+ pack folderslist [Side AtLeft, Expand Off]
+ pack folderslb [Side AtLeft]
+ pack foldersscb [Side AtRight, Fill Y]
+ pack fileslist [Side AtRight, Expand On]
+
+ folderslb # scrollbar Vertical foldersscb
+ pack fileslb [Side AtLeft]
+ pack filesscb [Side AtRight, Fill Y]
+ fileslb # scrollbar Vertical filesscb
+ pack status [PadX 10, PadY 3, Fill X, Expand On]
+
+ pack fileEntry [PadX 50, PadY 5, Fill X, Expand On]
+ pack buttons [PadY 5, PadX 30, Side AtRight]
+
+ updPathMenu pathmenubutton menuref path foldersref filesref pathref
+ folderslb fileslb file_var status showhiddenref
+
+ pack ok [PadX 5, Side AtLeft]
+ pack quit [PadX 5, Side AtRight]
+
+
+ -- events
+ clickeddeletefilebutton <- clicked deletefilebutton
+ clickedshowHiddenFiles <- clicked showHiddenFiles
+ clickedupbutton <- clicked upbutton
+ clickedrefreshbutton <- clicked refreshbutton
+ clickednewfolderbutton <- clicked newfolderbutton
+ clickedok <- clicked ok
+ clickedquit <- clicked quit
+ (fbpress, fbpress_ub) <- bindSimple folderslb (ButtonPress (Just 1))
+ (flpress, flpress_ub) <- bindSimple fileslb (ButtonPress (Just 1))
+ (enterName, en_ub) <- bindSimple fileEntry (KeyPress (Just (KeySym "Return")))
+
+ let cleanUp :: IO ()
+ cleanUp = flpress_ub >> fbpress_ub >> main_destr_ub
+
+ -- What to do when the user presses "OK" or "Return". Returns True
+ -- if we have successfully selected a file; False if we change
+ -- directory or the user cancels.
+ doFile :: Event ()
+ doFile =
+ always (
+ do
+ quit <- doFileInner
+ if quit
+ then
+ do
+ cleanUp
+ destroy main
+ else
+ sync listenDialog
+ )
+
+ doFileInner :: IO Bool
+ doFileInner =
+ do
+ file_nm <- readTkVariable file_var
+ path <- getRef pathref
+ let
+ trimmedPath = trimDir path
+ -- probably completely unnecessary, but I can't be
+ -- bothered to decrypt Andre's logic here.
+ fullnm= case file_nm of
+ '/':_ -> file_nm
+ _ -> combineNames trimmedPath file_nm
+
+ fileIsDir <- doesDirectoryExist fullnm
+ let
+ sendFile = syncNoWait (send msgQ (Just fullnm))
+
+ reset = setTkVariable file_var ""
+
+ if fileIsDir
+ then
+ do
+ showhidden <- getRef showhiddenref
+ status # text "Reading... "
+ success <- changeToFolder fullnm foldersref
+ filesref pathref
+ folderslb fileslb
+ file_var showhidden
+ (if success then
+ do status # text "Reading...ready"
+ nupath <- getRef pathref
+ updPathMenu pathmenubutton
+ menuref nupath foldersref
+ filesref pathref folderslb
+ fileslb file_var status
+ showhiddenref
+ done
+ else
+ do status # text "Permission denied!"
+ done)
+ return False
+ else
+ do
+ fileExists <- doesFileExist fullnm
+ if fileExists
+ then
+ if isNew
+ then
+ do
+ proceed <- confirmMess
+ "File exists. Overwrite?"
+
+ if proceed then sendFile else reset
+ return proceed
+ else
+ do
+ sendFile
+ return True
+ else
+ if isNew
+ then
+ do
+ sendFile
+ return True
+ else
+ do
+ warningMess
+ ("No such file or directory: "++
+ fullnm)
+ reset
+ return False
+
+ listenDialog :: Event ()
+ listenDialog =
+ (flpress >> always
+ (do
+ sel <- getSelection fileslb
+ :: IO (Maybe [Int])
+ case sel of
+ Just (i : _) ->
+ selectFile i filesref file_var
+ _ -> done) >>
+ listenDialog)
+ +> (fbpress >> always
+ (do
+ sel <- getSelection
+ folderslb :: IO (Maybe [Int])
+ case sel of
+ Just (i : _) ->
+ do
+ showhidden <- getRef showhiddenref
+ status # text "Reading... "
+ success <- selectedFolder i foldersref
+ filesref pathref
+ folderslb fileslb
+ file_var showhidden
+ (if success then
+ do
+ status # text "Reading...ready"
+ nupath <- getRef pathref
+ updPathMenu pathmenubutton
+ menuref nupath foldersref
+ filesref pathref folderslb
+ fileslb file_var status
+ showhiddenref
+ done
+ else
+ do status # text "Permission denied!"
+ done)
+ _ -> done) >>
+ listenDialog)
+ +> (clickedquit >> always (syncNoWait (send msgQ Nothing) >>
+ cleanUp >> destroy main))
+ +> (clickedok >> doFile)
+ +> (clickednewfolderbutton >>
+ always
+ (do
+ ret <- newRef Nothing
+ createFolder main childwindow ret
+ ret' <- getRef ret
+ case ret' of
+ Just nm ->
+ do
+ path <- getRef pathref
+ ok <- Control.Exception.try (Directory.createDirectory
+ (path ++ nm))
+ case ok of
+ Right _ ->
+ do
+ status #
+ text ("created folder " ++ nm)
+ showhidden <- getRef showhiddenref
+ refresh foldersref filesref pathref
+ folderslb fileslb showhidden
+ Left _ ->
+ status #
+ text
+ ("Error: Couldn't create folder '" ++
+ nm ++ "'") >>
+ done
+ _ -> status #
+ text "cancelled folder creation" >> done) >>
+ listenDialog)
+ +> (clickedrefreshbutton >>
+ always (do
+ showhidden <- getRef showhiddenref
+ refresh foldersref filesref pathref
+ folderslb fileslb showhidden) >>
+ listenDialog)
+ +> (clickedupbutton >>
+ always (do
+ showhidden <- getRef showhiddenref
+ success <- up foldersref filesref pathref
+ folderslb fileslb file_var status
+ showhidden
+ (if success then
+ do
+ status # text "Reading...ready"
+ nupath <- getRef pathref
+ updPathMenu pathmenubutton menuref nupath
+ foldersref filesref pathref folderslb
+ fileslb file_var status showhiddenref
+ done
+ else status # text "Permission denied!" >>
+ done)) >>
+ listenDialog)
+ +> (do clickedshowHiddenFiles
+ always (do s <- getRef showhiddenref
+ setRef showhiddenref (not s)
+ status # text "Reading... "
+ refresh foldersref filesref pathref folderslb
+ fileslb (not s)
+ status # text "Reading...ready"
+ done)
+ listenDialog)
+ +> (do
+ enterName
+ doFile
+ )
+ +> (clickeddeletefilebutton >>
+ always
+ (do
+ nm <- readTkVariable file_var
+ (if nm == "" then
+ status # text "no file selected" >> done
+ else
+ do
+ ret <- newRef False
+ path <- getRef pathref
+ confirmDeleteFile main (path ++ nm) childwindow
+ ret
+ ret' <- getRef ret
+ (if ret' then
+ do
+ ok <- Control.Exception.try (removeFile (path ++ nm))
+ case ok of
+ Right _ ->
+ do
+ status #
+ text ("file '" ++ nm ++ "' deleted")
+ showhidden <- getRef showhiddenref
+ refresh foldersref filesref pathref
+ folderslb fileslb showhidden
+ Left _ ->
+ status #
+ text
+ ("Error: Could not delete file '" ++
+ nm ++ "'") >> done
+ else status # text "cancelled file deletion" >>
+ done))) >>
+ listenDialog)
+ _ <- spawnEvent listenDialog
+ _ <- spawnEvent (main_destr >> always (do
+ mchildwindow <- getRef childwindow
+ case mchildwindow of
+ Just win -> destroy win
+ _ -> done
+ cleanUp
+ syncNoWait (send msgQ Nothing)))
+
+ return (receive msgQ)
+
+upImg = newImage [imgData GIF
+ "R0lGODlhFAAUAKEAAP//////AAAAAP///yH5BAEAAAMALAAAAAAUABQAAAJAnI+py+0Po1Si2iiC3gLZn21iN4TiWXGdeWqfu7bqW5WyG6RZvbOjyculWkOhTQh6wY7I5I95Q5GSVNChWp0oCgA7"]
+
+refreshImg = newImage [imgData GIF
+ "R0lGODlhFAAUAIQAAPj4+Pz8/Pv7+/b29gYGBvX19ZiYmPr6+oCAgAgICAcHB/Pz8/n5+QUFBYiIiJaWlv39/f7+/v///wAAAP///////////////////////////////////////////////yH5BAEAAB8ALAAAAAAUABQAAAU74CeOZGmeaKqu4+Q+rOjOLvuSz6TWccuXOlOC9vvMTgoaiXgiFInF1unYkwVRDdNtB4XFqNWweEwWhQAAOw=="]
+
+newFolderImg = newImage [imgData GIF
+ "R0lGODlhFAAUAKEAAAAAAP//////AP///yH5BAEAAAMALAAAAAAUABQAAAI5nI+pywjzXlOgzlXlPRHSbG2AQJYaBGblKkgjC6/WG8dzXd84rO9y5GP1gi0gkTQMhlLMJqcJ3TQKADs="]
+
+deleteFileImg = newImage [imgData GIF
+ "R0lGODlhFAAUAKEAAP////8AAP///////yH5BAEAAAAALAAAAAAUABQAAAIyhI+py+0WUnShTmBplVvZi2ShyHSY2WTk84HP6Wrt+8HxaNaLju/rgYIEOZwbcPhKPgoAOw=="]
diff --git a/HTk/Toolkit/GenGUI.hs b/HTk/Toolkit/GenGUI.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/GenGUI.hs
@@ -0,0 +1,891 @@
+-- | A generic graphical user interface.
+module HTk.Toolkit.GenGUI (
+
+ GenGUI, -- type
+ newGenGUI, {- :: CItem c => Maybe (GenGUIState c) -> IO (GenGUI c) -}
+
+ setStatus, {- :: CItem c => GenGUI c-> String-> IO () -}
+ clearStatus, {- :: CItem c => GenGUI c-> IO () -}
+ updateTextArea, {- :: CItem c => GenGUI c-> [MarkupText] -> IO () -}
+ clearTextArea, {- :: CItem c => GenGUI c-> IO () -}
+ genGUIMainMenu, {- :: CItem c => GenGUI c-> Menu -}
+
+ NewItem(..), -- external object representation
+ Item, -- internal object representation
+
+ Name(..),
+ CItem(..),
+
+ root, {- :: CItem c => GenGUI c -> IO (Item c) -}
+ openedFolder, {- :: CItem c=> GenGUI c-> IO (Maybe (Item c)) -}
+ addItem, {- :: CItem c => Item c -> NewItem c -> IO (Item c) -}
+ children, {- :: CItem c => Item c -> IO [Item c] -}
+ content, {- :: CItem c => (Item c) -> c -}
+
+ GenGUIEvent(..),
+ bindGenGUIEv, {- :: CItem c => GenGUI c -> -}
+ {- IO (Event (GenGUIEvent c), IO()) -}
+
+ GenGUIState, -- representation of the gui's state
+ exportGenGUIState, {- :: CItem c => GenGUI c -> IO (GenGUIState c) -}
+
+) where
+
+import Data.List
+import Data.Maybe
+
+import Util.Computation
+
+import Events.Events
+import Events.Channels
+import Events.Synchronized
+
+import Reactor.ReferenceVariables
+
+import HTk.Toplevel.HTk hiding (font)
+import qualified HTk.Toplevel.HTk as HTk (font)
+import HTk.Toolkit.ScrollBox
+import qualified HTk.Toolkit.TreeList as TreeList (obj_val, TreeListEvent(Selected), selected)
+import HTk.Toolkit.TreeList hiding (obj_val, TreeListEvent(Selected), selected)
+import qualified HTk.Toolkit.Notepad as Notepad (NotepadEvent(Dropped, Doubleclick, Rightclick))
+import HTk.Toolkit.Notepad hiding (NotepadEvent(Dropped, Doubleclick, Rightclick))
+import HTk.Kernel.Core
+
+import HTk.Toolkit.MarkupText
+import HTk.Toolkit.CItem
+
+
+--------------------------------------------------------------------------
+-- external object representation
+--------------------------------------------------------------------------
+
+-- | External representation of gengui objects.
+data NewItem c =
+
+ LeafItem c (Maybe (Position, -- position on notepad
+ Bool -- selected in notepad
+ ))
+ | FolderItem c [NewItem c] (Maybe (Bool, -- open in TreeList
+ -- (recover only)
+ Bool -- displayed in notepad
+ ))
+
+-- | Gets the name of a newitem object.
+getNameFromNewItem :: CItem c => NewItem c -> IO Name
+getNameFromNewItem (LeafItem c _) = getName c
+getNameFromNewItem (FolderItem c _ _) = getName c
+
+-- | Returns whether the given object is a folder or not.
+isNewItemFolder :: CItem c => NewItem c -> Bool
+isNewItemFolder (FolderItem _ _ _) = True
+isNewItemFolder _ = False
+
+
+--------------------------------------------------------------------------
+-- internal type & functionality
+--------------------------------------------------------------------------
+
+-- | internal object representation
+data Item c =
+ IntFolderItem (NewItem c) -- external representation
+ (Ref [Item c]) -- subitems
+ | IntLeafItem (NewItem c) -- external representation
+ (Ref Position) -- position on notepad
+ (Ref Bool) -- selected on notepad
+ | Root (Ref [Item c])
+
+-- | Internal.
+instance CItem c => Eq (Item c) where
+ item1 == item2 = content item1 == content item2
+
+-- | Objects must have a name and an icon.
+instance CItem c => CItem (Item c) where
+ -- Gets the object\'s name.
+ getName = getName . content
+ -- Gets the object\'s icon.
+ getIcon = getIcon . content
+
+-- | Returns whether an item is a folder or not.
+isItemFolder :: Item c
+ -- ^ the concerned item.
+ -> Bool
+ -- ^ @True@ if the given item is a folder,
+ -- otherwise @False@.
+isItemFolder it@(IntFolderItem _ _) = True
+isItemFolder _ = False
+
+
+-- | Returns whether an item is a folder or not.
+isItemLeaf :: Item c -> Bool
+isItemLeaf = Prelude.not . isItemFolder
+
+-- | Converts the external object representation to the internal object
+-- representation.
+toItem :: CItem c => NewItem c -> IO (Item c)
+toItem it@(FolderItem _ ch _) =
+ do
+ intch <- mapM toItem ch
+ intchref <- newRef intch
+ return (IntFolderItem it intchref)
+toItem it@(LeafItem _ Nothing) =
+ do
+ posref <- newRef (-1, -1)
+ selref <- newRef False
+ return (IntLeafItem it posref selref)
+toItem it@(LeafItem _ (Just (pos, selected))) =
+ do
+ posref <- newRef pos
+ selref <- newRef selected
+ return (IntLeafItem it posref selref)
+
+
+--------------------------------------------------------------------------
+-- external handle for root object
+--------------------------------------------------------------------------
+
+-- | GenGUI\'s root object.
+root :: CItem c => GenGUI c -> IO (Item c)
+root gui = return (Root (root_obj gui))
+
+
+--------------------------------------------------------------------------
+-- state import/export
+--------------------------------------------------------------------------
+
+-- | The gui\'s state.
+type GenGUIState c = [NewItem c]
+
+-- | Exports the gui\'s state.
+exportGenGUIState :: CItem c => GenGUI c
+ -- ^ the concerned GenGUI.
+ -> IO (GenGUIState c)
+ -- ^ the gui\'s state.
+exportGenGUIState gui =
+ do
+ saveNotepadItemStates gui
+ items <- getRef (root_obj gui)
+ mopenobj <- getRef (open_obj gui)
+ export items mopenobj
+ where export (item@(IntFolderItem (FolderItem c _ _) subitemsref) :
+ items) mopenobj =
+ do
+ subitems <- getRef subitemsref
+ subnewitems <- export subitems mopenobj
+ is_open <- isTreeListObjectOpen (treelist gui) item
+ rest <- export items mopenobj
+ return (FolderItem c subnewitems
+ (Just (is_open, Just item == mopenobj)) :
+ rest)
+ export (IntLeafItem (LeafItem c _) posref selref : items)
+ mopenobj =
+ do
+ pos <- getRef posref
+ selected <- getRef selref
+ rest <- export items mopenobj
+ return (LeafItem c (Just (pos, selected)) : rest)
+ export _ _ = return []
+
+
+--------------------------------------------------------------------------
+-- type and constructor
+--------------------------------------------------------------------------
+
+-- | The @GenGUI@ datatye.
+data GenGUI c =
+ GenGUI
+ { -- the treelist
+ treelist :: TreeList (Item c),
+
+ -- the notepad
+ notepad :: Notepad (Item c),
+
+ -- the markup text container
+ editor :: Editor,
+
+ -- the status bar
+ status :: Label,
+
+ -- GenGUI's main menu
+ topmenu :: Menu,
+
+ -- GenGUI's toplevel window
+ win :: Toplevel,
+
+ -- item displayed in notepad
+ open_obj :: Ref (Maybe (Item c)),
+
+ -- temporary, needed for current stupid placement of notepad items
+ place :: Ref Position,
+
+ -- internal state
+ root_obj :: Ref [Item c],
+
+ -- events
+ event_queue :: Ref (Maybe (Channel (GenGUIEvent c))),
+
+ show_leaves_in_tree :: Bool }
+
+
+-- -----------------------------------------------------------------------
+-- construction
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new gui and returns a handler.
+newGenGUI :: CItem c => Maybe (GenGUIState c)
+ -- ^ an optional GenGUI state to recover.
+ -> Bool
+ -- ^ @True@ if lleaves should be
+ -- displayed in the tree list.
+ -> IO (GenGUI c)
+ -- ^ A gui.
+newGenGUI mstate showLeavesInTree =
+ do
+ -- main window
+ main <- createToplevel [text "GenGUI"]
+
+ -- GenGUI menubar
+ menubar <- createMenu main False []
+ main # menu menubar
+
+ -- references
+ intstate <- case mstate of
+ Just state -> do
+ state <- mapM toItem state
+ newRef state
+ Nothing -> newRef []
+ displayref <- newRef Nothing
+
+ -- construct main widgets
+ let constructTreeListState intend
+ (newitem@(FolderItem c subnewitems
+ (Just (open,
+ selected))) :
+ newitems) =
+ do
+ subtreelistitems <- if open then
+ constructTreeListState (intend + 1)
+ subnewitems
+ else return []
+ rest <- constructTreeListState intend newitems
+ item <- toItem newitem
+
+ if selected then setRef displayref (Just item) else done
+ -- side effect: set reference for item displayed in notepad
+
+ return ([TreeListExportItem
+ { TreeList.obj_val = item,
+ obj_type =
+ if (any isNewItemFolder subnewitems) then Node
+ else Leaf,
+ open = open,
+ intend = intend,
+ TreeList.selected = selected }] ++
+ subtreelistitems ++ rest)
+ constructTreeListState intend (_ : newitems) =
+ constructTreeListState intend newitems
+ constructTreeListState _ _ = return []
+
+ stlab <- newLabel main [text "Welcome", relief Sunken,
+ HTk.font (Lucida, 12::Int)]
+ pack stlab [Side AtBottom, PadX 5, PadY 2, Fill X]
+
+
+ treeliststate <-
+ case mstate of
+ Just state -> do
+ tlstate <- constructTreeListState 0 state
+ return (Just tlstate)
+ Nothing -> return Nothing
+
+ tix <- isTixAvailable
+ (tl, np, edscr, ed) <-
+ (if tix then
+ do
+ objects_n_editor <- newPanedWindow main Horizontal []
+ paneh1 <- createPane objects_n_editor [initsize 430] []
+ paneh2 <- createPane objects_n_editor [initsize 370] []
+ objects <- newPanedWindow paneh1 Vertical []
+ panev1 <- createPane objects [initsize 220] []
+ panev2 <- createPane objects [initsize 220] []
+ pack objects [Fill Both, Expand On]
+ pack objects_n_editor [Fill Both, Expand On]
+ tl <- case treeliststate of
+ Just state ->
+ recoverTreeList panev1 (cfun showLeavesInTree) state
+ [background "white"]
+ _ -> newTreeList panev1 (cfun showLeavesInTree) []
+ [background "white"]
+ pack tl [PadX 5, PadY 5, Fill Both, Expand On]
+ np <- newNotepad panev2 Scrolled (12, 12) Nothing
+ [background "white", size (800, 800)]
+ pack np [PadX 5, PadY 5, Fill Both, Expand On]
+ (edscr, ed) <- newScrollBox paneh2
+ (\par -> newEditor par [width 40]) []
+ pack edscr [PadX 6, PadY 6, Fill Both, Expand On]
+ return (tl, np, edscr, ed)
+ else
+ do
+ objects <- newFrame main []
+ pack objects [Side AtLeft, Fill Both, Expand On]
+ tl <- case treeliststate of
+ Just state -> recoverTreeList objects
+ (cfun showLeavesInTree) state
+ [background "white", size (380, 200)]
+ _ -> newTreeList objects (cfun showLeavesInTree) []
+ [background "white", size (380, 200)]
+ pack tl [PadX 5, PadY 5, Fill Both, Expand On]
+ np <- newNotepad objects Scrolled (12, 12) Nothing
+ [size (800, 800), background "white"]
+ pack np [PadX 5, PadY 5, Fill Both, Expand On]
+ (edscr, ed) <- newScrollBox main
+ (\par -> newEditor par [width 40]) []
+ pack edscr [PadX 5, PadY 5, Fill Both, Expand On]
+ return (tl, np, edscr, ed))
+
+ ed # state Disabled
+
+ -- temporary (placement of objects in notepad / TD)
+ posref <- newRef (0, 0)
+
+ -- event queue
+ evq <- newRef Nothing
+
+ -- GenGUI value
+ let gui = GenGUI { treelist = tl,
+ notepad = np,
+ editor = ed,
+ status = stlab,
+ topmenu = menubar,
+ win = main,
+ open_obj = displayref,
+ place = posref,
+ root_obj = intstate,
+ event_queue = evq,
+ show_leaves_in_tree = showLeavesInTree }
+
+ -- listening events
+ clipboard_dnd <- newRef ((-1,-1), []) -- drop on editor
+ clipboard_mov <- newRef ((-1,-1), [], Nothing) -- drop on treelist
+ (enter_ed, _) <- bind ed [WishEvent [] Enter]
+
+ (np_ev, _) <- bindNotepadEv np
+ (tl_ev, _) <- bindTreeListEv tl
+
+ _ <- spawnEvent (forever ((do
+ ev <- np_ev
+ always
+ (case ev of
+ Selected c ->
+ npItemSelected gui (c, True)
+ Deselected c ->
+ npItemSelected gui (c, False)
+ Notepad.Dropped inf ->
+ npDropEvent gui inf
+ Notepad.Doubleclick inf ->
+ npDoubleClick gui inf
+ Notepad.Rightclick inf ->
+ npRightClick gui inf
+ ReleaseMovement ev_inf ->
+ synchronize (notepad gui)
+ (do
+ ((x1, y1), items1) <-
+ getRef clipboard_dnd
+ ((x2, y2), items2, mitem) <-
+ getRef clipboard_mov
+ (if x1 == xRoot ev_inf &&
+ y1 == yRoot ev_inf then
+ do
+ sendEv gui
+ (DroppedOnTextArea items1)
+ undoLastMotion np
+ else
+ if x2 == xRoot ev_inf &&
+ y2 == yRoot ev_inf &&
+ isJust mitem then
+ do
+ let item = fromJust mitem
+ undoLastMotion (notepad gui)
+ selected_notepaditems <-
+ getSelectedItems
+ (notepad gui)
+ mapM
+ (saveNotepadItemState gui)
+ selected_notepaditems
+ moveItems gui items2 item
+ else
+ do
+ selected_notepaditems <-
+ getSelectedItems np
+ selected_items <-
+ mapM getItemValue
+ selected_notepaditems
+ setRef clipboard_dnd
+ ((xRoot ev_inf,
+ yRoot ev_inf),
+ selected_items)
+ setRef clipboard_mov
+ ((xRoot ev_inf,
+ yRoot ev_inf),
+ selected_items, Nothing)))
+ _ -> done)) +>
+ (do
+ ev <- tl_ev
+ always
+ (case ev of
+ TreeList.Selected mobj ->
+ tlObjectSelected gui mobj
+ Focused mobjninf ->
+ tlObjectFocused gui clipboard_mov
+ mobjninf
+ )) +>
+ (do
+ ev_inf <- enter_ed
+ always
+ (do
+ ((x, y), items) <- getRef clipboard_dnd
+ (if x == xRoot ev_inf &&
+ y == yRoot ev_inf then
+ do
+ sendEv gui (DroppedOnTextArea items)
+ undoLastMotion np
+ else
+ do
+ selected_notepaditems <-
+ getSelectedItems np
+ selected_items <-
+ mapM getItemValue
+ selected_notepaditems
+ setRef clipboard_dnd
+ ((xRoot ev_inf, yRoot ev_inf),
+ selected_items))))))
+ ditem <- getRef displayref
+ case ditem of
+ Just item ->
+ tlObjectSelected gui (Just (newTreeListObject item Node))
+ _ -> done
+
+ return gui
+
+
+--------------------------------------------------------------------------
+-- internal event handling
+--------------------------------------------------------------------------
+
+-- | Saves the state (position etc.) of the currently displayed notepad
+-- items.
+saveNotepadItemStates :: CItem c => GenGUI c -> IO ()
+saveNotepadItemStates gui =
+ do
+ npitems <- getItems (notepad gui)
+ mapM (saveNotepadItemState gui) npitems
+ done
+
+-- | Saves the state of a single currently displayed notepad item.
+saveNotepadItemState :: CItem c => GenGUI c -> NotepadItem (Item c) ->
+ IO ()
+saveNotepadItemState gui npitem =
+ do
+ IntLeafItem _ posref selref <- getItemValue npitem
+ pos <- getPosition npitem
+ sel <- isNotepadItemSelected (notepad gui) npitem
+ setRef posref pos
+ setRef selref sel
+
+-- | Treelist selection event handler.
+tlObjectSelected :: CItem c => GenGUI c ->
+ Maybe (TreeListObject (Item c)) -> IO ()
+tlObjectSelected gui mobj =
+ let addNotepadItem item@(IntLeafItem _ posref selref) =
+ do
+ lastpos <- getRef posref
+ pos <- case lastpos of
+ (-1, -1) -> do
+ pos <- getNewItemPosition gui
+ setItemPosition item pos
+ return pos
+ _ -> return lastpos
+ npitem <- createNotepadItem item (notepad gui) False
+ [position pos]
+ b <- getRef selref
+ if b then selectAnotherItem (notepad gui) npitem else done
+ in case mobj of
+ Nothing -> do
+ mch <- getRef (event_queue gui)
+ case mch of
+ Just ch ->
+ syncNoWait (send ch (SelectTreeList Nothing))
+ _ -> done
+ Just obj ->
+ do
+ mch <- getRef (event_queue gui)
+ case mch of
+ Just ch ->
+ syncNoWait (send ch (SelectTreeList
+ (Just
+ (getTreeListObjectValue obj))))
+ _ -> done
+ synchronize gui (do
+ saveNotepadItemStates gui
+ ch <- children (getTreeListObjectValue obj)
+ clearNotepad (notepad gui)
+ mapM addNotepadItem
+ (filter isItemLeaf ch)
+ updNotepadScrollRegion (notepad gui)
+ done)
+ setRef (open_obj gui) (Just (getTreeListObjectValue obj))
+
+-- | Treelist focus event handler.
+tlObjectFocused :: CItem c => GenGUI c ->
+ Ref (Position, [Item c], Maybe (Item c)) ->
+ (Maybe (TreeListObject (Item c)),
+ EventInfo) ->
+ IO ()
+tlObjectFocused gui clipboard (mobj, ev_inf) =
+ do
+ mch <- getRef (event_queue gui)
+ case mobj of
+ Just obj -> do
+ let item = getTreeListObjectValue obj
+ ((x, y), items, mitem) <- getRef clipboard
+ (if x == xRoot ev_inf &&
+ y == yRoot ev_inf &&
+ isNothing mitem then
+ do
+ undoLastMotion (notepad gui)
+ selected_notepaditems <-
+ getSelectedItems (notepad gui)
+ mapM (saveNotepadItemState gui)
+ selected_notepaditems
+ moveItems gui items item
+ else do
+ case mch of
+ Just ch ->
+ do
+ let item = getTreeListObjectValue obj
+ syncNoWait
+ (send ch
+ (FocusTreeList (Just item)))
+ _ -> done
+ selected_notepaditems <-
+ getSelectedItems (notepad gui)
+ selected_items <-
+ mapM getItemValue selected_notepaditems
+ setRef clipboard
+ ((xRoot ev_inf, yRoot ev_inf),
+ selected_items, Just item))
+ _ -> case mch of
+ Just ch -> syncNoWait (send ch (FocusTreeList Nothing))
+ _ -> done
+
+-- | Moves the given leaf objects to another folder.
+moveItems :: CItem c => GenGUI c -> [Item c] -> Item c -> IO ()
+moveItems gui items target@(IntFolderItem _ subitemsref) =
+ let initItem (IntLeafItem _ posref selref) =
+ setRef posref (-1, -1) >> setRef selref False
+ in do
+ Just ditem@(IntFolderItem _ dsubitemsref) <- getRef (open_obj gui)
+ (if (ditem == target) then done
+ else do
+ dsubitems <- getRef dsubitemsref
+ setRef dsubitemsref (dsubitems \\ items)
+ subitems <- getRef subitemsref
+ mapM initItem items
+ setRef subitemsref (subitems ++ items)
+ npitems <- getItems (notepad gui)
+ mapM (\npitem -> do
+ item <- getItemValue npitem
+ let b = any (\item' -> item == item')
+ items
+ (if b then
+ deleteItem (notepad gui) npitem
+ else done)) npitems
+ done)
+
+
+--------------------------------------------------------------------------
+-- notepad events
+--------------------------------------------------------------------------
+
+-- | Notepad selection event handler.
+npItemSelected :: CItem c => GenGUI c -> (NotepadItem (Item c), Bool) ->
+ IO ()
+npItemSelected gui (npitem, b) =
+ do
+ mch <- getRef (event_queue gui)
+ case mch of
+ Just ch ->
+ do
+ item <- getItemValue npitem
+ syncNoWait (send ch (FocusNotepad (item, b)))
+ _ -> done
+
+-- | Notepad drop event handler.
+npDropEvent :: CItem c => GenGUI c ->
+ (NotepadItem (Item c),
+ [NotepadItem (Item c)]) -> IO ()
+npDropEvent gui (npitem, npitems) =
+ do
+ mch <- getRef (event_queue gui)
+ case mch of
+ Just ch -> do
+ item <- getItemValue npitem
+ items <- mapM getItemValue npitems
+ syncNoWait (send ch (Dropped (item, items)))
+ _ -> done
+
+-- | Notepad double click event handler.
+npDoubleClick :: CItem c => GenGUI c -> NotepadItem (Item c) -> IO ()
+npDoubleClick gui npitem =
+ do
+ mch <- getRef (event_queue gui)
+ case mch of
+ Just ch -> do
+ item <- getItemValue npitem
+ syncNoWait (send ch (Doubleclick item))
+ _ -> done
+
+-- | Notepad right click event handler.
+npRightClick :: CItem c => GenGUI c -> [NotepadItem (Item c)] -> IO ()
+npRightClick gui npitems =
+ do
+ mch <- getRef (event_queue gui)
+ case mch of
+ Just ch -> do
+ items <- mapM getItemValue npitems
+ syncNoWait (send ch (Rightclick items))
+ _ -> done
+
+
+--------------------------------------------------------------------------
+-- notepad item placement
+--------------------------------------------------------------------------
+
+-- | Gets the next free item position on the notepad.
+getNewItemPosition :: CItem c => GenGUI c -> IO Position
+getNewItemPosition gui = getFreeItemPosition (notepad gui)
+
+-- | Sets the items position reference.
+setItemPosition :: CItem c => Item c -> Position -> IO ()
+setItemPosition (IntLeafItem _ posref _) pos = setRef posref pos
+
+
+--------------------------------------------------------------------------
+-- exported GenGUI functionality
+--------------------------------------------------------------------------
+
+-- | Sets the status label\'s text.
+setStatus :: CItem c => GenGUI c-> String-> IO ()
+setStatus gui txt = (status gui) # text txt >> done
+
+-- | Clears the status label.
+clearStatus :: CItem c => GenGUI c-> IO ()
+clearStatus gui = (status gui) # text "" >> done
+
+-- | Displays the given markup text on the editor pane.
+updateTextArea :: CItem c => GenGUI c-> [MarkupText] -> IO ()
+updateTextArea gui mtxt = (editor gui) # new mtxt >> done
+
+-- | Clears the editor pane.
+clearTextArea :: CItem c => GenGUI c-> IO ()
+clearTextArea gui = (editor gui) # clear >> done
+
+-- | Gets the gui\'s menu container.
+genGUIMainMenu :: CItem c => GenGUI c-> Menu
+genGUIMainMenu gui = topmenu gui
+
+-- | Gets the children from a folder item.
+children :: CItem c => Item c -> IO [Item c]
+children (IntFolderItem _ chref) = getRef chref
+children (Root chref) =
+ do
+ items <- getRef chref
+ return items
+children _ = return []
+
+-- | Gets the item that is currently open (displayed on notepad).
+openedFolder :: CItem c=> GenGUI c-> IO (Maybe (Item c))
+openedFolder = getRef . open_obj
+
+-- | Adds a gengui object.
+addItem :: CItem c => GenGUI c
+ -- ^ the concerned gui.
+ -> Item c
+ -- ^ the parent (folder) object.
+ -> NewItem c
+ -- ^ the external representation of the new object.
+ -> IO (Item c)
+ -- ^ the internal representation of the new object.
+addItem gui par@(IntFolderItem (FolderItem c _ _) chref) newitem =
+ synchronize gui
+ (do
+ mditem <- getRef (open_obj gui)
+ ch <- getRef chref
+ item <- toItem newitem
+ setRef chref (ch ++ [item])
+ mch <- getRef (event_queue gui)
+ case mch of
+ Just ch -> syncNoWait (send ch (Addition item))
+ _ -> done
+ (if (isItemFolder item || show_leaves_in_tree gui) then
+ do
+ mkNode (treelist gui) par
+ nuch <- children item
+ let nod = if show_leaves_in_tree gui then
+ if Prelude.not (null nuch) then Node else Leaf
+ else
+ if (any isItemFolder nuch) then Node else Leaf
+ case newitem of
+ FolderItem c _ _ ->
+ addTreeListSubObject (treelist gui) par
+ (newTreeListObject item nod)
+ LeafItem c _ ->
+ addTreeListSubObject (treelist gui) par
+ (newTreeListObject item nod)
+ else done)
+ case mditem of
+ Just ditem -> if ditem == par then
+ do
+ pos <- getNewItemPosition gui
+ setItemPosition item pos
+ it <- createNotepadItem item (notepad gui) True
+ [position pos]
+ done
+ else done
+ _ -> done
+ return item)
+addItem gui (Root chref) newitem =
+ synchronize gui
+ (do
+ nm <- getNameFromNewItem newitem
+ items <- getRef chref
+ item <- toItem newitem
+ setRef chref (items ++ [item])
+ mch <- getRef (event_queue gui)
+ case mch of
+ Just ch -> syncNoWait (send ch (Addition item))
+ _ -> done
+ (if (isItemFolder item || show_leaves_in_tree gui) then
+ do
+ ch <- children item
+ let nod = if show_leaves_in_tree gui then
+ if Prelude.not (null ch) then Node else Leaf
+ else
+ if (any isItemFolder ch) then Node else Leaf
+ case newitem of
+ FolderItem c _ _ ->
+ addTreeListRootObject (treelist gui)
+ (newTreeListObject item nod)
+ LeafItem c _ ->
+ addTreeListRootObject (treelist gui)
+ (newTreeListObject item nod)
+ else done)
+ return item)
+addItem _ _ _ = error "GenGUI (addItem) : called for a leaf"
+
+-- | Returns the @CItem@ content of an item.
+content :: CItem c => (Item c) -> c
+content (IntFolderItem (FolderItem c _ _) _) = c
+content (IntLeafItem (LeafItem c _) _ _) = c
+content _ = error "GenGUI (content) : called for root"
+
+
+--------------------------------------------------------------------------
+-- events
+--------------------------------------------------------------------------
+
+-- | The @GenGUIEvent@ datatype.
+data GenGUIEvent c =
+ FocusTreeList (Maybe (Item c))
+ | SelectTreeList (Maybe (Item c))
+ | FocusNotepad (Item c, Bool) -- what's the Bool?
+ | Dropped (Item c, [Item c])
+ | Doubleclick (Item c)
+ | Rightclick [Item c]
+ | Addition (Item c)
+ | DroppedOnTextArea [Item c]
+
+-- | Binds a listener for gengui events to the gengui and returns
+-- a corresponding event and an unbind action.
+bindGenGUIEv :: CItem c => GenGUI c
+ -- ^ the concerned gui.
+ -> IO (Event (GenGUIEvent c), IO())
+ -- ^ A pair of (event, unbind action).
+bindGenGUIEv gui =
+ do
+ ch <- newChannel
+ setRef (event_queue gui) (Just ch)
+ return (receive ch, setRef (event_queue gui) Nothing)
+
+-- | Sends the given event if bound.
+sendEv :: CItem c => GenGUI c -> GenGUIEvent c -> IO ()
+sendEv gui ev =
+ do
+ mch <- getRef (event_queue gui)
+ case mch of
+ Just ch -> syncNoWait (send ch ev)
+ _ -> done
+
+
+--------------------------------------------------------------------------
+-- treelist children function
+--------------------------------------------------------------------------
+
+-- | Makes treelist objects from item.
+toTreeListObjects :: CItem c => Bool -> [Item c] ->
+ IO [TreeListObject (Item c)]
+toTreeListObjects showLeavesInTree (it : items) =
+ do
+ rest <- toTreeListObjects showLeavesInTree items
+ ch <- children it
+ let nod = if showLeavesInTree then
+ if (any isItemFolder ch) then Node else Leaf
+ else
+ if Prelude.not (null ch) then Node else Leaf
+ return (newTreeListObject it nod : rest)
+toTreeListObjects _ _ = return []
+
+-- | The treelists children function.
+cfun :: CItem c => Bool -> ChildrenFun (Item c)
+cfun showLeavesInTree tlobj =
+ do
+ let item = getTreeListObjectValue tlobj
+ ch <- children item
+ toTreeListObjects showLeavesInTree (if showLeavesInTree then ch
+ else filter isItemFolder ch)
+
+
+--------------------------------------------------------------------------
+-- instances
+--------------------------------------------------------------------------
+
+-- | Internal.
+instance CItem c => Eq (GenGUI c) where
+ gui1 == gui2 = win gui1 == win gui2
+
+-- | Internal.
+instance CItem c => GUIObject (GenGUI c) where
+ toGUIObject gui = toGUIObject (win gui)
+ cname _ = "GenGUI"
+
+-- | A @GenGUI@ object can be destroyed.
+instance CItem c => Destroyable (GenGUI c) where
+ -- Destroys a @GenGUI@ object.
+ destroy = destroy . toGUIObject
+
+-- | A @GenGUI@ object is a window.
+instance CItem c => Window (GenGUI c) where
+ -- Iconifies the gui.
+ iconify gui = iconify (win gui)
+ -- Deiconifies the gui.
+ deiconify gui = deiconify (win gui)
+ -- Withdraws the gui.
+ withdraw gui = withdraw (win gui)
+ -- Puts the gui window on top.
+ putWinOnTop gui = putWinOnTop (win gui)
+ -- Puts the gui window at bottom-
+ putWinAtBottom gui = putWinAtBottom (win gui)
+
+-- | You can synchronize on a gengui object.
+instance CItem c => Synchronized (GenGUI c) where
+ -- Synchronizes on a gengui object.
+ synchronize gui = synchronize (win gui)
diff --git a/HTk/Toolkit/GenericBrowser.hs b/HTk/Toolkit/GenericBrowser.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/GenericBrowser.hs
@@ -0,0 +1,275 @@
+-- | A generic data browser.
+module HTk.Toolkit.GenericBrowser (
+
+ newGenericBrowser,
+ GenericBrowser,
+ GBObject(..),
+
+ GenericBrowserEvent(..),
+ bindGenericBrowserEv
+
+) where
+
+import Control.Monad
+
+import System.IO.Unsafe
+
+import Util.Computation
+
+import Events.Events
+import Events.Channels
+
+import Reactor.ReferenceVariables
+
+import HTk.Toplevel.HTk
+import HTk.Kernel.Core
+import HTk.Toolkit.TreeList as TreeList
+import qualified HTk.Toolkit.Notepad as Notepad
+import HTk.Toolkit.Notepad hiding (NotepadEvent(..))
+
+-- | Browsed data needs to instantiate the class @CItem@.
+class CItem o => GBObject o where
+ getChildren :: o -> IO [o]
+ isObjectNode :: o -> IO Bool
+
+posRef :: Ref Position
+posRef = unsafePerformIO (newRef (10, 10))
+{-# NOINLINE posRef #-}
+
+resetPos :: IO ()
+resetPos = setRef posRef (40, 40)
+
+max_x :: Distance
+max_x = 350
+
+dx :: Distance
+dx = 60
+
+dy :: Distance
+dy = 50
+
+getPos :: IO Position
+getPos = do pos@(x,y) <- getRef posRef
+ let nupos = if (x + dx > max_x) then (40, y + dy)
+ else (x + dx, y)
+ setRef posRef nupos
+ return pos
+
+
+-- -----------------------------------------------------------------------
+-- datatype
+-- -----------------------------------------------------------------------
+
+-- | The @GenericBrowser@ datatype.
+data GBObject o => GenericBrowser o =
+ GenericBrowser { container :: Frame,
+ treelist :: TreeList o,
+ notepad :: Notepad o,
+
+ -- event queue
+ event_queue ::
+ Ref (Maybe (Channel (GenericBrowserEvent o))) }
+
+
+-- -----------------------------------------------------------------------
+-- construction
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new generic browser and returns a handler.
+newGenericBrowser :: (GBObject o, Container par) =>
+ par
+ -- ^ the parent widget (which has to be a container
+ -- widget).
+ -> [o]
+ -- ^ the list of top level objects.
+ -> [Config (GenericBrowser o)]
+ -- ^ the list of configuration options for this
+ -- generic browser.
+ ->
+ IO (GenericBrowser o)
+ -- ^ A generic browser.
+newGenericBrowser par rootobjs cnf =
+ do fr <- newFrame par []
+ let toTreeListObject obj = do --ch <- getChildren obj
+ --let is_node = not (null ch)
+ is_node <- isObjectNode obj
+ return (newTreeListObject obj
+ (if is_node then Node
+ else Leaf))
+ cfun :: GBObject o => ChildrenFun o
+ cfun tlobj = do ch <- getChildren (getTreeListObjectValue tlobj)
+ ch' <- filterM isObjectNode ch
+ mapM toTreeListObject ch'
+ tl <- newTreeList fr cfun [] [bg "white"]
+ pack tl [Side AtLeft, Fill Both, Expand On]
+ np <- newNotepad fr Scrolled (12, 12) Nothing [bg "white" {-,
+ size (500, 2000)-}]
+ pack np [Side AtRight, Fill Both, Expand On]
+ evq <- newRef Nothing
+ let gb = GenericBrowser { container = fr,
+ treelist = tl,
+ notepad = np,
+ event_queue = evq }
+ foldl (>>=) (return gb) cnf
+ (tl_ev, _) <- bindTreeListEv tl
+ (np_ev, _) <- bindNotepadEv np
+ let listenComponents = (do ev <- tl_ev
+ always (case ev of
+ TreeList.Selected mobj ->
+ tlObjectSelected gb mobj
+ TreeList.Focused (mobj, _) ->
+ tlObjectFocused gb mobj
+ )) +>
+ (do ev <- np_ev
+ always (case ev of
+ Notepad.Dropped
+ (npobj, npobjs) ->
+ npItemsDropped gb
+ (npobj, npobjs)
+ Notepad.Selected npobj ->
+ npItemSelected gb npobj
+ Notepad.Deselected npobj ->
+ npItemDeselected gb npobj
+ Notepad.Doubleclick npobj ->
+ npItemDoubleclick gb npobj
+ Notepad.Rightclick npobjs ->
+ npItemsRightclick gb npobjs
+ _ -> done))
+ _ <- spawnEvent (forever listenComponents)
+ rootobjs' <- filterM isObjectNode rootobjs
+ initBrowser gb rootobjs'
+ return gb
+
+{-
+containsSubNodes :: GBObject o => o -> IO Bool
+containsSubNodes obj =
+ let containsSubNodes' (obj : objs) =
+ do b <- isObjectNode obj
+ if b then return True else containsSubNodes' objs
+ containsSubNodes' _ = return False
+ in do ch <- getChildren obj
+ containsSubNodes' ch
+-}
+
+-- Initializes the browser.
+initBrowser :: GBObject o => GenericBrowser o -> [o] -> IO ()
+initBrowser gb rootobjs =
+ let addObject obj =
+ do b <- isObjectNode obj
+ if b then addTreeListRootObject (treelist gb)
+ (newTreeListObject obj Node)
+ else done
+ in mapM addObject rootobjs >> done
+
+-- Treelist selection event handler.
+tlObjectSelected :: GBObject o => GenericBrowser o ->
+ Maybe (TreeListObject o) -> IO ()
+tlObjectSelected gb mtlobj =
+ let addObject obj = do pos <- getPos
+ createNotepadItem obj (notepad gb) False
+ [position pos]
+ done
+ in do case mtlobj of
+ Just tlobj -> let obj = getTreeListObjectValue tlobj
+ in do clearNotepad (notepad gb)
+ resetPos
+ sendEv gb (SelectedInTreeList (Just obj))
+ ch <- getChildren obj
+ ch' <- filterM
+ (\obj -> do b <- isObjectNode obj
+ return (not b)) ch
+ mapM addObject ch'
+ updNotepadScrollRegion (notepad gb)
+ done
+ _ -> sendEv gb (SelectedInTreeList Nothing)
+
+-- Treelist focus event handler.
+tlObjectFocused :: GBObject o => GenericBrowser o ->
+ Maybe (TreeListObject o) -> IO ()
+tlObjectFocused gb mtlobj =
+ case mtlobj of
+ Just tlobj -> let obj = getTreeListObjectValue tlobj
+ in sendEv gb (FocusedInTreeList (Just obj))
+ _ -> sendEv gb (FocusedInTreeList Nothing)
+
+-- Notepad drop event handler.
+npItemsDropped :: GBObject o => GenericBrowser o ->
+ (NotepadItem o, [NotepadItem o]) -> IO ()
+npItemsDropped gb (npobj, npobjs) =
+ do obj <- getItemValue npobj
+ objs <- mapM getItemValue npobjs
+ sendEv gb (Dropped (obj, objs))
+
+-- Notepad selection event handler.
+npItemSelected :: GBObject o => GenericBrowser o -> NotepadItem o -> IO ()
+npItemSelected gb npobj = do obj <- getItemValue npobj
+ sendEv gb (SelectedInNotepad obj)
+
+-- Notepad deselection event handler.
+npItemDeselected :: GBObject o => GenericBrowser o -> NotepadItem o ->
+ IO ()
+npItemDeselected gb npobj = do obj <- getItemValue npobj
+ sendEv gb (DeselectedInNotepad obj)
+
+-- Notepad doubleclick event handler.
+npItemDoubleclick :: GBObject o => GenericBrowser o -> NotepadItem o ->
+ IO ()
+npItemDoubleclick gb npobj = do obj <- getItemValue npobj
+ sendEv gb (Doubleclick obj)
+
+-- Notepad rightclick event handler.
+npItemsRightclick :: GBObject o => GenericBrowser o -> [NotepadItem o] ->
+ IO ()
+npItemsRightclick gb npobjs = do objs <- mapM getItemValue npobjs
+ sendEv gb
+ (Rightclick objs)
+
+
+-- -----------------------------------------------------------------------
+-- events
+-- -----------------------------------------------------------------------
+
+data GBObject o => GenericBrowserEvent o =
+ SelectedInTreeList (Maybe o)
+ | FocusedInTreeList (Maybe o)
+ | Dropped (o, [o])
+ | SelectedInNotepad o
+ | DeselectedInNotepad o
+ | Doubleclick o
+ | Rightclick [o]
+
+-- send an event if bound
+sendEv :: GBObject o => GenericBrowser o -> GenericBrowserEvent o -> IO ()
+sendEv gb ev =
+ do
+ mch <- getRef (event_queue gb)
+ case mch of
+ Just ch -> syncNoWait (send ch ev)
+ _ -> done
+
+-- | Binds a listener for generic browser events to the tree list and
+-- returns a corresponding event and an unbind action.
+bindGenericBrowserEv :: GBObject o => GenericBrowser o
+ -- ^ the concerned generic browser.
+ ->
+ IO (Event (GenericBrowserEvent o),
+ IO ())
+ -- ^ A pair of (event, unbind action).
+bindGenericBrowserEv gb =
+ do
+ ch <- newChannel
+ setRef (event_queue gb) (Just ch)
+ return (receive ch, setRef (event_queue gb) Nothing)
+
+
+-- -----------------------------------------------------------------------
+-- instantiations
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GBObject o => GUIObject (GenericBrowser o) where
+ toGUIObject = toGUIObject . container
+ cname _ = "GenericBrowser"
+
+-- | Internal.
+instance GBObject o => Widget (GenericBrowser o)
diff --git a/HTk/Toolkit/HTkMenu.hs b/HTk/Toolkit/HTkMenu.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/HTkMenu.hs
@@ -0,0 +1,88 @@
+-- | HTkMenu is a user-friendly interface to HTk's menu operations, which
+-- compiles a version of MenuType.MenuPrim to an HTk menu.
+module HTk.Toolkit.HTkMenu(
+ HTkMenu(..),
+ compileHTkMenu,
+ ) where
+
+import Util.Computation
+
+import Events.Events
+
+import HTk.Kernel.Core(HasCommand(..))
+import HTk.Kernel.Packer(Container)
+import HTk.Kernel.Configuration(HasText(..))
+
+import HTk.Menuitems.Menu
+import HTk.Widgets.MenuButton
+import HTk.Menuitems.MenuCascade
+import HTk.Menuitems.MenuSeparator
+import HTk.Menuitems.MenuCommand
+
+import HTk.Toolkit.MenuType hiding (MenuPrim(Menu))
+import qualified HTk.Toolkit.MenuType as MenuType (MenuPrim(Menu))
+
+
+-- ----------------------------------------------------------------------
+-- The HTkMenu type
+-- ----------------------------------------------------------------------
+
+-- | Describes a menu to be compiled.
+-- The value identifies the buttons in the menu so the client
+-- can tell which was clicked.
+-- The String is a title which is given to menu cascades.
+newtype HTkMenu value = HTkMenu (MenuType.MenuPrim String value)
+
+-- ----------------------------------------------------------------------
+-- compileHTkMenu
+-- ----------------------------------------------------------------------
+
+-- | compileHTkMenu compiles a menu to a MenuButton. It does not display it;
+-- the caller should pack the MenuButton in the parent with whatever options
+-- are desired.
+compileHTkMenu :: Container parent => parent -> HTkMenu value
+ -> IO (MenuButton,Event value)
+compileHTkMenu parent htkMenu =
+ do
+ let (title,subMenus) = normalise htkMenu
+ menuButton <- newMenuButton parent [text title]
+ topMenu <- createMenu menuButton tearoff []
+ menuButton # menu topMenu
+ clickEvents <- mapM (compileMenuPrim topMenu) subMenus
+ return (menuButton,choose clickEvents)
+
+-- | normalise decomposes the menu into a title plus a list of submenus.
+normalise :: HTkMenu value -> (String,[MenuType.MenuPrim String value])
+normalise (HTkMenu menuPrim) =
+ case menuPrim of
+ MenuType.Menu title subMenus -> (title,subMenus)
+ Button s value -> (s,[menuPrim])
+ Blank -> ("",[Blank])
+
+
+-- | Set tearoff if we want tearoff menus, which means ones which open a
+-- new top-level window.
+tearoff :: Bool
+tearoff = False
+
+-- | Compiles the menu and inserts it into the parent (which is itself a menu),
+-- returning the event click operation
+compileMenuPrim :: Menu -> MenuType.MenuPrim String value -> IO (Event value)
+compileMenuPrim parent menuPrim =
+ case menuPrim of
+ Button string value ->
+ do
+ menuCommand <- createMenuCommand parent [text string]
+ event <- clicked menuCommand
+ return (event >> return value)
+ Blank ->
+ do
+ menuSeparator <- createMenuSeparator parent []
+ return never
+ MenuType.Menu title subMenuPrims ->
+ do
+ cascade <- createMenuCascade parent [text title]
+ innerMenu <- createMenu parent tearoff []
+ cascade # menu innerMenu
+ events <- mapM (compileMenuPrim innerMenu) subMenuPrims
+ return (choose events)
diff --git a/HTk/Toolkit/IconBar.hs b/HTk/Toolkit/IconBar.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/IconBar.hs
@@ -0,0 +1,186 @@
+-- | A simple /icon bar/ containing buttons and separators.
+module HTk.Toolkit.IconBar (
+ IconBar,
+ newIconBar,
+
+ addSeparator,
+ addButton,
+
+ Button,
+ Separator,
+
+ getIconButtons,
+ getIconBarItems
+
+)
+
+where
+
+import Util.Computation
+
+import Events.Synchronized
+
+import Reactor.ReferenceVariables
+
+import HTk.Kernel.Configuration
+import HTk.Kernel.GUIObject
+import HTk.Toplevel.HTk
+
+
+-- -----------------------------------------------------------------------
+-- IconBar Type
+-- -----------------------------------------------------------------------
+
+type Separator = Frame
+
+-- | The @IconBar@ datatype.
+data IconBar = IconBar Box (Ref [Either Separator Button])
+
+
+-- -----------------------------------------------------------------------
+-- Commands
+-- -----------------------------------------------------------------------
+
+-- | Creates a new icon bar and returns a handler.
+newIconBar :: Container par => par
+ -- ^ the parent widget (which has to be a container
+ -- widget).
+ -> [Config IconBar]
+ -- ^ the list of configuration options for this icon bar.
+ -> IO IconBar
+ -- ^ An icon bar.
+newIconBar par cnf =
+ do
+ b <- newBox par Rigid []
+ em <- newRef []
+ configure (IconBar b em) cnf
+
+
+-- -----------------------------------------------------------------------
+-- IconBar Instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance Eq IconBar where
+ w1 == w2 = (toGUIObject w1) == (toGUIObject w2)
+
+-- | Internal.
+instance GUIObject IconBar where
+ toGUIObject (IconBar b e) = toGUIObject b
+ cname _ = "IconBar"
+
+-- | An icon bar can be destroyed.
+instance Destroyable IconBar where
+ -- Destroys an icon bar.
+ destroy = destroy . toGUIObject
+
+-- | An icon bar has a configureable foreground and background colour.
+instance HasColour IconBar where
+ legalColourID = hasForeGroundColour
+
+-- | An icon bar has standard widget properties
+-- (concerning focus, cursor).
+instance Widget IconBar where
+ cursor c ib@(IconBar b pv) =
+ synchronize ib
+ (do
+ configure b [cursor c]
+ bts <- getIconButtons ib
+ foreach bts (cursor c)
+ return ib)
+
+-- | An icon bar has a configureable size.
+instance HasSize IconBar
+
+-- | An icon bar has a configureable border.
+instance HasBorder IconBar
+
+-- | An icon bar is a stateful widget, it can be enabled or disabled.
+instance HasEnable IconBar where
+ -- Sets the icon bar\'s state.
+ state st ib =
+ synchronize ib (do
+ ibs <- getIconButtons ib
+ foreach ibs (\ib -> configure ib [state st])
+ return ib)
+ -- Gets the icon bar\'s state.
+ getState ib = do
+ b <- isEnabled ib
+ if b then return Normal else return Disabled
+ -- @True@ if the icon bar is enabled.
+ isEnabled ib =
+ synchronize ib (do
+ ibs <- getIconButtons ib
+ sl <- sequence (map getState ibs)
+ return (foldr (||) False (map (/= Disabled) sl)) )
+
+-- | An icon bar has either a vertical or horizontal orientation.
+instance HasOrientation IconBar where
+ -- Sets the icon bar\'s orientation.
+ orient o sb@(IconBar b bts) =
+ do
+ orient o b
+ return sb
+ -- Gets the icon bar\'s orientation.
+ getOrient (IconBar b bts) = getOrient b
+
+-- | You can synchronize on an icon bar object.
+instance Synchronized IconBar where
+ -- Synchronizes on an icon bar object.
+ synchronize w = synchronize (toGUIObject w)
+
+
+-- -----------------------------------------------------------------------
+-- Parent/Child Relationship
+-- -----------------------------------------------------------------------
+
+-- | Adds a separator at the end of the icon bar.
+addSeparator :: IconBar
+ -- ^ the concerned icon bar.
+ -> IO Separator
+ -- ^ A separator.
+addSeparator ib@(IconBar box _) =
+ do
+ or <- getOrient ib
+ f <- newFrame box [case or of
+ Vertical -> height 5
+ Horizontal -> width 5]
+ pack f []
+ return f
+
+-- | Adds a button at the end of the icon bar.
+addButton :: IconBar
+ -- ^ the concerned icon bar.
+ -> [Config Button]
+ -- ^ the list of configuration options for the button to
+ -- add.
+ -> IO Button
+ -- ^ A button.
+addButton ib@(IconBar box _) cnf =
+ do
+ b <- newButton box cnf
+ pack b []
+ return b
+
+
+-- -----------------------------------------------------------------------
+-- Aux
+-- -----------------------------------------------------------------------
+
+-- | Gets the buttons from an icon bar.
+getIconButtons :: IconBar
+ -- ^ the concerned icon bar.
+ -> IO [Button]
+ -- ^ A list of the contained buttons.
+getIconButtons ib@(IconBar _ elemsref) =
+ do
+ elems <- getRef elemsref
+ return (map (\ (Right b) -> b) (buttons elems))
+ where buttons elems = filter (either (\_ -> False) (\_ -> True)) elems
+
+-- | Gets the items from an icon bar.
+getIconBarItems :: IconBar
+ -- ^ the concerned icon bar.
+ -> IO [Either Frame Button]
+ -- ^ Alist of the contained buttons and separators.
+getIconBarItems ib@(IconBar _ elemsref) = getRef elemsref
diff --git a/HTk/Toolkit/InputForm.hs b/HTk/Toolkit/InputForm.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/InputForm.hs
@@ -0,0 +1,815 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+-- | the inputform
+module HTk.Toolkit.InputForm (
+ InputForm(..),
+ newInputForm,
+
+ InputField(..),
+ FormState(fFormValue),
+
+ EntryField,
+ newEntryField,
+
+ NumEntryField,
+ newNumEntryField,
+
+ CheckboxField,
+ newCheckboxField,
+
+ EnumField,
+ newEnumField,
+
+ TextField,
+ newTextField,
+
+ getFormValue,
+ setFormValue,
+
+ RecordField,
+ newRecordField,
+
+ undefinedFormValue
+
+ )
+where
+
+import Util.Messages
+import HTk.Kernel.Core
+import qualified HTk.Toplevel.HTk as HTk (font)
+import HTk.Toplevel.HTk hiding (font)
+import HTk.Toolkit.SpinButton
+import HTk.Toolkit.ScrollBox
+import Reactor.ReferenceVariables
+
+-- --------------------------------------------------------------------------
+-- Classes
+-- --------------------------------------------------------------------------
+class InputField f where
+ selector :: GUIValue b => (a -> b) -> Config (f a b)
+ modifier :: GUIValue b => (a -> b -> a) -> Config (f a b)
+
+class Variable a b where
+ setVar :: a -> b -> IO ()
+ getVar :: a -> IO b
+
+-- --------------------------------------------------------------------------
+-- InputForm Type
+-- --------------------------------------------------------------------------
+-- | The @InputForm@ datatype.
+data InputForm a = InputForm Box (Ref (FormState a))
+
+data FormState a = FormState {
+ fFormValue :: Maybe a,
+ fFormBg :: Maybe Colour,
+ fFormFg :: Maybe Colour,
+ fFormFont :: Maybe Font,
+ fFormCursor :: Maybe Cursor,
+ fFormState :: Maybe State,
+ fRecordFields :: [FieldInf a]
+ }
+
+data FieldInf a = FieldInf {
+ fSetField :: a -> IO (),
+ fUpdField :: a -> IO a,
+ fSetBgColour :: Colour -> IO (),
+ fSetFgColour :: Colour -> IO (),
+ fSetFont :: Font -> IO (),
+ fSetCursor :: Cursor -> IO (),
+ fSetState :: State -> IO ()
+ }
+
+-- --------------------------------------------------------------------------
+-- Commands
+-- --------------------------------------------------------------------------
+-- | Creates a new @InputForm@
+newInputForm :: Box
+ -- ^ parent container in which the form is embedded
+ -> Maybe a
+ -- ^ the datatype which contains the initial field values and the results
+ -> [Config (InputForm a)]
+ -- ^ list of configuration options for this form
+ -> IO (InputForm a)
+ -- ^ a @InputForm@
+newInputForm par val ol = do {
+ em <- newRef (FormState val Nothing Nothing Nothing Nothing Nothing []);
+ configure (InputForm par em) ol
+}
+
+-- --------------------------------------------------------------------------
+-- InputForm Instances
+-- --------------------------------------------------------------------------
+-- | Internal.
+instance Eq (InputForm a) where
+ w1 == w2 = (toGUIObject w1) == (toGUIObject w2)
+
+-- | Internal.
+instance GUIObject (InputForm a) where
+ toGUIObject (InputForm b e) = toGUIObject b
+ cname _ = "InputForm"
+
+
+instance HasColour (InputForm a) where
+ legalColourID _ "foreground" = True
+ legalColourID _ "background" = True
+ legalColourID _ _ = False
+ setColour form@(InputForm b e) "background" c = synchronize form (do
+ {
+ configure b [bg c];
+ setFormConfig (\fst -> fst{fFormBg = Just c}) form
+ })
+ setColour form@(InputForm b e) "foreground" c = synchronize form (do {
+ configure b [fg c];
+ setFormConfig (\fst -> fst{fFormFg = Just c}) form
+ })
+ setColour form _ _ = return form
+ getColour form "background" = getFormConfig form fFormBg
+ getColour form "foreground" = getFormConfig form fFormFg
+ getColour _ _ = return cdefault
+
+instance HasFont (InputForm a) where
+ font f form@(InputForm b e) = synchronize form (
+ setFormConfig (\fst -> fst{fFormFont = Just (toFont f)}) form
+ )
+ getFont form = getFormConfig form fFormFont
+
+instance HasEnable (InputForm a) where
+ state s form@(InputForm b e) = synchronize form (
+ setFormConfig (\fst -> fst{fFormState = Just s}) form
+ )
+ getState form = getFormConfig form fFormState
+
+instance Widget (InputForm a) where
+ cursor c form@(InputForm b e) = synchronize form ( do {
+ configure b [cursor c];
+ setFormConfig (\fst -> fst{fFormCursor = Just (toCursor c)}) form
+ })
+ getCursor form = getFormConfig form fFormCursor
+
+instance Container (InputForm a)
+
+instance HasSize (InputForm a)
+
+instance HasBorder (InputForm a)
+
+instance Synchronized (InputForm a) where
+ synchronize w = synchronize (toGUIObject w)
+
+instance Variable (InputForm a) a where
+ setVar form val = setFormValue form val
+ getVar form = getFormValue form
+
+-- --------------------------------------------------------------------------
+-- Auxiliary
+-- --------------------------------------------------------------------------
+getFormValue :: InputForm a -> IO a
+getFormValue form@(InputForm b e) = synchronize form (do {
+ fst <- getRef e;
+ case fFormValue fst of
+ Nothing -> raise undefinedFormValue
+ (Just val) -> updValue (fRecordFields fst) val
+ })
+ where updValue [] val = return val
+ updValue (fei:fel) val = do {
+ val' <- (fei # fUpdField) val;
+ updValue fel val'
+ }
+
+
+setFormValue :: InputForm a -> a -> IO ()
+setFormValue form @ (InputForm b e) val = synchronize form (do {
+ fst <- getRef e;
+ setRef e (fst{fFormValue = Just val});
+ foreach (fRecordFields fst) (\fei -> (fSetField fei) val)
+ })
+
+setFormConfig :: (FormState a -> FormState a) -> Config (InputForm a)
+setFormConfig trans form@(InputForm b e) = do {
+ changeRef e trans;
+ fst <- getRef e;
+ foreach (fRecordFields fst) (setDefaultAttrs fst);
+ return form
+ }
+
+getFormConfig :: GUIValue b => InputForm a -> (FormState a -> Maybe b) -> IO b
+getFormConfig form@(InputForm b e) fetch = do {
+ mv <- withRef e fetch;
+ case mv of
+ Nothing -> return cdefault
+ (Just c) -> return c
+ }
+
+-- --------------------------------------------------------------------------
+-- Exceptions
+-- --------------------------------------------------------------------------
+undefinedFormValue :: IOError
+undefinedFormValue = userError "form value is not defined"
+
+
+-- --------------------------------------------------------------------------
+-- Entry Fields
+-- --------------------------------------------------------------------------
+-- | The @EntryField@ datatype.
+data EntryField a b = EntryField (Entry b) Label (Ref (FieldInf a))
+
+-- | Add a new @EntryField@ to the form
+newEntryField :: GUIValue b => InputForm a
+ -- ^ the form to which the field is added
+ -> [Config (EntryField a b)]
+ -- ^ a list of configuration options for this field
+ -> IO (EntryField a b)
+ -- ^ a @EntryField@
+newEntryField form@(InputForm box field) confs = do {
+ b <- newHBox box [];
+ pack b [Expand On, Fill X];
+ lbl <- newLabel b [];
+ pack lbl [Expand Off, Fill X];
+ pr <- newEntry b [];
+ pack pr [Fill X, Expand On];
+ pv <- newFieldInf
+ (\c -> do {bg (toColour c) pr; done})
+ (\c -> do {fg (toColour c) pr; done})
+ (\f -> do {HTk.font (toFont f) pr; done})
+ (\c -> do {cursor (toCursor c) pr; done})
+ (\s -> do {state s pr; done});
+ configure (EntryField pr lbl pv) confs;
+ addNewField form pr pv;
+ return (EntryField pr lbl pv)
+ }
+
+instance Eq (EntryField a b) where
+ w1 == w2 = (toGUIObject w1) == (toGUIObject w2)
+
+instance GUIObject (EntryField a b) where
+ toGUIObject (EntryField pr _ _) = toGUIObject pr
+ cname _ = "EntryField"
+
+instance Widget (EntryField a b) where
+ cursor c fe@(EntryField pr _ _) = do {cursor c pr; return fe}
+ getCursor (EntryField pr _ _) = getCursor pr
+
+instance HasColour (EntryField a b) where
+ legalColourID _ _ = True
+ setColour fe@(EntryField pr lbl _) cid c = do {
+ setColour pr cid c; setColour lbl cid c; return fe}
+ getColour (EntryField pr _ _) cid = getColour pr cid
+
+instance HasBorder (EntryField a b)
+
+instance HasSize (EntryField a b) where
+ width w fe @ (EntryField pr _ _) = do {width w pr; return fe}
+ getWidth (EntryField pr _ _) = getWidth pr
+ height h fe @ (EntryField pr _ _) = do {height h pr; return fe}
+ getHeight fe @ (EntryField pr _ _)= getHeight pr
+
+instance HasFont (EntryField a b)
+
+instance HasEnable (EntryField a b) where
+ state v f@(EntryField pr _ _) = do {state v pr; return f}
+ getState (EntryField pr _ _) = getState pr
+
+instance (GUIValue b,GUIValue c) => HasText (EntryField a b) c where
+ text v f@(EntryField pr lbl _) = do {text v lbl; return f}
+ getText (EntryField pr lbl _) = getText lbl
+
+instance Synchronized (EntryField a b) where
+ synchronize fe = synchronize (toGUIObject fe)
+
+instance GUIValue b => Variable (EntryField a b) b where
+ setVar f@(EntryField pr _ _) val = do {value val pr; done}
+ getVar (EntryField pr _ _) = getValue pr
+
+instance InputField EntryField where
+ selector f fe@(EntryField pr lbl pv) = synchronize fe (do {
+ setSelectorCmd pv cmd;
+ return fe
+ }) where cmd r = do {value (f r) pr; done}
+ modifier f fe@(EntryField pr lbl pv) = synchronize fe (do {
+ setReplacorCmd pv cmd;
+ return fe
+ }) where cmd r = do {
+ ans <- try (getVar fe);
+ case ans of
+ (Left e) -> do {
+ txt <- getText lbl;
+ errorMess (txt++" legal field value");
+ raise illegalGUIValue
+ }
+ (Right val) -> return (f r val)
+ }
+
+-- --------------------------------------------------------------------------
+-- Numeric Entry Fields
+-- --------------------------------------------------------------------------
+-- | The @NumEntryField@ datatype.
+data NumEntryField a b = NumEntryField (Entry b) Label SpinButton
+ (Ref (FieldInf a))
+
+-- | Add a new @NumEntryField@ to the form
+newNumEntryField :: (Ord b, Num b, GUIValue b) => InputForm a
+ -- ^ the form to which the field is added
+ -> (b, b)
+ -- ^ upper and lower bound (for the spin only)
+ -> b
+ -- ^ increment\/decrement for the spin button
+ -> [Config (NumEntryField a b)]
+ -- ^ a list of configuration options for this field
+ -> IO (NumEntryField a b)
+ -- ^ a @NumEntryField@
+newNumEntryField form@(InputForm box field) (min, max) delta confs =
+ do let spin Up v = if v+ delta <= max then v+delta else v
+ spin Down v = if v- delta >= min then v-delta else v
+ b <- newHBox box []
+ pack b [Expand On, Fill X]
+ lbl <- newLabel b []
+ pack lbl [Expand Off, Fill X]
+ pr <- newEntry b []
+ pack pr [Fill X, Expand Off]
+ sp <- newSpinButton b (\sp-> do tv<- try (getValue pr);
+ case tv of
+ Right v -> pr # value (spin sp v)
+ Left _ -> return pr) []
+ pack sp [Expand Off]
+ pv <- newFieldInf
+ (\c -> do {bg (toColour c) pr; done})
+ (\c -> do {fg (toColour c) pr; done})
+ (\f -> do {HTk.font (toFont f) pr; done})
+ (\c -> do {cursor (toCursor c) pr; done})
+ (\s -> do {state s pr; done})
+ configure (NumEntryField pr lbl sp pv) confs
+ addNewField form pr pv
+ return (NumEntryField pr lbl sp pv)
+
+instance Eq (NumEntryField a b) where
+ w1 == w2 = (toGUIObject w1) == (toGUIObject w2)
+
+instance GUIObject (NumEntryField a b) where
+ toGUIObject (NumEntryField pr _ _ _) = toGUIObject pr
+ cname _ = "NumEntryField"
+
+instance Widget (NumEntryField a b) where
+ cursor c fe@(NumEntryField pr _ _ _) = do {cursor c pr; return fe}
+ getCursor (NumEntryField pr _ _ _) = getCursor pr
+
+instance HasColour (NumEntryField a b) where
+ legalColourID _ _ = True
+ setColour fe@(NumEntryField pr lbl sp _) cid c = do {
+ setColour pr cid c; setColour lbl cid c; setColour sp cid c;
+ return fe}
+ getColour (NumEntryField pr _ _ _) cid = getColour pr cid
+
+instance HasBorder (NumEntryField a b)
+
+instance HasSize (NumEntryField a b) where
+ width w fe @ (NumEntryField pr _ _ _) = do {width w pr; return fe}
+ getWidth (NumEntryField pr _ _ _) = getWidth pr
+ height h fe @ (NumEntryField pr _ _ _) = do {height h pr; return fe}
+ getHeight fe @ (NumEntryField pr _ _ _)= getHeight pr
+
+instance HasFont (NumEntryField a b)
+
+instance HasEnable (NumEntryField a b) where
+ state v f@(NumEntryField pr _ sp _) = do {state v pr; state v sp; return f}
+ getState (NumEntryField pr _ _ _) = getState pr
+
+instance (GUIValue b,GUIValue c) => HasText (NumEntryField a b) c where
+ text v f@(NumEntryField pr lbl _ _) = do {text v lbl; return f}
+ getText (NumEntryField pr lbl _ _) = getText lbl
+
+instance Synchronized (NumEntryField a b) where
+ synchronize fe = synchronize (toGUIObject fe)
+
+instance GUIValue b => Variable (NumEntryField a b) b where
+ setVar f@(NumEntryField pr _ _ _) val = do {value val pr; done}
+ getVar (NumEntryField pr _ _ _) = getValue pr
+
+instance InputField NumEntryField where
+ selector f fe@(NumEntryField pr lbl _ pv) = synchronize fe (do {
+ setSelectorCmd pv cmd;
+ return fe
+ }) where cmd r = do {value (f r) pr; done}
+ modifier f fe@(NumEntryField pr lbl _ pv) =
+ synchronize fe $ do {
+ setReplacorCmd pv cmd;
+ return fe
+ } where cmd r = do {
+ ans <- try (getVar fe);
+ case ans of
+ (Left e) -> do {
+ txt <- getText lbl;
+ errorMess ("Illegal field value for "++ txt);
+ raise illegalGUIValue
+ }
+ (Right val) -> return (f r val) {- do
+ num <- try ((readIO val) :: IO b)
+ case num of
+ Left _ -> do txt <- getText lbl
+ createErrorWin
+ ("Not a numeric \value for field "
+ ++ txt) []
+ Right _ -> return (f r val) -}
+ }
+
+
+
+-- --------------------------------------------------------------------------
+-- Checkbox Fields
+-- --------------------------------------------------------------------------
+-- | The @CheckboxField@ datatype.
+data CheckboxField a b = CheckboxField (CheckButton b) Label (TkVariable b) (Ref (FieldInf a))
+
+-- | Add a new @CheckboxField@ to the form
+newCheckboxField :: GUIValue b=> InputForm a
+ -- ^ the form to which the field is added
+ -> b
+ -- ^ initial value
+ -> [Config (CheckboxField a b)]
+ -- ^ a list of configuration options for this field
+ -> IO (CheckboxField a b)
+ -- ^ a @CheckbuttonField@
+newCheckboxField form@(InputForm box field) init confs = do {
+ b <- newHBox box [];
+ pack b [Expand On, Fill X];
+ lbl <- newLabel b [];
+ pack lbl [Expand Off, Fill X];
+ cbvar <- createTkVariable init;
+ pr <- newCheckButton b [variable cbvar];
+ pack pr [Expand Off]; -- , Side AtRight];
+ pv <- newFieldInf
+ (\c -> do {bg (toColour c) pr; done})
+ (\c -> do {fg (toColour c) pr; done})
+ (\f -> do {HTk.font (toFont f) pr; done})
+ (\c -> do {cursor (toCursor c) pr; done})
+ (\s -> do {state s pr; done});
+ configure (CheckboxField pr lbl cbvar pv) confs;
+ addNewField form pr pv;
+ return (CheckboxField pr lbl cbvar pv)
+ }
+
+instance Eq (CheckboxField a b) where
+ w1 == w2 = (toGUIObject w1) == (toGUIObject w2)
+
+instance GUIObject (CheckboxField a b) where
+ toGUIObject (CheckboxField pr _ _ _) = toGUIObject pr
+ cname _ = "CheckboxField"
+
+instance Widget (CheckboxField a b) where
+ cursor c fe@(CheckboxField pr _ _ _) = do {cursor c pr; return fe}
+ getCursor (CheckboxField pr _ _ _) = getCursor pr
+
+instance HasColour (CheckboxField a b) where
+ legalColourID _ _ = True
+ setColour fe@(CheckboxField pr lbl _ _) cid c = do {
+ setColour pr cid c; setColour lbl cid c; return fe}
+ getColour (CheckboxField pr _ _ _) cid = getColour pr cid
+
+instance HasBorder (CheckboxField a b)
+
+instance HasSize (CheckboxField a b) where
+ width w fe @ (CheckboxField pr _ _ _) = do {width w pr; return fe}
+ getWidth (CheckboxField pr _ _ _) = getWidth pr
+ height h fe @ (CheckboxField pr _ _ _) = do {height h pr; return fe}
+ getHeight fe @ (CheckboxField pr _ _ _)= getHeight pr
+
+instance HasFont (CheckboxField a b)
+
+instance HasEnable (CheckboxField a b) where
+ state v f@(CheckboxField pr _ _ _) = do {state v pr; return f}
+ getState (CheckboxField pr _ _ _) = getState pr
+
+instance (GUIValue b, GUIValue c) => HasText (CheckboxField a b) c where
+ text v f@(CheckboxField pr lbl _ _) = do {text v lbl; return f}
+ getText (CheckboxField pr lbl _ _) = getText lbl
+
+instance Synchronized (CheckboxField a b) where
+ synchronize fe = synchronize (toGUIObject fe)
+
+instance GUIValue b=> Variable (CheckboxField a b) b where
+ setVar f@(CheckboxField pr _ cbv _) val = setTkVariable cbv val
+ getVar (CheckboxField pr _ cbv _) = readTkVariable cbv
+
+instance InputField CheckboxField where
+ selector f fe@(CheckboxField pr lbl cbv pv) = synchronize fe (do {
+ setSelectorCmd pv cmd;
+ return fe
+ }) where cmd r = do {setTkVariable cbv (f r)}
+ modifier f fe@(CheckboxField pr lbl cbv pv) = synchronize fe (do {
+ setReplacorCmd pv cmd;
+ return fe
+ }) where cmd r = do {
+ ans <- try (getVar fe);
+ case ans of
+ (Left e) -> do {
+ txt <- getText lbl;
+ errorMess (txt++" legal field value");
+ raise illegalGUIValue
+ }
+ (Right val) -> return (f r val)
+ }
+
+
+-- --------------------------------------------------------------------------
+-- Text Fields
+-- --------------------------------------------------------------------------
+-- | The @TextField@ datatype.
+data TextField a b = TextField Editor Label (Ref (FieldInf a))
+
+-- | Add a new @TextField@ to the form
+newTextField :: GUIValue b => InputForm a
+ -- ^ the form to which the field is added
+ -> [Config (TextField a b)]
+ -- ^ a list of configuration options for this field
+ -> IO (TextField a b)
+ -- ^ a @TextField@
+newTextField form@(InputForm box field) confs =
+ do
+ b <- newVBox box []
+ pack b [Expand On, Fill Both, PadX (cm 0.1), PadY (cm 0.1)]
+ lbl <- newLabel b [anchor West]
+ pack lbl [Expand Off, Fill Both]
+ let edit p = newEditor p []
+ (sb, tp) <- newScrollBox b edit []
+ pack sb [Expand On, Fill Both]
+ pv <- newFieldInf
+ (\c -> do {done})
+ (\c -> do {done})
+ (\f -> do {done})
+ (\c -> do {done})
+ (\s -> do {state s tp; done})
+ configure (TextField tp lbl pv) confs
+ addNewField form tp pv
+ return (TextField tp lbl pv)
+
+
+instance Eq (TextField a b) where
+ w1 == w2 = (toGUIObject w1) == (toGUIObject w2)
+
+instance GUIObject (TextField a b) where
+ toGUIObject (TextField tp _ _) = toGUIObject tp
+ cname _ = "TextField"
+
+instance Synchronized (TextField a b) where
+ synchronize fe = synchronize (toGUIObject fe)
+
+instance HasColour (TextField a b) where
+ legalColourID _ _ = True
+ setColour fe@(TextField ed lbl _) cid c = do {setColour ed cid c; setColour ed cid c; return fe}
+ getColour (TextField ed _ _) cid = getColour ed cid
+
+instance HasBorder (TextField a b)
+
+instance HasSize (TextField a b) where
+ width w fe @ (TextField ed _ _) = do {width w ed; return fe}
+ getWidth (TextField ed _ _) = getWidth ed
+ height h fe @ (TextField ed _ _) = do {height h ed; return fe}
+ getHeight fe @ (TextField ed _ _)= getHeight ed
+
+instance HasFont (TextField a b) where
+ font f fe@(TextField ed _ _) = do {HTk.font f ed; return fe}
+ getFont (TextField ed _ _) = getFont ed
+
+instance HasEnable (TextField a b) where
+ state v f@(TextField ed _ _) = do {state v ed; return f}
+ getState (TextField ed _ _) = getState ed
+
+instance (GUIValue b,GUIValue c) => HasText (TextField a b) c where
+ text v f@(TextField pr lbl _) = do {text v lbl; return f}
+ getText (TextField pr lbl _) = getText lbl
+
+instance GUIValue b => Variable (TextField a b) b where
+ setVar fe @ (TextField tp _ _) t = do {value t tp; done}
+ getVar (TextField tp _ _) = getValue tp
+
+instance InputField TextField where
+ selector f fe@(TextField tp lbl pv) = synchronize fe (do {
+ setSelectorCmd pv cmd;
+ return fe
+ }) where cmd r = do {value (f r) tp; done}
+ modifier f fe@(TextField tp lbl pv) = synchronize fe (do {
+ setReplacorCmd pv cmd;
+ return fe
+ }) where cmd r = do {
+ ans <- try (getVar fe);
+ case ans of
+ Left err -> do {
+ txt <- getText lbl;
+ errorMess (txt++" legal field value");
+ raise illegalGUIValue
+ }
+ Right val -> return (f r val)
+ }
+
+
+-- --------------------------------------------------------------------------
+-- Enumeration Fields
+-- --------------------------------------------------------------------------
+-- | The @EnumField@ datatype.
+data EnumField a b = EnumField (OptionMenu b) Label (Ref (FieldInf a))
+
+-- | Add a new @EnumField@ to the form
+newEnumField :: GUIValue b => InputForm a
+ -- ^ the form to which the field is added
+ -> [b]
+ -- ^ the list of choices in this field
+ -> [Config (EnumField a b)]
+ -- ^ a list of configuration options for this field
+ -> IO (EnumField a b)
+ -- ^ a @EnumField@
+newEnumField form@(InputForm box field) choices confs =
+ do
+ b <- newHBox box []
+ pack b [Expand On, Fill X, PadX (cm 0.1), PadY (cm 0.1)]
+ lbl <- newLabel b []
+ pack lbl [Expand Off, Fill Both]
+ mn <- newOptionMenu b choices []
+ pack mn [Expand Off, Fill Both]
+ pv <- newFieldInf
+ (\c -> do {bg (toColour c) mn; done})
+ (\c -> do {fg (toColour c) mn; done})
+ (\f -> do {HTk.font (toFont f) mn; done})
+ (\c -> do {cursor (toCursor c) mn; done})
+ (\s -> do {state s mn; done})
+ configure (EnumField mn lbl pv) confs
+ addNewField form mn pv
+ return (EnumField mn lbl pv)
+
+
+instance Eq (EnumField a b) where
+ w1 == w2 = (toGUIObject w1) == (toGUIObject w2)
+
+instance GUIObject (EnumField a b) where
+ toGUIObject (EnumField mn lbl pv) = toGUIObject mn
+ cname _ = "EnumField"
+
+instance Widget (EnumField a b) where
+ cursor c fe@(EnumField mn _ _) = do {cursor c mn; return fe}
+ getCursor (EnumField mn _ _) = getCursor mn
+
+instance HasColour (EnumField a b) where
+ legalColourID _ _ = True
+ setColour fe@(EnumField mn lbl _) cid c = do {setColour mn cid c; setColour lbl cid c; return fe}
+ getColour (EnumField mn lbl _) cid = getColour mn cid
+
+instance HasBorder (EnumField a b)
+
+instance HasSize (EnumField a b)
+
+instance HasFont (EnumField a b) where
+ font f fe@(EnumField mn _ _) = do {HTk.font f mn; return fe}
+ getFont (EnumField mn _ _) = getFont mn
+
+instance HasEnable (EnumField a b) where
+ state v f@(EnumField mn _ _) = do {state v mn; return f}
+ getState (EnumField mn _ _) = getState mn
+
+instance GUIValue c => HasText (EnumField a b) c where
+ text v fe @ (EnumField mn lbl pv) = do {text v lbl; return fe}
+ getText fe@(EnumField mn lbl pv) = getText lbl
+
+instance Synchronized (EnumField a b) where
+ synchronize fe = synchronize (toGUIObject fe)
+
+instance GUIValue b => Variable (EnumField a b) b where
+ setVar fe@(EnumField mn lbl pv) v = do {value v mn; done}
+ getVar fe@(EnumField mn lbl pv) = getValue mn
+
+instance InputField EnumField where
+ selector f fe@(EnumField mn lbl pv) = synchronize fe (do {
+ setSelectorCmd pv cmd;
+ return fe
+ }) where cmd r = do {value (f r) mn; done}
+ modifier f fe@(EnumField mn lbl pv) = synchronize fe (do {
+ setReplacorCmd pv cmd;
+ return fe
+ }) where cmd r = do {val <- getValue mn;return (f r val)}
+
+-- --------------------------------------------------------------------------
+-- Record Fields
+-- --------------------------------------------------------------------------
+data RecordField a b =
+ RecordField (InputForm b) Label (Ref (FieldInf a))
+
+newRecordField :: InputForm a -> (Box -> IO (InputForm b)) -> [Config (RecordField a b)] -> IO (RecordField a b, InputForm b)
+newRecordField form@(InputForm box e) newform confs =
+ do
+ b <- newVBox box []
+ pack b [Expand On, Fill Both, PadX (cm 0.1), PadY (cm 0.1)]
+ lbl <- newLabel b []
+ pack lbl [Expand Off, Fill X]
+ cf <- newform b
+ pv <- newFieldInf
+ (\c -> do {bg (toColour c) cf; bg (toColour c) lbl; done})
+ (\c -> do {fg (toColour c) cf; fg (toColour c) lbl; done})
+ (\f -> do {HTk.font (toFont f) cf; HTk.font (toFont f) lbl; done})
+ (\c -> do {cursor (toCursor c) cf; cursor (toCursor c) lbl; done})
+ (\s -> do {state s cf; done})
+ configure (RecordField cf lbl pv) confs
+ addNewField form cf pv
+ return (RecordField cf lbl pv, cf)
+
+
+instance Eq (RecordField a b) where
+ w1 == w2 = (toGUIObject w1) == (toGUIObject w2)
+
+instance GUIObject (RecordField a b) where
+ toGUIObject (RecordField form lb pv) = toGUIObject lb
+ cname _ = "RecordField"
+
+instance Widget (RecordField a b) where
+ cursor c fe@(RecordField cf lb _) = synchronize fe (do {
+ cursor c lb;
+ cursor c cf;
+ return fe
+ })
+ getCursor (RecordField mn lb _) = getCursor lb
+
+instance HasColour (RecordField a b) where
+ legalColourID _ _ = True
+ setColour fe@(RecordField cf lb _) cid c = synchronize fe (do {
+ setColour cf cid c;
+ setColour lb cid c;
+ return fe
+ })
+ getColour (RecordField cf _ _) cid = getColour cf cid
+
+instance HasBorder (RecordField a b)
+
+instance HasSize (RecordField a b)
+
+instance HasFont (RecordField a b) where
+ font f fe@(RecordField cf lb _) = synchronize fe (do {
+ HTk.font f cf;
+ HTk.font f lb;
+ return fe
+ })
+ getFont (RecordField cf _ _) = getFont cf
+
+instance HasEnable (RecordField a b) where
+ state v fe@(RecordField cf _ _) = do {state v cf; return fe}
+ getState (RecordField cf _ _) = getState cf
+
+instance GUIValue c => HasText (RecordField a b) c where
+ text v fe @ (RecordField cf lb pv) = do {text v lb; return fe}
+ getText fe@(RecordField cf lb pv) = getText lb
+
+instance Synchronized (RecordField a b) where
+ synchronize fe = synchronize (toGUIObject fe)
+
+instance GUIValue b => Variable (RecordField a b) b where
+ setVar fe@(RecordField cf lb pv) v = setVar cf v
+ getVar fe@(RecordField cf lb pv) = getVar cf
+
+instance InputField RecordField where
+ selector f fe@(RecordField cf lb pv) = synchronize fe (do {
+ setSelectorCmd pv cmd;
+ return fe
+ }) where cmd r = do {setFormValue cf (f r); done}
+ modifier f fe@(RecordField cf lb pv) = synchronize fe (do {
+ setReplacorCmd pv cmd;
+ return fe
+ }) where cmd r = do {val <- getFormValue cf;return (f r val)}
+
+
+-- --------------------------------------------------------------------------
+-- Auxiliary Computations for Field Information
+-- --------------------------------------------------------------------------
+type Field a = (Ref (FieldInf a))
+
+newFieldInf :: (Colour -> IO ())
+ -> (Colour -> IO ())
+ -> (Font -> IO ())
+ -> (Cursor -> IO ())
+ -> (State -> IO ())
+ -> IO (Field a)
+newFieldInf setBg setFg setFont setCursor setState = newRef inf
+ where inf = FieldInf (const done) return setBg setFg setFont setCursor setState
+
+
+addNewField :: InputForm a -> w -> Field a -> IO ()
+addNewField form@(InputForm b em) w pv = do {
+ fei <- getRef pv;
+ fst <- getRef em;
+ setDefaultAttrs fst fei;
+ configure w [];
+ changeRef em (\fst -> fst {fRecordFields = (fRecordFields fst) ++ [fei]})
+ }
+
+setDefaultAttrs :: FormState a -> FieldInf a -> IO ()
+setDefaultAttrs fst fei = do {
+ incase (fFormBg fst) (fSetBgColour fei);
+ incase (fFormFg fst) (fSetFgColour fei);
+ incase (fFormFont fst) (fSetFont fei);
+ incase (fFormCursor fst) (fSetCursor fei);
+ incase (fFormState fst) (fSetState fei);
+ done
+ }
+
+setSelectorCmd :: Field a -> (a -> IO ()) -> IO ()
+setSelectorCmd pv cmd = do
+ changeRef pv (\fei -> fei{fSetField = cmd})
+
+
+setReplacorCmd :: Field a -> (a -> IO a) -> IO ()
+setReplacorCmd pv cmd = do
+ changeRef pv (\fei -> fei{fUpdField = cmd})
diff --git a/HTk/Toolkit/InputWin.hs b/HTk/Toolkit/InputWin.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/InputWin.hs
@@ -0,0 +1,175 @@
+-- | Basic input window for record values and their fields.
+module HTk.Toolkit.InputWin (
+ InputWin,
+ createInputWin,
+ createInputWin',
+
+ wait,
+ waitValidate
+ ) where
+
+import HTk.Kernel.Core
+import HTk.Toplevel.HTk
+import HTk.Widgets.Space
+import HTk.Toolkit.SelectBox
+import HTk.Toolkit.ModalDialog
+import HTk.Toolkit.InputForm
+import Reactor.ReferenceVariables
+import HTk.Toolkit.Separator
+
+-- ---------------------------------------------------------------------------
+-- Data Type
+-- ---------------------------------------------------------------------------
+
+-- | The @InputWin@ datatype.
+data InputWin a = InputWin {
+ fWindow :: Toplevel,
+ fForm :: InputForm a,
+ fEvents :: (Event Bool)
+ }
+
+-- ---------------------------------------------------------------------------
+-- Instantiations
+-- ---------------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject (InputWin a) where
+ toGUIObject iwin = toGUIObject (fWindow iwin)
+ cname iwin = cname (fWindow iwin)
+
+-- ---------------------------------------------------------------------------
+-- Constructor
+-- ---------------------------------------------------------------------------
+-- | Create an @InputWindow@ with a generic message box title
+createInputWin' :: String
+ -- ^ the message for the headline
+ -> [Config Message]
+ -- ^ configs for the header message, e.g. font or aspect
+ -> (Box -> IO (InputForm a))
+ -- ^ the @InputForm@-function
+ -> [Config Toplevel]
+ -- ^ configuration for the toplevel (e.g. title)
+ -> IO (InputWin a, InputForm a)
+ -- ^ the @InputWindow@ and @InputForm@
+createInputWin' str hdconfs ifun tpconfs =
+ delayWish $ do
+ tp <- createToplevel ([text "Input Form Window"]++tpconfs)
+ pack tp [Expand On, Fill Both]
+
+ b <- newVBox tp []
+ pack b [Expand On, Fill Both]
+
+ let fmsg = xfont {family = Just Times, weight = Just Bold,
+ slant = Just Roman, points = (Just 180)}
+ msg <- newMessage b ([text str, borderwidth 0, aspect 750, font fmsg]++
+ hdconfs)
+
+ pack msg [Expand On, Fill Both, PadX (cm 0.5), PadY (cm 0.5)]
+
+ sp1 <- newSpace b (cm 0.15) []
+ pack sp1 [Expand Off, Fill X, Side AtTop]
+
+ newHSeparator b
+
+ sp2 <- newSpace b (cm 0.15) []
+ pack sp2 [Expand Off, Fill X, Side AtTop]
+
+ formbox <- newVBox b []
+ pack formbox [Expand On, Fill Both, PadX (cm 0.5)]
+
+ form <- ifun formbox
+
+ sp3 <- newSpace b (cm 0.15) []
+ pack sp3 [Expand Off, Fill X, Side AtBottom]
+
+ newHSeparator b
+
+ sp4 <- newSpace b (cm 0.15) []
+ pack sp4 [Expand Off, Fill X, Side AtBottom]
+
+ sb <- newSelectBox b Nothing []
+ pack sb [Expand Off, Fill X, Side AtBottom]
+
+ but1 <- addButton sb [text "Ok"] [Expand On, Side AtRight]
+ but2 <- addButton sb [text "Cancel"] [Expand On, Side AtRight]
+
+ clickedbut1 <- clicked but1
+ clickedbut2 <- clicked but2
+
+ let ev = (clickedbut1 >> (always (return True))) +> (clickedbut2 >> (always (return False)))
+
+ sp5 <- newSpace b (cm 0.3) []
+ pack sp5 [Fill X]
+
+ --form <- newInputForm formbox val []
+
+ --case val of
+ -- Nothing -> return (InputWin tp form ev)
+ -- Just val' -> do
+ return ((InputWin tp form ev), form)
+
+
+-- Create an InputWindow, title given as a string
+createInputWin :: String
+ -- ^ the title
+ -> (Box -> IO (InputForm a))
+ -- ^ the @InputForm@-function
+ -> [Config Toplevel]
+ -- ^ configuration for the toplevel
+ -> IO (InputWin a, InputForm a)
+ -- ^ the @InputWindow@ and @InputForm@
+createInputWin str = createInputWin' str []
+
+
+-- ---------------------------------------------------------------------------
+-- Additional Funcitons
+-- ---------------------------------------------------------------------------
+-- | Wait for the user to end the dialog.
+wait :: InputWin a
+ -- ^ the @InputWindow@ to wait for
+ -> Bool
+ -- ^ grep focus
+ -> IO (Maybe a)
+ -- ^ Nothing or Just (the data stored in the @IputForm@)
+wait win@(InputWin tp form@(InputForm b e) ev) modality = do
+ -- before we can question a user we should fill all the fields with
+ -- their initial values (to be done automatically)
+ fst <- getRef e
+ initiate form (fFormValue fst)
+ internalWait win (const (return True)) modality
+
+-- | Wait for the user to end the dialog, and validate the result
+waitValidate :: InputWin a
+ -- ^ the @InputWindow@ to wait for
+ -> (a-> IO Bool)
+ -- ^ grep focus
+ -> Bool
+ -- ^ check the value of the form
+ -> IO (Maybe a)
+ -- ^ Nothing or Just (the data stored in the @IputForm@)
+waitValidate win@(InputWin tp form@(InputForm b e) ev) validate modality = do
+ -- before we can question a user we should fill all the fields with
+ -- their initial values (to be done automatically)
+ fst <- getRef e
+ initiate form (fFormValue fst)
+ internalWait win validate modality
+
+internalWait :: InputWin a -> (a-> IO Bool)-> Bool -> IO (Maybe a)
+internalWait win@(InputWin tp form ev) val mod = do
+ ans <- modalInteraction tp False mod ev
+ case ans of
+ False -> do
+ destroy win
+ return Nothing
+ True -> do
+ res <- try (getFormValue form)
+ case res of
+ Left e -> internalWait win val mod
+ Right res' -> do chck <- val res'
+ if chck then do destroy win
+ return (Just res')
+ else internalWait win val mod
+
+initiate :: InputForm a -> Maybe a -> IO ()
+initiate form Nothing = done
+initiate form (Just val) = setFormValue form val
diff --git a/HTk/Toolkit/LogWin.hs b/HTk/Toolkit/LogWin.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/LogWin.hs
@@ -0,0 +1,107 @@
+-- | A simple log window.
+module HTk.Toolkit.LogWin (
+
+ LogWin(..),
+ createLogWin,
+
+ HasFile(..),
+
+ writeLogWin
+
+) where
+
+import System.IO.Unsafe
+import Reactor.ReferenceVariables
+import HTk.Toplevel.HTk
+import HTk.Kernel.Core
+import HTk.Toolkit.ScrollBox
+import HTk.Toolkit.FileDialog
+import System.Environment
+
+
+-- -----------------------------------------------------------------------
+-- Type
+-- -----------------------------------------------------------------------
+
+-- | The @LogWin@ datatype.
+data LogWin = LogWin Toplevel Editor (IO ())
+
+
+-- -----------------------------------------------------------------------
+-- Commands
+-- -----------------------------------------------------------------------
+
+-- | Creates a new log window and returns a handler.
+createLogWin :: [Config Toplevel]
+ -- ^ the list of configuration options for this log window.
+ -> IO LogWin
+ -- ^ A log window.
+createLogWin cnf =
+ do
+ win <- createToplevel cnf
+ b <- newVFBox win [relief Groove, borderwidth (cm 0.05) ]
+ pack b []
+ mb <- createMenu win False []
+ filecasc <- createMenuCascade mb [text "File"]
+ mfile <- createMenu win False []
+ filecasc # menu mfile
+ savecmd <- createMenuCommand mfile [text "Save"]
+ clickedsavecmd <- clicked savecmd
+ quitcmd <- createMenuCommand mfile [text "Quit"]
+ clickedquitcmd <- clicked quitcmd
+ win # menu mb
+ (sb, ed) <- newScrollBox b (\par -> newEditor par [bg "white"]) []
+ pack sb []
+ death <- newChannel
+ let listen :: Event ()
+ listen = (clickedsavecmd >> always (saveLog ed) >> listen) +>
+ (clickedquitcmd >>> destroy win) +>
+ receive death
+ _ <- spawnEvent listen
+ return (LogWin win ed (syncNoWait (send death ())))
+
+
+pathRef :: Ref String
+pathRef = unsafePerformIO $ getEnv "HOME" >>= newRef
+{-# NOINLINE pathRef #-}
+
+saveLog :: Editor -> IO ()
+saveLog ed =
+ do selev <- fileDialog "Open file" pathRef
+ file <- sync selev
+ case file of
+ Just fp -> try (writeTextToFile ed fp) >> done
+ _ -> done
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject LogWin where
+ toGUIObject (LogWin win _ _) = toGUIObject win
+ cname _ = "LogWin"
+
+-- | A log window can be destroyed.
+instance Destroyable LogWin where
+ -- Destroys a log window.
+ destroy (LogWin win _ death) = death >> destroy win
+
+
+-- -----------------------------------------------------------------------
+-- Write Log
+-- -----------------------------------------------------------------------
+
+-- | Writes into the log window.
+writeLogWin :: LogWin
+ -- ^ the concerned log window.
+ -> String
+ -- ^ the text to write to the log window.
+ -> IO ()
+ -- ^ None.
+writeLogWin lw@(LogWin _ ed _) str =
+ do
+ try (insertText ed EndOfText str)
+ moveto Vertical ed 1.0
+ done
diff --git a/HTk/Toolkit/MarkupText.hs b/HTk/Toolkit/MarkupText.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/MarkupText.hs
@@ -0,0 +1,1275 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
+-- | A simple markup language for convenient writing into an editor widget.
+module HTk.Toolkit.MarkupText (
+
+-- type
+ MarkupText,
+
+-- combinators
+ prose,
+ font,
+ newline,
+ bold,
+ underline,
+ italics,
+ spaces,
+ offset,
+ colour,
+ bgcolour,
+ flipcolour,
+ flipunderline,
+ action,
+ rangeaction,
+ clipup,
+ leftmargin,
+ wrapmargin,
+ rightmargin,
+ centered,
+ flushright,
+ flushleft,
+ href,
+ window,
+ window1,
+
+-- special characters
+ alpha,
+ beta,
+ chi,
+ delta,
+ epsilon,
+ phi,
+ gamma,
+ eta,
+ varphi,
+ iota,
+ kappa,
+ lambda,
+ mu,
+ nu,
+ omikron,
+ pi,
+ theta,
+ vartheta,
+ rho,
+ sigma,
+ varsigma,
+ tau,
+ upsilon,
+ varpi,
+ omega,
+ xi,
+ psi,
+ zeta,
+ aalpha,
+ bbeta,
+ cchi,
+ ddelta,
+ eeps,
+ pphi,
+ ggamma,
+ eeta,
+ iiota,
+ kkappa,
+ llambda,
+ mmu,
+ nnu,
+ oomikron,
+ ppi,
+ ttheta,
+ rrho,
+ ssigma,
+ ttau,
+ uupsilon,
+ oomega,
+ xxi,
+ ppsi,
+ zzeta,
+ forallsmall,
+ exists,
+ forallbig,
+ eexists,
+ existsone,
+ not,
+ and,
+ bigand,
+ or,
+ times,
+ sum,
+ prod,
+ comp,
+ bullet,
+ tensor,
+ otimes,
+ oplus,
+ bot,
+ rightarrow,
+ rrightarrow,
+ longrightarrow,
+ llongrightarrow,
+ leftrightarrow,
+ lleftrightarrow,
+ ddownarrow,
+ uuparrow,
+ vline,
+ hline,
+ rbrace1,
+ rbrace2,
+ rbrace3,
+ emptyset,
+ inset,
+ notin,
+ intersect,
+ union,
+ subset,
+ subseteq,
+ setminus,
+ powerset,
+ inf,
+ iintersect,
+ uunion,
+ equiv,
+ neq,
+ leq,
+ grteq,
+ lsem,
+ rsem,
+ dots,
+ copyright,
+
+
+-- container class for markup texts
+ HasMarkupText(..),
+
+
+ scrollMarkupText,
+) where
+
+import Data.Char
+import Prelude hiding (pi, not, and, or, sum)
+import qualified Prelude (not)
+
+import System.IO.Unsafe
+
+import Util.Object
+import Util.Computation
+
+import Events.Channels
+import Events.Events
+
+import Reactor.ReferenceVariables
+
+import HTk.Toplevel.HTk hiding (font, underline, offset)
+import HTk.Kernel.GUIObject
+import qualified HTk.Kernel.Configuration as Configuration (font)
+import qualified HTk.Textitems.TextTag as TextTag (offset)
+import HTk.Kernel.Font
+
+-- -----------------------------------------------------------------------
+-- state
+-- -----------------------------------------------------------------------
+
+unbinds :: Ref [(ObjectID, [IO ()])]
+unbinds = unsafePerformIO (newRef [])
+{-# NOINLINE unbinds #-}
+
+addToState :: Editor -> [IO ()] -> IO ()
+addToState ed acts =
+ do
+ let GUIOBJECT oid _ = toGUIObject ed
+ ub <- getRef unbinds
+ setRef unbinds ((oid, acts) : ub)
+
+
+-- -----------------------------------------------------------------------
+-- types
+-- -----------------------------------------------------------------------
+
+-- | The @MarkupText@ datatype.
+data MarkupText =
+ MarkupText [MarkupText]
+ | MarkupProse [String]
+ | MarkupSpecialChar Font Int
+ | MarkupFont Font [MarkupText]
+ | MarkupNewline
+ | MarkupBold [MarkupText]
+ | MarkupItalics [MarkupText]
+ | MarkupOffset Int [MarkupText]
+ | MarkupColour Colour [MarkupText]
+ | MarkupBgColour Colour [MarkupText]
+ | MarkupFlipColour Colour Colour [MarkupText]
+ | MarkupFlipUnderline [MarkupText]
+ | MarkupUnderline [MarkupText]
+ | MarkupJustify Justify [MarkupText]
+ | MarkupAction (IO ()) [MarkupText]
+ | MarkupClipUp [MarkupText] [MarkupText]
+ | MarkupRangeAction (Maybe (IO ())) (Maybe (IO ())) [MarkupText]
+ | MarkupLeftMargin Int [MarkupText]
+ | MarkupWrapMargin Int [MarkupText]
+ | MarkupRightMargin Int [MarkupText]
+ | MarkupHRef [MarkupText] [MarkupText]
+ | forall w . Widget w => MarkupWindow (Editor -> IO (w, IO()))
+
+type TagFun = Editor -> BaseIndex -> BaseIndex -> IO TextTag
+
+type Tag = (Position, Position, TagFun)
+
+type EmbWindowFun =
+ Editor -> BaseIndex -> IO EmbeddedTextWin
+
+type EmbWindow = (Position, EmbWindowFun)
+
+
+-- ----------------------------------------------------------------------
+-- combinators
+-- -----------------------------------------------------------------------
+
+-- | The markup prose combinator.
+prose :: String -> MarkupText
+prose str = MarkupProse (lines str)
+
+-- | The markup font combinator.
+font :: FontDesignator f => f -> [MarkupText] -> MarkupText
+font f = MarkupFont (toFont f)
+
+-- | The markup newline combinator.
+newline :: MarkupText
+newline = MarkupNewline
+
+-- | The markup bold combinator.
+bold :: [MarkupText] -> MarkupText
+bold = MarkupBold
+
+-- | The markup underline combinator.
+underline :: [MarkupText] -> MarkupText
+underline = MarkupUnderline
+
+-- | Center this part of the text
+centered :: [MarkupText]-> MarkupText
+centered = MarkupJustify JustCenter
+
+-- | Flush this part of the against the left margin
+flushleft :: [MarkupText]-> MarkupText
+flushleft = MarkupJustify JustLeft
+
+----
+-- Flush this part of the against the right margin
+flushright :: [MarkupText]-> MarkupText
+flushright = MarkupJustify JustRight
+
+-- | The markup italics combinator.
+italics :: [MarkupText] -> MarkupText
+italics = MarkupItalics
+
+-- | The markup baseline offset combinator.
+offset :: Int-> [MarkupText]-> MarkupText
+offset = MarkupOffset
+
+-- | The markup foreground colour combinator.
+colour :: ColourDesignator c => c -> [MarkupText] -> MarkupText
+colour c = MarkupColour (toColour c)
+
+-- | The markup background colour combinator.
+bgcolour :: ColourDesignator c => c -> [MarkupText] -> MarkupText
+bgcolour c = MarkupBgColour (toColour c)
+
+-- | The markup space combinator (a number of space characters).
+spaces :: Int -> MarkupText
+spaces n = MarkupProse [replicate n ' ']
+
+-- | The markup flipcolour combinator (flips the colour when the mouse
+-- is over this text segment).
+flipcolour :: ColourDesignator c => c -> c -> [MarkupText] -> MarkupText
+flipcolour c1 c2 = MarkupFlipColour (toColour c1) (toColour c2)
+
+-- | The markup flipunderline combinator (underlines this text segment when
+-- the mouse is over this segment).
+flipunderline :: [MarkupText] -> MarkupText
+flipunderline = MarkupFlipUnderline
+
+-- | The markup action combinator (binds an action for mouse clicks on this
+-- text segment).
+action :: IO () -> [MarkupText] -> MarkupText
+action = MarkupAction
+
+-- | The markup range action combinator (binds actions for entering and\/or
+-- leaving this text segment with the mouse cursor).
+rangeaction :: Maybe (IO ()) -> Maybe (IO ()) -> [MarkupText] ->
+ MarkupText
+rangeaction = MarkupRangeAction
+
+-- | The markup clipup combinator (clips up a text segment on a mouse
+-- click).
+clipup :: [MarkupText] -> [MarkupText] -> MarkupText
+clipup = MarkupClipUp
+
+-- | The markup left margin combinator (normal left intend for a line).
+leftmargin :: Int -> [MarkupText] -> MarkupText
+leftmargin = MarkupLeftMargin
+
+-- | The markup wrap margin combinator (intend for a part of a line
+-- that gets wrapped).
+wrapmargin :: Int -> [MarkupText] -> MarkupText
+wrapmargin = MarkupWrapMargin
+
+-- | The markup right margin combinator.
+rightmargin :: Int -> [MarkupText] -> MarkupText
+rightmargin = MarkupRightMargin
+
+
+-- | The markup window combinator (a widget container inside the editor
+-- widget).
+window1 :: Widget w => (Editor -> IO (w, IO())) -> MarkupText
+window1 = MarkupWindow
+
+window :: Widget w => IO (w, IO()) -> MarkupText
+window act = window1 (const act)
+
+-- | The markup href combinator (a link to another markup text).
+href :: [MarkupText] -> [MarkupText] -> MarkupText
+href = MarkupHRef
+
+
+-- -----------------------------------------------------------------------
+-- special characters
+-- -----------------------------------------------------------------------
+
+-- grk letters, lowercase
+
+-- | Special character.
+alpha :: MarkupText
+alpha = symbchr 97
+
+-- | Special character.
+beta :: MarkupText
+beta = symbchr 98
+
+-- | Special character.
+chi ::MarkupText
+chi = symbchr 99
+
+-- | Special character.
+delta :: MarkupText
+delta = symbchr 100
+
+-- | Special character.
+epsilon :: MarkupText
+epsilon = symbchr 101
+
+-- | Special character.
+phi :: MarkupText
+phi = symbchr 102
+
+-- | Special character.
+gamma :: MarkupText
+gamma = symbchr 103
+
+-- | Special character.
+eta :: MarkupText
+eta = symbchr 104
+
+-- | Special character.
+varphi :: MarkupText
+varphi = symbchr 106
+
+-- | Special character.
+iota :: MarkupText
+iota = symbchr 105
+
+-- | Special character.
+kappa :: MarkupText
+kappa = symbchr 107
+
+-- | Special character.
+lambda :: MarkupText
+lambda = symbchr 108
+
+-- | Special character.
+mu :: MarkupText
+mu = symbchr 109
+
+-- | Special character.
+nu :: MarkupText
+nu = symbchr 110
+
+-- | Special character.
+omikron :: MarkupText
+omikron = symbchr 111
+
+-- | Special character.
+pi :: MarkupText
+pi = symbchr 112
+
+-- | Special character.
+theta :: MarkupText
+theta = symbchr 113
+
+-- | Special character.
+vartheta :: MarkupText
+vartheta = symbchr 74
+
+-- | Special character.
+rho :: MarkupText
+rho = symbchr 114
+
+-- | Special character.
+sigma :: MarkupText
+sigma = symbchr 115
+
+-- | Special character.
+varsigma :: MarkupText
+varsigma = symbchr 86
+
+-- | Special character.
+tau :: MarkupText
+tau = symbchr 116
+
+-- | Special character.
+upsilon :: MarkupText
+upsilon = symbchr 117
+
+-- | Special character.
+varpi :: MarkupText
+varpi = symbchr 118
+
+-- | Special character.
+omega :: MarkupText
+omega = symbchr 119
+
+-- | Special character.
+xi :: MarkupText
+xi = symbchr 120
+
+-- | Special character.
+psi :: MarkupText
+psi = symbchr 121
+
+-- | Special character.
+zeta :: MarkupText
+zeta = symbchr 122
+
+
+
+-- grk letters, uppercase
+
+-- | Special character (uppercase).
+aalpha :: MarkupText
+aalpha = symbchr 65
+
+-- | Special character (uppercase).
+bbeta :: MarkupText
+bbeta = symbchr 66
+
+-- | Special character (uppercase).
+cchi :: MarkupText
+cchi = symbchr 67
+
+-- | Special character (uppercase).
+ddelta :: MarkupText
+ddelta = symbchr 68
+
+-- | Special character (uppercase).
+eeps :: MarkupText
+eeps = symbchr 69
+
+-- | Special character (uppercase).
+pphi :: MarkupText
+pphi = symbchr 70
+
+-- | Special character (uppercase).
+ggamma :: MarkupText
+ggamma = symbchr 71
+
+-- | Special character (uppercase).
+eeta :: MarkupText
+eeta = symbchr 72
+
+-- | Special character (uppercase).
+iiota :: MarkupText
+iiota = symbchr 73
+
+-- | Special character (uppercase).
+kkappa :: MarkupText
+kkappa = symbchr 75
+
+-- | Special character (uppercase).
+llambda :: MarkupText
+llambda = symbchr 76
+
+-- | Special character (uppercase).
+mmu :: MarkupText
+mmu = symbchr 77
+
+-- | Special character (uppercase).
+nnu :: MarkupText
+nnu = symbchr 78
+
+-- | Special character (uppercase).
+oomikron :: MarkupText
+oomikron = symbchr 79
+
+-- | Special character (uppercase).
+ppi :: MarkupText
+ppi = symbchr 80
+
+-- | Special character (uppercase).
+ttheta :: MarkupText
+ttheta = symbchr 81
+
+-- | Special character (uppercase).
+rrho :: MarkupText
+rrho = symbchr 82
+
+-- | Special character (uppercase).
+ssigma :: MarkupText
+ssigma = symbchr 83
+
+-- | Special character (uppercase).
+ttau :: MarkupText
+ttau = symbchr 84
+
+-- | Special character (uppercase).
+uupsilon :: MarkupText
+uupsilon = symbchr 85
+
+-- | Special character (uppercase).
+oomega :: MarkupText
+oomega = symbchr 87
+
+-- | Special character (uppercase).
+xxi :: MarkupText
+xxi = symbchr 88
+
+-- | Special character (uppercase).
+ppsi :: MarkupText
+ppsi = symbchr 89
+
+-- | Special character (uppercase).
+zzeta :: MarkupText
+zzeta = symbchr 90
+
+
+
+-- quantifiers and junctors
+
+-- | Special character.
+forallsmall :: MarkupText
+forallsmall = symbchr 34
+
+-- | Special character.
+exists :: MarkupText
+exists = symbchr 36
+
+-- | Special character.
+forallbig :: MarkupText
+forallbig = bigsymbchr 34
+
+-- | Special character.
+eexists :: MarkupText
+eexists = bigsymbchr 36
+
+-- | Special character.
+existsone :: MarkupText
+existsone = symbstr [36, 33]
+
+-- | Special character.
+not :: MarkupText
+not = symbchr 216
+
+-- | Special character.
+and :: MarkupText
+and = symbchr 217
+
+-- | Special character.
+bigand :: MarkupText
+bigand = bigsymbchr 217
+
+-- | Special character.
+or :: MarkupText
+or = symbchr 218
+
+
+-- other operations
+
+-- | Special character.
+times :: MarkupText
+times = symbchr 180
+
+-- | Special character.
+sum :: MarkupText
+sum = symbchr 229
+
+-- | Special character.
+prod :: MarkupText
+prod = symbchr 213
+
+-- | Special character.
+comp :: MarkupText
+comp = symbchr 183
+
+-- | Special character.
+bullet :: MarkupText
+bullet = symbchr 183
+
+-- | Special character.
+tensor :: MarkupText
+tensor = symbchr 196
+
+-- | Special character.
+otimes :: MarkupText
+otimes = symbchr 196
+
+-- | Special character.
+oplus :: MarkupText
+oplus = symbchr 197
+
+-- | Special character.
+bot :: MarkupText
+bot = symbchr 94
+
+
+-- arrows
+
+-- | Special character.
+rightarrow :: MarkupText
+rightarrow = symbchr 174
+
+-- | Special character.
+rrightarrow :: MarkupText
+rrightarrow = symbchr 222
+
+-- | Special character.
+longrightarrow :: MarkupText
+longrightarrow = symbstr [190, 174]
+
+-- | Special character.
+llongrightarrow :: MarkupText
+llongrightarrow = symbstr [61, 222]
+
+-- | Special character.
+leftrightarrow :: MarkupText
+leftrightarrow = symbchr 171
+
+-- | Special character.
+lleftrightarrow :: MarkupText
+lleftrightarrow = symbchr 219
+
+-- | Special character.
+ddownarrow :: MarkupText
+ddownarrow = symbchr 223
+
+-- | Special character.
+uuparrow :: MarkupText
+uuparrow = symbchr 221
+
+-- | Special character.
+vline :: MarkupText
+vline = symbchr 189
+
+-- | Special character.
+hline :: MarkupText
+hline = symbchr 190
+
+-- | Special character.
+rbrace1 :: MarkupText
+rbrace1 = symbchr 236
+
+-- | Special character.
+rbrace2 :: MarkupText
+rbrace2 = symbchr 237
+
+-- | Special character.
+rbrace3 :: MarkupText
+rbrace3 = symbchr 238
+
+
+-- set operations
+
+-- | Special character.
+emptyset :: MarkupText
+emptyset = symbchr 198
+
+-- | Special character.
+inset :: MarkupText
+inset = symbchr 206
+
+-- | Special character.
+notin :: MarkupText
+notin = symbchr 207
+
+-- | Special character.
+intersect :: MarkupText
+intersect = symbchr 199
+
+-- | Special character.
+union :: MarkupText
+union = symbchr 200
+
+-- | Special character.
+subset :: MarkupText
+subset = symbchr 204
+
+-- | Special character.
+subseteq :: MarkupText
+subseteq = symbchr 205
+
+-- | Special character.
+setminus :: MarkupText
+setminus = symbchr 164
+
+-- | Special character.
+powerset :: MarkupText
+powerset = symbchr 195
+
+-- | Special character.
+inf :: MarkupText
+inf = symbchr 165
+
+-- | Special character.
+iintersect :: MarkupText
+iintersect = bigsymbchr 199
+
+-- | Special character.
+uunion :: MarkupText
+uunion = bigsymbchr 200
+
+
+-- relations
+
+-- | Special character.
+equiv :: MarkupText
+equiv = symbchr 186
+
+-- | Special character.
+neq :: MarkupText
+neq = symbchr 185
+
+-- | Special character.
+leq :: MarkupText
+leq = symbchr 163
+
+-- | Special character.
+grteq :: MarkupText
+grteq = symbchr 179
+
+-- | Special character.
+lsem :: MarkupText
+lsem = symbstr [91, 91]
+
+-- | Special character.
+rsem :: MarkupText
+rsem = symbstr [93, 93]
+
+
+-- misc other symbols
+
+-- | Special character.
+dots :: MarkupText
+dots = symbchr 188
+
+-- | Special character.
+copyright :: MarkupText
+copyright = symbchr 227
+
+-- aux
+symbchr :: Int -> MarkupText
+symbchr i = MarkupSpecialChar
+ (Font "-*-symbol-medium-r-normal-*-14-*-*-*-*-*-*-*") i
+
+bigsymbchr :: Int -> MarkupText
+bigsymbchr i = MarkupSpecialChar
+ (Font "-*-symbol-medium-r-normal-*-18-*-*-*-*-*-*-*") i
+
+symbstr :: [Int] -> MarkupText
+symbstr is = MarkupText (map symbchr is)
+
+
+-- -----------------------------------------------------------------------
+-- parse markup text structures
+-- -----------------------------------------------------------------------
+
+checkfont :: Font -> Bool -> Bool -> Font
+checkfont f@(Font str) bold italics =
+ let xf = read str
+ in case xf of
+ XFontAlias _ -> f
+ _ ->
+ case (bold, italics) of
+ (True, True) -> toFont xf {weight = Just Bold,
+ slant = Just Italic}
+ (True, False) -> toFont xf {weight = Just Bold}
+ (False, True) -> toFont xf {slant = Just Italic}
+ _ -> f
+
+clipact :: Editor -> Mark -> Mark -> Ref Bool -> Ref [TextTag] ->
+ String -> [Tag] -> IO ()
+clipact ed mark1 mark2 open settags txt tags =
+ do
+ b <- getRef open
+ setRef open (Prelude.not b)
+ (if b then
+ do
+ tags' <- getRef settags
+ st <- getState ed
+ if st == Disabled then ed # state Normal >> done else done
+ mapM destroy tags'
+ deleteTextRange ed mark1 mark2
+ ed # state st -- restore state
+ done
+ else
+ do
+ st <- getState ed
+ if st == Disabled then ed # state Normal >> done else done
+ insertText ed mark1 txt
+ tags' <- insertTags tags
+ ed # state st -- restore state
+ setRef settags tags')
+ where insertTags :: [Tag] -> IO [TextTag]
+ insertTags (((l1,c1), (l2,c2), f) : ts) =
+ do
+ pos1 <- getBaseIndex ed
+ (mark1, [ForwardLines (fromDistance l1),
+ ForwardChars (fromDistance c1)])
+ pos2 <- getBaseIndex ed
+ (mark1, [ForwardLines (fromDistance l2),
+ ForwardChars (fromDistance c2)])
+ tag <- f ed pos1 pos2
+ tags <- insertTags ts
+ return (tag : tags)
+ insertTags _ = return []
+
+parseMarkupText :: [MarkupText] -> Font -> IO (String, [EmbWindow], [Tag])
+parseMarkupText m f =
+ do
+ (ret, _) <- parseMarkupText' m [] [] [] (1,0) False False f
+ return ret
+ where
+ simpleProperty :: [MarkupText] -> [MarkupText] -> String ->
+ [Tag] -> [EmbWindow] -> Position -> Bool -> Bool ->
+ Font -> [Config TextTag] ->
+ IO ((String, [EmbWindow], [Tag]), Position)
+ simpleProperty ms m' txt tags wins (line, char) bold italics
+ current_font cnf =
+ do
+ ((txt', wins', tags'), (line', char')) <-
+ parseMarkupText' m' txt tags wins (line, char) bold italics
+ current_font
+ let tag = ((line, char), (line', char'),
+ \ed pos1 pos2 ->
+ createTextTag ed pos1 pos2 cnf)
+ parseMarkupText' ms txt' (tag : tags') wins' (line', char') bold
+ italics current_font
+
+ parseMarkupText' :: [MarkupText] -> String -> [Tag] -> [EmbWindow] ->
+ Position -> Bool -> Bool -> Font ->
+ IO ((String, [EmbWindow], [Tag]), Position)
+ parseMarkupText' (m : ms) txt tags wins (line, char) bold italics
+ current_font =
+ case m of
+
+ MarkupText m' -> parseMarkupText' (m' ++ ms) txt tags wins
+ (line, char) bold italics
+ current_font
+
+ MarkupProse [str] -> parseMarkupText' ms
+ (txt ++ str) tags wins
+ (line, char + Distance (length str))
+ bold italics current_font
+ MarkupProse (l:rest) -> parseMarkupText' (MarkupProse rest:ms)
+ (txt++ l++ "\n") tags wins
+ (line+ 1, 0)
+ bold italics current_font
+ MarkupProse [] -> parseMarkupText' ms txt tags wins
+ (line, char) bold italics current_font
+
+ MarkupSpecialChar f i ->
+ parseMarkupText' (MarkupFont f [prose [chr i]] : ms) txt tags
+ wins (line, char) bold italics current_font
+
+ MarkupNewline -> parseMarkupText' ms (txt ++ "\n") tags wins
+ (line + 1, 0) bold italics
+ current_font
+
+ MarkupColour c m' -> simpleProperty ms m' txt tags wins
+ (line, char) bold italics current_font
+ [fg c]
+
+ MarkupOffset i m' -> simpleProperty ms m' txt tags wins
+ (line, char) bold italics current_font
+ [TextTag.offset (Distance i)]
+
+ MarkupBgColour c m' -> simpleProperty ms m' txt tags wins
+ (line, char) bold italics current_font
+ [bg c]
+
+ MarkupLeftMargin i m' ->
+ simpleProperty ms m' txt tags wins (line, char)
+ bold italics current_font [lmargin1 (Distance i)]
+
+ MarkupWrapMargin i m' ->
+ simpleProperty ms m' txt tags wins (line, char)
+ bold italics current_font [lmargin2 (Distance i)]
+
+ MarkupRightMargin i m' ->
+ simpleProperty ms m' txt tags wins (line, char)
+ bold italics current_font [rmargin (Distance i)]
+
+ MarkupUnderline m' ->
+ simpleProperty ms m' txt tags wins (line, char)
+ bold italics current_font [underlined On]
+
+ MarkupJustify j m' ->
+ simpleProperty ms m' txt tags wins (line, char)
+ bold italics current_font [justify j]
+
+ MarkupFont f m' ->
+ do
+ ((txt', wins', tags'), (line', char')) <-
+ parseMarkupText' m' txt tags wins (line, char) bold italics
+ f
+
+ let (Font fstr) = f
+
+ let tag = ((line, char), (line', char'),
+ \ed pos1 pos2 ->
+ createTextTag ed pos1 pos2
+ [Configuration.font
+ (checkfont f bold italics)])
+ parseMarkupText' ms txt' (tag : tags') wins' (line', char')
+ bold italics current_font
+
+ MarkupBold m' ->
+ do
+ ((txt', wins', tags'), (line', char')) <-
+ parseMarkupText' m' txt tags wins (line, char) True italics
+ current_font
+
+ let (Font fstr) = current_font
+
+ let tag = ((line, char), (line', char'),
+ \ed pos1 pos2 ->
+ createTextTag ed pos1 pos2
+ [Configuration.font
+ (checkfont current_font True italics)])
+ parseMarkupText' ms txt' (tag : tags') wins' (line', char')
+ bold italics current_font
+
+ MarkupItalics m' ->
+ do
+ ((txt', wins', tags'), (line', char')) <-
+ parseMarkupText' m' txt tags wins (line, char) bold True
+ current_font
+
+ let (Font fstr) = current_font
+
+ let tag = ((line, char), (line', char'),
+ \ed pos1 pos2 ->
+ createTextTag ed pos1 pos2
+ [Configuration.font
+ (checkfont current_font bold True)])
+ parseMarkupText' ms txt' (tag : tags') wins' (line', char')
+ bold italics current_font
+
+ MarkupFlipColour c1 c2 m' ->
+ do
+ ((txt', wins', tags'), (line', char')) <-
+ parseMarkupText' m' txt tags wins (line, char) bold italics
+ current_font
+ let tag = ((line, char), (line', char'),
+ \ed pos1 pos2 ->
+ do
+ tag <- createTextTag ed pos1 pos2 []
+ tag # fg c1
+ (entered, u_entered) <- bindSimple tag Enter
+ (left, u_left) <- bindSimple tag Leave
+ death <- newChannel
+ let listenTag :: Event ()
+ listenTag =
+ (entered >>
+ (always (tag # fg c2) >>
+ listenTag))
+ +> (left >>
+ (always (tag # fg c1) >>
+ listenTag))
+ +> receive death
+ _ <- spawnEvent listenTag
+ addToState ed [u_entered, u_left,
+ syncNoWait(send death ())]
+ return tag)
+ parseMarkupText' ms txt' (tag : tags') wins' (line', char')
+ bold italics current_font
+
+ MarkupFlipUnderline m' ->
+ do
+ ((txt', wins', tags'), (line', char')) <-
+ parseMarkupText' m' txt tags wins (line, char) bold italics
+ current_font
+ let tag = ((line, char), (line', char'),
+ \ed pos1 pos2 ->
+ do
+ tag <- createTextTag ed pos1 pos2 []
+ (entered, u_entered) <- bindSimple tag Enter
+ (left, u_left) <- bindSimple tag Leave
+ death <- newChannel
+ let listenTag :: Event ()
+ listenTag =
+ (entered >>
+ (always (tag # underlined On) >>
+ listenTag))
+ +> (left >>
+ (always (tag # underlined Off) >>
+ listenTag))
+ +> receive death
+ _ <- spawnEvent listenTag
+ addToState ed [u_entered, u_left,
+ syncNoWait (send death ())]
+ return tag)
+ parseMarkupText' ms txt' (tag : tags') wins' (line', char')
+ bold italics current_font
+
+ MarkupAction act m' ->
+ do
+ ((txt', wins', tags'), (line', char')) <-
+ parseMarkupText' m' txt tags wins (line, char) bold italics
+ current_font
+ let tag = ((line, char), (line', char'),
+ \ed pos1 pos2 ->
+ do
+ tag <- createTextTag ed pos1 pos2 []
+ (click, u_click) <-
+ bindSimple tag (ButtonPress (Just 1))
+ death <- newChannel
+ let listenTag :: Event ()
+ listenTag =
+ (click >> always act >> listenTag)
+ +> receive death
+ _ <- spawnEvent listenTag
+ addToState ed [u_click,
+ syncNoWait (send death ())]
+ return tag)
+ parseMarkupText' ms txt' (tag : tags') wins' (line', char')
+ bold italics current_font
+
+ MarkupRangeAction menteract mleaveact m' ->
+ do
+ ((txt', wins', tags'), (line', char')) <-
+ parseMarkupText' m' txt tags wins (line, char) bold italics
+ current_font
+ let tag = ((line, char), (line', char'),
+ \ed pos1 pos2 ->
+ do
+ tag <- createTextTag ed pos1 pos2 []
+ (enter, enter_u) <- bindSimple tag Enter
+ (leave, leave_u) <- bindSimple tag Leave
+ death <- newChannel
+ let listenTag :: Event ()
+ listenTag =
+ (enter >> always (case menteract of
+ Just act -> act
+ Nothing -> done) >>
+ listenTag) +>
+ (leave >> always (case mleaveact of
+ Just act -> act
+ Nothing -> done) >>
+ listenTag) +>
+ receive death
+ _ <- spawnEvent listenTag
+ addToState ed [enter_u, leave_u,
+ syncNoWait (send death ())]
+ return tag)
+ parseMarkupText' ms txt' (tag : tags') wins' (line', char')
+ bold italics current_font
+
+ MarkupClipUp m' cliptext ->
+ do
+ let pos = (if char > 0 then line + 1 else line, 0)
+ s = if char > 0 then "\n" else ""
+ ((txt', wins', tags'), (line', char')) <-
+ parseMarkupText' m' (s ++ txt) tags wins pos bold italics
+ current_font
+ let tag = (pos, (line', char'),
+ \ed pos1 pos2 ->
+ do
+ ((txt', wins', tags'), (line', char')) <-
+ parseMarkupText' (cliptext ++ [newline]) ""
+ [] [] (0, 0) bold italics f
+ oid1 <- newObject
+ mark1 <- createMark ed ("m" ++ show oid1)
+ (pos1, [ForwardLines 1])
+ setMarkGravity mark1 ToLeft
+ oid2 <- newObject
+ mark2 <- createMark ed ("m" ++ show oid2)
+ (pos1, [ForwardLines 1])
+ tag <- createTextTag ed pos1 pos2 []
+ (click, u_click) <-
+ bindSimple tag (ButtonPress (Just 1))
+ open <- newRef False
+ settags <- newRef []
+ death <- newChannel
+ let listenTag :: Event ()
+ listenTag =
+ (click >>
+ always (clipact ed mark1 mark2 open
+ settags txt' tags') >>
+ listenTag)
+ +> receive death
+ _ <- spawnEvent listenTag
+ addToState ed [u_click,
+ syncNoWait (send death ())]
+ return tag)
+ parseMarkupText' ms (txt' ++ "\n") (tag : tags') wins'
+ (line' + 1, 0) bold italics current_font
+
+ MarkupHRef m' linktext ->
+ do
+ ((txt', wins', tags'), (line', char')) <-
+ parseMarkupText' m' txt tags wins (line, char) bold italics
+ current_font
+ let tag = ((line, char), (line', char'),
+ \ed pos1 pos2 ->
+ do
+ tag <- createTextTag ed pos1 pos2 []
+ (click, u_click) <-
+ bindSimple tag (ButtonPress (Just 1))
+ death <- newChannel
+ let listenTag :: Event ()
+ listenTag =
+ (click >>
+ always (ed # clear >>
+ ed # new linktext) >>
+ listenTag)
+ +> receive death
+ _ <- spawnEvent listenTag
+ addToState ed [u_click,
+ syncNoWait (send death ())]
+ return tag)
+ parseMarkupText' ms txt' (tag : tags') wins' (line', char')
+ bold
+ italics current_font
+
+ MarkupWindow iowid ->
+ let win = ((line, char),
+ \ed pos -> do
+ (wid, cleanup) <- iowid ed
+ w <- createEmbeddedTextWin ed pos wid []
+ addToState ed [cleanup]
+ return w)
+ in parseMarkupText' ms txt tags (win : wins) (line, char)
+ bold italics current_font
+
+ parseMarkupText' _ txt tags wins (line, char) _ _ _ =
+ return ((txt, wins, tags), (line, char))
+
+
+-- -----------------------------------------------------------------------
+-- class HasMarkupText
+-- -----------------------------------------------------------------------
+
+-- | Widgets that can contain markup text instantiate the
+-- @class HasMarkupText@.
+class HasMarkupText w where
+ -- Clears the editor widget and inserts the given markup text.
+ new :: [MarkupText] -> w -> IO w
+ -- Inserts the given markup text at the specified position.
+ insertAt :: [MarkupText] -> Position -> Config w
+ -- Clears the editor widget.
+ clear :: Config w
+
+-- | An editor widget is a container for markup text.
+instance HasMarkupText Editor where
+ -- Clears the editor widget and inserts the given markup text.
+ new m ed =
+ do
+ st <- getState ed
+ if st == Disabled then ed # state Normal >> done else done
+ f <- getFont ed
+ (txt, wins, tags) <- parseMarkupText m f
+ ed # value txt
+ mapM (\ (pos1, pos2, f) -> do
+ pos1' <- getBaseIndex ed pos1
+ pos2' <- getBaseIndex ed pos2
+ f ed pos1' pos2')
+ tags
+ mapM (\ (pos, f) -> do
+ pos' <- getBaseIndex ed pos
+ ew <- f ed pos'
+ addToState ed [destroy ew])
+ wins
+ ed # state st -- restore state
+ return ed
+ -- Inserts the given markup text at the specified position.
+ insertAt m pos@(line, char) ed =
+ do
+ f <- getFont ed
+ (txt, wins, tags) <- parseMarkupText m f
+ l <- getTextLine ed pos
+ st <- getState ed
+ if st == Disabled then ed # state Normal >> done else done
+ insertText ed pos (replicate (fromDistance char - length l) ' ' ++
+ txt)
+ let tags' = shiftTags pos tags
+ mapM (\ (pos1, pos2, f) -> do
+ pos1' <- getBaseIndex ed pos1
+ pos2' <- getBaseIndex ed pos2
+ f ed pos1' pos2')
+ tags'
+ ed # state st -- restore state
+ return ed
+ where
+ shiftTags :: Position -> [Tag] -> [Tag]
+ shiftTags p tags = map (shiftTag p) tags
+
+ shiftTag :: Position -> Tag -> Tag
+ shiftTag (line, char) (p1@(line1, char1), p2@(line2, char2), tag) =
+ ((shiftLine line line1, shiftChar char p1),
+ (shiftLine line line2, shiftChar char p2), tag)
+
+ shiftLine :: Distance -> Distance -> Distance
+ shiftLine pline line = pline + (line - 1)
+
+ shiftChar :: Distance -> Position -> Distance
+ shiftChar pchar (line, char) =
+ if line == 1 then char + pchar else char
+ -- Clears the editor widget.
+ clear ed =
+ do
+ let obj@(GUIOBJECT oid _) = toGUIObject ed
+ unbinds' <- getRef unbinds
+ mapM (\ (oid', ubs) -> if oid == oid' then
+ (mapM (\ act -> act) ubs) >> done
+ else done)
+ unbinds'
+ setRef unbinds []
+ return ed
+
+fromDistance :: Distance -> Int
+fromDistance (Distance i) = i
+
+-- -----------------------------------------------------------------------
+-- A utility for putting a scroll-bar around MarkupText.
+-- -----------------------------------------------------------------------
+
+scrollMarkupText :: Size -> [MarkupText] -> MarkupText
+scrollMarkupText size1 markups =
+ let
+ action :: Editor -> IO (Frame,IO ())
+ action editor =
+ do
+ editorFrame <- newFrame editor []
+ editorFrame2 <- newFrame editorFrame []
+
+ editor <- newEditor editorFrame2 [wrap NoWrap,disable,new markups,size size1]
+ scrollBar1 <- newScrollBar editorFrame2 [orient Vertical]
+ scrollBar2 <- newScrollBar editorFrame [orient Horizontal]
+
+ editor # scrollbar Vertical scrollBar1
+ editor # scrollbar Horizontal scrollBar2
+
+ pack editor [Side AtRight,Fill Both]
+ pack scrollBar1 [Side AtRight,Fill Y,Expand On]
+ pack editorFrame2 [Side AtTop]
+ pack scrollBar2 [Side AtTop,Fill X]
+ return (editorFrame,destroy editorFrame)
+
+ in
+ window1 action
diff --git a/HTk/Toolkit/MenuType.hs b/HTk/Toolkit/MenuType.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/MenuType.hs
@@ -0,0 +1,81 @@
+-- | This module contains 'MenuType' - a general abstract datatype for menus -
+-- plus some map-like operations on it.
+--
+-- NBNBNB. 'MenuType' is also used by the graphs and daVinci stuff, which is
+-- supposed to be independent of HTk. So before making HTk-specific changes
+-- to this datatype, please find some way of harmlessly ignoring them
+-- (at best) for daVinci.
+module HTk.Toolkit.MenuType(
+ MenuPrim(..), -- the general type of menus.
+
+ -- Map functions
+ mapMenuPrim, -- :: (a -> b) -> MenuPrim c a -> MenuPrim c b
+ mapMenuPrim', -- :: (c -> d) -> MenuPrim c a -> MenuPrim d a
+ mapMMenuPrim, -- :: (Monad m) => (a -> m b) -> MenuPrim c a
+ -- -> m (MenuPrim c b)
+ mapMMenuPrim', -- :: (Monad m) => (c -> m d) -> MenuPrim c a
+ -- -> m (MenuPrim d a)
+ ) where
+
+-- ----------------------------------------------------------------------
+-- General basic Menu type.
+-- For particular applications, for example HTk menus, it is recommended
+-- that we wrap MenuPrim inside a newtype, for example
+-- newtype HTkMenu value = HTkMenu (MenuPrim (Maybe String) value)
+-- Different applications will need different values for both the
+-- typevariables subMenuValue and value; for example daVinci uses a
+-- value of subMenuValue which isn't Maybe String while it is compiling
+-- menus.
+-- ----------------------------------------------------------------------
+
+data MenuPrim subMenuValue value =
+ Button String value
+ -- A button with the given (String) label
+ | Menu subMenuValue [MenuPrim subMenuValue value]
+ -- A list of buttons (or further menus) inside a menu
+ | Blank
+ -- A Blank can be used to separate groups of menu buttons in the
+ -- same menu.
+
+-- ----------------------------------------------------------------------
+-- Map functions
+-- There are 4 of these, for each possible answer to the two questions
+-- (1) map or monadic map?
+-- (2) map first type or second type?
+-- ----------------------------------------------------------------------
+
+mapMenuPrim :: (a -> b) -> MenuPrim c a -> MenuPrim c b
+mapMenuPrim a2b (Button label a) = Button label (a2b a)
+mapMenuPrim a2b (Menu subMenuValue menuButtons) =
+ Menu subMenuValue (map (mapMenuPrim a2b) menuButtons)
+mapMenuPrim a2b Blank = Blank
+
+mapMenuPrim' :: (c -> d) -> MenuPrim c a -> MenuPrim d a
+mapMenuPrim' c2d (Button title action) = Button title action
+mapMenuPrim' c2d (Menu subMenuValue menuButtons) =
+ Menu (c2d subMenuValue) (map (mapMenuPrim' c2d) menuButtons)
+mapMenuPrim' c2d Blank = Blank
+
+mapMMenuPrim :: (Monad m) => (a -> m b) -> MenuPrim c a
+ -> m (MenuPrim c b)
+mapMMenuPrim a2bAct (Button label a) =
+ do
+ b <- a2bAct a
+ return (Button label b)
+mapMMenuPrim a2bAct (Menu subMenuValue menuButtons) =
+ do
+ bMenuButtons <- mapM (mapMMenuPrim a2bAct) menuButtons
+ return (Menu subMenuValue bMenuButtons)
+mapMMenuPrim a2bAct Blank = return Blank
+
+mapMMenuPrim' :: (Monad m) => (c -> m d) -> MenuPrim c a
+ -> m (MenuPrim d a)
+mapMMenuPrim' c2dAct (Button title action) =
+ return (Button title action)
+mapMMenuPrim' c2dAct (Menu subMenuValue menuButtons) =
+ do
+ dMenuButtons <- mapM (mapMMenuPrim' c2dAct) menuButtons
+ dSubMenuValue <- c2dAct subMenuValue
+ return (Menu dSubMenuValue dMenuButtons)
+mapMMenuPrim' c2dAct Blank = return Blank
+
diff --git a/HTk/Toolkit/ModalDialog.hs b/HTk/Toolkit/ModalDialog.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/ModalDialog.hs
@@ -0,0 +1,70 @@
+module HTk.Toolkit.ModalDialog (
+
+ modalDialog,
+ modalInteraction
+
+) where
+
+import HTk.Toplevel.HTk
+
+-- -----------------------------------------------------------------------
+-- Basic Behaviours for modelling Modal Dialogs
+-- -----------------------------------------------------------------------
+
+{-
+This function should acctually find out if the window allows modality or not,
+but since this not possible at the moment, the function gets an extra parameter
+to decide. There the supplied window is always destroyed after the event occoured.
+ -}
+modalDialog :: Toplevel -> Bool -> Event a -> IO a
+modalDialog win modality ev =
+ do
+ --modality <- getModal win --old way
+ maybeModalDialog True modality win ev
+
+{-
+
+ -}
+maybeModalDialog :: Bool -> Bool -> Toplevel -> Event a -> IO a
+maybeModalDialog destr True win ev = doModalDialog destr win ev
+maybeModalDialog destr False win ev =
+ do
+ ans <- sync ev
+ when destr (destroy win)
+ return ans
+
+doModalDialog :: Bool -> Toplevel -> Event a -> IO a
+doModalDialog destr win ev =
+ do
+ gw <- getCurrentGrab
+ grabLocal win
+ ans <- sync ev
+ try(releaseGrab win)
+ when destr (do {try (destroy win);done})
+ returnGrab gw
+ return ans
+
+
+-- --------------------------------------------------------------------------
+-- Modals Interaction
+-- --------------------------------------------------------------------------
+{-
+Same as with modalDialog here, only that the caller decides if the window is
+destroyed after the event occoured or not.
+ -}
+modalInteraction :: Toplevel -> Bool -> Bool -> Event a -> IO a
+modalInteraction win destr modality ev =
+ do
+ --modality <- getModal win
+ maybeModalDialog destr modality win ev
+
+
+
+
+
+
+
+
+
+
+
diff --git a/HTk/Toolkit/Name.hs b/HTk/Toolkit/Name.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/Name.hs
@@ -0,0 +1,32 @@
+-- | This module exports a common interface for named objects.
+module HTk.Toolkit.Name (
+
+ Name(..),
+ createName,
+ getFullName,
+ getShortName
+
+) where
+
+-- | The @Name@ datatype.
+data Name = Name { short :: Int -> String,
+ full :: String }
+
+shortdef :: String -> Int -> String
+shortdef str i =
+ if length str > i then take (i - 2) str ++ ".." else str
+
+-- | Creates a new name.
+createName :: String
+ -- ^ the full name.
+ -> Name
+ -- ^ A name.
+createName str = Name { short = shortdef str, full = str }
+
+-- | Gets the full name from a @Name@ object.
+getFullName :: Name -> String
+getFullName nm = full nm
+
+-- | Gets a short name of the given length from a @Name@ object.
+getShortName :: Name -> Int -> String
+getShortName nm i = short nm i
diff --git a/HTk/Toolkit/Notepad.hs b/HTk/Toolkit/Notepad.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/Notepad.hs
@@ -0,0 +1,1249 @@
+-- | A simple drag and drop field.
+module HTk.Toolkit.Notepad (
+
+ Notepad,
+ NotepadItem,
+
+ newNotepad,
+ createNotepadItem,
+ getFreeItemPosition,
+ getItemValue,
+
+ ScrollType(..),
+
+ module HTk.Toolkit.Name,
+ setName,
+
+ updNotepadScrollRegion,
+ selectAll,
+ deselectAll,
+ selectItem,
+ selectAnotherItem,
+ selectItemsWithin,
+ deselectItem,
+ getItems,
+ getSelectedItems,
+ isNotepadItemSelected,
+ deleteItem,
+ clearNotepad,
+ undoLastMotion,
+
+ bindNotepadEv, {- :: Notepad a -> IO (Event (NotepadEvent a), IO ()) -}
+ NotepadEvent(..),
+
+ NotepadExportItem(..),
+ NotepadState,
+ exportNotepadState,
+ importNotepadState,
+
+ module HTk.Toolkit.CItem
+
+) where
+
+import Data.Maybe
+import qualified Data.Map as Map
+
+import Util.Computation
+
+import Events.Events
+import Events.Channels
+import Events.Synchronized
+
+import Reactor.ReferenceVariables
+
+import HTk.Toplevel.HTk
+import HTk.Canvasitems.CanvasItemAux
+import HTk.Toolkit.ScrollBox
+import HTk.Toolkit.Name
+import qualified Events.Examples as Examples (watch)
+import HTk.Kernel.Core
+import HTk.Toolkit.CItem
+
+getCoords :: EventInfo -> IO (Distance, Distance)
+getCoords eventInfo = return (x eventInfo, y eventInfo)
+
+char_px = 8
+
+
+-------------------
+-- Notepad items --
+-------------------
+
+-- type
+
+-- | The @NotepadItem@ datatype.
+data NotepadItem a =
+ NotepadItem { it_img :: ImageItem, -- image
+ it_img_size :: Size, -- size of image
+ it_txt :: TextItem, -- displayed name
+ it_val :: Ref a, -- value
+ it_long_name_bg :: Ref (Maybe Rectangle), -- long names bg
+ it_bg :: Ref (Maybe (Rectangle, Rectangle)) }
+ -- bg if selected
+
+-- handler for enter events
+enteredItem :: CItem c => Notepad c -> NotepadItem c -> IO ()
+enteredItem notepad item =
+ synchronize item
+ (do
+ v <- getRef (it_val item)
+ nm <- getName v
+ let fullnm = full nm
+ it_txt item # text fullnm
+ mlast_bg <- getRef (it_long_name_bg item)
+ case mlast_bg of
+ Nothing -> do
+ Just (x1, y1, x2, y2) <-
+ bbox (canvas notepad) (it_txt item)
+ (_, (sizex, _)) <- getScrollRegion (canvas notepad)
+ let dx = if x1 < 0 then -x1 + 6
+ else if x2 > sizex then (sizex - x2)
+ else 0
+ moveItem (it_txt item) dx 0
+ b <- isNotepadItemSelected notepad item
+ rect <- createRectangle (canvas notepad)
+ (coord [(x1 - 5 + dx, y1 - 1),
+ (x2 + 5 + dx, y2 + 1)] :
+ (if b then [filling "blue",
+ outline "blue"]
+ else [filling "white",
+ outline "black"]))
+ putItemOnTop rect
+ putItemOnTop (it_txt item)
+ setRef (it_long_name_bg item) (Just rect)
+ _ -> done
+ done)
+
+text_gap :: Int
+text_gap = 11
+
+-- handler for leave events
+leftItem :: CItem c => Notepad c -> NotepadItem c -> IO ()
+leftItem notepad item =
+ synchronize item
+ (do
+ (x, y) <- getPosition item
+ let (Distance iwidth, Distance iheight) = img_size notepad
+ it_txt item # position (x, y + Distance (div iheight 2 + text_gap))
+ let (Distance dx, _) = img_size notepad
+ len = div (dx + 80) char_px
+ v <- getRef (it_val item)
+ nm <- getName v
+ let shortnm = short nm len
+ it_txt item # text shortnm
+ mlast_bg <- getRef (it_long_name_bg item)
+ case mlast_bg of
+ Just last_bg -> destroy last_bg >>
+ setRef (it_long_name_bg item) Nothing
+ _ -> done
+ done)
+
+
+-- constructor
+
+-- | Creates a new notepad item and returns a handler.
+createNotepadItem :: CItem c => c
+ -- ^ the notepad item\'s value.
+ -> Notepad c
+ -- ^ the concerned notepad.
+ -> Bool
+ -- ^ @True@ if the notepad\'s
+ -- scrollregion should be updated.
+ ->
+ [Config (NotepadItem c)]
+ -- ^ the list of configuration options for this notepad
+ -- item.
+ ->
+ IO (NotepadItem c)
+ -- ^ A notepad item.
+createNotepadItem val notepad updscrollregion cnf =
+ do
+ pho <- getIcon val
+ img <- createImageItem (canvas notepad) [coord [(-200, -200)],
+ photo pho]
+ let (Distance dx, _) = img_size notepad
+ len = div (dx + 80) char_px
+ nm <- getName val
+ txt <- createTextItem (canvas notepad) [coord [(-200, -200)],
+ font (Helvetica, 10 :: Int),
+ text (short nm len)]
+ itemval <- newRef val
+ itemsel <- newRef Nothing
+ lnbg <- newRef Nothing
+ let item = NotepadItem { it_img = img,
+ it_img_size = (img_size notepad),
+ it_txt = txt,
+ it_val = itemval,
+ it_long_name_bg = lnbg,
+ it_bg = itemsel }
+ foldl (>>=) (return item) cnf
+
+
+ (entered, _) <- bindSimple item Enter
+ (left, _) <- bindSimple item Leave
+ _ <- spawnEvent (forever ((entered >>>
+ (do st <- getIntState notepad
+ (if st /= Mov then
+ do
+ last <- getRef (entered_item notepad)
+ if not (isJust last)
+ then do setRef (entered_item notepad)
+ (Just item)
+ enteredItem notepad item
+ else if fromJust last /= item
+ then do leftItem notepad
+ (fromJust last)
+ setRef
+ (entered_item notepad)
+ (Just item)
+ enteredItem notepad item
+ else done
+ else done)) ) +>
+ (left >>>
+ (do st <- getIntState notepad
+ (if st /= Mov then
+ do
+ last <- getRef (entered_item notepad)
+ setRef (entered_item notepad) Nothing
+ if isJust last
+ then leftItem notepad (fromJust last)
+ else done
+ else done)))))
+
+ addItemToState notepad item
+ if updscrollregion then updNotepadScrollRegion notepad else done
+ return item
+
+-- | Returns a free item position on the notepad.
+getFreeItemPosition :: CItem c => Notepad c
+ -- ^ the concerned notepad.
+ -> IO Position
+ -- ^ the free position on the notepad.
+getFreeItemPosition notepad =
+ let num_cols = 4
+ (Distance iwidth, Distance iheight) = img_size notepad
+ dy_n = Distance (div iheight 2)
+ dy_s = Distance (div iheight 2 + 18)
+ dx = Distance (max (div iwidth 2) 40)
+
+ overlaps (x, y) (item : items) =
+ do
+ (ix, iy) <- getPosition item
+ (if (( (x - dx >= ix - dx && x - dx <= ix + dx) ||
+ (x + dx > ix - dx && x + dx < ix + dx) ) &&
+ ( (y - dy_n >= iy - dy_n && y - dy_n <= iy + dy_s) ||
+ (y + dy_s > iy - dy_n && y + dy_s < iy + dy_s) )) then
+ return True
+ else overlaps (x, y) items)
+ overlaps _ _ = return False
+ in do
+ items <- getRef (items notepad)
+ let getPos pos@(x, y) =
+ do
+ b <- overlaps pos items
+ (if b then
+ getPos (if x + 2 * dx + 10 > 10 + dx + (num_cols * 2 * dx)
+ then (10 + dx, y + dy_s + dy_n + 10)
+ else (x + 2 * dx + 10, y))
+ else return pos)
+ getPos (10 + dx, 10 + dy_n)
+
+-- | Gets the value from a notepad item.
+getItemValue :: NotepadItem a -> IO a
+getItemValue item = getRef (it_val item)
+
+
+-- instances --
+
+-- | Internal.
+instance Eq (NotepadItem a) where
+ item1 == item2 = it_img item1 == it_img item2
+
+-- | Internal.
+instance GUIObject (NotepadItem a) where
+ toGUIObject item = toGUIObject (it_img item)
+ cname _ = "NotepadItem"
+
+-- | You can synchronize on a notepad item.
+instance Synchronized (NotepadItem a) where
+ -- Synchronizes on a notepad item.
+ synchronize item = synchronize (toGUIObject (it_img item))
+
+-- | A notepad item has a position on the associated notepad.
+instance HasPosition (NotepadItem a) where
+ -- Sets the notepad item\'s position.
+ position p@(x, y) item =
+ itemPositionD2 p (it_img item) >>
+ let (Distance iwidth, Distance iheight) = it_img_size item
+ in itemPositionD2 (x, y + Distance (div iheight 2 + text_gap))
+ (it_txt item) >>
+ return item
+ -- Gets the notepad item\'s position.
+ getPosition item = getItemPositionD2 (it_img item)
+
+-- | A notepad item can be destroyed.
+instance Destroyable (NotepadItem a) where
+ -- Destroys a notepad item.
+ destroy item =
+ do
+ destroy (it_img item)
+ destroy (it_txt item)
+ mrects <- getRef (it_bg item)
+ case mrects of
+ Just (rect1, rect2) -> destroy rect1 >> destroy rect2
+ _ -> done
+
+-- | (Re-)sets the name of a notepad item.
+setName :: CItem c => NotepadItem c -> Name -> IO ()
+setName item nm =
+ do
+ let (Distance dx, _) = it_img_size item
+ len = div (dx + 80) char_px
+ it_txt item # text (short nm len)
+ done
+
+
+--------------------------------------------------------------------------
+-- notepad events
+--------------------------------------------------------------------------
+
+-- | Binds a listener for notepad events to the notepad and returns
+-- a corresponding event and an unbind action.
+bindNotepadEv :: Notepad a
+ -- ^ the concerned notepad.
+ -> IO (Event (NotepadEvent a), IO ())
+ -- ^ A pair of (event, unbind action).
+bindNotepadEv np =
+ do
+ ch <- newChannel
+ setRef (event_queue np) (Just ch)
+ return (receive ch, setRef (event_queue np) Nothing)
+
+-- | The @NotepadEvent@ datatype.
+data NotepadEvent a =
+ Dropped (NotepadItem a, [NotepadItem a]) -- ^ Drop event.
+ | Selected (NotepadItem a) -- ^ Selection event.
+ | Deselected (NotepadItem a) -- ^ Deselection event.
+ | Doubleclick (NotepadItem a) -- ^ Doubleclick event.
+ | Rightclick [NotepadItem a] -- ^ Rightclick event.
+ | ReleaseSelection -- ^ Buttonrelease after a selection.
+ | ReleaseMovement EventInfo -- ^ Buttonrelease after a movement.
+
+sendEv :: Notepad a -> NotepadEvent a -> IO ()
+sendEv np ev =
+ do
+ mch <- getRef (event_queue np)
+ case mch of
+ Just ch -> syncNoWait (send ch ev)
+ _ -> done
+
+
+--------------------------------------------------------------------------
+-- Notepad type
+--------------------------------------------------------------------------
+
+-- | The @Notepad@ datatype.
+data Notepad a =
+ Notepad { -- main canvas widget
+ canvas :: Canvas,
+
+ -- scrollbox if scrolled
+ scrollbox :: Maybe (ScrollBox Canvas),
+
+ -- size of item images
+ img_size :: Size,
+
+ -- contained items
+ items :: Ref ([NotepadItem a]),
+
+ -- selected items
+ selected_items :: Ref ([NotepadItem a]),
+
+ -- entered item (mouse over item)
+ entered_item :: Ref (Maybe (NotepadItem a)),
+
+ -- undo last motion action (needed for drag and drop with
+ -- other widgets)
+ undo_last_motion :: Ref UndoMotion,
+
+ -- entered item when other items dragged /
+ -- rectangles (highlight)
+ drop_item :: (Ref (Maybe (NotepadItem a, Rectangle,
+ Rectangle))),
+
+ -- event queue
+ event_queue :: Ref (Maybe (Channel (NotepadEvent a))),
+
+ -- clean up when destroyed
+ clean_up :: [IO ()],
+
+ -- notepad state
+ npstate :: Ref IntState }
+
+data IntState = Norm | Mov deriving Eq
+
+setIntState :: Notepad a -> IntState -> IO ()
+setIntState np st = setRef (npstate np) st
+
+getIntState :: Notepad a -> IO IntState
+getIntState np = getRef (npstate np)
+
+-- | The @ScrollType@ datatype.
+data ScrollType = Scrolled | NotScrolled deriving Eq
+
+data UndoMotion = ToPerform (IO ()) | Performed
+
+
+-- state --
+
+addItemToState :: Notepad a -> NotepadItem a -> IO ()
+addItemToState notepad item =
+ do
+ notepaditems <- getRef (items notepad)
+ setRef (items notepad) (item : notepaditems)
+
+highlight :: Canvas -> NotepadItem a -> IO ()
+highlight cnv item =
+ do
+ let (Distance iwidth, Distance iheight) = it_img_size item
+ it_txt item # filling "white"
+ s <- getRef (it_bg item)
+ case s of
+ Nothing -> do
+ (x, y) <- getPosition item
+ rect1 <- createRectangle cnv
+ [filling "blue", outline "blue"]
+ putItemAtBottom rect1
+ rect1 # coord [(x - Distance (div iwidth 2 + 1),
+ y - Distance (div iheight 2 + 1)),
+ (x + Distance (div iwidth 2),
+ y + Distance (div iheight 2))]
+ rect2 <- createRectangle cnv
+ [filling "blue", outline "blue"]
+ putItemAtBottom rect2
+ rect2 #
+ coord [(x - Distance
+ (max (div iwidth 2 + 40) 40),
+ y + Distance (div iheight 2 + 4)),
+ (x + Distance
+ (max (div iwidth 2 + 40) 40),
+ y + Distance
+ (div iheight 2 + 18))]
+ setRef (it_bg item) (Just (rect1, rect2))
+ Just _ -> done
+
+deHighlight :: NotepadItem a -> IO ()
+deHighlight item =
+ do
+ it_txt item # filling "black"
+ s <- getRef (it_bg item)
+ case s of
+ Just (rect1, rect2) ->
+ destroy rect1 >> destroy rect2 >> setRef (it_bg item) Nothing
+ _ -> done
+
+-- | Selects a specific notepad item.
+selectItem :: Notepad a
+ -- ^ the concerned notepad.
+ -> NotepadItem a
+ -- ^ the concerned notepad item.
+ -> IO ()
+ -- ^ None.
+selectItem np item =
+ do
+ deselectAll np
+ highlight (canvas np) item
+ selecteditems <- getRef (selected_items np)
+ setRef (selected_items np) (item : selecteditems)
+ sendEv np (Selected item)
+
+-- | Adds an item to the notepad\'s selection.
+selectAnotherItem :: Notepad a
+ -- ^ the concerned notepad.
+ -> NotepadItem a
+ -- ^ the concerned notepad item.
+ -> IO ()
+ -- ^ None.
+selectAnotherItem np item =
+ do
+ highlight (canvas np) item
+ selecteditems <- getRef (selected_items np)
+ setRef (selected_items np) (item : selecteditems)
+ sendEv np (Selected item)
+
+-- | Deselects a notepad item.
+deselectItem :: Notepad a
+ -- ^ the concerned notepad.
+ -> NotepadItem a
+ -- ^ the concerned notepad item.
+ -> IO ()
+ -- ^ None.
+deselectItem np item =
+ do
+ deHighlight item
+ selecteditems <- getRef (selected_items np)
+ setRef (selected_items np) (filter ((/=) item) selecteditems)
+ sendEv np (Deselected item)
+
+-- | Selects all items inside the notepad.
+selectAll :: Notepad a
+ -- ^ the concerned notepad.
+ -> IO ()
+ -- ^ None.
+selectAll np =
+ do
+ notepaditems <- getRef (items np)
+ mapM (highlight (canvas np)) notepaditems
+ mapM (\item -> do
+ b <- isNotepadItemSelected np item
+ if b then done else sendEv np (Selected item))
+ notepaditems
+ setRef (selected_items np) notepaditems
+
+-- | Deselects all items inside the notepad.
+deselectAll :: Notepad a
+ -- ^ the concerned notepad.
+ -> IO ()
+ -- ^ None.
+deselectAll np =
+ do
+ notepaditems <- getRef (items np)
+ selecteditems <- getRef (selected_items np)
+ mapM deHighlight selecteditems
+ mapM (\item -> do
+ b <- isNotepadItemSelected np item
+ if b then sendEv np (Deselected item) else done)
+ notepaditems
+ setRef (selected_items np) []
+
+-- | Deletes an item from a notepad.
+deleteItem :: CItem c => Notepad c
+ -- ^ the concerned notepad.
+ -> NotepadItem c
+ -- ^ the concerned notepad item.
+ -> IO ()
+ -- ^ None.
+deleteItem np item =
+ synchronize np
+ (do
+ notepaditems <- getRef (items np)
+ selecteditems <- getRef (selected_items np)
+ entereditem <- getRef (entered_item np)
+ (if isJust entereditem then setRef (entered_item np) Nothing >>
+ leftItem np (fromJust entereditem)
+ else done)
+ setRef (items np) (filter ((/=) item) notepaditems)
+ setRef (selected_items np) (filter ((/=) item) selecteditems)
+ destroy item)
+
+-- | Deletes all items from a notepad.
+clearNotepad :: Notepad a
+ -- ^ the concerned notepad.
+ -> IO ()
+ -- ^ None.
+clearNotepad np =
+ do
+ notepaditems <- getRef (items np)
+ mapM destroy notepaditems
+ setRef (items np) []
+ setRef (selected_items np) []
+
+-- | Internal (for use with GenGUI).
+undoLastMotion :: Notepad a -> IO ()
+undoLastMotion np =
+ synchronize np (do
+ act <- getRef (undo_last_motion np)
+ case act of
+ ToPerform act' -> setRef (undo_last_motion np)
+ Performed >>
+ act'
+ _ -> done)
+
+-- | @True@ if the given notepad item is selected.
+isNotepadItemSelected :: Notepad a
+ -- ^ the concerned notepad.
+ -> NotepadItem a
+ -- ^ the concerned notepad item.
+ -> IO Bool
+ -- ^ @True@ if the given notepad item is
+ -- selected, otherwise @False@.
+isNotepadItemSelected np item =
+ do
+ selecteditems <- getRef (selected_items np)
+ return (any ((==) item) selecteditems)
+
+-- | Selects all items within the specified region.
+selectItemsWithin :: Position
+ -- ^ the upper left coordinate of the region.
+ -> Position
+ -- ^ the lower right coordinate of the region.
+ -> Notepad a
+ -- ^ the concerned notepad.
+ -> IO ()
+ -- ^ None.
+selectItemsWithin p1@(x0, y0) p2@(x1, y1) np =
+ do
+ notepaditems <- getRef (items np)
+ let within :: Position -> Bool
+ within (x, y) =
+ ((x0 <= x && x <= x1) || (x1 <= x && x <= x0)) &&
+ ((y0 <= y && y <= y1) || (y1 <= y && y <= y0))
+ mapM (\ item -> do
+ pos <- getPosition item
+ b <- isNotepadItemSelected np item
+ (if within pos then
+ if b then done else selectAnotherItem np item
+ else
+ if b then deselectItem np item else done))
+ notepaditems
+ done
+
+-- | Gets the items from a notepad.
+getItems :: Notepad a
+ -- ^ the concerned notepad.
+ -> IO [NotepadItem a]
+ -- ^ A list of the contained notepad items.
+getItems np = getRef (items np)
+
+-- | Gets the selected items from a notepad.
+getSelectedItems :: Notepad a
+ -- ^ the concerned notepad.
+ -> IO [NotepadItem a]
+ -- ^ A list of the selected notepad items.
+getSelectedItems np = getRef (selected_items np)
+
+getView :: Notepad a -> IO (Distance, Distance, Distance, Distance)
+getView np =
+ do (dx_norm, dx_displ_norm) <- view Horizontal (canvas np)
+ (dy_norm, dy_displ_norm) <- view Vertical (canvas np)
+ (_, (Distance sizex, Distance sizey)) <- getScrollRegion (canvas np)
+ let p1_x = Distance (round (dx_norm * fromInteger (toInteger sizex)))
+ p1_y = Distance (round (dy_norm * fromInteger (toInteger sizey)))
+ p2_x = p1_x + Distance (round (dx_displ_norm *
+ fromInteger (toInteger sizex)))
+ p2_y = p1_y + Distance (round (dy_displ_norm *
+ fromInteger (toInteger sizey)))
+ return (p1_x, p1_y, p2_x, p2_y)
+
+
+--------------------------------------------------------------------------
+-- notepad construction
+--------------------------------------------------------------------------
+
+-- | Constructs a new notepad and returns a handler.
+newNotepad :: (CItem c, Container par) =>
+ par
+ -- ^ the parent widget (which has to be a container
+ -- widget).
+ -> ScrollType
+ -- ^ the scrolltype for this notepad.
+ -> Size
+ -- ^ the size of the notepad items images for this
+ -- notepad.
+ -> Maybe (NotepadState c)
+ -- ^ an optional previous notepad state to recover.
+ ->
+ [Config (Notepad c)]
+ -- ^ the list of configuration options for this notepad.
+ -> IO (Notepad c)
+ -- ^ A notepad.
+newNotepad par scrolltype imgsize mstate cnf =
+ do
+ let scrolled = (scrolltype == Scrolled)
+ notepaditemsref <- newRef []
+ selecteditemsref <- newRef []
+ entereditemref <- newRef Nothing
+ dropref <- newRef Nothing
+ ulm <- newRef Performed
+ evq <- newRef Nothing
+ nps <- newRef Norm
+ (cnv, notepad) <- if scrolled then
+ do
+ (scrollbox, cnv) <-
+ newScrollBox par (\p -> newCanvas p []) []
+ return (cnv,
+ Notepad { canvas = cnv,
+ scrollbox = Just scrollbox,
+ img_size = imgsize,
+ items = notepaditemsref,
+ selected_items =
+ selecteditemsref,
+ entered_item = entereditemref,
+ drop_item = dropref,
+ event_queue = evq,
+ undo_last_motion = ulm,
+ clean_up = [],
+ npstate = nps })
+ else
+ do
+ cnv <- newCanvas par []
+ return (cnv,
+ Notepad { canvas = cnv,
+ scrollbox = Nothing,
+ img_size = imgsize,
+ items = notepaditemsref,
+ selected_items =
+ selecteditemsref,
+ entered_item = entereditemref,
+ drop_item = dropref,
+ event_queue = evq,
+ undo_last_motion = ulm,
+ clean_up = [],
+ npstate = nps })
+
+ (click, _) <- bind cnv [WishEvent [] (ButtonPress (Just 1))]
+ (rightclick, _) <- bind cnv
+ [WishEvent [] (ButtonPress (Just 2))]
+ (motion', _) <- bind cnv [WishEvent [] Motion]
+ (motion, _) <- Examples.watch motion'
+ (clickmotion', _) <- bind cnv [WishEvent [Button1] Motion]
+ (clickmotion, _) <- Examples.watch clickmotion'
+ (doubleclick, _) <- bind cnv [WishEvent [Double]
+ (ButtonPress (Just 1))]
+ (shiftclick, _) <- bind cnv [WishEvent [Shift]
+ (ButtonPress (Just 1))]
+ (release, _) <- bind cnv [WishEvent [] (ButtonRelease (Just 1))]
+ (leave, _) <- bindSimple cnv Leave
+
+ stopListening <- newChannel
+
+ let getD :: IO (Distance, Distance)
+ getD = do
+ (dx_norm, dx_displ_norm) <- view Horizontal cnv
+ (dy_norm, _) <- view Vertical cnv
+ (_, (Distance sizex, Distance sizey)) <-
+ getScrollRegion cnv
+ return (Distance (round (dx_norm *
+ fromInteger (toInteger sizex))),
+ Distance (round (dy_norm *
+ fromInteger (toInteger sizey))))
+
+ addToTag :: CanvasTag -> NotepadItem a -> IO ()
+ addToTag tag item =
+ do
+ it_img item # tags [tag]
+ it_txt item # tags [tag]
+ rects <- getRef (it_bg item)
+ case rects of
+ Nothing -> done
+ Just(rect1, rect2) -> do
+ rect1 # tags [tag]
+ rect2 # tags [tag]
+ done
+
+ createTagFromSelection :: Notepad a -> IO CanvasTag
+ createTagFromSelection notepad =
+ do
+ notepaditems <- getRef (items notepad)
+ selecteditems <- getRef (selected_items notepad)
+ tag <- createCanvasTag (canvas notepad) []
+ mapM (addToTag tag) selecteditems
+ return tag
+
+ selectByRectangle :: Distance -> Distance -> Position ->
+ Rectangle -> Event ()
+ selectByRectangle dx dy pos rect =
+ let selectByRectangle' :: Position -> Rectangle -> Event ()
+ selectByRectangle' pos@(x, y) rect =
+ (do
+ (x1, y1) <- clickmotion >>>= getCoords
+ always (rect # coord [(x + dx, y + dy),
+ (x1 + dx, y1 + dy)])
+ always (selectItemsWithin (x + dx, y + dy)
+ (x1 + dx, y1 + dy) notepad)
+ selectByRectangle' pos rect) +>
+ (do
+ ev_inf <- release
+ always (do
+ (dx, dy) <- getD
+ (x1,y1) <- getCoords ev_inf
+ sendEv notepad ReleaseSelection
+ selectItemsWithin (x + dx, y + dy)
+ (x1 + dx, y1 + dy) notepad
+ destroy rect))
+ in selectByRectangle' pos rect
+
+
+ checkPositions :: [NotepadItem a] -> IO (Distance, Distance)
+ checkPositions (item : items) =
+ do
+ let (Distance iwidth, Distance iheight) = it_img_size item
+ (Distance x, Distance y) <- getPosition item
+ (Distance dx, Distance dy) <- checkPositions items
+
+ (_, (Distance sizex, Distance sizey)) <-
+ getScrollRegion (canvas notepad)
+
+ let min_x = x - (max (div iwidth 2 + 30) 40)
+ min_y = y - (div iheight 2 + 1)
+
+ dx' = max dx (-min_x)
+ {-if dx < 0 then min min_x dx
+ else if dx == 0 then
+ if min_x < 0 then min_x
+ else if max_x > sizex then max_x - sizex
+ else 0
+ else if dx > 0 then
+ max dx (max_x - sizex)
+ else 0-}
+ dy' = max dy (-min_y)
+ {-if dy < 0 then min min_y dy
+ else if dy == 0 then
+ if min_y < 0 then min_y
+ else if max_y > sizey then max_y - sizey
+ else 0
+ else if dy > 0 then
+ max dy (max_y - sizey)
+ else 0-}
+
+ return (Distance dx', Distance dy')
+ checkPositions [] = return (Distance 0, Distance 0)
+
+{-
+ checkPositions :: [NotepadItem a] -> IO (Distance, Distance)
+ checkPositions (item : items) =
+ do
+ let (Distance iwidth, Distance iheight) = it_img_size item
+ (Distance x, Distance y) <- getPosition item
+ (Distance dx, Distance dy) <- checkPositions items
+ (_, (Distance sizex, Distance sizey)) <-
+ getScrollRegion (canvas notepad)
+ let min_x = x - (max (div iwidth 2 + 30) 40)
+ max_x = x + (max (div iwidth 2 + 30) 40)
+ min_y = y - (div iheight 2 + 1)
+ max_y = y + (div iheight 2 + 18)
+
+ dx' = if dx < 0 then min min_x dx
+ else if dx == 0 then
+ if min_x < 0 then min_x
+ else if max_x > sizex then max_x - sizex
+ else 0
+ else if dx > 0 then
+ max dx (max_x - sizex)
+ else 0
+ dy' = if dy < 0 then min min_y dy
+ else if dy == 0 then
+ if min_y < 0 then min_y
+ else if max_y > sizey then max_y - sizey
+ else 0
+ else if dy > 0 then
+ max dy (max_y - sizey)
+ else 0
+
+ return (Distance dx', Distance dy')
+ checkPositions [] = return (Distance 0, Distance 0)
+-}
+
+ grid_x :: Int
+ grid_x = 10
+ grid_y :: Int
+ grid_y = 10
+
+ checkDropZones :: CItem a =>
+ Map.Map (Int, Int) [NotepadItem a] ->
+ Notepad a -> Distance -> Distance -> IO ()
+ checkDropZones it_map notepad x@(Distance ix) y@(Distance iy) =
+ let doSet item =
+ do
+ (x, y) <- getPosition item
+ let (Distance iwidth, Distance iheight) =
+ it_img_size item
+ rect1 <- createRectangle (canvas notepad)
+ [coord [(x - Distance (div iwidth 2 + 1),
+ y - Distance (div iheight 2 + 1)),
+ (x + Distance (div iwidth 2),
+ y + Distance (div iheight 2))],
+ filling "yellow", outline "yellow"]
+ putItemAtBottom rect1
+ rect2 <- createRectangle (canvas notepad)
+ [coord [(x - Distance
+ (max (div iwidth 2 + 40) 40),
+ y + Distance (div iheight 2)),
+ (x + Distance
+ (max (div iwidth 2 + 40) 40),
+ y + Distance (div iheight 2 + 18))],
+ filling "yellow", outline "yellow"]
+ putItemAtBottom rect2
+ setRef (drop_item notepad) (Just (item, rect1, rect2))
+
+ setDropRef item =
+ do
+ drop <- getRef (drop_item notepad)
+ case drop of
+ Nothing -> doSet item
+ Just (ditem, rect1, rect2) ->
+ if item == ditem then done
+ else destroy rect1 >> destroy rect2 >> doSet item
+
+ inDropZone item =
+ do
+ (x_it, y_it) <- getPosition (it_img item)
+ return (if x_it - 30 < x && x_it + 30 > x &&
+ y_it - 10 < y && y_it + 30 > y then True
+ else False)
+
+ checkDropZones' (item : items) =
+ do
+ b <- inDropZone item
+ (if b then setDropRef item else checkDropZones' items)
+ checkDropZones' [] =
+ do
+ maybeitem <- getRef (drop_item notepad)
+ case maybeitem of
+ Just (_, rect1, rect2) ->
+ destroy rect1 >> destroy rect2 >>
+ setRef (drop_item notepad) Nothing
+ Nothing -> done
+
+ in do (_, (Distance sizex, Distance sizey)) <-
+ getScrollRegion (canvas notepad)
+ let idx@(idx_x, idx_y) = (div ix (div sizex grid_x), div iy (div sizey grid_y))
+ items = (Map.findWithDefault [] idx it_map)
+ checkDropZones' items
+
+ buildMap :: CItem a => Notepad a -> IO (Map.Map (Int, Int) [NotepadItem a])
+ buildMap notepad =
+ do notepaditems <- getRef (items notepad)
+ selecteditems <- getRef (selected_items notepad)
+ let nonselecteditems =
+ filter (\item -> not(any ((==) item) selecteditems))
+ notepaditems
+ fmref <- newRef Map.empty
+ let add (idx_x, idx_y) notepaditem =
+ if idx_x >= 0 && idx_x < grid_x &&
+ idx_y >= 0 && idx_y < grid_y then
+ do fm <- getRef fmref
+ let mnotepaditems = Map.lookup (idx_x, idx_y) fm
+ let nufm = case mnotepaditems of
+ Just notepaditems ->
+ Map.insert (idx_x, idx_y)
+ (notepaditem : notepaditems) fm
+ _ -> Map.insert (idx_x, idx_y)
+ [notepaditem] fm
+ setRef fmref nufm
+ else done
+ getCenterIndex notepaditem =
+ do (_, (Distance sizex, Distance sizey)) <-
+ getScrollRegion (canvas notepad)
+ (Distance x, Distance y) <- getPosition notepaditem
+ return (div x (div sizex grid_x),
+ div y (div sizey grid_y))
+ addNotepadItem notepaditem =
+ do idx@(idx_x, idx_y) <- getCenterIndex notepaditem
+ add idx notepaditem
+ add (idx_x - 1, idx_y ) notepaditem
+ add (idx_x - 1, idx_y - 1) notepaditem
+ add (idx_x , idx_y - 1) notepaditem
+ add (idx_x + 1, idx_y - 1) notepaditem
+ add (idx_x + 1, idx_y ) notepaditem
+ add (idx_x + 1, idx_y + 1) notepaditem
+ add (idx_x , idx_y + 1) notepaditem
+ add (idx_x - 1, idx_y + 1) notepaditem
+ mapM addNotepadItem nonselecteditems
+ getRef fmref
+
+ moveSelectedItems it_map rpos@(rootx, rooty) (x0, y0) t =
+ (do
+ (x, y) <- clickmotion >>>= getCoords
+ always (do
+ (dx, dy) <- getD
+ checkDropZones it_map notepad (x + dx) (y + dy)
+ setRef (undo_last_motion notepad)
+ (ToPerform (moveItem t (rootx - x0)
+ (rooty - y0)))
+ moveItem t (x - x0) (y - y0))
+ moveSelectedItems it_map rpos (x, y) t)
+ +> (do
+ ev_inf <- release
+ always (do
+ sendEv notepad (ReleaseMovement ev_inf)
+ drop <- getRef dropref
+ case drop of
+ Just (item, rect1, rect2) ->
+ do
+ act <- getRef (undo_last_motion notepad)
+ case act of
+ Performed -> done
+ _ -> do
+ undoLastMotion notepad
+ selecteditems <-
+ getRef selecteditemsref
+ sendEv notepad
+ (Dropped (item,
+ selecteditems))
+ setRef dropref Nothing
+ destroy rect1
+ destroy rect2
+ _ -> do
+ selecteditems <-
+ getRef selecteditemsref
+ (dx, dy) <-
+ checkPositions selecteditems
+-- moveItem t (-dx) (-dy)))
+ moveItem t dx dy
+ updNotepadScrollRegion notepad))
+
+ checkEnteredItem (x, y) =
+ let overItem item =
+ do
+ (dx, dy) <- getD
+ (x_it, y_it) <- getPosition (it_img item)
+ return (if x_it - 30 < x + dx && x_it + 30 > x + dx &&
+ y_it - 10 < y + dy && y_it + 30 > y + dy then True
+ else False)
+ checkItems (item : items) =
+ do
+ b <- overItem item
+ (if b then setRef entereditemref (Just item)
+ else checkItems items)
+ checkItems _ = setRef entereditemref Nothing
+ in synchronize notepad
+ (do
+ last <- getRef entereditemref
+ items <- getRef notepaditemsref
+ checkItems items
+ new <- getRef entereditemref
+ (if isJust last then
+ if isJust new then
+ if fromJust last == fromJust new then done
+ else
+ leftItem notepad (fromJust last) >>
+ enteredItem notepad (fromJust new)
+ else
+ leftItem notepad (fromJust last)
+ else
+ if isJust new then
+ enteredItem notepad (fromJust new)
+ else
+ done))
+
+ listenNotepad :: Event ()
+ listenNotepad =
+ (leave >> always (do
+ mentereditem <- getRef entereditemref
+ (if isJust mentereditem then
+ leftItem notepad
+ (fromJust mentereditem) >>
+ setRef entereditemref Nothing
+ else done)) >>
+ listenNotepad)
+-- -----
+{-
+ +> (do
+ (x, y) <- motion >>>= getCoords
+ always (checkEnteredItem (x, y))
+ listenNotepad)
+-}
+-- -------
+
+ +> (do
+ (x, y) <- click >>>= getCoords
+ always
+ (do
+ entereditem <- getRef entereditemref
+ case entereditem of
+ Nothing -> do
+ deselectAll notepad
+ (dx, dy) <- getD
+ rect <- createRectangle cnv
+ [coord [(x + dx, y + dy),
+ (x + dx, y + dy)]]
+ sync
+ (selectByRectangle dx dy (x, y)
+ rect)
+ done
+ Just item ->
+ do
+ leftItem notepad item
+ b <- isNotepadItemSelected notepad item
+ if b then done else selectItem notepad item
+ t <- createTagFromSelection notepad
+ sync (do mp <- always (buildMap notepad)
+ always (setIntState notepad Mov)
+ moveSelectedItems mp (x, y) (x, y) t
+ always (setIntState notepad Norm))
+ done)
+ listenNotepad)
+ +> (do
+ (x, y) <- rightclick >>>= getCoords
+ always
+ (do
+ entereditem <- getRef entereditemref
+ case entereditem of
+ Nothing -> do
+ deselectAll notepad
+ sendEv notepad (Rightclick [])
+ Just entereditem ->
+ do
+ b <- isNotepadItemSelected notepad
+ entereditem
+ (if b then
+ do
+ selecteditems <- getRef selecteditemsref
+ sendEv notepad (Rightclick selecteditems)
+ else
+ do
+ selectItem notepad entereditem
+ sendEv notepad
+ (Rightclick [entereditem])))
+ listenNotepad)
+ +> (doubleclick >> do
+ always (do
+ entereditem <-
+ getRef entereditemref
+ case entereditem of
+ Just item ->
+ sendEv notepad
+ (Doubleclick item)
+ _ -> done)
+ listenNotepad)
+ +> (shiftclick >> do
+ always (do
+ entereditem <-
+ getRef entereditemref
+ case entereditem of
+ Just item ->
+ do
+ b <- isNotepadItemSelected
+ notepad item
+ (if b then
+ deselectItem notepad
+ item
+ else
+ selectAnotherItem
+ notepad item)
+ _ -> done)
+ listenNotepad)
+ +> (release >> listenNotepad) -- avoid cueing of release events
+ +> receive stopListening
+
+ _ <- spawnEvent listenNotepad
+ foldl (>>=) (return notepad) cnf
+ case mstate of
+ Just state -> importNotepadState notepad state
+ _ -> done
+ return notepad
+
+updNotepadScrollRegion :: Notepad a -> IO ()
+updNotepadScrollRegion np =
+ let getMax (item : items) mx my =
+ do (x, y) <- getPosition item
+ let nux = max x mx
+ nuy = max y my
+ getMax items nux nuy
+ getMax _ mx my = return (mx, my)
+ in do (x1, y1, x2, y2) <- getView np
+ items <- getItems np
+ (x, y) <- getMax items 0 0
+ np # size (x + 80, y + 40)
+ done
+
+-- instances --
+
+-- | Internal.
+instance GUIObject (Notepad a) where
+ toGUIObject np =
+ case (scrollbox np) of Nothing -> toGUIObject (canvas np)
+ Just box -> toGUIObject box
+ cname _ = "Notepad"
+
+-- | A notepad can be destroyed.
+instance Destroyable (Notepad a) where
+ -- Destroys a notepad.
+ destroy = destroy . toGUIObject -- TD : clean up !!!
+
+-- | A notepad has standard widget properties
+-- (concerning focus, cursor).
+instance Widget (Notepad a)
+
+-- | You can synchronize on a notepad object.
+instance Synchronized (Notepad a) where
+ -- Synchronizes on a notepad object.
+ synchronize w = synchronize (toGUIObject w)
+
+-- | A notepad has a configureable border.
+instance HasBorder (Notepad a)
+
+-- | A notepad has a configureable background colour.
+instance HasColour (Notepad a) where
+ legalColourID np = hasBackGroundColour (canvas np)
+ setColour notepad cid col =
+ setColour (canvas notepad) cid col >> return notepad
+ getColour np cid = getColour (canvas np) cid
+
+-- | A notepad has a configureable size.
+instance HasSize (Notepad a) where
+ -- Sets the notepad\'s width.
+ width s np =
+ do
+ (_, (_, sizey)) <- getScrollRegion (canvas np)
+ canvas np # scrollRegion ((0, 0), (s, sizey))
+ if isJust (scrollbox np) then done else canvas np # width s >> done
+ return np
+ -- Gets the notepad\'s width.
+ getWidth np = getWidth (canvas np)
+ -- Sets the notepad\'s height.
+ height s np =
+ do
+ (_, (sizex, _)) <- getScrollRegion (canvas np)
+ canvas np # scrollRegion ((0, 0), (sizex, s))
+ (if (isJust (scrollbox np)) then done
+ else canvas np # height s >> done)
+ return np
+ -- Gets the notepad\'s height.
+ getHeight np = getHeight (canvas np)
+
+
+-- -----------------------------------------------------------------------
+-- state import / export
+-- -----------------------------------------------------------------------
+
+-- | The @NotepadExportItem@ datatype.
+data CItem c => NotepadExportItem c =
+ NotepadExportItem { val :: c,
+ pos :: Position,
+ selected :: Bool }
+
+type NotepadState c = [NotepadExportItem c]
+
+-- | Exports a notepad\'s state.
+exportNotepadState :: CItem c => Notepad c
+ -- ^ the concerned notepad.
+ -> IO (NotepadState c)
+ -- ^ The notepad\'s state.
+exportNotepadState np =
+ synchronize np (do
+ items' <- getRef (items np)
+ exportNotepadState' np items')
+ where exportNotepadState' :: CItem c => Notepad c -> [NotepadItem c] ->
+ IO (NotepadState c)
+ exportNotepadState' np (item : items) =
+ do
+ val' <- getRef (it_val item)
+ pos <- getPosition (it_img item)
+ is_selected <- isNotepadItemSelected np item
+ rest <- exportNotepadState' np items
+ return (NotepadExportItem { val = val',
+ pos = pos,
+ selected = is_selected } : rest)
+ exportNotepadState' _ _ = return []
+
+-- | Imports a notepad\'s state.
+importNotepadState :: CItem c => Notepad c
+ -- ^ the concerned notepad.
+ -> NotepadState c
+ -> IO ()
+ -- ^ None.
+importNotepadState np st =
+ synchronize np (do
+ clearNotepad np
+ addItems np st
+ updNotepadScrollRegion np)
+ where addItems :: CItem c => Notepad c -> NotepadState c -> IO ()
+ addItems np (it : items) =
+ do
+ new_it <- createNotepadItem (val it) np False
+ [position (pos it)]
+ if selected it then selectAnotherItem np new_it else done
+ addItems np items
+ addItems _ _ = done
diff --git a/HTk/Toolkit/Prompt.hs b/HTk/Toolkit/Prompt.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/Prompt.hs
@@ -0,0 +1,141 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | A simple prompt (a labelled entry field).
+module HTk.Toolkit.Prompt (
+
+ Prompt,
+ newPrompt,
+
+ getPromptEntry
+
+) where
+
+import Util.Computation
+
+import Events.Synchronized
+
+import HTk.Kernel.Core
+import HTk.Toplevel.HTk
+
+-- -----------------------------------------------------------------------
+-- datatype
+-- -----------------------------------------------------------------------
+
+-- | The @Prompt@ datatype.
+data Prompt a = Prompt Box Label (Entry a)
+
+
+-- -----------------------------------------------------------------------
+-- Commands
+-- -----------------------------------------------------------------------
+
+-- i had problems creating a TkVariable of any kind here?!?
+
+-- | Construct a new prompt and returns a handler.
+newPrompt :: GUIValue a => Box
+ -- ^ the parent box.
+ -> [Config (Prompt a)]
+ -- ^ the list of configuration options for this prompt.
+ -> IO (Prompt a)
+ -- ^ A prompt.
+newPrompt par cnf = do {
+ b <- newHBox par [];
+ pack b [Expand On, Fill X];
+ lbl <- newLabel b [];
+ pack lbl [Expand Off, Fill X];
+ ent <- newEntry b [];
+ pack ent [Fill X, Expand On];
+ configure (Prompt b lbl ent) cnf
+}
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance Eq (Prompt a) where
+ w1 == w2 = (toGUIObject w1) == (toGUIObject w2)
+
+-- | Internal.
+instance GUIObject (Prompt a) where
+ toGUIObject (Prompt bx _ _) = toGUIObject bx
+ cname _ = "Prompt"
+
+-- | A prompt has standard widget properties
+-- (concerning focus, cursor).
+instance Widget (Prompt a) where
+ -- Sets the mouse cursor for this prompt.
+ cursor c pr @ (Prompt bx lbl ent) =
+ synchronize pr (do
+ cursor c bx
+ cursor c lbl
+ cursor c ent
+ return pr)
+
+-- | A prompt has a configureable border.
+instance HasBorder (Prompt a)
+
+{- not needed ?!?
+instance HasSize (Prompt a) where
+ height _ w = return w
+ getHeight _ = return 1
+-}
+
+-- | A prompt has a configureable foreground and background colour.
+instance HasColour (Prompt a) where
+ legalColourID _ _ = True
+ setColour pr @ (Prompt bx lbl en_) cid c =
+ synchronize pr (do
+ setColour bx cid c
+ setColour lbl cid c
+ return pr)
+
+-- | A propt has a configureable font.
+instance HasFont (Prompt a) where
+ -- Sets the font of the prompt.
+ font f pr @ (Prompt bx lbl ent) =
+ synchronize pr (do
+ font f lbl
+ return pr)
+ -- Gets the font of the prompt.
+ getFont (Prompt bx lbl ent) = getFont lbl
+
+-- | A prompt has a configureable text.
+instance (GUIValue a, GUIValue b) => HasText (Prompt a) b where
+ -- Sets the prompt\'s text.
+ text t pr @ (Prompt _ lbl _) = do {text t lbl; return pr}
+ -- Gets the prompt\'s text.
+ getText (Prompt _ lbl _) = getText lbl
+
+-- | A prompt is a stateful component, it can be enabled or disabled.
+instance HasEnable (Prompt a) where
+ -- Sets the prompt\'s state.
+ state s pr @ (Prompt bx lbl ent) = do {state s ent; return pr}
+ -- Gets the prompt\'s state.
+ getState (Prompt bx lbl ent) = getState ent
+
+-- | You can synchronize on a prompt object.
+instance Synchronized (Prompt a) where
+ -- Synchronizes on a prompt object.
+ synchronize w = synchronize (toGUIObject w)
+
+-- | A prompt widget has an (entered) value.
+instance GUIValue a => HasValue (Prompt a) a where
+ -- Sets the prompt\'s value.
+ value val p@(Prompt bx lbl ent) = value val p
+ -- Gets the prompt\'s value.
+ getValue (Prompt bx lbl ent) = getValue ent
+
+
+-- -----------------------------------------------------------------------
+-- Entry Components
+-- -----------------------------------------------------------------------
+
+-- | Gets the entry field of the prompt.
+getPromptEntry :: Prompt a
+ -- ^ the concerned prompt.
+ -> Entry a
+ -- ^ the prompt\'s entry.
+getPromptEntry pr@(Prompt _ _ ent) = ent
diff --git a/HTk/Toolkit/ScrollBox.hs b/HTk/Toolkit/ScrollBox.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/ScrollBox.hs
@@ -0,0 +1,161 @@
+-- | A simple scroll pane for a scrolled widget.
+module HTk.Toolkit.ScrollBox (
+
+ ScrollBox(..),
+ newScrollBox,
+
+ getScrolledWidget,
+ getScrollBars
+
+) where
+
+import Util.Computation
+
+import Events.Synchronized
+
+import HTk.Toplevel.HTk
+import HTk.Kernel.Core
+
+
+-- -----------------------------------------------------------------------
+-- type
+-- -----------------------------------------------------------------------
+
+-- | The @ScrollBox@ datatype.
+data ScrollBox a =
+ ScrollBox {
+ fScrollFrame :: Frame,
+ fPadFrames :: [Frame],
+ fScrollBars :: [ScrollBar],
+ fScrolledWidget :: a
+ }
+
+
+-- -----------------------------------------------------------------------
+-- constructor
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new scrollbox and returns a handler.
+newScrollBox :: (Widget wid, HasScroller wid, Container par) =>
+ par
+ -- ^ the parent widget, which has to be a container widget.
+ -> (Frame -> IO wid)
+ -- ^ a function that returns the scrollbox\'es content for
+ -- a given parent container.
+ ->
+ [Config (ScrollBox wid)]
+ -- ^ the list of configuration options for this scrollbox.
+ ->
+ IO (ScrollBox wid, wid)
+ -- ^ A scrollbox.
+newScrollBox par wfun cnf =
+ do
+ f <- newFrame par []
+ w <- wfun f
+ let sz = cm 0.3
+ sz' = if scrollY then sz else 0 -- width of y scrollbar
+ scrollY = (isWfOrientation w Vertical)
+ scrollX = (isWfOrientation w Horizontal)
+ fl <- newFrame f [width sz']
+ pack fl [Fill Y, Side AtRight]
+ (sf,sby) <-
+ if scrollY then
+ do
+ sb <- newScrollBar fl [width sz, orient Vertical]
+ pack sb [Expand On, Fill Y, Side AtTop]
+ configure w [scrollbar Vertical sb]
+ sf <- newFrame fl [width sz, height (cm 0.5)]
+ pack sf [Side AtBottom]
+ return ([sf],[sb])
+ else
+ return ([],[])
+ sbx <- if scrollX then
+ do
+ sb <- newScrollBar f [width sz, orient Horizontal]
+ pack sb [Side AtBottom, Fill X]
+ configure w [scrollbar Horizontal sb]
+ return [sb]
+ else
+ return []
+ let sbox = (ScrollBox f (fl:sf) (sbx ++ sby) w)
+ configure sbox cnf
+ pack w [Fill Both, Expand On]
+ return (sbox, w)
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance Eq (ScrollBox a) where
+ w1 == w2 = (toGUIObject w1) == (toGUIObject w2)
+
+-- | Internal.
+instance GUIObject (ScrollBox a) where
+ toGUIObject (ScrollBox w _ _ _) = toGUIObject w
+ cname _ = "ScrollBox"
+
+-- | A scrollbox can be destroyed.
+instance Destroyable (ScrollBox a) where
+ -- Destroys a scrollbox.
+ destroy = destroy . toGUIObject
+
+-- | A scrollbox has standard widget properties
+-- (concerning focus, cursor).
+instance (Widget a, HasScroller a) => Widget (ScrollBox a) where
+ cursor c sb =
+ do
+ foreach (fPadFrames sb) (cursor c)
+ cursor c (fScrollFrame sb)
+ foreach (fScrollBars sb) (cursor c)
+ cursor c (fScrolledWidget sb)
+ return sb
+
+-- | A scrollbox has a configureable foreground and background colour.
+instance (HasColour a,HasScroller a) => HasColour (ScrollBox a) where
+ legalColourID _ _ = True
+ setColour sb cid c =
+ do
+ foreach (fPadFrames sb) (\f -> setColour f cid c)
+ setColour (fScrollFrame sb) cid c
+ foreach (fScrollBars sb) (\s -> setColour s cid c)
+ return sb
+
+-- | A scrollbox has a configureable border.
+instance HasBorder (ScrollBox a)
+
+-- | A scrollbox has scrollbars.
+instance HasScroller a => HasScroller (ScrollBox a) where
+ isWfOrientation (ScrollBox _ _ _ sw) axis = isWfOrientation sw axis
+ -- Dummy.
+ scrollbar _ _ sb = return sb -- already done
+ -- Moves the given axis to the given fraction.
+ moveto axis (ScrollBox _ _ _ sw) fraction = moveto axis sw fraction
+ -- Scrolls the given axis by the given amount.
+ scroll axis (ScrollBox _ _ _ sw) step unit = scroll axis sw step unit
+
+-- | You can synchronize on a scrollbox.
+instance Synchronized (ScrollBox a) where
+ -- Synchronizes on a scrollbox.
+ synchronize = synchronize . toGUIObject
+
+-- | A scrollbox has a configureable size.
+instance HasSize (ScrollBox a) where
+ -- Sets the width of the scrollbox.
+ width w scb = fScrollFrame scb # width w >> return scb
+ -- Sets the height of the scrollbox.
+ height h scb = fScrollFrame scb # height h >> return scb
+
+
+-- -----------------------------------------------------------------------
+-- selectors
+-- -----------------------------------------------------------------------
+
+-- | Gets the scrolled widget from a scrollbox.
+getScrolledWidget :: (Widget a, HasScroller a) => ScrollBox a -> a
+getScrolledWidget = fScrolledWidget
+
+-- | Gets the scrollbars from a scrollbox.
+getScrollBars :: HasScroller a => ScrollBox a -> [ScrollBar]
+getScrollBars = fScrollBars
diff --git a/HTk/Toolkit/SelectBox.hs b/HTk/Toolkit/SelectBox.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/SelectBox.hs
@@ -0,0 +1,197 @@
+-- | A simple container for a group of button widgets.
+module HTk.Toolkit.SelectBox (
+
+ SelectBox,
+ newSelectBox,
+
+ addButton,
+ addSpace,
+
+ getDefault,
+ selectDefault
+
+) where
+
+import HTk.Toplevel.HTk
+import HTk.Kernel.GUIObject
+import HTk.Widgets.Space
+import Reactor.ReferenceVariables
+
+-- -----------------------------------------------------------------------
+-- SelectBox type
+-- -----------------------------------------------------------------------
+
+-- | The @SelectBox@ datatype.
+data SelectBox = SelectBox Box (Maybe (Frame,Int)) (Ref [Button])
+
+type Elements = [Button]
+
+
+-- -----------------------------------------------------------------------
+-- creation
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new select box and returns a handler.
+newSelectBox :: Container par =>
+ par
+ -- ^ the parent widget, which has to be a container widget.
+ -> Maybe Int
+ -- ^ the optional index of a default button.
+ -> [Config SelectBox]
+ -- ^ the list of configuration options for this select box.
+ -> IO SelectBox
+ -- ^ A select box.
+newSelectBox par def@(Nothing) cnf =
+ do
+ b <- newHBox par []
+ pack b [Expand On, Fill X]
+ em <- newRef []
+ configure (SelectBox b Nothing em) cnf
+newSelectBox par def@(Just i) ol =
+ do
+ b <- newHBox par []
+ pack b [Expand On, Fill X]
+ em <- newRef []
+ f <- newFrame b [relief Sunken, borderwidth 1]
+ pack f []
+ configure (SelectBox b (Just (f,i)) em) ol
+
+
+-- -----------------------------------------------------------------------
+-- SelectBox instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance Eq SelectBox where
+ w1 == w2 = (toGUIObject w1) == (toGUIObject w2)
+
+-- | A select box can be destroyed.
+instance Destroyable SelectBox where
+ -- Destroys a select box.
+ destroy = destroy . toGUIObject
+
+-- | Internal.
+instance GUIObject SelectBox where
+ toGUIObject (SelectBox b _ e) = toGUIObject b
+ cname _ = "SelectBox"
+
+-- | A select box has a configureable foreground and background colour.
+instance HasColour SelectBox where
+ legalColourID = hasForeGroundColour
+
+-- | A select box has standard widget properties
+-- (concerning focus, cursor).
+instance Widget SelectBox
+
+-- | A select box has a configureable size.
+instance HasSize SelectBox
+
+-- | A select box has a configureable border.
+instance HasBorder SelectBox
+
+-- | A select box is a stateful widget, it can be enabled or disabled.
+instance HasEnable SelectBox where
+ -- Sets the select box\'es state.
+ state st sb@(SelectBox b _ em) =
+ synchronize sb (do
+ ibs <- getRef em
+ foreach ibs (\ib -> configure ib [state st])
+ return sb)
+ -- Gets the select box\'es state.
+ getState sb = do
+ b <- isEnabled sb
+ if b then return Normal else return Disabled
+ -- @True@, if the select box is enabled, otherwise
+ -- @False@.
+ isEnabled sb@(SelectBox b _ em) =
+ synchronize sb (do
+ ibs <- getRef em
+ sl <- sequence (map getState ibs)
+ return (foldr (||) False (map (/= Disabled) sl)))
+
+-- | You can synchronize on a select box.
+instance Synchronized SelectBox where
+ -- Synchronizes on a select box.
+ synchronize = synchronize . toGUIObject
+
+
+-- -----------------------------------------------------------------------
+-- selection
+-- -----------------------------------------------------------------------
+
+-- | Selects the default button of a select box.
+selectDefault :: SelectBox
+ -- ^ the concerned select box.
+ -> IO ()
+ -- ^ None.
+selectDefault sb =
+ do
+ mbt <- getDefault sb
+ incase mbt (\bt -> flash bt >> invoke bt)
+
+-- | Gets the default button from a select box (if there is one).
+getDefault :: SelectBox
+ -- ^ the concerned select box.
+ -> IO (Maybe Button)
+ -- ^ The default button of the select box
+ -- (if there is one).
+getDefault sb@(SelectBox b Nothing em) = return Nothing
+getDefault sb@(SelectBox b (Just (f,i)) em) =
+ do
+ bts <- getRef em
+ return (Just (bts !! i))
+
+
+-- -----------------------------------------------------------------------
+-- elements
+-- -----------------------------------------------------------------------
+
+-- | Adds a space widget at the end of the select box.
+addSpace :: SelectBox
+ -- ^ the concerned select box.
+ -> Distance
+ -- ^ the width of the space widget.
+ -> IO Space
+ -- ^ A space widget.
+addSpace sb@(SelectBox b _ em) dist =
+ do
+ s <- newSpace b dist [orient Horizontal]
+ pack s []
+ return s
+
+-- | Adds a button widget at the end of the select box.
+addButton :: SelectBox
+ -- ^ the concerned select box.
+ -> [Config Button]
+ -- ^ the list of configuration options for the constructed
+ -- button.
+ -> [PackOption]
+ -- ^ the list of pack options for the constructed button.
+ -> IO Button
+ -- ^ A button widget.
+addButton sb@(SelectBox b Nothing em) cnf pcnf =
+ synchronize sb (do
+ bt <- newButton b cnf
+ pack bt pcnf
+ changeRef em (\el -> el ++ [bt])
+ return bt)
+addButton sb@(SelectBox b (Just (f,i)) em) cnf pcnf =
+ synchronize sb (do
+ el <- getRef em
+ let is_default = (i == length el + 1)
+
+ bt <- if is_default then newButton f cnf
+ else newButton b cnf
+ (if is_default then
+ do
+ bt <- newButton f cnf
+ pack bt [Side AtLeft, PadX (cm 0.2),
+ PadY (cm 0.1)]
+ pack f (pcnf ++ [Side AtLeft, PadX (cm 0.2),
+ PadY (cm 0.1)])
+ else
+ do
+ bt <- newButton b cnf
+ pack bt (Side AtLeft : pcnf))
+ setRef em (el ++ [bt])
+ return bt)
diff --git a/HTk/Toolkit/Separator.hs b/HTk/Toolkit/Separator.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/Separator.hs
@@ -0,0 +1,92 @@
+-- | Separators for widgets. It is just
+-- a frame with a given relief and borderwidth etc.
+module HTk.Toolkit.Separator (
+ Separator,
+ newSeparator,
+ newHSeparator,
+ newVSeparator
+
+ ) where
+
+import Util.Computation
+
+import HTk.Kernel.Core
+import HTk.Toplevel.HTk
+
+-- --------------------------------------------------------------------------
+-- Separator
+-- --------------------------------------------------------------------------
+
+-- | The @Separator@ datatype.
+data Separator = Separator Frame deriving Eq
+
+
+-- | Constructs a new separator widget and returns it as a value.
+newSeparator :: (Container par) => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> [Config Separator]
+ -- ^ the list of configuration options for this separator.
+ -> IO Separator
+ -- ^ a separator widget.
+newSeparator par conf =
+ do
+ w <- newFrame par []
+ configure (Separator w) conf
+
+
+-- | Constructs a new horizontal separator widget and returns it as a value. (no packing needed)
+newHSeparator :: (Container par) => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> IO Separator
+ -- ^ a separator widget.
+newHSeparator par =
+ do
+ w <- newFrame par [relief Sunken, height 2, borderwidth 1]
+ pack w [Expand Off, Fill X]
+ configure (Separator w) []
+
+-- | Constructs a new vertical separator widget and returns it as a value. (no packing needed)
+newVSeparator :: (Container par) => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> IO Separator
+ -- ^ a separator widget.
+newVSeparator par =
+ do
+ w <- newFrame par [relief Sunken, width 2, borderwidth 1]
+ pack w [Expand Off, Fill Y]
+ configure (Separator w) []
+
+-- --------------------------------------------------------------------------
+-- Instances
+-- --------------------------------------------------------------------------
+-- | Internal.
+instance GUIObject Separator where
+ toGUIObject (Separator w) = toGUIObject w
+ cname w = "Separator"
+
+-- | A separator can be destroyed.
+instance Destroyable Separator where
+ -- Destroys a separator widget.
+ destroy = destroy . toGUIObject
+
+-- | A separator widget has a configureable border.
+instance HasBorder Separator
+
+-- | You can specify the size of a separator widget.
+instance HasSize Separator
+
+-- | A spearator widget has an orientation (Horizontal or Vertical)
+instance HasOrientation Separator where
+ orient Horizontal s = do {
+ configure s [height 2];
+ return s
+ }
+ orient Vertical s = do {
+ configure s [width 2];
+ return s
+ }
+
+
diff --git a/HTk/Toolkit/SimpleForm.hs b/HTk/Toolkit/SimpleForm.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/SimpleForm.hs
@@ -0,0 +1,976 @@
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverlappingInstances #-}
+
+-- |
+-- Description: Graphical Form Input
+--
+-- This module defines 'SimpleForm's, a simple interface
+-- to filling in forms using HTk. (Indeed, it is simple enough that it might
+-- be ported to some other GUI sometime.)
+module HTk.Toolkit.SimpleForm(
+ Form, -- This represents a series of input fields.
+ -- A (Form x) represents a form yielding a value of type x
+ -- Form is an instance of functor, so fmap works for it.
+ -- But mapForm is more general.
+
+ newFormEntry, -- :: (FormLabel label,FormValue value)
+ -- => label -> value -> Form value
+ -- This creates a new form with a single labelled entry.
+ -- The FormValue class includes text fields and radio buttons.
+
+ emptyForm, -- :: Form ()
+ -- The empty form (rather boring).
+
+ nullForm, -- :: FormLabel label => label -> Form ()
+ -- also pretty boring; just displays the label but doesn't provide
+ -- any interaction.
+
+ newFormMenu, -- :: (FormLabel label) => label -> HTkMenu value
+ -- -> Form (Maybe value)
+ -- This creates a new form with a single labelled entry, selected
+ -- by a menu. A value of Nothing indicates that the user did not
+ -- click this menu.
+ -- The String is used to label the menu button containing the menu.
+
+ newFormOptionMenu, -- :: (GUIValue a) => [a] -> Form a
+ -- This creates an "option menu" button. The
+ -- advantage this has over a normal menu is that the value is shown.
+ -- The first value in the list functions as a default value.
+
+ newFormOptionMenu2, -- :: (GUIValue a) => [(a,b)] -> Form b
+ -- Like newFormOptionMenu2 but returns the corresponding b value.
+
+
+ (//), -- :: Form value1 -> Form value2 -> Form (value1,value2)
+ -- This combines two forms. They will be displayed with one on top of
+ -- the other.
+
+ (\\), -- :: Form value1 -> Form value2 -> Form (value1,value2)
+ -- Like //, but combines two forms side-by-side.
+
+ column, -- :: [Form value] -> Form [value]
+ row, -- :: [Form value] -> Form [value]
+ -- Two other combinators obtained by iterating (//) and (\\)
+
+ doForm, -- :: String -> Form x -> IO (Maybe x)
+ -- This displays a form. The first string is the title;
+ -- the second the form. As well as the entries in the form,
+ -- "OK" and "Cancel" buttons are displayed.
+ doFormMust, -- :: String -> Form value -> IO value
+ -- Like doForm, but the user is not provided with a cancel button.
+
+ doFormList,
+ -- :: String -> [(Form x,String)] -> IO (Event (WithError x),IO ())
+ -- Display a sequence of forms, horizontally, one after another.
+ -- To the right of each form is a button, with text given by the
+ -- accompanying String.
+ -- Clicking this button causes an event to be generated, carrying
+ -- the accompanying form's value, or if invalid the error
+ -- message.
+ -- The first argument is the title of the window. The
+ -- IO () action returned closes the window.
+
+ mapForm, -- :: (x -> WithError y) -> Form x -> Form y
+ -- mapForm changes the type of a form. When we press OK with doForm,
+ -- the supplied function is called. If it returns a y, we return y
+ -- and close the window; if it returns an error message,
+ -- the error message is
+ -- displayed, and we continue.
+ mapFormIO, -- :: (x -> IO (WithError y)) -> Form x -> Form y
+ -- IO'based version of mapForm.
+
+ guardForm, -- :: (x -> Bool) -> String -> Form x -> Form x
+ -- guardForm uses mapForm to check the value of x with the supplied
+ -- error message.
+ guardFormIO, -- :: (x -> IO Bool) -> String -> Form x -> Form x
+ -- IO'based version of guardForm.
+ guardNothing, -- :: String -> Form (Maybe x) -> Form x
+ -- Checks that Nothing is not returned, with the attached error
+ -- message.
+
+ FormValue(..), -- This is a class of values which can be read in from a
+ -- simple form. Instances include Int, String and Bool and ().
+ -- (() just does nothing and is useful if you want a label without
+ -- anything on it.)
+ -- A user friendly way of constructing new instances is to instance
+ -- one of the following two classes.
+
+ mapMakeFormEntry,
+ -- :: FormValue value2
+ -- => (value1 -> value2) -> (value2 -> value1)
+ -- -> (Frame -> value1 -> IO (EnteredForm value1))
+ -- Function for creating one instance of FormValue from another.
+
+-- FormRadioButton(..), -- This class is used for types which are suitable
+ -- for being read with radio buttons, for example a small enumeration.
+ FormTextField(..), -- This class is used for types which can be
+ -- read in using a text field.
+ FormTextFieldIO(..), -- Slightly more general version allowing IO actions.
+
+ Password(..),
+ -- newtype alias which specifies that the given FormTextField(IO)
+ -- instance should not be displayed on the screen, but replaced by
+ -- '.' characters.
+ FormLabel(..), -- This class represents things which can be used for
+ -- labels in the form. Instances include String and Image.
+ EmptyLabel(EmptyLabel),
+ -- Another instance of FormLabel, which we use if we don't want a label.
+
+ WrappedFormLabel(..), -- this is an existentially wrapped type around
+ -- values of type FormLabel.
+
+ Radio(..), -- type for wrapping round something to use radio buttons.
+ HasConfigRadioButton(..), -- for setting fancy configurations for
+ -- radio buttons.
+
+ editableTextForm, -- :: [Config Editor] -> Form String
+ -- A form for typing (possibly several lines of) editable text.
+ editableTextForm0, -- :: [Config Editor] -> Form String
+ -- Like 'editableTextForm' but no scrollbars are displayed.
+
+ ) where
+
+import Data.Char
+
+import Data.IORef
+import Data.Typeable
+
+import Util.ExtendedPrelude
+import Util.BinaryAll(HasBinary(..),mapWrite,mapRead)
+import Util.Messages
+
+import Util.Computation
+
+import Events.Events
+import Events.Channels
+
+import HTk.Toplevel.HTk
+import HTk.Toolkit.HTkMenu
+
+-- -------------------------------------------------------------------------
+-- The EnteredForm type
+-- -------------------------------------------------------------------------
+
+-- | EnteredForm represents a form entry constructed in a given widget
+-- The actions should be performed in the following sequence:
+-- packAction
+-- 0 or more uses of getFormValue
+-- destroyAction
+data EnteredForm value = EnteredForm {
+ packAction :: IO (), -- packs the form entry into the widget.
+ getFormValue :: IO (WithError value),
+ -- extracts value or produces an error message
+ destroyAction :: IO () -- does any necessary clean-up.
+ }
+
+mapEnteredForm :: (a -> b) -> EnteredForm a -> EnteredForm b
+mapEnteredForm f
+ (EnteredForm{packAction = packAction,getFormValue = getFormValue,
+ destroyAction = destroyAction}) =
+ EnteredForm {packAction = packAction,destroyAction = destroyAction,
+ getFormValue = do
+ we1 <- getFormValue
+ return (mapWithError f we1)
+ }
+
+mapEnteredForm' :: (a -> WithError b) -> EnteredForm a -> EnteredForm b
+mapEnteredForm' f
+ (EnteredForm{packAction = packAction,getFormValue = getFormValue,
+ destroyAction = destroyAction}) =
+ EnteredForm {packAction = packAction,destroyAction = destroyAction,
+ getFormValue = do
+ we1 <- getFormValue
+ return (mapWithError' f we1)
+ }
+
+mapEnteredFormIO' :: (a -> IO (WithError b)) -> EnteredForm a
+ -> EnteredForm b
+mapEnteredFormIO' f
+ (EnteredForm{packAction = packAction,getFormValue = getFormValue,
+ destroyAction = destroyAction}) =
+ EnteredForm {packAction = packAction,destroyAction = destroyAction,
+ getFormValue = do
+ we1 <- getFormValue
+ mapWithErrorIO' f we1
+ }
+
+-- -------------------------------------------------------------------------
+-- The Form type and (//)
+-- -------------------------------------------------------------------------
+
+newtype Form value = Form (forall container . Container container
+ => container -> IO (EnteredForm value))
+
+instance Functor Form where
+ fmap f (Form getEnteredForm0) =
+ let
+ getEnteredForm1 container =
+ do
+ enteredForm1 <- getEnteredForm0 container
+ return (mapEnteredForm f enteredForm1)
+ in
+ Form getEnteredForm1
+
+
+mapForm :: (x -> WithError y) -> Form x -> Form y
+mapForm f (Form getEnteredForm0) =
+ let
+ getEnteredForm1 container =
+ do
+ enteredForm1 <- getEnteredForm0 container
+ return (mapEnteredForm' f enteredForm1)
+ in
+ Form getEnteredForm1
+
+mapFormIO :: (x -> IO (WithError y)) -> Form x -> Form y
+mapFormIO f (Form getEnteredForm0) =
+ let
+ getEnteredForm1 container =
+ do
+ enteredForm1 <- getEnteredForm0 container
+ return (mapEnteredFormIO' f enteredForm1)
+ in
+ Form getEnteredForm1
+
+
+infixr 8 // -- so it binds less tightly than \\
+
+(//) :: Form value1 -> Form value2 -> Form (value1,value2)
+(//) (Form enterForm1) (Form enterForm2) =
+ let
+ enterForm container =
+ do
+ enteredForm1 <- enterForm1 container
+ enteredForm2 <- enterForm2 container
+ let
+ enteredForm = EnteredForm {
+ packAction = (
+ do
+ packAction enteredForm1
+ packAction enteredForm2
+ ),
+ getFormValue = (
+ do
+ valueError1 <- getFormValue enteredForm1
+ valueError2 <- getFormValue enteredForm2
+ return (pairWithError valueError1 valueError2)
+ ),
+ destroyAction = (
+ do
+ destroyAction enteredForm1
+ destroyAction enteredForm2
+ )
+ }
+ return enteredForm
+ in
+ Form enterForm
+
+guardForm :: (x -> Bool) -> String -> Form x -> Form x
+guardForm test mess =
+ mapForm (\x -> if test x then hasValue x else hasError mess)
+
+guardFormIO :: (x -> IO Bool) -> String -> Form x -> Form x
+guardFormIO test mess =
+ mapFormIO (\ x ->
+ do
+ res <- test x
+ return (if res then hasValue x else hasError mess)
+ )
+
+guardNothing :: String -> Form (Maybe x) -> Form x
+guardNothing mess =
+ mapForm (\ xOpt ->
+ case xOpt of
+ Nothing -> hasError mess
+ Just x -> hasValue x
+ )
+
+
+-- -------------------------------------------------------------------------
+-- The \\ function
+-- -------------------------------------------------------------------------
+
+(\\) :: Form x -> Form y -> Form (x,y)
+(\\) (Form enterForm1) (Form enterForm2) =
+ let
+ enterForm container =
+ -- This is somewhat clumsy as we can't specify the pack action
+ -- of the internal forms, so have to wrap them in two further forms.
+ do
+ frame <- newFrame container []
+ frame1 <- newFrame frame []
+ enteredForm1 <- enterForm1 frame1
+ frame2 <- newFrame frame []
+ enteredForm2 <- enterForm2 frame2
+ let
+ enteredForm = EnteredForm {
+ packAction = (
+ do
+ packAction enteredForm1
+ pack frame1 [Side AtLeft]
+ packAction enteredForm2
+ pack frame2 [Side AtLeft]
+ pack frame []
+ ),
+ getFormValue = (
+ do
+ valueError1 <- getFormValue enteredForm1
+ valueError2 <- getFormValue enteredForm2
+ return (pairWithError valueError1 valueError2)
+ ),
+ destroyAction = (
+ do
+ destroyAction enteredForm1
+ destroyAction enteredForm2
+ )
+ }
+
+ return enteredForm
+ in
+ Form enterForm
+
+infixr 9 \\ -- so it binds more tightly than //
+
+
+-- -------------------------------------------------------------------------
+-- emptyForm, nullForm, column and row
+-- -------------------------------------------------------------------------
+
+emptyForm :: Form ()
+emptyForm = Form (\ container ->
+ return (EnteredForm {
+ packAction = done,
+ getFormValue = return (hasValue ()),
+ destroyAction = done
+ })
+ )
+
+nullForm :: FormLabel label => label -> Form ()
+nullForm label = newFormEntry label ()
+
+emptyFormList :: Form [a]
+emptyFormList = fmap (const []) emptyForm
+
+column :: [Form value] -> Form [value]
+column forms =
+ foldr
+ (\ form listForm -> fmap (uncurry (:)) (form // listForm))
+ emptyFormList
+ forms
+
+row :: [Form value] -> Form [value]
+row forms =
+ foldr
+ (\ form listForm -> fmap (uncurry (:)) (form // listForm))
+ emptyFormList
+ forms
+
+-- -------------------------------------------------------------------------
+-- The doForm action
+-- -------------------------------------------------------------------------
+
+doFormMust :: String -> Form value -> IO value
+doFormMust title form =
+ do
+ (Just value) <- doForm1 False title form
+ return value
+
+doForm :: String -> Form value -> IO (Maybe value)
+doForm = doForm1 True
+
+doForm1 :: Bool -> String -> Form value -> IO (Maybe value)
+doForm1 canCancel title (Form enterForm) =
+ do
+ (toplevel,enteredForm,okEvent,cancelEvent) <- delayWish (
+ do
+ toplevel <- createToplevel [text title]
+ enteredForm0 <- enterForm toplevel
+ -- create frame for "OK" and "Cancel" buttons.
+ frame <- newFrame toplevel []
+ okButton <- newButton frame [text "OK"]
+ okEvent <- clicked okButton
+
+ packAction enteredForm0
+ pack okButton [Side AtLeft]
+
+ cancelEvent <-
+ if canCancel
+ then
+ do
+ cancelButton <- newButton frame [text "Cancel"]
+ pack cancelButton [Side AtRight]
+ clicked cancelButton
+ else
+ return never
+
+ (destroyEvent,cancelBind) <- bindSimple toplevel Destroy
+
+ let
+ enteredForm =
+ enteredForm0 {
+ destroyAction =
+ do
+ destroyAction enteredForm0
+ cancelBind
+ }
+
+ pack frame [Side AtTop]
+ return (toplevel,enteredForm,okEvent,cancelEvent +> destroyEvent)
+ )
+
+ let
+ handler =
+ (do
+ okEvent
+ always (
+ do
+ valueError <- getFormValue enteredForm
+ case fromWithError valueError of
+ Right value -> return (Just value)
+ Left err ->
+ do
+ errorMess err
+ sync handler
+ )
+ )
+ +> (do
+ cancelEvent
+ return Nothing
+ )
+
+ valueOpt <- sync handler
+
+ -- finish off
+ destroyAction enteredForm
+ destroy toplevel
+
+ return valueOpt
+
+doFormList :: String -> [(Form x,String)] -> IO (Event (WithError x),IO ())
+doFormList title (formList :: [(Form x,String)]) =
+ do
+ let
+ doOneForm :: Toplevel -> (Form x,String)
+ -> IO (Event (WithError x),IO ())
+ doOneForm toplevel (Form enterForm,buttonName) =
+ do
+ frame <- newFrame toplevel []
+ leftFrame <- newFrame frame []
+
+ enteredForm <- enterForm leftFrame
+ button <- newButton frame [text buttonName,anchor East]
+ clickEvent <- clicked button
+
+ packAction enteredForm
+ pack leftFrame [Side AtLeft,Anchor West]
+ pack button [Side AtRight,Anchor East]
+ pack frame [Side AtTop,Fill X]
+
+ let
+ handler = clickEvent >>> getFormValue enteredForm
+ return (handler,done)
+ (toplevel,enterResults) <- delayWish (
+ do
+ toplevel <- createToplevel [text title]
+ enterResults <- mapM (doOneForm toplevel) formList
+ return (toplevel,enterResults)
+ )
+ (destroyEvent,unbind) <- bindSimple toplevel Destroy
+
+ let
+ event0 = choose (map fst enterResults)
+
+ event1 = event0
+ +> (do
+ destroyEvent
+ return (fail "Window destroyed")
+ )
+
+ destroyWindow :: IO ()
+ destroyWindow =
+ do
+ mapM_ snd enterResults
+ unbind
+ destroy toplevel
+ return (event1,destroyWindow)
+
+
+-- -------------------------------------------------------------------------
+-- newFormEntry
+-- -------------------------------------------------------------------------
+
+newFormEntry :: (FormLabel label,FormValue value) => label -> value
+ -> Form value
+newFormEntry label value =
+ let
+ enterForm container =
+ do
+ frame <- newFrame container []
+ packLabel <- formLabel frame label
+ enteredForm1 <- makeFormEntry frame value
+ let
+ enteredForm = EnteredForm {
+ packAction = (
+ do
+ packLabel
+ packAction enteredForm1
+ pack frame [Side AtTop,Fill X]
+ ),
+ getFormValue = getFormValue enteredForm1,
+ destroyAction = destroyAction enteredForm1
+ }
+ return enteredForm
+ in
+ Form enterForm
+
+-- -------------------------------------------------------------------------
+-- newFormMenu
+-- -------------------------------------------------------------------------
+
+newFormMenu :: FormLabel label => label -> HTkMenu value -> Form (Maybe value)
+newFormMenu label htkMenu =
+ let
+ enterForm container =
+ do
+ frame <- newFrame container []
+ packLabel <- formLabel frame label
+ enteredForm1 <- makeFormMenuEntry frame htkMenu
+ let
+ enteredForm = EnteredForm {
+ packAction = (
+ do
+ packLabel
+ packAction enteredForm1
+ pack frame [Side AtTop,Fill X]
+ ),
+ getFormValue = getFormValue enteredForm1,
+ destroyAction = destroyAction enteredForm1
+ }
+ return enteredForm
+ in
+ Form enterForm
+
+
+makeFormMenuEntry :: Frame -> HTkMenu value -> IO (EnteredForm (Maybe (value)))
+makeFormMenuEntry frame htkMenu =
+ do
+ (menuButton,menuEvent) <- compileHTkMenu frame htkMenu
+ -- Set up things for the thread which watches for menu events so that
+ -- it picks up the last one.
+ resultRef <- newIORef Nothing -- put the result here!
+ killChannel <- newChannel -- terminate watcher thread here!
+ let
+ menuEventThread =
+ (do
+ menuClick <- menuEvent
+ always (writeIORef resultRef (Just menuClick))
+ menuEventThread
+ )
+ +> receive killChannel
+
+ _ <- spawnEvent menuEventThread
+
+ return (EnteredForm{
+ packAction = pack menuButton [],
+ getFormValue = (
+ do
+ valueOpt <- readIORef resultRef
+ return (hasValue valueOpt)
+ ),
+ destroyAction = sync (send killChannel ())
+ })
+
+-- -------------------------------------------------------------------------
+-- newFormOptionMenu
+-- -------------------------------------------------------------------------
+
+newFormOptionMenu :: (GUIValue a) => [a] -> Form a
+newFormOptionMenu options =
+ let
+ enterForm container =
+ do
+ optionMenu <- newOptionMenu container options []
+ return (EnteredForm {
+ packAction = pack optionMenu [],
+ getFormValue = (
+ do
+ val <- getValue optionMenu
+ return (hasValue val)
+ ),
+ destroyAction = done
+ })
+ in
+ Form enterForm
+
+
+newFormOptionMenu2 :: (Eq a,GUIValue a) => [(a,b)] -> Form b
+newFormOptionMenu2 options =
+ let
+ form1 = newFormOptionMenu (map fst options)
+ in
+ fmap
+ (\ a0 -> case findJust
+ (\ (a1,b1) -> if a1 == a0 then Just b1 else Nothing)
+ options
+ of
+ Nothing -> error (
+ "SimpleForm.newFormOptionMenu2: HTk returned strange value")
+ Just b -> b
+ )
+ form1
+
+-- -------------------------------------------------------------------------
+-- The FormLabel class
+-- This is used for labels of fields in the form, and also for labels
+-- of radio buttons.
+-- -------------------------------------------------------------------------
+
+class FormLabel label where
+ formLabel :: Frame -> label -> IO (IO ())
+ -- formLabel frame label creates a new label
+ -- (normally at the left of) the frame "frame" with detail label. The action
+ -- returned is the packing action.
+
+instance FormLabel String where
+ formLabel frame str =
+ do
+ label <- newLabel frame [text str,anchor West]
+ return (pack label [Side AtLeft,Fill X])
+
+instance FormLabel Image where
+ formLabel frame image =
+ do
+ label <- newLabel frame [photo image]
+ return (pack label [Side AtLeft])
+
+
+-- We provide a heterogenous version of this too.
+data WrappedFormLabel = forall label . FormLabel label
+ => WrappedFormLabel label
+
+instance FormLabel WrappedFormLabel where
+ formLabel frame (WrappedFormLabel label) = formLabel frame label
+
+-- Finally, a label which actually does nothing at all.
+data EmptyLabel = EmptyLabel
+
+instance FormLabel EmptyLabel where
+ formLabel _ _ = return done
+
+
+-- -------------------------------------------------------------------------
+-- The FormValue class
+-- -------------------------------------------------------------------------
+
+class FormValue value where
+ makeFormEntry :: Frame -> value -> IO (EnteredForm value)
+ -- Create a new form entry, given a default value.
+
+mapMakeFormEntry :: FormValue value2
+ => (value1 -> value2) -> (value2 -> value1)
+ -> (Frame -> value1 -> IO (EnteredForm value1))
+mapMakeFormEntry toValue2 fromValue2 frame value1 =
+ do
+ enteredForm <- makeFormEntry frame (toValue2 value1)
+ return (mapEnteredForm fromValue2 enteredForm)
+
+-- -------------------------------------------------------------------------
+-- Instance #1 - FormTextField's, corresponding to a single line of text.
+-- -------------------------------------------------------------------------
+
+class FormTextField value where
+ makeFormString :: value -> String
+ -- used for computing the initial string from the given default value
+ readFormString :: String -> WithError value
+ -- readFormString computes the value, or an error message.
+
+-- Two examples
+
+-- strings
+instance FormTextField String where
+ makeFormString str = str
+ readFormString str = hasValue str
+
+allSpaces :: String -> Bool
+allSpaces = all isSpace
+
+-- numbers
+instance (Num a,Show a,Read a) => FormTextField a where
+ makeFormString value = show value
+ readFormString str = case reads str of
+ [(value,rest)] | allSpaces rest -> hasValue value
+ _ -> hasError (show str ++ " is not a number")
+
+instance FormTextField value => FormTextFieldIO value where
+ makeFormStringIO value = return (makeFormString value)
+ readFormStringIO value = return (readFormString value)
+
+-- -------------------------------------------------------------------------
+-- Instance #1A - FormTextFieldIO's, where IO actions are allowed
+-- -------------------------------------------------------------------------
+
+class FormTextFieldIO value where
+ makeFormStringIO :: value -> IO String
+ readFormStringIO :: String -> IO (WithError value)
+
+instance FormTextFieldIO value => FormValue value where
+ makeFormEntry frame defaultVal =
+ do
+ defaultString <- makeFormStringIO defaultVal
+ contentsVariable <- createTkVariable defaultString
+ (entry :: Entry String) <- newEntry frame [variable contentsVariable]
+ let
+ getFormValue =
+ do
+ (contents :: String) <- readTkVariable contentsVariable
+ readFormStringIO contents
+ let
+ enteredForm = EnteredForm {
+ packAction = pack entry [Side AtRight,Fill X],
+ getFormValue = getFormValue,
+ destroyAction = done
+ }
+ return enteredForm
+
+-- -------------------------------------------------------------------------
+-- Instance #1B - A variation of the former, for a text field where the
+-- characters are not displayed as typed in, but replaced by '.'
+-- -------------------------------------------------------------------------
+
+newtype Password value = Password value
+
+instance FormTextFieldIO value => FormValue (Password value) where
+ makeFormEntry frame (Password defaultVal) =
+ do
+ defaultString <- makeFormStringIO defaultVal
+ contentsVariable <- createTkVariable defaultString
+ (entry :: Entry String)
+ <- newEntry frame [showText '.',variable contentsVariable]
+ let
+ getFormValue =
+ do
+ (contents :: String) <- readTkVariable contentsVariable
+ valueWE <- readFormStringIO contents
+ return (mapWithError Password valueWE)
+ let
+ enteredForm = EnteredForm {
+ packAction = pack entry [Side AtRight,Fill X],
+ getFormValue = getFormValue,
+ destroyAction = done
+ }
+ return enteredForm
+
+-- -------------------------------------------------------------------------
+-- Instance #2B. Maybe something that's an instance of FormTextFieldIO
+-- so corresponding to Maybe String or Maybe Number.
+-- It is possible to nest FormTextFieldIO's Maybe(Maybe . . .) but this is
+-- not recommended.
+-- When reading a null string, this will be parsed as a value rather than
+-- Nothing if possible; this happens for example with String.
+-- -------------------------------------------------------------------------
+
+instance FormTextFieldIO value => FormTextFieldIO (Maybe value) where
+ makeFormStringIO Nothing = return ""
+ makeFormStringIO (Just value) = makeFormStringIO value
+
+ readFormStringIO "" =
+ do
+ null <- readFormStringIO ""
+ return (case fromWithError null of
+ Left _ -> hasValue Nothing
+ Right x -> hasValue (Just x)
+ )
+ readFormStringIO str =
+ do
+ xWE <- readFormStringIO str
+ return (mapWithError Just xWE)
+
+-- -------------------------------------------------------------------------
+-- Instance #2C - Radio Buttons
+-- If "x" is an instance of "Show", "Bounded" and "Enum", "Radio x" will be an
+-- instance of FormValue, and will display the buttons in order.
+-- But if you don't like this define your own instances of Show or,
+-- for pictures, HasConfigRadioButton.
+--
+-- Radio Int is _not_ recommended.
+-- -------------------------------------------------------------------------
+
+data Radio x = Radio x | NoRadio deriving (Typeable)
+-- The NoRadio indicates that no radio button is selected.
+
+class HasConfigRadioButton value where
+ configRadioButton :: value -> Config (RadioButton Int)
+
+-- instance Show value => HasConfigRadioButton value where
+-- configRadioButton value = text (show value)
+
+instance (HasConfigRadioButton value,Bounded value,Enum value)
+ => FormValue (Radio value) where
+ makeFormEntry frame rvalue =
+ do
+ let
+ minB :: value
+ minB = minBound
+ maxB :: value
+ maxB = maxBound
+
+ minBoundInt :: Int
+ minBoundInt = fromEnum minB
+ maxBoundInt :: Int
+ maxBoundInt = fromEnum maxB
+
+ fromRValue :: Radio value -> Int
+ fromRValue NoRadio = -1
+ fromRValue (Radio x) = fromEnum x - minBoundInt
+
+ toRValue :: Int -> Radio value
+ toRValue (-1) = NoRadio
+ toRValue i =
+ if i>= 0 && i<= maxBoundInt - minBoundInt
+ then
+ Radio (toEnum (i+minBoundInt))
+ else error
+ ("SimpleForm.toRValue - radio button with odd number:"++
+ show i)
+
+ radioVar <- createTkVariable (fromRValue rvalue)
+ -- Add the radio buttons and get their packing actions.
+ packActions <- mapM
+ (\ val ->
+ do
+ radioButton <- newRadioButton frame [
+ configRadioButton val,
+ variable radioVar,
+ value (fromRValue (Radio val))
+ ]
+ return (pack radioButton [Side AtLeft])
+ )
+ [minB .. maxB]
+ let
+ enteredForm = EnteredForm {
+ packAction = sequence_ packActions,
+ getFormValue =
+ do
+ valInt <- readTkVariable radioVar
+ return (hasValue (toRValue valInt)),
+ destroyAction = done
+ }
+ return enteredForm
+
+-- We need elsewhere in the workbench a Binary instance for Radio
+instance (Monad m,HasBinary x m) => HasBinary (Radio x) m where
+ writeBin = mapWrite (\ radio -> case radio of
+ Radio x -> Just x
+ NoRadio -> Nothing
+ )
+ readBin = mapRead (\ xOpt -> case xOpt of
+ Just x -> Radio x
+ Nothing -> NoRadio
+ )
+
+-- -------------------------------------------------------------------------
+-- Instance #3 - Check buttons a.k.a. Bools.
+-- -------------------------------------------------------------------------
+
+instance FormValue Bool where
+ makeFormEntry frame b =
+ do
+ boolVar <- createTkVariable b
+ checkButton <- newCheckButton frame [variable boolVar]
+ let
+ enteredForm = EnteredForm {
+ packAction = pack checkButton [Side AtLeft],
+ getFormValue = (
+ do
+ bool <- readTkVariable boolVar
+ return (hasValue bool)
+ ),
+ destroyAction = done
+ }
+ return enteredForm
+
+-- -------------------------------------------------------------------------
+-- ()
+-- -------------------------------------------------------------------------
+
+instance FormValue () where
+ makeFormEntry frame () =
+ return (
+ EnteredForm {
+ packAction = done,
+ getFormValue = return (hasValue ()),
+ destroyAction = done
+ }
+ )
+
+
+-- -------------------------------------------------------------------------
+-- An editable text window as a form entry.
+-- -------------------------------------------------------------------------
+
+-- | An editable text window as a form entry
+-- Useful config options:
+-- (value String) to set initial contents
+-- (height i), (width i) to set the height and width in characters.
+-- (background s) to set the background colour to s.
+editableTextForm :: [Config Editor] -> Form String
+editableTextForm configs =
+ Form (\ container ->
+ do
+ editorFrame <- newFrame container []
+
+ editor <- newEditor editorFrame (configs ++ [wrap NoWrap])
+ scrollBar1 <- newScrollBar editorFrame [orient Vertical]
+ scrollBar2 <- newScrollBar container [orient Horizontal]
+
+ editor # scrollbar Vertical scrollBar1
+ editor # scrollbar Horizontal scrollBar2
+
+ return (EnteredForm {
+ packAction =
+ (do
+ pack editor [Side AtRight]
+ pack scrollBar1 [Side AtRight,Fill Y,Expand On]
+ pack editorFrame []
+ pack scrollBar2 [Side AtTop,Fill X,Expand On]
+ ),
+ getFormValue = (
+ do
+ value <- getValue editor
+ return (hasValue value)
+ ),
+ destroyAction = done
+ })
+ )
+
+
+-- | Like 'editableTextForm' but no scrollbars are displayed.
+editableTextForm0 :: [Config Editor] -> Form String
+editableTextForm0 configs =
+ Form (\ container ->
+ do
+ editorFrame <- newFrame container []
+
+ editor <- newEditor editorFrame (configs ++ [wrap NoWrap])
+
+ return (EnteredForm {
+ packAction =
+ (do
+ pack editor [Side AtRight]
+ pack editorFrame []
+ ),
+ getFormValue = (
+ do
+ value <- getValue editor
+ return (hasValue value)
+ ),
+ destroyAction = done
+ })
+ )
diff --git a/HTk/Toolkit/SimpleListBox.hs b/HTk/Toolkit/SimpleListBox.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/SimpleListBox.hs
@@ -0,0 +1,215 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | This module implements a simple list box to which strings can be
+-- added at the end and deleted.
+module HTk.Toolkit.SimpleListBox(
+ SimpleListBox,
+ newSimpleListBox,
+ -- :: String -> (value -> String) -> (Distance,Distance)
+ -- -> IO (SimpleListBox value)
+ -- Create a ListBox. The String gives the title for the box; the
+ -- function argument gives the String's which
+ -- are displayed; the integers give the width (characters) and height
+ -- (rows) of the displayed section of the box.
+
+ -- This implements Destroyable.
+
+ SimpleListBoxItem,
+ -- Instance of Object, Eq, Ord.
+ addItemAtEnd,
+ -- :: SimpleListBox value -> value -> IO (SimpleListBoxItem value)
+ deleteItem,
+ -- :: SimpleListBox value -> SimpleListBoxItem value -> IO ()
+ getItems,
+ -- :: SimpleListBox value -> IO [value]
+
+ bindSelection,
+ -- :: SimpleListBox value
+ -- -> IO (Event [SimpleListBoxItem value]),IO ())
+ -- Returns an event for selections in this list box. ([] can happen,
+ -- for example, if the user selects or clicks an area into which no
+ -- item has yet been added.)
+ ) where
+
+import Data.Maybe
+
+import Control.Concurrent.MVar
+
+import Util.ExtendedPrelude
+import Util.Object
+import Util.Computation
+
+import Events.Events
+
+import HTk.Kernel.Core(GUIObject(..))
+import HTk.Toplevel.HTk
+
+
+-- -------------------------------------------------------------------------
+-- Datatypes
+-- -------------------------------------------------------------------------
+
+data SimpleListBox val = SimpleListBox {
+ frame :: Frame, -- contains the list box, and the scroll-bar.
+ listBox :: ListBox String,
+ mkString :: val -> String,
+ contentsMVar :: MVar [SimpleListBoxItem val]
+ }
+
+data SimpleListBoxItem val = SimpleListBoxItem {
+ val :: val,
+ oID :: ObjectID
+ }
+
+-- -------------------------------------------------------------------------
+-- Non-HTk Instances
+-- -------------------------------------------------------------------------
+
+instance Object (SimpleListBox val) where
+ objectID simpleListBox = objectID (toGUIObject simpleListBox)
+
+instance Destroyable (SimpleListBox val) where
+ destroy simpleListBox = destroy (frame simpleListBox)
+
+instance Object (SimpleListBoxItem val) where
+ objectID simpleListBoxItem = oID simpleListBoxItem
+
+instance Eq (SimpleListBoxItem val) where
+ (==) = mapEq oID
+
+instance Ord (SimpleListBoxItem val) where
+ compare = mapOrd oID
+
+-- -------------------------------------------------------------------------
+-- HTk instances (needed for packing a list box)
+-- -------------------------------------------------------------------------
+
+instance GUIObject (SimpleListBox val) where
+ toGUIObject simpleListBox = toGUIObject (frame simpleListBox)
+
+ cname _ = "SimpleListBox"
+
+instance Widget (SimpleListBox val)
+
+instance HasSize (SimpleListBox val)
+
+
+-- -------------------------------------------------------------------------
+-- Functions
+-- -------------------------------------------------------------------------
+
+newSimpleListBox
+ :: Container par
+ => par -> (val -> String) -> [Config (SimpleListBox val)]
+ -> IO (SimpleListBox val)
+newSimpleListBox parent mkString configs =
+ do
+ frame <- newFrame parent []
+ listBox <- newListBox frame [value ([] :: [String]),bg "white"]
+
+ pack listBox [Side AtLeft,Fill Y]
+
+ scroll <- newScrollBar frame []
+ pack scroll [Side AtRight,Fill Y]
+
+ listBox # scrollbar Vertical scroll
+ listBox # selectMode Extended
+
+ contentsMVar <- newMVar []
+
+ let
+ simpleListBox = SimpleListBox {
+ frame = frame,
+ listBox = listBox,
+ mkString = mkString,
+ contentsMVar = contentsMVar
+ }
+
+ configure simpleListBox configs
+
+ return simpleListBox
+
+addItemAtEnd :: SimpleListBox val -> val -> IO (SimpleListBoxItem val)
+addItemAtEnd simpleListBox (val1 :: val) =
+ do
+ -- We have to recompute the complete list of Strings, since
+ -- Einar doesn't seem to have provided a function for adding a single
+ -- item to a ListBox, and I can't be bothered to implement one.
+ let
+ mVar = contentsMVar simpleListBox
+ mkS = mkString simpleListBox
+
+ oID <- newObject
+ let
+ simpleListBoxItem = SimpleListBoxItem {
+ val = val1,
+ oID = oID
+ }
+
+ contents0 <- takeMVar mVar
+ let
+ contents1 :: [SimpleListBoxItem val]
+ contents1 = contents0 ++ [simpleListBoxItem]
+
+ newValue :: [String]
+ newValue = map (mkS . val) contents1
+
+ (listBox simpleListBox) # value newValue
+ putMVar mVar contents1
+
+ return simpleListBoxItem
+
+deleteItem :: SimpleListBox val -> SimpleListBoxItem val -> IO ()
+deleteItem simpleListBox simpleListBoxItem =
+ do
+ let
+ mVar = contentsMVar simpleListBox
+ mkS = mkString simpleListBox
+
+ contents0 <- takeMVar mVar
+ let
+ contents1 = deleteFirst (== simpleListBoxItem) contents0
+
+ (newValue :: [String]) = map (mkS . val) contents1
+
+ (listBox simpleListBox) # value newValue
+ putMVar mVar contents1
+ done
+
+getItems :: SimpleListBox value -> IO [value]
+getItems simpleListBox =
+ do
+ contents <- readMVar (contentsMVar simpleListBox)
+ return (map val contents)
+
+bindSelection :: SimpleListBox val
+ -> IO (Event [SimpleListBoxItem val],IO ())
+bindSelection simpleListBox =
+ do
+ (press,terminator)
+ <- bindSimple (listBox simpleListBox) (ButtonPress (Just 1))
+ let
+ event =
+ press
+ >>>
+ do
+ indexOpt <- getSelection (listBox simpleListBox)
+ contents0 <- readMVar (contentsMVar simpleListBox)
+ return (case indexOpt of
+ Nothing -> []
+ Just items ->
+ let
+ max = length contents0
+ in
+ mapMaybe
+ (\ index -> if index >= max
+ then
+ Nothing
+ -- can happen if events and a deletion
+ -- get processed in the wrong order.
+ else
+ Just (contents0 !! index)
+ )
+ items
+ )
+ return (event,terminator)
diff --git a/HTk/Toolkit/SpinButton.hs b/HTk/Toolkit/SpinButton.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/SpinButton.hs
@@ -0,0 +1,157 @@
+-- | A spin button widget consisting of two button widgets.
+module HTk.Toolkit.SpinButton (
+
+ Spin(..),
+
+ SpinButton,
+ newSpinButton
+
+) where
+
+import System.IO.Unsafe
+
+import Util.Computation
+
+import Events.Events
+import Events.Channels
+import Events.Synchronized
+
+import HTk.Kernel.Core
+import HTk.Toplevel.HTk
+
+
+
+-- -----------------------------------------------------------------------
+-- datatype
+-- -----------------------------------------------------------------------
+
+-- | The @SpinButton@ datatype.
+data SpinButton =
+ SpinButton {
+ fContainer :: Box,
+ fButtonUp :: Button,
+ fButtonDown :: Button,
+ fDeath :: IO ()
+ }
+
+-- | The @Spin@ datatype.
+data Spin = Down | Up deriving (Eq,Ord)
+
+
+-- -----------------------------------------------------------------------
+-- construction
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new spin button and returns a handler.
+newSpinButton :: Container par => par
+ -- ^ the parent widget, which has to be a container widget.
+ -> (Spin -> IO a)
+ -- ^ the command to execute, when a button is pressed.
+ ->
+ [Config SpinButton]
+ -- ^ the list of configuration options for this spin
+ -- button.
+ -> IO SpinButton
+ -- ^ A spin button.
+newSpinButton par cmd cnf =
+ do
+ b <- newVFBox par []
+ bup <- newButton b [photo msUpButtonImg]
+ clicked_bup <- clicked bup
+ pack bup []
+ bdown <- newButton b [photo msDownButtonImg]
+ clicked_bdown <- clicked bdown
+ pack bdown []
+ death <- newChannel
+ let listenButtons :: Event ()
+ listenButtons = (clicked_bdown >> always (cmd Down) >>
+ listenButtons) +>
+ (clicked_bup >> always (cmd Up) >>
+ listenButtons) +>
+ receive death
+ _ <- spawnEvent listenButtons
+ configure (SpinButton b bup bdown (syncNoWait (send death ())))
+ cnf
+
+
+-- -----------------------------------------------------------------------
+-- SpinButton instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance Eq SpinButton where
+ w1 == w2 = (toGUIObject w1) == (toGUIObject w2)
+
+-- | Internal.
+instance GUIObject SpinButton where
+ toGUIObject sb = toGUIObject (fContainer sb)
+ cname _ = "SpinButton"
+
+-- | A spin button can be destroyed.
+instance Destroyable SpinButton where
+ -- Destroys a spin button.
+ destroy sb = fDeath sb >> destroy (toGUIObject sb)
+
+-- | A spin button has standard widget properties
+-- (concerning focus, cursor).
+instance Widget SpinButton
+
+-- | You can synchronize on a spin button.
+instance Synchronized SpinButton where
+ -- Synchronizes on a spin button.
+ synchronize = synchronize . toGUIObject
+
+-- | A spin button has a normal foreground and background colour and an
+-- active\/disabled foreground and background colour.
+instance HasColour SpinButton where
+ legalColourID _ _ = True
+ setColour sb cid col =
+ do
+ setColour (fContainer sb) cid col
+ setColour (fButtonUp sb) cid col
+ setColour (fButtonDown sb) cid col
+ return sb
+
+-- | A spin button has a configureable border.
+instance HasBorder SpinButton
+
+
+-- | A spin button is a stateful widget, it can be enabled or disabled.
+instance HasEnable SpinButton where
+ -- Sets the spin button\'s state.
+ state s sb =
+ synchronize sb (do
+ foreach [fButtonUp sb, fButtonDown sb] (state s)
+ return sb)
+ -- Gets the spin button\'s state.
+ getState sb = getState (fButtonUp sb)
+
+-- | A spin button has a configureable font.
+instance HasFont SpinButton where
+ -- Sets the spin button\'s font.
+ font f sb =
+ synchronize sb (do
+ foreach [fButtonUp sb, fButtonDown sb] (font f)
+ return sb)
+ -- Gets the spin button\'s font.
+ getFont sb = getFont (fButtonUp sb)
+
+-- | A spin button has a configureable size.
+instance HasSize SpinButton
+
+
+-- -----------------------------------------------------------------------
+-- The images
+-- -----------------------------------------------------------------------
+
+msDownButtonImg :: Image
+msDownButtonImg =
+ unsafePerformIO (newImage [imgData GIF
+ "R0lGODdhCQAGAPAAAP///wAAACwAAAAACQAGAAACC4SPoRvHnRRys5oCADs="])
+{-# NOINLINE msDownButtonImg #-}
+
+msUpButtonImg :: Image
+msUpButtonImg =
+ unsafePerformIO (newImage [imgData GIF
+ "R0lGODdhCQAGAPAAAP///wAAACwAAAAACQAGAAACC4SPF2nh6aKKkp0CADs"])
+{-# NOINLINE msUpButtonImg #-}
diff --git a/HTk/Toolkit/TextDisplay.hs b/HTk/Toolkit/TextDisplay.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/TextDisplay.hs
@@ -0,0 +1,57 @@
+-- | A simple window to display uneditable, scrollable text (e.g. error logs)
+
+module HTk.Toolkit.TextDisplay(
+
+ createTextDisplayExt, -- :: String-> String-> [Config ...] -> IO()-> IO Toplvl
+ createTextDisplay -- :: String-> String-> [Config ...] -> IO ()
+
+) where
+
+import Util.Computation
+
+import Events.Events
+
+import HTk.Toplevel.HTk
+import HTk.Toolkit.ScrollBox
+
+-- | Display some (longish) text in an uneditable, scrollable editor.
+-- Returns immediately-- the display is forked off to separate thread.
+createTextDisplayExt :: String
+ -- ^ the title of the window
+ -> String
+ -- ^ the text to be displayed
+ -> [Config Editor]
+ -- ^ configuration options for the text editor
+ -> IO()
+ -- ^ action to be executed when the window is closed
+ -> IO (Toplevel,Editor)
+ -- ^ the window in which the text is displayed
+createTextDisplayExt title txt conf unpost =
+ do win <- createToplevel [text title]
+ b <- newFrame win [relief Groove, borderwidth (cm 0.05)]
+ t <- newLabel b [text title, font (Helvetica, Roman, 18::Int)]
+ q <- newButton b [text "Close", width 12]
+ (sb, ed) <- newScrollBox b (\p-> newEditor p (state Normal:conf)) []
+ pack b [Side AtTop, Expand On, Fill Both]
+ pack t [Side AtTop, Expand Off, PadY 10]
+ pack sb [Side AtTop, Expand On, Fill Both]
+ pack ed [Side AtTop, Expand On, Fill Both]
+ pack q [Side AtRight, PadX 5, PadY 5]
+
+ ed # value txt
+ ed # state Disabled
+
+ quit <- clicked q
+ _ <- spawnEvent (quit >>> do destroy win; unpost)
+ return (win, ed)
+
+-- | Display some (longish) text in an uneditable, scrollable editor.
+-- Simplified version of createTextDisplayExt
+createTextDisplay :: String
+ -- ^ the title of the window
+ -> String
+ -- ^ the text to be displayed
+ -> [Config Editor]
+ -- ^ configuration options for the text editor
+ -> IO()
+createTextDisplay t txt conf = do createTextDisplayExt t txt conf done; done
diff --git a/HTk/Toolkit/TreeList.hs b/HTk/Toolkit/TreeList.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toolkit/TreeList.hs
@@ -0,0 +1,1219 @@
+-- | HTk\'s /TreeList/ module.
+module HTk.Toolkit.TreeList (
+
+ newTreeList, {- :: (Container par, Eq a) =>
+ par -> ChildrenFun a -> [TreeListObject a] ->
+ [Config (TreeList a)] -> IO (TreeList a) -}
+ TreeList,
+
+ bindTreeListEv, {- :: TreeList c ->
+ IO (Event (TreeListEvent c), IO ()) -}
+ TreeListEvent(..),
+
+ removeTreeListObject, {- :: Eq a=> TreeList a-> a-> IO () -}
+
+ updateTreeList, {- :: Eq a => TreeList a -> IO () -}
+ addTreeListRootObject, {- :: Eq a => TreeList a ->
+ TreeListObject a -> IO () -}
+ addTreeListSubObject, {- :: Eq a => TreeList a -> a ->
+ TreeListObject a -> IO () -}
+
+ newTreeListObject, {- :: Eq a => a -> TreeListObjectType ->
+ TreeListObject a -}
+
+ TreeListObject,
+ TreeListObjectType(..),
+
+ isLeaf, {- :: Eq a => TreeList a -> a -> IO (Maybe Bool) -}
+ isNode, {- :: Eq a => TreeList a -> a -> IO (Maybe Bool) -}
+ mkLeaf, {- :: Eq a => TreeList a -> a -> IO () -}
+ mkNode, {- :: Eq a => TreeList a -> a -> IO () -}
+
+ getTreeListObjectValue, {- :: TreeListObject a -> a -}
+ getTreeListObjectType, {- :: TreeListObject a -> TreeListObjectType -}
+
+ isTreeListObjectOpen,
+
+ ChildrenFun,
+ {- type ChildrenFun a = TreeListObject a -> IO [TreeListObject a] -}
+
+ setImage,
+ setTreeListObjectName,
+
+ TreeListExportItem(..),
+ TreeListState,
+ exportTreeListState,
+ importTreeListState,
+ recoverTreeList,
+
+ module HTk.Toolkit.CItem
+
+) where
+
+import Data.Maybe
+
+import System.IO.Unsafe
+
+import Util.Computation
+
+import Events.Events
+import Events.Channels
+import Events.Synchronized
+
+import Reactor.ReferenceVariables
+
+import HTk.Toplevel.HTk
+import HTk.Toolkit.ScrollBox
+import Data.List
+import HTk.Kernel.Core
+import HTk.Toolkit.CItem
+import HTk.Toolkit.Name
+
+-- internal options
+intendation = 19
+lineheight = 20
+cwidth = 15
+
+
+-- -----------------------------------------------------------------------
+-- -----------------------------------------------------------------------
+-- tree lists
+-- -----------------------------------------------------------------------
+-- -----------------------------------------------------------------------
+
+-- -----------------------------------------------------------------------
+-- basic types
+-- -----------------------------------------------------------------------
+
+data StateEntry a =
+ StateEntry (TREELISTOBJECT a) -- object
+ Bool -- open: True / closed: False
+ Int -- intendation
+ [a] -- ids of previously open subobjects for reopen
+ deriving Eq
+
+-- | The @ChildrenFun@ type.
+type ChildrenFun a = TreeListObject a -> IO [TreeListObject a]
+
+-- | The @TreeList@ datatype.
+data CItem c => TreeList c =
+ TreeList { -- main canvas
+ cnv :: Canvas,
+
+ -- scrollbox
+ scrollbox :: (ScrollBox Canvas),
+
+ -- treelist state
+ internal_state :: (Ref [StateEntry c]),
+
+ -- node children function
+ cfun :: (ChildrenFun c),
+
+ -- selected object
+ selected_object :: (Ref (Maybe (TREELISTOBJECT c))),
+
+ -- tree list event queue
+ event_queue :: Ref (Maybe (Channel (TreeListEvent c))),
+
+ -- clean up on destruction
+ clean_up :: Ref [IO ()] }
+
+
+-- -----------------------------------------------------------------------
+-- tree list construction
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new tree list.
+newTreeList :: (Container par, CItem a) =>
+ par
+ -- ^ the parent widget, which has to be a container widget.
+ -> ChildrenFun a
+ -- ^ the tree list\'s children function.
+ -> [TreeListObject a]
+ -- ^ the initial list of tree list objects.
+ ->
+ [Config (TreeList a)]
+ -- ^ the list of configuration options for this tree list.
+ -> IO (TreeList a)
+ -- ^ A tree list.
+newTreeList par cfun objs cnf =
+ do
+ (scr, cnv) <- newScrollBox par (\p -> newCanvas p []) []
+ stateref <- newRef []
+ selref <- newRef Nothing
+ evq <- newRef Nothing
+ cleanup <- newRef []
+ let treelist = TreeList { cnv = cnv,
+ scrollbox = scr,
+ internal_state = stateref,
+ cfun = cfun,
+ selected_object = selref,
+ event_queue = evq,
+ clean_up = cleanup }
+ foldl (>>=) (return treelist) cnf
+ rootobjs <- mapM (\ (TreeListObject (val, objtype)) ->
+ do
+ nm <- getName val
+ mkTreeListObject treelist val
+ (objtype == Node)
+ False [name nm]) objs
+ let toStateEntry obj = StateEntry obj False 0 []
+ setRef stateref (map toStateEntry rootobjs)
+ let setImg obj =
+ do
+ pho <- getIcon (val obj)
+ obj_img obj # photo pho
+ mapM setImg rootobjs
+ (if not(null rootobjs) then
+ do
+ packTreeListObject (head rootobjs) True (5, 5)
+ let packObjs :: CItem a => Position -> [TREELISTOBJECT a] ->
+ IO ()
+ packObjs (x, y) (obj : objs) =
+ packTreeListObject obj False (x, y) >>
+ packObjs (x, y + Distance lineheight) objs
+ packObjs _ _ = done
+ packObjs (5, 5 + Distance lineheight) (tail rootobjs)
+ updScrollRegion cnv stateref
+ else done)
+ (press, ub) <- bindSimple cnv (ButtonPress (Just 1))
+ death <- newChannel
+ let listenCnv :: Event ()
+ listenCnv =
+ (press >> always (deselect treelist) >> listenCnv) +>
+ receive death
+ _ <- spawnEvent listenCnv
+ setRef cleanup [ub, syncNoWait (send death ())]
+ return treelist
+
+-- | Binds a listener for tree list events to the tree list and returns
+-- a corresponding event and an unbind action.
+bindTreeListEv :: CItem c => TreeList c
+ -- ^ the concerned tree list.
+ ->
+ IO (Event (TreeListEvent c), IO ())
+ -- ^ A pair of (event, unbind action).
+bindTreeListEv tl =
+ do
+ ch <- newChannel
+ setRef (event_queue tl) (Just ch)
+ return (receive ch, setRef (event_queue tl) Nothing)
+
+-- | The @TreeListEvent@ datatype.
+data TreeListEvent c =
+ Selected (Maybe (TreeListObject c))
+ | Focused (Maybe (TreeListObject c), EventInfo)
+ -- event info needed for drag & drop in GenGUI
+
+-- send an event if bound
+sendEv :: CItem c => TreeList c -> TreeListEvent c -> IO ()
+sendEv tl ev =
+ do
+ mch <- getRef (event_queue tl)
+ case mch of
+ Just ch -> syncNoWait (send ch ev)
+ _ -> done
+
+
+-- | Constructs a new tree list recovering a previously saved state.
+recoverTreeList :: (Container par, CItem a) =>
+ par
+ -- ^ the parent widget, which has to be a container widget.
+ -> ChildrenFun a
+ -- ^ the tree list\'s children function.
+ -> TreeListState a
+ -- ^ the state to recover.
+ ->
+ [Config (TreeList a)]
+ -- ^ the list of configuration options for this tree list.
+ ->
+ IO (TreeList a)
+ -- ^ A tree list.
+recoverTreeList par cfun st cnf =
+ do
+ (scr, cnv) <- newScrollBox par (\p -> newCanvas p []) []
+ stateref <- newRef []
+ selref <- newRef Nothing
+ evq <- newRef Nothing
+ cleanup <- newRef []
+ let tl = TreeList { cnv = cnv,
+ scrollbox = scr,
+ internal_state = stateref,
+ cfun = cfun,
+ selected_object = selref,
+ event_queue = evq,
+ clean_up = cleanup }
+ foldl (>>=) (return tl) cnf
+ state <- mkEntries tl st
+ setRef stateref state
+ let (StateEntry root _ _ _) = head state
+ pho <- getIcon (val root)
+ obj_img root # photo pho
+ packTreeListObject root True (5, 5)
+ let mselexp = find (\ exportitem -> selected exportitem) st
+ case mselexp of
+ Just selexp ->
+ let (Just (StateEntry obj _ _ _)) =
+ find (\ (StateEntry obj' _ _
+ _) -> val obj' == obj_val selexp) state
+ in obj_nm obj # fg "white" >> obj_nm obj # bg "blue" >>
+ setRef selref (Just obj)
+ _ -> done
+ insertObjects tl (5 + Distance intendation, 5)
+ (toObjects (tail state))
+ updScrollRegion cnv stateref
+ (press, ub) <- bindSimple cnv (ButtonPress (Just 1))
+ death <- newChannel
+ let listenCnv :: Event ()
+ listenCnv = (press >> always (deselect tl) >> listenCnv) +>
+ receive death
+ _ <- spawnEvent listenCnv
+ setRef cleanup [ub, syncNoWait (send death ())]
+ return tl
+
+-- | Deletes all objects from the tree list.
+clearTreeList :: CItem c => TreeList c
+ -- ^ the concerned tree list.
+ -> IO ()
+ -- ^ None.
+clearTreeList tl =
+ do
+ state <- getRef (internal_state tl)
+ mapM (\ (StateEntry obj _ _ _) -> removeObject obj) state
+ setRef (internal_state tl) []
+
+getObjectFromTreeList :: CItem a => TreeList a -> a ->
+ IO (Maybe (TREELISTOBJECT a, Bool))
+getObjectFromTreeList tl objval =
+ do
+ state <- getRef (internal_state tl)
+ let msentry = find (entryEqualsObject objval) state
+ case msentry of
+ Just sentry@(StateEntry obj _ _ _) ->
+ return (Just (obj, head state == sentry))
+ _ -> return Nothing
+ where entryEqualsObject :: CItem a => a -> StateEntry a -> Bool
+ entryEqualsObject objval (StateEntry obj _ _ _) =
+ objval == val obj
+
+-- | Checks for a given tree list object value if the corresponding
+-- object is a node.
+isNode :: CItem a => TreeList a
+ -- ^ the concerned tree list.
+ -> a
+ -- ^ the concerned tree list object value.
+ -> IO (Maybe Bool)
+ -- ^ @Nothing@ if no corresponding object is
+ -- found, otherwise @Just True@ if
+ -- the corresponding object is a node, otherwise
+ -- @Just False@.
+isNode tl val =
+ do
+ mobj <- getObjectFromTreeList tl val
+ return (case mobj of
+ Just (obj, _) -> Just (is_node obj)
+ _ -> Nothing)
+
+-- | Checks for a given tree list object value if the corresponding
+-- object is a leaf.
+isLeaf :: CItem a => TreeList a
+ -- ^ the concerned tree list.
+ -> a
+ -- ^ the concerned tree list object value.
+ -> IO (Maybe Bool)
+ -- ^ @Nothing@ if no corresponding object is
+ -- found, otherwise @Just True@ if
+ -- the corresponding object is a leaf, otherwise
+ -- @Just False@.
+isLeaf tl val =
+ do
+ mnode <- isNode tl val
+ case mnode of
+ Just b -> return (Just (not b))
+ _ -> return Nothing
+
+-- | Converts the corresponding object to a given tree list object value
+-- to a node.
+mkNode :: CItem a => TreeList a
+ -- ^ the concerned tree list.
+ -> a
+ -- ^ the concerned treelist object\'s value.
+ -> IO ()
+ -- ^ None.
+mkNode tl val =
+ do
+ mleaf <- isLeaf tl val
+ case mleaf of
+ Just True ->
+ do
+ Just (obj, isroot) <- getObjectFromTreeList tl val
+ nm <- getTreeListObjectName obj
+ [(x, y)] <- getCoord (embedded_win obj)
+ removeObject obj
+ nuobj <- mkTreeListObject tl val True False [name nm]
+ objectChanged tl obj nuobj
+ pho <- getIcon val
+ obj_img nuobj # photo pho
+ packTreeListObject nuobj isroot (x - 15, y)
+ _ -> done
+
+-- | Converts the corresponding object to a given tree list object value
+-- to a leaf.
+mkLeaf :: CItem a => TreeList a
+ -- ^ the concerned tree list.
+ -> a
+ -- ^ the concerned tree list object\'s value.
+ -> IO ()
+ -- ^ None.
+mkLeaf tl val =
+ do
+ mnode <- isNode tl val
+ case mnode of
+ Just True ->
+ do
+ Just (obj, isroot) <- getObjectFromTreeList tl val
+ Just (ch, _) <- getChildrenAndUpper tl val
+ (if null ch then done
+ else error "TreeList (mkLeaf) : node is not empty")
+ nm <- getTreeListObjectName obj
+ [(x, y)] <- getCoord (embedded_win obj)
+ removeObject obj
+ nuobj <- mkTreeListObject tl val False False [name nm]
+ objectChanged tl obj nuobj
+ pho <- getIcon val
+ obj_img nuobj # photo pho
+ packTreeListObject nuobj isroot (x - 15, y)
+ _ -> done
+
+-- | Removes the corresponding objects to a given tree list object value
+-- from the tree list.
+removeTreeListObject :: CItem a => TreeList a
+ -- ^ the concerned tree list.
+ -> a
+ -- ^ the concerned tree list object\'s value.
+ -> IO ()
+ -- ^ None.
+removeTreeListObject tl val =
+ do
+ mobj <- getObjectFromTreeList tl val
+ case mobj of
+ Just (obj, _) ->
+ do mch <- getChildrenAndUpper tl val
+ case mch of
+ Just (ch, upper) ->
+ do mapM removeObject (obj : ch)
+ done
+ _ -> done
+ _ -> done
+
+getChildrenAndUpper :: CItem a => TreeList a -> a ->
+ IO (Maybe ([TREELISTOBJECT a],
+ [TREELISTOBJECT a]))
+getChildrenAndUpper tl objval =
+ let getChildrenAndUpper' :: CItem a => a -> [StateEntry a] ->
+ Maybe ([TREELISTOBJECT a],
+ [TREELISTOBJECT a])
+ getChildrenAndUpper' objval ((StateEntry obj _ intend _) : ents) =
+ if val obj == objval then
+ Just (getChildrenAndUpper'' ents intend [])
+ else getChildrenAndUpper' objval ents
+ getChildrenAndUpper' _ _ = Nothing
+
+ getChildrenAndUpper'' :: CItem a => [StateEntry a] -> Int ->
+ [TREELISTOBJECT a] ->
+ ([TREELISTOBJECT a],
+ [TREELISTOBJECT a])
+ getChildrenAndUpper'' ((StateEntry obj _ intend' _) : ents) intend
+ ch =
+ if intend' > intend then getChildrenAndUpper'' ents intend
+ (ch ++ [obj])
+ else (ch, map (\ (StateEntry obj _ _ _) -> obj) ents)
+ in do
+ state <- getRef (internal_state tl)
+ return (getChildrenAndUpper' objval state)
+
+objectChanged :: CItem a => TreeList a -> TREELISTOBJECT a ->
+ TREELISTOBJECT a -> IO ()
+objectChanged tl obj nuobj =
+ let objectChanged' (ent@(StateEntry obj' isopen intend sub) : ents) =
+ if obj == obj' then
+ StateEntry nuobj isopen intend sub : objectChanged' ents
+ else ent : objectChanged' ents
+ objectChanged' _ = []
+ in do
+ state <- getRef (internal_state tl)
+ setRef (internal_state tl) (objectChanged' state)
+
+-- | Updates the tree list by recalling the children function for all opened
+-- objects.
+updateTreeList :: CItem a => TreeList a
+ -- ^ the concerned tree list.
+ -> IO ()
+ -- ^ None.
+updateTreeList tl =
+ synchronize tl
+ (do
+ state <- getRef (internal_state tl)
+ let (StateEntry root isopen _ _) = (head state)
+ if isopen then pressed root >> pressed root else done)
+
+
+-- -----------------------------------------------------------------------
+-- adding of objects (while running)
+-- -----------------------------------------------------------------------
+
+-- | Adds a subobject to a tree list object.
+addTreeListSubObject :: CItem a => TreeList a
+ -- ^ the concerned tree list.
+ -> a
+ -- ^ the parent object\'s value.
+ ->
+ TreeListObject a
+ -- ^ the new tree list object to add.
+ -> IO ()
+ -- ^ None.
+addTreeListSubObject tl parval obj@(TreeListObject (objval, objtype)) =
+ synchronize tl
+ (do
+ state <- getRef (internal_state tl)
+ (if visibleAndOpen state parval then
+ do
+ nm <- getName objval
+ (lowerobj, upperobj, parintend, y) <- sep state parval
+ intobj <-
+ mkTreeListObject tl objval (objtype == Node) False [name nm]
+ setRef (internal_state tl)
+ (lowerobj ++
+ [StateEntry intobj False (parintend + 1) []] ++
+ upperobj)
+ mapM (shiftObject lineheight) upperobj
+ pho <- getIcon objval
+ obj_img intobj # photo pho
+ let (StateEntry obj _ _ _) = last lowerobj
+ packTreeListObject intobj False
+ (5 + Distance ((parintend + 1) *
+ intendation),
+ y + Distance lineheight)
+ updScrollRegion (cnv tl) (internal_state tl)
+ else done))
+ where visibleAndOpen :: CItem a => [StateEntry a] -> a -> Bool
+ visibleAndOpen state parval =
+ let msentry = find (\ (StateEntry obj _ _ _) ->
+ val obj == parval) state
+ in case msentry of
+ Just (StateEntry obj isopen _ _) -> isopen
+ _ -> False
+
+ sep :: CItem a => [StateEntry a] -> a ->
+ IO ([StateEntry a], [StateEntry a], Int,
+ Distance)
+ sep sentries parval = sep1 sentries parval []
+
+ sep1 :: CItem a => [StateEntry a] -> a -> [StateEntry a] ->
+ IO ([StateEntry a], [StateEntry a], Int,
+ Distance)
+ sep1 (ent@(StateEntry obj _ intend _) : ents) parval lower =
+ if val obj == parval then
+ do
+ [(_, y)] <- getCoord (embedded_win obj)
+ sep2 ents intend (lower ++ [ent]) y
+ else sep1 ents parval (lower ++ [ent])
+
+ sep2 :: CItem a => [StateEntry a] -> Int -> [StateEntry a] ->
+ Distance ->
+ IO ([StateEntry a], [StateEntry a], Int,
+ Distance)
+ sep2 (ent@(StateEntry obj _ intend' _) : ents) intend lower _ =
+ case ents of
+ [] -> do
+ [(_, y)] <- getCoord (embedded_win obj)
+ return (lower ++ [ent], [], intend, y)
+ _ ->
+ if intend' > intend then sep2 ents intend
+ (lower ++ [ent]) 0
+ else do
+ [(_, y)] <- getCoord (embedded_win obj)
+ return (lower, ent : ents, intend,
+ y - Distance lineheight)
+ sep2 _ intend lower y =
+ return (lower, [], intend, y)
+
+-- | Adds a toplevel tree list object.
+addTreeListRootObject :: CItem a => TreeList a
+ -- ^ the concerned tree list.
+ -> TreeListObject a
+ -- ^ the tree list object to add.
+ ->
+ IO ()
+ -- ^ None.
+addTreeListRootObject tl obj@(TreeListObject (val, objtype)) =
+ synchronize tl
+ (do
+ nm <- getName val
+ tlobj <- mkTreeListObject tl val (objtype == Node) False [name nm]
+ pho <- getIcon val
+ obj_img tlobj # photo pho
+ objs <- getRef (internal_state tl)
+ setRef (internal_state tl) (objs ++ [StateEntry tlobj False 0 []])
+ packTreeListObject tlobj (length objs == 0)
+ (5, 5 + Distance (length objs * lineheight))
+ updScrollRegion (cnv tl) (internal_state tl))
+
+startObjectInteractor :: CItem a => TREELISTOBJECT a -> IO ()
+startObjectInteractor obj =
+ do
+ (press, ub) <- bindSimple (plusminus obj) (ButtonPress (Just 1))
+ addUnbindAction obj ub
+ death <- newChannel
+ let listenObject :: Event ()
+ listenObject = (press >> always (pressed obj) >> listenObject)
+ +> (receive death)
+ _ <- spawnEvent listenObject
+ addUnbindAction obj (syncNoWait (send death ()))
+ done
+
+addUnbindAction :: CItem a => TREELISTOBJECT a -> IO () -> IO ()
+addUnbindAction obj ub =
+ do
+ ubs <- getRef (ub_acts obj)
+ setRef (ub_acts obj) (ub : ubs)
+
+vLineLength :: CItem c => TREELISTOBJECT c -> IO Distance
+vLineLength obj =
+ do
+ state <- getRef (internal_state (treelist obj))
+ return(start obj (reverse state))
+ where start :: CItem a => TREELISTOBJECT a -> [StateEntry a] ->
+ Distance
+ start obj (StateEntry obj' _ intend _ : sentries) =
+ if obj' == obj then inner intend 0 sentries
+ else start obj sentries
+ inner :: CItem a => Int -> Int -> [StateEntry a] -> Distance
+ inner intend n (StateEntry obj _ intend' _ : sentries) =
+ if intend' <= intend then
+ (Distance (n * lineheight) +
+ Distance (if (is_node obj) then lineheight - 13
+ else lineheight - 9))
+ else inner intend (n + 1) sentries
+ inner _ _ _ = Distance (lineheight - 13)
+
+-- packs an (internal) tree list object
+packTreeListObject :: CItem a => TREELISTOBJECT a -> Bool -> Position ->
+ IO ()
+packTreeListObject obj isroot pos@(x, y) =
+ let hline = (selHLine (obj_lines obj))
+ vline = (selVLine (obj_lines obj))
+ in do
+ embedded_win obj # coord [(x + 15, y)]
+ dist <- vLineLength obj
+ (if (is_node obj) then
+ do
+ plusminus obj # position (x, y + 5)
+ hline # coord [(x + 9, y + 9), (x + 13, y + 9)]
+ if not isroot then
+ vline # coord [(x + 4, y + 5),
+ (x + 4, y - dist)] >> done else done
+ else
+ do
+ hline # coord [(x + 4, y + 9), (x + 13, y + 9)]
+ (if not isroot then
+ vline # coord [(x + 4, y + 9), (x + 4, y - dist)] >>
+ done
+ else done)
+ done)
+ if (is_node obj) then startObjectInteractor obj else done
+
+
+-- -----------------------------------------------------------------------
+-- TreeList instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance CItem c => GUIObject (TreeList c) where
+ toGUIObject tl = toGUIObject (scrollbox tl)
+ cname _ = "TreeList"
+
+-- | A tree list can be destroyed.
+instance CItem c => Destroyable (TreeList c) where
+ -- Destroys a tree list.
+ destroy = destroy . toGUIObject
+
+-- | A tree list has standard widget properties
+-- (concerning focus, cursor).
+instance CItem c => Widget (TreeList c)
+
+-- | You can synchronize on a tree list.
+instance CItem c => Synchronized (TreeList c) where
+ -- Synchronizes on a tree list.
+ synchronize = synchronize . toGUIObject
+
+-- | A tree list has a configureable border.
+instance CItem c => HasBorder (TreeList c)
+
+-- | A tree list has a configureale background colour.
+instance CItem c => HasColour (TreeList c) where
+ legalColourID tl = hasBackGroundColour (cnv tl)
+ setColour tl cid col = setColour (cnv tl) cid col >> return tl
+ getColour tl cid = getColour (cnv tl) cid
+
+-- | A tree list has a configureable size.
+instance CItem c => HasSize (TreeList c) where
+ width s tl = (cnv tl) # width s >> return tl
+ getWidth tl = getWidth (cnv tl)
+ height s tl = (cnv tl) # height s >> return tl
+ getHeight tl = getHeight (cnv tl)
+
+
+-- -----------------------------------------------------------------------
+-- -----------------------------------------------------------------------
+-- tree list objects
+-- -----------------------------------------------------------------------
+-- -----------------------------------------------------------------------
+
+-- -----------------------------------------------------------------------
+-- basic types
+-- -----------------------------------------------------------------------
+
+-- | The @TreeListObjectType@ datatype.
+data TreeListObjectType = Node | Leaf deriving Eq
+
+-- | The @TreeListObject@ datatype.
+newtype TreeListObject a =
+ TreeListObject (a, TreeListObjectType)
+
+data CItem a => TREELISTOBJECT a = -- internal representation
+ TREELISTOBJECT { val :: a, -- value
+ treelist :: TreeList a, -- parent
+ is_node :: Bool, -- true if node
+ plusminus :: ImageItem, -- plusminus
+ obj_lines :: (Line, Line), -- lines
+ obj_img :: Label, -- object image
+ obj_nm :: Label, -- object name
+ embedded_win :: EmbeddedCanvasWin, -- main frame
+ ub_acts :: Ref [IO ()] } -- unbind actions
+
+
+-- -----------------------------------------------------------------------
+-- construction of tree list objects
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new tree list object.
+newTreeListObject :: CItem a => a
+ -- ^ the object\'s value.
+ -> TreeListObjectType
+ -- ^ the object\'s type (node or leaf).
+ ->
+ TreeListObject a
+ -- ^ A tree list object.
+newTreeListObject val objtype = TreeListObject (val, objtype)
+
+
+-- -----------------------------------------------------------------------
+-- exported functionality on tree list objects
+-- -----------------------------------------------------------------------
+
+-- | Selector for the value of a tree list object.
+getTreeListObjectValue :: TreeListObject a
+ -- ^ the concerned tree list object.
+ -> a
+ -- ^ The given object\'s value.
+getTreeListObjectValue obj@(TreeListObject (val, _)) = val
+
+-- | Selector for the type of a tree list object (node or leaf).
+getTreeListObjectType :: TreeListObject a
+ -- ^ the concerned tree list object.
+ -> TreeListObjectType
+ -- ^ The object\'s type (node or leaf).
+getTreeListObjectType obj@(TreeListObject (_, objtype)) = objtype
+
+-- | True, if the object with the given value is currently opened in the
+-- tree list.
+isTreeListObjectOpen :: CItem c => TreeList c
+ -- ^ the concerned tree list.
+ -> c
+ -- ^ the concerned object\'s value.
+ -> IO Bool
+ -- ^ @True@, if the object with the given value
+ -- is currently opened in the tree list, otherwise
+ -- @False@.
+isTreeListObjectOpen tl v =
+ synchronize tl
+ (do
+ state <- getRef (internal_state tl)
+ let msentry = find (\ (StateEntry obj _ _ _) -> v == val obj) state
+ case msentry of
+ Just (StateEntry _ b _ _) -> return b
+ Nothing -> return False)
+
+-- | (Re-)sets the image of a tree list object.
+setImage :: CItem a => TreeList a
+ -- ^ the concerned tree list.
+ -> a
+ -- ^ the concerned object\'s value.
+ -> Image
+ -- ^ the image to set.
+ -> IO ()
+ -- ^ None.
+setImage tl objval img =
+ do
+ state <- getRef (internal_state tl)
+ setImage' state objval img
+ where setImage' :: CItem a => [StateEntry a] -> a -> Image -> IO ()
+ setImage' ((StateEntry obj _ _ _) : ents) val' img =
+ if val obj == val' then obj_img obj # photo img >> done
+ else setImage' ents val' img
+ setImage' _ _ _ = done
+
+-- | (Re-)sets the name of a tree list object.
+setTreeListObjectName :: CItem a => TreeList a
+ -- ^ the concerned tree list.
+ -> a
+ -- ^ the concerned object\'s value.
+ -> Name
+ -- ^ the name to set.
+ -> IO ()
+ -- ^ None.
+setTreeListObjectName tl objval nm =
+ do
+ state <- getRef (internal_state tl)
+ setName state objval
+ where setName :: CItem a => [StateEntry a] -> a -> IO ()
+ setName ((StateEntry obj _ _ _) : ents) val' =
+ if val obj == val' then do
+-- nm <- getName (val obj)
+ obj_nm obj # text (full nm) >> done
+ else setName ents val'
+ setName _ _ = done
+
+
+-- -----------------------------------------------------------------------
+-- internal functionality on tree list objects
+-- -----------------------------------------------------------------------
+
+-- shifts a displayed object by dy pixels (vertical)
+shiftObject :: CItem c => Int -> StateEntry c -> IO ()
+shiftObject dy (StateEntry obj _ _ _) =
+ do
+ (if (is_node obj) then moveItem (plusminus obj) 0 (Distance dy) >>
+ done
+ else done)
+ moveItem (selHLine (obj_lines obj)) 0 (Distance dy)
+ moveItem (selVLine (obj_lines obj)) 0 (Distance dy)
+ coords <- getCoord (selVLine (obj_lines obj))
+ hlinelength <- vLineLength obj
+ (let (x, y) = selLower coords
+ in (selVLine (obj_lines obj)) #
+ coord [(x, y), (x, y - hlinelength -
+ if (is_node obj) then 5 else 9)])
+ moveItem (embedded_win obj) 0 (Distance dy)
+
+-- selects the lowest position from a list of positions
+selLower :: Coord -> Position
+selLower coords = selLower' (head coords) (tail coords)
+ where selLower' :: Position -> Coord -> Position
+ selLower' l@(_, yl) (c@(_, y) : cs) =
+ if y > yl then selLower' c cs else selLower' l cs
+ selLower' l _ = l
+
+-- updates the scroll region
+updScrollRegion :: CItem a => Canvas -> Ref [StateEntry a] -> IO ()
+updScrollRegion cnv stateref =
+ do
+ state <- getRef stateref
+ updScrollRegion' cnv 0 0 state
+ where updScrollRegion' :: CItem a => Canvas -> Distance -> Distance ->
+ [StateEntry a] -> IO ()
+ updScrollRegion' cnv x y
+ ((StateEntry obj _ _ _) : sentries) =
+ do
+ Just (_, _, x', y') <- bbox cnv (embedded_win obj)
+ updScrollRegion' cnv (max x x') (max y y') sentries
+ updScrollRegion' cnv x y _ =
+ (cnv # scrollRegion ((0, 0), (x, y))) >> done
+
+-- inserts objects into the treelist
+insertObjects :: CItem a => TreeList a -> Position ->
+ [(Int, Bool, TREELISTOBJECT a)] -> IO ()
+insertObjects tl (x, y) chobjs =
+ do
+ state <- getRef (internal_state tl)
+ insertObjects' (cnv tl) (x, y + Distance lineheight) chobjs
+ where insertObjects' :: CItem a => Canvas -> Position ->
+ [(Int, Bool, TREELISTOBJECT a)] ->
+ IO ()
+ insertObjects' cnv (x, y) ((i, b, obj) : objs) =
+ do
+ pho <- getIcon (val obj)
+ obj_img obj # photo pho
+ packTreeListObject obj False
+ (5 + Distance (i * intendation), y)
+ insertObjects' cnv (x, y + Distance lineheight) objs
+ insertObjects' _ (x, y) _ = done
+
+-- removes an object from the treelist
+removeObject :: CItem a => TREELISTOBJECT a -> IO ()
+removeObject obj =
+ do
+ ubs <- getRef (ub_acts obj)
+ mapM id ubs
+ destroy (embedded_win obj)
+ if (is_node obj) then destroy (plusminus obj) else done
+ destroy (selHLine (obj_lines obj))
+ destroy (selVLine (obj_lines obj))
+ setRef (ub_acts obj) []
+ done
+
+-- gets information about a tree list object
+-- (intendation, object open or not, ids of previously open subobjects)
+getObjInfo :: CItem a => TREELISTOBJECT a -> [StateEntry a] ->
+ IO (Int, Bool, [a])
+getObjInfo obj (StateEntry obj' isopen i prevopen : entries) =
+ if obj == obj' then return (i, isopen, prevopen)
+ else getObjInfo obj entries
+
+-- constructs a state entry
+mkEntry :: CItem a => (Int, Bool, TREELISTOBJECT a) -> StateEntry a
+mkEntry (i, b, obj) = StateEntry obj b i []
+
+-- gets the displayed children of a tree list object
+getChildren :: CItem a => [StateEntry a] -> TREELISTOBJECT a ->
+ IO ([TREELISTOBJECT a], [a])
+getChildren state obj = getChildren' state obj (-1) [] []
+ where getChildren' :: CItem a => [StateEntry a] -> TREELISTOBJECT a ->
+ Int -> [TREELISTOBJECT a] -> [a] ->
+ IO ([TREELISTOBJECT a], [a])
+ getChildren' (st@(StateEntry obj' isopen intend _) : es)
+ obj i objs opensubobjvals =
+ if (i == -1 && obj /= obj') then
+ getChildren' es obj i objs opensubobjvals
+ else
+ if (obj == obj') then
+ getChildren' es obj intend objs opensubobjvals
+ else
+ if intend > i then
+ if isopen then
+ getChildren' es obj i (obj' : objs)
+ (val obj' : opensubobjvals)
+ else
+ getChildren' es obj i (obj' : objs) opensubobjvals
+ else
+ return (objs, opensubobjvals)
+ getChildren' _ _ _ objs opensubobjvals =
+ return (objs, opensubobjvals)
+
+-- reopens previously open sub-objects of a tree list object
+-- (used while opening)
+reopenSubObjects :: CItem a => ChildrenFun a -> [a] ->
+ [(Int, TREELISTOBJECT a)] ->
+ IO [(Int, Bool, TREELISTOBJECT a)]
+reopenSubObjects c_fun prevopen ((i, tlobj) : objs) =
+ if elem (val tlobj) prevopen then
+ do
+ plusminus tlobj # photo minusImg
+ ch <- c_fun (TreeListObject (val tlobj, if (is_node tlobj) then Node
+ else Leaf))
+ thisobjch <- mkTreeListObjects (treelist tlobj) ch (i + 1) prevopen
+ chobjs <- reopenSubObjects c_fun prevopen thisobjch
+ rest <- reopenSubObjects c_fun prevopen objs
+ return (((i, True, tlobj) : chobjs) ++ rest)
+ else
+ do
+ rest <- reopenSubObjects c_fun prevopen objs
+ return ((i, False, tlobj) : rest)
+reopenSubObjects _ _ _ = return []
+
+-- event handler (buttonpress)
+pressed :: CItem c => TREELISTOBJECT c -> IO ()
+pressed obj =
+ synchronize (treelist obj)
+ (do
+ state <- getRef (internal_state (treelist obj))
+ c <- getCoord (embedded_win obj)
+ index <-
+ return
+ ((fromJust
+ (elemIndex obj (map (\ (StateEntry obj _ _ _) -> obj)
+ state))) + 1)
+ (i, isopen, prevopen) <- getObjInfo obj state
+ (if isopen then
+ do -- close
+ plusminus obj # photo plusImg
+ (children, opensubobjvals) <- getChildren state obj
+ mapM removeObject children
+ setRef (internal_state (treelist obj))
+ (take (index - 1) state ++
+ [StateEntry obj False i opensubobjvals] ++
+ drop (index + length children) state)
+ mapM (shiftObject (-(length children) * lineheight))
+ (drop (index + length children) state)
+ done
+ else
+ do -- open
+ plusminus obj # photo minusImg
+ ch <- (cfun (treelist obj))
+ (TreeListObject (val obj, if (is_node obj) then Node
+ else Leaf))
+ thisobjch <- mkTreeListObjects (treelist obj) ch (i + 1)
+ prevopen
+ chobjs <- reopenSubObjects (cfun (treelist obj)) prevopen
+ thisobjch
+ setRef (internal_state (treelist obj))
+ (take (index - 1) state ++
+ [StateEntry obj True i []] ++
+ map mkEntry chobjs ++ drop index state)
+ mapM (shiftObject ((length chobjs) * lineheight))
+ (drop index state)
+ insertObjects (treelist obj) (head c) chobjs
+ done)
+ updScrollRegion (cnv (treelist obj))
+ (internal_state (treelist obj)))
+
+-- selects objects and send the concerned event
+selectObject :: CItem c => TreeList c -> TREELISTOBJECT c -> IO ()
+selectObject tl obj =
+ do
+ unmarkSelectedObject tl
+ setRef (selected_object tl) (Just obj)
+ obj_nm obj # fg "white"
+ obj_nm obj # bg "blue"
+ sendEv tl (Selected (Just (TreeListObject (val obj,
+ if (is_node obj) then Node
+ else Leaf))))
+ done
+
+-- deselects an object
+deselect :: CItem c => TreeList c -> IO ()
+deselect tl =
+ do
+ unmarkSelectedObject tl
+ setRef (selected_object tl) Nothing
+ sendEv tl (Selected Nothing)
+-- syncNoWait (send (selection_ch tl) Nothing)
+ done
+
+-- unmarks the sekected object
+unmarkSelectedObject :: CItem c => TreeList c -> IO ()
+unmarkSelectedObject tl =
+ do
+ sel <- getRef (selected_object tl)
+ case sel of
+ Just obj -> do
+ obj_nm obj # fg "black"
+ obj_nm obj # bg "white"
+ done
+ _ -> done
+
+-- True for a selected object
+isSelectedTreeList :: CItem c => TreeList c -> TREELISTOBJECT c -> IO Bool
+isSelectedTreeList tl obj =
+ do
+ sel <- getRef (selected_object tl)
+ case sel of
+ Just s -> return (s == obj)
+ _ -> return False
+
+-- constructs the internal representation of new tree list objects
+mkTreeListObjects :: CItem a => TreeList a -> [TreeListObject a] -> Int ->
+ [a] -> IO [(Int, TREELISTOBJECT a)]
+mkTreeListObjects tl objs i prevopen =
+ mapM (mk tl i prevopen) objs
+ where mk :: CItem a => TreeList a -> Int -> [a] -> TreeListObject a ->
+ IO (Int, TREELISTOBJECT a)
+ mk tl i prevopen (TreeListObject (val, objtype)) =
+ do
+ nm <- getName val
+ obj <- mkTreeListObject tl val
+ (if objtype == Node then True else False)
+ (elem val prevopen) [name nm]
+ return (i, obj)
+
+-- constructs the internal representation of a single tree list object
+mkTreeListObject :: CItem a => TreeList a -> a -> Bool -> Bool ->
+ [Config (TREELISTOBJECT a)] ->
+ IO (TREELISTOBJECT a)
+mkTreeListObject tl val isnode isopen cnf =
+ do
+ box <- newHBox (cnv tl) [background "white"]
+ drawnstuff <-
+ do
+ hline <- createLine (cnv tl) [coord [(-200, -200), (-200, -200)]]
+ vline <- createLine (cnv tl) [coord [(-200, -200), (-200, -200)]]
+ return (hline, vline)
+ plusminus <- createImageItem (cnv tl)
+ [coord [(-200, -200)], canvAnchor NorthWest,
+ photo (if isopen then minusImg else plusImg)]
+ img <- newLabel box [background "white"]
+ pack img [Side AtLeft]
+ txt <- newLabel box [background "white", font (Lucida, 12::Int)]
+ pack txt [Side AtRight]
+ emb <- createEmbeddedCanvasWin (cnv tl) box [coord [(-200, -200)],
+ canvAnchor NorthWest]
+ unbind_actions <- newRef []
+ let obj = TREELISTOBJECT { val = val,
+ treelist = tl,
+ is_node = isnode,
+ plusminus = plusminus,
+ obj_lines = drawnstuff,
+ obj_img = img,
+ obj_nm = txt,
+ embedded_win = emb,
+ ub_acts = unbind_actions }
+ foldl (>>=) (return obj) cnf
+ (enterTxt, ub) <- bind txt [WishEvent [] Enter]
+ addUnbindAction obj ub
+ death <- newChannel
+ addUnbindAction obj (syncNoWait (send death ()))
+ (leaveTxt, ub) <- bind txt [WishEvent [] Leave]
+ addUnbindAction obj ub
+ (pressTxt, ub) <- bindSimple txt (ButtonPress (Just 1))
+ addUnbindAction obj ub
+ let listenObject :: Event ()
+ listenObject =
+ (pressTxt >> always (selectObject tl obj) >> listenObject)
+ +> (do
+ ev_inf <- leaveTxt
+ always (do
+ b <- isSelectedTreeList tl obj
+ if b then done else txt # bg "white" >>
+ txt # fg "black" >> done
+ sendEv tl (Focused (Nothing, ev_inf)))
+ listenObject)
+ +> (do
+ ev_inf <- enterTxt
+ always (do
+ b <- isSelectedTreeList tl obj
+ if b then done else txt # bg "grey" >>
+ txt # fg "white" >> done
+ sendEv tl (Focused
+ (Just (TreeListObject
+ (val,
+ if isnode then Node
+ else Leaf)), ev_inf)))
+ listenObject)
+ +> receive death
+ _ <- spawnEvent listenObject
+ return obj
+
+-- selector for the horizontal line of an (internal) tree list object
+selHLine :: (Line, Line) -> Line
+selHLine (hline, _) = hline
+
+-- selector for the vertical line of an (internal) tree list object
+selVLine :: (Line, Line) -> Line
+selVLine (_, vline) = vline
+
+
+-- -----------------------------------------------------------------------
+-- internal tree list object instances
+-- -----------------------------------------------------------------------
+
+instance CItem a => Eq (TREELISTOBJECT a) where
+ obj1 == obj2 = obj_nm obj1 == obj_nm obj2
+
+instance CItem a => GUIObject (TREELISTOBJECT a) where
+ toGUIObject obj = toGUIObject (embedded_win obj)
+ cname _ = "TREELISTOBJECT"
+
+instance CItem a => HasPhoto (TREELISTOBJECT a) where
+ photo i obj = obj_img obj # photo i >> return obj
+ getPhoto obj = getPhoto (obj_img obj)
+
+name :: CItem a => Name -> Config (TREELISTOBJECT a)
+name nm obj = obj_nm obj # text (full nm) >> return obj
+
+getTreeListObjectName :: CItem a => TREELISTOBJECT a -> IO Name
+getTreeListObjectName obj =
+ do
+ nm <- getName (val obj)
+ return nm
+
+
+-- -----------------------------------------------------------------------
+-- state import / export
+-- -----------------------------------------------------------------------
+
+-- | Imports a previously saved tree list state.
+importTreeListState :: CItem a => TreeList a
+ -- ^ the concerned tree list.
+ -> TreeListState a
+ -- ^ the state to import.
+ -> IO ()
+ -- ^ None.
+importTreeListState tl st =
+ synchronize tl
+ (do
+ clearTreeList tl
+ state <- mkEntries tl st
+ setRef (internal_state tl) state
+ let StateEntry root _ _ _ = head state
+ packTreeListObject root True (5, 5)
+ pho <- getIcon (val root)
+ obj_img root # photo pho
+ insertObjects tl (5 + Distance intendation, 5)
+ (toObjects (tail state))
+ updScrollRegion (cnv tl) (internal_state tl))
+
+toObjects :: [StateEntry a] -> [(Int, Bool, TREELISTOBJECT a)]
+toObjects (StateEntry obj isopen intend _ : ents) =
+ (intend, isopen, obj) : toObjects ents
+toObjects _ = []
+
+mkEntries :: CItem a => TreeList a -> TreeListState a -> IO [StateEntry a]
+mkEntries tl (i : is) =
+ do
+ nm <- getName (obj_val i)
+ obj <- mkTreeListObject tl (obj_val i)
+ (if obj_type i == Node then True else False) (open i)
+ [name nm]
+ rest <- mkEntries tl is
+ return (StateEntry obj (open i) (intend i) [] : rest)
+mkEntries _ _ = return []
+
+data TreeListExportItem a =
+ TreeListExportItem { obj_val :: a,
+ obj_type :: TreeListObjectType,
+ open :: Bool, -- ignored if leaf
+ intend :: Int,
+ selected :: Bool } -- yet ignored, multiple
+ -- selections to come ...
+
+type TreeListState a = [TreeListExportItem a]
+
+-- | Exports the tree list\'s state.
+exportTreeListState :: CItem c => TreeList c
+ -- ^ the concerned tree list.
+ -> IO (TreeListState c)
+ -- ^ The tree list\'s state.
+exportTreeListState tl =
+ synchronize tl
+ (do
+ state <- getRef (internal_state tl)
+ exportTreeListState' tl state)
+ where exportTreeListState' :: CItem c =>
+ TreeList c -> [StateEntry c] ->
+ IO (TreeListState c)
+ exportTreeListState' tl (StateEntry obj open intendation _ :
+ ents) =
+ do
+ sel <- isSelectedTreeList tl obj
+ rest <- exportTreeListState' tl ents
+ return (TreeListExportItem
+ { obj_val = val obj,
+ obj_type = if (is_node obj) then Node else Leaf,
+ open = open,
+ intend = intendation,
+ selected = sel} : rest)
+ exportTreeListState' _ _ = return []
+
+
+-- -----------------------------------------------------------------------
+-- images
+-- -----------------------------------------------------------------------
+
+plusImg :: Image
+plusImg = unsafePerformIO (newImage [imgData GIF "R0lGODlhCQAJAJEAAP///9Dc4H6LjwAAACwAAAAACQAJAEACFJSPiTHdYYIcEopKZax1s35NINcVADs="])
+{-# NOINLINE plusImg #-}
+
+minusImg :: Image
+minusImg = unsafePerformIO (newImage [imgData GIF "R0lGODlhCQAJAJEAAP///9Dc4H6LjwAAACwAAAAACQAJAEACEZSPiTHdYYKcUNAZb9Vb5ysUADs="])
+{-# NOINLINE minusImg #-}
diff --git a/HTk/Toplevel/HTk.hs b/HTk/Toplevel/HTk.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Toplevel/HTk.hs
@@ -0,0 +1,422 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- |
+-- Description: Low-Level Tcl\/Tk interface
+module HTk.Toplevel.HTk (
+
+ requirePackage,
+ forgetPackage,
+ isPackageAvailable,
+ isTixAvailable,
+
+
+-- basic ressources
+
+ module HTk.Kernel.Resources,
+ module HTk.Kernel.GUIValue,
+ module HTk.Kernel.Font,
+ module HTk.Kernel.Geometry,
+ module HTk.Kernel.Colour,
+ module HTk.Kernel.Tooltip,
+ module HTk.Kernel.TkVariables,
+ module Events.Synchronized,
+ module Util.Computation,
+ module HTk.Kernel.Configuration,
+ module HTk.Kernel.BaseClasses,
+ module HTk.Kernel.Cursor,
+
+
+-- text items
+
+ module HTk.Textitems.TextTag,
+ module HTk.Textitems.Mark,
+ module HTk.Textitems.EmbeddedTextWin,
+
+
+-- window submodules
+
+ module HTk.Containers.Window,
+ module HTk.Containers.Toplevel,
+
+
+-- widget submodules
+
+ module HTk.Containers.Frame,
+ module HTk.Widgets.Label,
+ module HTk.Widgets.Message,
+ module HTk.Widgets.Entry,
+ module HTk.Widgets.Button,
+ module HTk.Widgets.CheckButton,
+ module HTk.Widgets.RadioButton,
+ module HTk.Widgets.MenuButton,
+ module HTk.Widgets.Canvas,
+ module HTk.Widgets.Editor,
+ module HTk.Widgets.ListBox,
+ module HTk.Widgets.OptionMenu,
+ module HTk.Widgets.Scale,
+ module HTk.Widgets.ScrollBar,
+ module HTk.Devices.Screen,
+ module HTk.Containers.Box,
+
+
+-- tix submodules
+
+ module HTk.Tix.NoteBook,
+ module HTk.Tix.LabelFrame,
+ module HTk.Tix.PanedWindow,
+ module HTk.Widgets.ComboBox,
+
+
+-- devices submodules
+
+ module HTk.Devices.Bell,
+ module HTk.Devices.Printer,
+
+
+-- menu / menuitem submodules
+
+ module HTk.Menuitems.Menu,
+ module HTk.Menuitems.MenuCascade,
+ module HTk.Menuitems.MenuCommand,
+ module HTk.Menuitems.MenuCheckButton,
+ module HTk.Menuitems.MenuRadioButton,
+ module HTk.Menuitems.MenuSeparator,
+
+
+-- canvasitem submodules
+
+ module HTk.Canvasitems.CanvasItem,
+ module HTk.Canvasitems.Arc,
+ module HTk.Canvasitems.Line,
+ module HTk.Canvasitems.Oval,
+ module HTk.Canvasitems.Polygon,
+ module HTk.Canvasitems.Rectangle,
+ module HTk.Canvasitems.ImageItem,
+ module HTk.Canvasitems.BitMapItem,
+ module HTk.Canvasitems.TextItem,
+ module HTk.Canvasitems.CanvasTag,
+ module HTk.Canvasitems.EmbeddedCanvasWin,
+
+
+-- components submodules
+
+ module HTk.Components.Index,
+ module HTk.Components.BitMap,
+ module HTk.Components.Image,
+ module HTk.Components.Focus,
+ module HTk.Components.Icon,
+ module HTk.Components.Selection,
+
+-- widget packing
+
+ module HTk.Kernel.ButtonWidget,
+ module HTk.Kernel.Packer,
+ module HTk.Kernel.PackOptions,
+ module HTk.Kernel.GridPackOptions,
+
+
+-- events
+
+ module Events.Events,
+ module HTk.Kernel.EventInfo,
+ module Events.Spawn,
+ module Events.Channels,
+ WishEvent(..),
+ WishEventType(..),
+ WishEventModifier(..),
+ KeySym(..),
+ bind,
+ bindSimple,
+ bindPath,
+ bindPathSimple,
+ HasCommand(..),
+
+ delayWish,
+
+-- other basic stuff // TD: sort out!
+
+ initHTk, -- :: [Config HTk] -> IO HTk
+ -- initHTk initialises HTk.
+
+ withdrawMainWin, -- :: Config HTk
+ -- withDraw as a configuration
+
+ resourceFile, -- :: String-> Config HTk
+ -- loads resource file
+
+ finishHTk, -- :: IO ()
+ -- waits for all wish to finish and then terminates
+
+ withdrawWish, -- :: IO ()
+ -- withdrawWish withdraws the wish window.
+
+ HTk,
+
+ updateAllTasks,
+ updateIdleTasks,
+
+ Destructible(..),
+ Destroyable(..),
+
+ cleanupWish,
+
+ getHTk,
+) where
+
+import Control.Concurrent
+
+import Events.Channels
+import Events.Destructible
+import Events.Events
+import Events.Spawn
+import Events.Synchronized
+
+import HTk.Canvasitems.Arc
+import HTk.Canvasitems.BitMapItem
+import HTk.Canvasitems.CanvasItem hiding (Canvas)
+import HTk.Canvasitems.CanvasTag
+import HTk.Canvasitems.EmbeddedCanvasWin
+import HTk.Canvasitems.ImageItem
+import HTk.Canvasitems.Line
+import HTk.Canvasitems.Oval
+import HTk.Canvasitems.Polygon
+import HTk.Canvasitems.Rectangle
+import HTk.Canvasitems.TextItem
+
+import HTk.Components.BitMap
+import HTk.Components.Focus
+import HTk.Components.Icon
+import HTk.Components.Image
+import HTk.Components.Index
+import HTk.Components.Selection
+
+import HTk.Containers.Box
+import HTk.Containers.Frame
+import HTk.Containers.Toplevel
+import HTk.Containers.Window
+
+import HTk.Devices.Bell
+import HTk.Devices.Printer
+import HTk.Devices.Screen
+
+import HTk.Kernel.BaseClasses
+import HTk.Kernel.ButtonWidget
+import HTk.Kernel.Colour
+import HTk.Kernel.Configuration
+import HTk.Kernel.Core
+import HTk.Kernel.Cursor
+import HTk.Kernel.EventInfo
+import HTk.Kernel.Font
+import HTk.Kernel.GUIValue
+import HTk.Kernel.Geometry
+import HTk.Kernel.GridPackOptions
+import HTk.Kernel.PackOptions
+import HTk.Kernel.Packer
+import HTk.Kernel.Resources
+import HTk.Kernel.TkVariables
+import HTk.Kernel.Tooltip
+import HTk.Kernel.Wish
+
+import HTk.Menuitems.Menu
+import HTk.Menuitems.MenuCascade
+import HTk.Menuitems.MenuCheckButton
+import HTk.Menuitems.MenuCommand
+import HTk.Menuitems.MenuRadioButton
+import HTk.Menuitems.MenuSeparator
+
+import HTk.Textitems.EmbeddedTextWin
+import HTk.Textitems.Mark
+import HTk.Textitems.TextTag
+
+import HTk.Tix.LabelFrame
+import HTk.Tix.NoteBook
+import HTk.Tix.PanedWindow
+
+import HTk.Widgets.Button
+import HTk.Widgets.Canvas
+import HTk.Widgets.CheckButton
+import HTk.Widgets.ComboBox
+import HTk.Widgets.Editor
+import HTk.Widgets.Entry
+import HTk.Widgets.Label
+import HTk.Widgets.ListBox
+import HTk.Widgets.MenuButton
+import HTk.Widgets.Message
+import HTk.Widgets.OptionMenu
+import HTk.Widgets.RadioButton
+import HTk.Widgets.Scale
+import HTk.Widgets.ScrollBar
+
+import System.IO.Unsafe
+import Util.Computation
+
+-- -----------------------------------------------------------------------
+-- type HTk and its instances
+-- -----------------------------------------------------------------------
+
+-- | The @HTk@ datatype - a handle for the wish instance and
+-- the main window.
+newtype HTk = HTk GUIOBJECT
+
+-- | Internal.
+instance GUIObject HTk where
+ toGUIObject (HTk obj) = obj
+ cname _ = "HTk"
+
+-- | Internal.
+instance Eq HTk where
+ (HTk obj1) == (HTk obj2) = obj1 == obj2
+
+-- | The wish instance can be destroyed.
+instance Destroyable HTk where
+ -- Destroys the wish instance.
+ destroy = destroy . toGUIObject
+
+-- | The wish instance is associated with the main window (with various
+-- configurations and actions concerning its stacking order, display
+-- status, screen, aspect ratio etc.).
+instance Window HTk
+
+-- | The main window is a container for widgets. You can pack widgets to
+-- the main window via pack or grid command in the
+-- @module HTk.Kernel.Packer@.
+instance Container HTk
+
+-- | You can synchronize on the wish instance.
+instance Synchronized HTk where
+ -- Synchronizes on the wish instance.
+ synchronize = synchronize . toGUIObject
+
+
+-- -----------------------------------------------------------------------
+-- commands
+-- -----------------------------------------------------------------------
+
+--- @doc initHTk
+-- Only one HTk is allowed to exist, of course. It is initialised
+-- by whichever of getHTk and initHTk is called first; once initialised
+-- initHTk may not be called again. So in general, where initHTk is
+-- used, you should use it before any other HTk action.
+theHTkMVar :: MVar (Maybe HTk)
+theHTkMVar = unsafePerformIO (newMVar Nothing)
+{-# NOINLINE theHTkMVar #-}
+
+-- | Initializes HTk.
+initHTk :: [Config HTk]
+ -- ^ the list of configuration options for the wish
+ -- instance \/ main window.
+ -> IO HTk
+ -- ^ The wish instance.
+initHTk cnf =
+ do
+ htkOpt <- takeMVar theHTkMVar
+ htk <- case htkOpt of
+ Nothing -> newHTk cnf
+ Just htk -> return htk -- should we configure again?
+ putMVar theHTkMVar (Just htk)
+ return htk
+
+
+
+--- @doc getHTk
+-- getHTk retrieves the current HTk (initialising if necessary).
+getHTk :: IO HTk
+getHTk =
+ do
+ htkOpt <- takeMVar theHTkMVar
+ htk <- case htkOpt of
+ Nothing -> newHTk []
+ Just htk -> return htk
+ putMVar theHTkMVar (Just htk)
+ return htk
+
+--- @doc newHTk
+-- newHTk actually creates a new HTk. DO NOT call this except
+-- by initHTk or getHTk!
+newHTk :: [Config HTk] -> IO HTk
+newHTk opts =
+ do
+ obj <- createHTkObject htkMethods
+ configure (HTk obj) opts
+ return (HTk obj)
+
+--- @doc withdrawWish
+-- withdrawWish withdraws the wish window.
+withdrawWish :: IO ()
+withdrawWish =
+ do
+ htk <- getHTk
+ withdraw htk
+
+-- | Withdraws the main window.
+withdrawMainWin :: Config HTk
+withdrawMainWin htk =
+ do
+ withdraw htk
+ return htk
+
+--- @doc readResourceFile
+-- Load a resource file
+-- A resource files specifies the default options for fonts, colours, &c.
+resourceFile :: String-> Config HTk
+resourceFile file htk =
+ do execCmd ("option readfile "++ file++ " startup")
+ -- "startup" is the priority; we could make this user-
+ -- configurable if wished?
+ return htk
+
+--- @doc finishHTk
+-- waits for HTk to finish, and calls cleanupWish to clean up.
+-- This rebinds the Destroy event of the main window, so
+-- do not call this function if you have bound anything to that.
+-- In that case, call cleanupWish after you have finished with wish.
+finishHTk :: IO ()
+finishHTk =
+ do htk <- getHTk
+ (htk_destr, _) <- bindSimple htk Destroy
+ sync htk_destr
+ cleanupWish
+
+
+-- -----------------------------------------------------------------------
+-- HTk methods
+-- -----------------------------------------------------------------------
+
+htkMethods = Methods tkGetToplevelConfig
+ tkSetToplevelConfigs
+ (createCmd voidMethods)
+ (packCmd voidMethods)
+ (gridCmd voidMethods)
+ (destroyCmd defMethods)
+ (bindCmd defMethods)
+ (unbindCmd defMethods)
+ (cleanupCmd defMethods)
+
+
+-- -----------------------------------------------------------------------
+-- application updates
+-- -----------------------------------------------------------------------
+
+-- | Updates all tasks.
+updateAllTasks :: IO ()
+updateAllTasks = execTclScript ["update"]
+
+-- | Updates idle tasks.
+updateIdleTasks :: IO ()
+updateIdleTasks = execTclScript ["update idletasks"]
+
+
+-- -----------------------------------------------------------------------
+-- application Name
+-- -----------------------------------------------------------------------
+
+-- | The wish instance has a value - the application name.
+instance GUIValue v => HasValue HTk v where
+ -- Sets the application name.
+ value aname htk =
+ do
+ execTclScript ["tk appname " ++ show aname]
+ return htk
+ -- Gets the application name.
+ getValue _ = evalTclScript ["tk appname"] >>= creadTk
diff --git a/HTk/Widgets/Button.hs b/HTk/Widgets/Button.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Widgets/Button.hs
@@ -0,0 +1,119 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | HTk\'s /button widget/.
+-- A simple click button.
+module HTk.Widgets.Button (
+
+ Button,
+ newButton
+
+) where
+
+import Util.Computation
+import Events.Destructible
+import Events.Synchronized
+
+import HTk.Kernel.Core
+import HTk.Kernel.ButtonWidget
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import HTk.Components.Image
+import HTk.Components.BitMap
+import HTk.Kernel.Packer
+import HTk.Kernel.Tooltip
+
+
+-- -----------------------------------------------------------------------
+-- type
+-- -----------------------------------------------------------------------
+
+-- | The @Button@ datatype.
+newtype Button = Button GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- creation
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new button widget and returns a handler.
+newButton :: Container par => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> [Config Button]
+ -- ^ the list of configuration options for this button.
+ -> IO Button
+ -- ^ A button widget.
+newButton par cnf =
+ do
+ b <- createGUIObject (toGUIObject par) BUTTON defMethods
+ configure (Button b) cnf
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject Button where
+ toGUIObject (Button w) = w
+ cname _ = "Button"
+
+-- | A button widget can be destroyed.
+instance Destroyable Button where
+ -- Destroys a button widget.
+ destroy = destroy . toGUIObject
+
+-- | A button widget has standard widget properties
+-- (concerning focus, cursor).
+instance Widget Button
+
+-- | A button widget can be flashed (redisplayed several times in
+-- alternate colours) and invoked (the associated event).
+instance ButtonWidget Button
+
+-- | A button widget can contain a bitmap.
+instance HasBitMap Button
+
+-- | A button widget has a configureable border.
+instance HasBorder Button
+
+-- | A button widget has a normal foreground and background colour and an
+-- active\/disabled foreground and background colour.
+instance HasColour Button where
+ legalColourID = buttonColours
+
+-- | A button widget is a stateful widget, it can be enabled or disabled.
+instance HasEnable Button
+
+-- | You can specify the font of a button.
+instance HasFont Button
+
+-- | A button has a configureable text justification.
+instance HasJustify Button
+
+-- | A button can contain an image.
+instance HasPhoto Button
+
+-- | You can specify the size of a button.
+instance HasSize Button
+
+-- | A button can contain text.
+instance GUIValue v => HasText Button v
+
+-- | You can set the index of a text character to underline.
+instance HasUnderline Button
+
+-- | You can synchronize on a button object.
+instance Synchronized Button where
+ -- Synchronizes on a button object.
+ synchronize = synchronize . toGUIObject
+
+-- | When a button is clicked, a corresponding event is invoked.
+instance HasCommand Button
+
+-- | A button can have a tooltip.
+instance HasTooltip Button
+
+-- | A button has a text anchor.
+instance HasAnchor Button
diff --git a/HTk/Widgets/Canvas.hs b/HTk/Widgets/Canvas.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Widgets/Canvas.hs
@@ -0,0 +1,303 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | HTk's canvas widget.
+-- A canvas is a drawing pad, that can also contain widgets in embedded
+-- windows.
+-- A canvas widget contains canvas items.
+module HTk.Widgets.Canvas (
+
+ Canvas,
+ newCanvas,
+
+ closeEnough,
+ getCloseEnough,
+
+ confine,
+ getConfine,
+
+ screenToCanvasCoord,
+
+ ScrollRegion,
+ scrollRegion,
+ getScrollRegion,
+
+ scrollIncrement,
+-- getScrollIncrementer
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import HTk.Kernel.Resources
+import HTk.Kernel.Geometry
+import HTk.Widgets.ScrollBar
+import HTk.Devices.Printer
+import Util.Computation
+import Events.Destructible
+import Events.Synchronized
+import HTk.Kernel.Packer
+import HTk.Kernel.Tooltip
+
+
+-- -----------------------------------------------------------------------
+-- canvas
+-- -----------------------------------------------------------------------
+
+-- | The @Canvas@ datatype.
+newtype Canvas = Canvas GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- constructor
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new canvas widget and returns a handler.
+newCanvas :: Container par => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> [Config Canvas]
+ -- ^ the list of configuration options for this canvas.
+ -> IO Canvas
+ -- ^ A canvas widget.
+newCanvas par cnf = do
+ w <- createGUIObject (toGUIObject par) CANVAS canvasMethods
+ configure (Canvas w) cnf
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject Canvas where
+ toGUIObject (Canvas w) = w
+ cname _ = "Canvas"
+
+-- | A canvas widget can be destroyed.
+instance Destroyable Canvas where
+ -- Destroys a canvas widget.
+ destroy = destroy . toGUIObject
+
+-- | A canvas widget has standard widget properties
+-- (concerning focus, cursor).
+instance Widget Canvas
+
+-- | A canvas is also a container for widgets, because it can contain
+-- widgets in embedded windows.
+instance Container Canvas
+
+-- | A canvas widget has a configureable border.
+instance HasBorder Canvas
+
+-- | A canvas widget has a foreground and background colour.
+instance HasColour Canvas where
+ legalColourID = hasBackGroundColour
+
+-- | A canvas widget is a stateful widget, it can be enabled or disabled.
+instance HasEnable Canvas
+
+-- | You can specify the size of a canvas.
+instance HasSize Canvas
+
+-- | A canvas is a scrollable widget.
+instance HasScroller Canvas
+
+-- | The contents of a canvas is printable.
+instance HasPostscript Canvas
+
+-- | You can synchronize on a canvas object (in JAVA style).
+instance Synchronized Canvas where
+ -- Synchronizes on a canvas object.
+ synchronize = synchronize . toGUIObject
+
+-- | A canvas can have a tooltip (only displayed if you are using tixwish).
+instance HasTooltip Canvas
+
+
+-- -----------------------------------------------------------------------
+-- canvas-specific configuration options
+-- -----------------------------------------------------------------------
+
+-- | Sets the maximum distance from the mouse to an overlapped object.
+closeEnough :: Double
+ -- ^ the distance to be set.
+ -> Canvas
+ -- ^ the canvas to apply this configuration.
+ -> IO Canvas
+ -- ^ The concerned canvas.
+closeEnough dist cnv = cset cnv "closeenough" dist
+
+-- | Selector for the maximum distance from the mouse to an overlapped
+-- object.
+getCloseEnough :: Canvas
+ -- ^ the canvas to get this configuration from.
+ -> IO Double
+ -- ^ The requested distance.
+getCloseEnough cnv = cget cnv "closeenough"
+
+-- | @True@ constraints view to the scroll region.
+confine :: Bool
+ -- ^ @Bool@, see above.
+ -> Canvas
+ -- ^ the canvas to apply this configuration.
+ -> IO Canvas
+ -- ^ The concerned canvas.
+confine b cnv = cset cnv "confine" b
+
+-- | Selector for the @confine@ configuration, constraints view
+-- to the scroll region if @True@.
+getConfine :: Canvas
+ -- ^ the canvas to get this configuration from.
+ -> IO Bool
+ -- ^ The confine configuration as a @Bool@
+ -- value (see @confine@).
+getConfine w = cget w "confine"
+
+
+-- -----------------------------------------------------------------------
+-- bounding boxes
+-- -----------------------------------------------------------------------
+
+-- | You can request the bounding box size of a canvas item (use a canvas
+-- tag for the bounding box of a set of items).
+instance GUIObject c => HasBBox Canvas c where
+
+-- Gets the bounding box of a canvas item.
+-- cnv - the concerned canvas.
+-- item - the concerned canvas item.
+-- result is the requested bounding box (upper left position,
+-- lower right position).
+ bbox cnv item =
+ do
+ objnm <- getObjectName (toGUIObject item)
+ ans <- try (evalMethod cnv (\nm -> tkBBox nm objnm))
+ case ans of
+ Left e -> return Nothing
+ Right a -> return (Just a)
+
+tkBBox :: ObjectName -> ObjectName -> TclScript
+tkBBox nm (CanvasItemName _ cid) =
+ ["global " ++ drop 1 (show cid), show nm ++ " bbox " ++ show cid]
+tkBBox _ _ = []
+{-# INLINE tkBBox #-}
+
+
+-- -----------------------------------------------------------------------
+-- coordinate transformation
+-- -----------------------------------------------------------------------
+
+-- | Maps from screen X or Y coordinates (orientation parameter) to the
+-- corresponding coordinates in canvas space.
+screenToCanvasCoord :: Canvas
+ -- ^ the concerned canvas widget.
+ -> Orientation
+ -- ^ the orientation
+ -- (@Vertical@ or @Horizontal@).
+ -> Distance
+ -- ^ the input coordinate.
+ ->
+ Maybe Distance
+ -- ^ an optional grid (the output can be rounded to
+ -- multiples of this grid if specified).
+ -> IO Distance
+ -- ^ The requested distance in the specified orientation.
+screenToCanvasCoord cnv orient dist grid =
+ evalMethod cnv (\nm -> tkCanvas nm orient dist grid)
+
+
+-- -----------------------------------------------------------------------
+-- scrolling
+-- -----------------------------------------------------------------------
+
+-- | The @ScrollRegion@ datatype (scrollable region of the canvas
+-- widget).
+type ScrollRegion = (Position, Position)
+
+-- | Sets the scrollable region for a canvas widget.
+scrollRegion :: ScrollRegion
+ -- ^ the scroll region to set.
+ -> Canvas
+ -- ^ the canvas widget to apply this scrollregion.
+ -> IO Canvas
+ -- ^ The concerned canvas.
+scrollRegion reg@((x1, y1), (x2, y2)) cnv =
+ let reg = " { " ++ show x1 ++ " " ++ show y1 ++ " " ++ show x2 ++ " " ++
+ show y2 ++ " }"
+ in cset cnv ("scrollregion" ++ reg) ([] :: [Position])
+
+-- | Gets the applied scroll region from a canvas widget.
+getScrollRegion :: Canvas
+ -- ^ the canvas widget to get the applied scroll region
+ -- from.
+ -> IO ScrollRegion
+ -- ^ The requested scroll region.
+getScrollRegion cnv =
+ cget cnv "scrollregion" >>= \reg ->
+ case reg of
+ [p1,p2] -> return (p1,p2)
+ _ -> return ((0,0), (0,0))
+
+-- | Sets the distance for one scrolling unit.
+scrollIncrement :: Orientation
+ -- ^ the orientation
+ -- (@Vertical@ or @Horizontal@).
+ -> Distance
+ -- ^ the distance to set.
+ -> Canvas
+ -- ^ the canvas widget to apply this scrolling
+ -- distance.
+ -> IO Canvas
+ -- ^ The concerned canvas.
+scrollIncrement orient dist cnv =
+ case orient of Horizontal -> cset cnv "xscrollincrement" dist
+ _ -> cset cnv "yscrollincrement" dist
+
+-- | Gets the applied minimum scrolling distance from a canvas widget.
+getScrollIncrement :: Orientation
+ -- ^ the orientation
+ -- (@Vertical@ or @Horizontal@).
+ -> Canvas
+ -- ^ the canvas widget to get the applied minimum
+ -- scrolling distance from.
+ -> IO Distance
+ -- ^ The requested minimum scrolling distance.
+getScrollIncrement orient cnv =
+ case orient of Horizontal -> cget cnv "xscrollincrement"
+ Vertical -> cget cnv "yscrollincrement"
+
+
+-- -----------------------------------------------------------------------
+-- canvas methods
+-- -----------------------------------------------------------------------
+
+canvasMethods = defMethods { cleanupCmd = tkCleanupCanvas,
+ createCmd = tkCreateCanvas }
+
+
+-- -----------------------------------------------------------------------
+-- Tk commands
+-- -----------------------------------------------------------------------
+
+tkCreateCanvas :: ObjectName -> ObjectKind -> ObjectName -> ObjectID ->
+ [ConfigOption] -> TclScript
+tkCreateCanvas pnm kind name oid confs =
+ tkDeclVar ("sv" ++ show oid) (show name) ++
+ (createCmd defMethods) pnm kind name oid confs
+{-# INLINE tkCreateCanvas #-}
+
+tkCleanupCanvas :: ObjectID -> ObjectName -> TclScript
+tkCleanupCanvas oid _ = tkUndeclVar ("sv" ++ show oid)
+{-# INLINE tkCleanupCanvas #-}
+
+tkCanvas :: ObjectName -> Orientation -> Distance -> Maybe Distance ->
+ TclScript
+tkCanvas nm Horizontal d sp =
+ [show nm ++ " canvasx " ++ show d ++ showGrid sp]
+tkCanvas nm Vertical d sp =
+ [show nm ++ " canvasy " ++ show d ++ showGrid sp]
+{-# INLINE tkCanvas #-}
+
+showGrid Nothing = ""
+showGrid (Just gs) = " " ++ show gs
diff --git a/HTk/Widgets/CheckButton.hs b/HTk/Widgets/CheckButton.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Widgets/CheckButton.hs
@@ -0,0 +1,134 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | HTk\'s /checkbutton/ widget.
+-- A simple checkbutton associated with a polymorphic variable.
+module HTk.Widgets.CheckButton (
+
+ CheckButton,
+ newCheckButton
+
+) where
+
+import Util.Computation
+import Events.Destructible
+import Events.Synchronized
+
+import HTk.Kernel.Core
+import HTk.Kernel.ButtonWidget
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import HTk.Components.Image
+import HTk.Components.BitMap
+import HTk.Kernel.TkVariables
+import HTk.Kernel.Packer
+import HTk.Kernel.Tooltip
+
+
+-- -----------------------------------------------------------------------
+-- type
+-- -----------------------------------------------------------------------
+
+-- | The @CheckButton@ datatpe - it is associated with a
+-- polymorphic @TkVariable@.
+newtype CheckButton a = CheckButton GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- creation
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new checkbutton widget and returns a handler.
+newCheckButton :: Container par => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> [Config (CheckButton a)]
+ -- ^ the list of configuration options for this
+ -- checkbutton.
+ ->
+ IO (CheckButton a)
+ -- ^ A checkbutton widget.
+newCheckButton par cnf =
+ do
+ b <- createGUIObject (toGUIObject par) CHECKBUTTON defMethods
+ configure (CheckButton b) cnf
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject (CheckButton a) where
+ toGUIObject (CheckButton w) = w
+ cname _ = "CheckButton"
+
+-- | A checkbutton widget can be destroyed.
+instance Destroyable (CheckButton a) where
+ -- Destroys a checkbutton widget.
+ destroy = destroy . toGUIObject
+
+-- | A checkbutton widget has standard widget properties
+-- (concerning focus, cursor).
+instance Widget (CheckButton a)
+
+-- | A checkbutton widget can be flashed (redisplayed several times in
+-- alternate colours) and invoked (the associated event) as any button
+-- widget.
+instance ButtonWidget (CheckButton a)
+
+-- | A checkbutton widget can contain a bitmap.
+instance HasBitMap (CheckButton a)
+
+-- | A checkbutton widget has a configureable border.
+instance HasBorder (CheckButton a)
+
+-- | A checkbutton widget has a normal foreground and background colour and
+-- an active\/disabled foreground and background colour.
+instance HasColour (CheckButton a) where
+ legalColourID = buttonColours
+
+-- | A checkbutton widget is a stateful widget, it can be enabled or
+-- disabled.
+instance HasEnable (CheckButton a)
+
+-- | You can specify the font of a checkbutton.
+instance HasFont (CheckButton a)
+
+-- | A checkbutton has a text justification configuration.
+instance HasJustify (CheckButton a)
+
+-- | A checkbutton can contain an image.
+instance HasPhoto (CheckButton a)
+
+-- | You can specify the size of a checkbutton.
+instance HasSize (CheckButton a)
+
+-- | A checkbutton can contain text.
+instance GUIValue v => HasText (CheckButton a) v
+
+-- | You can set the index of a text character to underline.
+instance HasUnderline (CheckButton a)
+
+-- | You can synchronize on a checkbutton object.
+instance Synchronized (CheckButton a) where
+ -- Synchronizes on a checkbutton object.
+ synchronize = synchronize . toGUIObject
+
+-- | When a checkbutton is clicked, a corresponding event is invoked.
+instance HasCommand (CheckButton a)
+
+-- | A checkbutton has a value, that corresponds to a polymorphic
+-- @TkVariable@.
+-- instance GUIValue a => HasValue (CheckButton a) a
+-- No, it doesn\'t.
+
+-- | The polymorphic variable the checkbutton\'s value is associated with.
+instance HasVariable (CheckButton a)
+
+-- | An checkbutton can have a tooltip (only displayed if you are using
+-- tixwish).
+instance HasTooltip (CheckButton a)
+
+-- | A checkbutton has a text anchor.
+instance HasAnchor (CheckButton a)
diff --git a/HTk/Widgets/ComboBox.hs b/HTk/Widgets/ComboBox.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Widgets/ComboBox.hs
@@ -0,0 +1,181 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+-- | HTk\'s /ComboBox/.
+-- Only available when using tixwish. However this module needs to go
+-- in the uni-htk-widgets package because it depends on it.
+module HTk.Widgets.ComboBox (
+
+ ComboBox,
+ newComboBox,
+
+ pick,
+ entrySubwidget,
+ listBoxSubwidget
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import Util.Computation
+import Events.Synchronized
+import Events.Destructible
+import HTk.Kernel.Packer
+import HTk.Widgets.Entry
+import HTk.Widgets.ListBox
+import HTk.Tix.Subwidget
+
+
+-- -----------------------------------------------------------------------
+-- datatype
+-- -----------------------------------------------------------------------
+
+-- | The @ComboBox@ datatype.
+-- A ComboBox is a so called mega widget composed of an entry widget
+-- and a list box. Both subwidgets are accessible by themselves.
+
+data GUIValue a =>
+ ComboBox a = ComboBox GUIOBJECT (Entry a) (ListBox a)
+ deriving Eq
+
+-- | Retrieve the entry subwidget of a combo box.
+entrySubwidget :: GUIValue a => ComboBox a -> Entry a
+entrySubwidget (ComboBox _ x _) = x
+
+-- | Retrieve the list box subwidget of a combo box.
+listBoxSubwidget :: GUIValue a => ComboBox a -> ListBox a
+listBoxSubwidget (ComboBox _ _ x) = x
+
+-- -----------------------------------------------------------------------
+-- combo box creation
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new combo box and returns a handler.
+newComboBox :: (GUIValue a, Container par) =>
+ par
+ -- ^ the list of configuration options for this
+ -- combo box.
+ -> Bool
+ -- ^ true if the user should be allowed to type into the
+ -- entry of the ComboBox.
+ -> [Config (ComboBox a)]
+ -> IO (ComboBox a)
+ -- ^ A combo box.
+newComboBox par editable cnf =
+ do
+ cb <- createGUIObject (toGUIObject par) (COMBOBOX editable) comboBoxMethods
+ e <- createAsSubwidget cb
+ lb <- createAsSubwidget cb
+ configure (ComboBox cb e lb) cnf
+
+
+-- -----------------------------------------------------------------------
+-- combo box specific commands and options
+-- -----------------------------------------------------------------------
+
+-- | Sets the index item in the listbox to be the current value of the
+-- ComboBox.
+pick :: GUIValue a => Int -> Config (ComboBox a)
+pick i cb = execMethod cb (\nm -> tkPick nm i) >> return cb
+
+-- -----------------------------------------------------------------------
+-- combo box methods
+-- -----------------------------------------------------------------------
+
+comboBoxMethods :: Methods
+comboBoxMethods = Methods (cgetCmd defMethods)
+ (csetCmd defMethods)
+ tkCreateComboBox
+ (packCmd defMethods)
+ (gridCmd defMethods)
+ (destroyCmd defMethods)
+ (bindCmd defMethods)
+ (unbindCmd defMethods)
+ (cleanupCmd defMethods)
+
+
+-- -----------------------------------------------------------------------
+-- combo box instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIValue a => GUIObject (ComboBox a) where
+ toGUIObject (ComboBox f _ _) = f
+
+ cname _ = "ComboBox"
+
+-- | The value of a combo box is the list of the displayed objects (these
+-- are instances of class @GUIValue@ and therefore instances
+-- of class @Show@).
+instance (GUIValue a, GUIValue [a]) => HasValue (ComboBox a) [a] where
+ value vals w =
+ execMethod w (\nm -> tkInsert nm 0 (map toGUIValue vals)) >> return w
+ -- Gets the list of displayed objects.
+ getValue w = evalMethod w (\nm -> tkGet nm)
+
+-- | A combo box has standard widget properties (focus, cursor, ...).
+instance GUIValue a => Widget (ComboBox a)
+
+-- | A combo box widget can be destroyed.
+instance GUIValue a => Destroyable (ComboBox a) where
+ -- Destroys a combo box widget.
+ destroy = destroy . toGUIObject
+
+-- | A combo box widget has a configureable border.
+instance GUIValue a => HasBorder (ComboBox a)
+
+-- | A combo box widget has a text anchor.
+instance GUIValue a => HasAnchor (ComboBox a)
+
+-- | A combo box widget has a background colour.
+instance GUIValue a => HasColour (ComboBox a) where
+ legalColourID = hasBackGroundColour
+
+-- | You can specify the size of a combo box widget-
+instance GUIValue a => HasSize (ComboBox a)
+
+-- | You can synchronize on a combo box widget.
+instance GUIValue a => Synchronized (ComboBox a) where
+ -- Synchronizes on a combo box widget.
+ synchronize = synchronize . toGUIObject
+
+-- | A combo box widget is a stateful widget, it can be enabled or disabled.
+instance GUIValue a => HasEnable (ComboBox a)
+
+-- -----------------------------------------------------------------------
+-- Tk commands
+-- -----------------------------------------------------------------------
+
+tkCreateComboBox :: ObjectName -> ObjectKind -> ObjectName ->
+ ObjectID -> [ConfigOption] -> TclScript
+tkCreateComboBox _ (COMBOBOX editable) name _ opts =
+ ["tixComboBox " ++ show name ++ " -editable " ++ show editable ++
+ showConfigs opts]
+tkCreateComboBox _ _ _ _ _ = []
+{-# INLINE tkCreateComboBox #-}
+
+tkInsert :: ObjectName -> Int -> [GUIVALUE] -> TclScript
+tkInsert name inx elems =
+ [tkDelete name "0" "end",
+ show name ++ " subwidget listbox insert " ++ show inx ++ " " ++
+ showElements elems]
+{-# INLINE tkInsert #-}
+
+tkDelete :: ObjectName -> String -> String -> TclCmd
+tkDelete name first last =
+ show name ++ " subwidget listbox delete " ++ first ++ " " ++ last
+{-# INLINE tkDelete #-}
+
+tkGet :: ObjectName -> TclScript
+tkGet name = [show name ++ " subwidget entry get"]
+{-# INLINE tkGet #-}
+
+showElements :: [GUIVALUE] -> String
+showElements = concatMap (++ " ") . (map show)
+{-# INLINE showElements #-}
+
+tkPick :: ObjectName -> Int -> TclScript
+tkPick name index = [show name ++ " pick " ++ show index]
+{-# INLINE tkPick #-}
+
diff --git a/HTk/Widgets/Editor.hs b/HTk/Widgets/Editor.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Widgets/Editor.hs
@@ -0,0 +1,879 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | HTk\'s /editor widget/.
+-- A text container for editing purposes. An editor widget can contain
+-- text tags, to which you can bind events, and also embedded windows.
+module HTk.Widgets.Editor (
+
+ Editor,
+ newEditor,
+
+ deleteText,
+ deleteTextRange,
+ getTextRange,
+ insertText,
+ insertNewline,
+ getTextLine,
+ appendText,
+
+ getIndexPosition,
+ compareIndices,
+
+ writeTextToFile,
+ readTextFromFile,
+
+ HasTabulators(..),
+ HasLineSpacing(..),
+
+ adjustViewTo,
+
+ scanMark,
+ scanDragTo,
+
+ SearchDirection(..),
+ SearchMode(..),
+ SearchSwitch(..),
+ search,
+
+ IndexModifiers(..),
+ IndexModifier(..),
+
+ WrapMode(..),
+ wrap,
+ getWrapMode
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import HTk.Kernel.Resources
+import HTk.Kernel.Geometry
+import HTk.Widgets.ScrollBar
+import HTk.Components.Selection
+import HTk.Devices.XSelection
+import HTk.Components.ICursor
+import HTk.Components.Index
+import Data.Char(isSpace)
+import Util.Computation
+import Events.Destructible
+import Events.Synchronized
+import HTk.Kernel.Packer
+import HTk.Kernel.Tooltip
+
+
+-- -----------------------------------------------------------------------
+-- Editor
+-- -----------------------------------------------------------------------
+
+-- | The @Editor@ datatpe.
+newtype Editor = Editor GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- creation
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new editor widget and returns it as a value.
+newEditor :: Container par => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> [Config Editor]
+ -- ^ the list of configuration options for this editor.
+ -> IO Editor
+ -- ^ An editor widget.
+newEditor par cnf =
+ do
+ w <- createGUIObject (toGUIObject par) (TEXT cdefault) textMethods
+ tp <- return (Editor w)
+ configure tp cnf
+ where defvalue :: GUIValue a => Editor -> a -> a
+ defvalue tp a = a
+
+
+-- -----------------------------------------------------------------------
+-- instantiations
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject Editor where
+ -- Internal.
+ toGUIObject (Editor w) = w
+ -- Internal.
+ cname _ = "Text"
+
+-- | An editor widget can be destroyed.
+instance Destroyable Editor where
+ -- Destroys a check button widget.
+ destroy = destroy . toGUIObject
+
+-- | An editor widget has standard widget properties
+-- (concerning focus, cursor).
+instance Widget Editor
+
+-- | An editor is also a container for widgets, because it can contain
+-- widgets in embedded windows.
+instance Container Editor
+
+-- | A editor widget has a configureable border.
+instance HasBorder Editor
+
+-- | An editor widget has a foreground and background colour.
+instance HasColour Editor where
+ -- Internal.
+ legalColourID = hasForeGroundColour
+
+-- | You can specify the size of an editor widget.
+instance HasSize Editor
+
+-- | You can specify the font of an editor widget.
+instance HasFont Editor
+
+-- | A editor widget is a stateful widget, it can be enabled or
+-- disabled.
+instance HasEnable Editor
+
+-- | You can adjust the line spacing of an editor widget.
+instance HasLineSpacing Editor
+
+-- | An editor widget has adjustable tab stops.
+instance HasTabulators Editor
+
+-- | An editor is a scrollable widget.
+instance HasScroller Editor
+
+-- | You can synchronize on an editor widget.
+instance Synchronized Editor where
+ -- Synchronizes on an editor widget.
+ synchronize = synchronize . toGUIObject
+
+-- | An editor widget has a value (its textual content).
+instance GUIValue a => HasValue Editor a where
+ -- Sets the editor\'s value.
+ value val w = setTextLines w val >> return w
+ -- Gets the editor\'s value.
+ getValue w = getTextLines w
+
+-- | An editor widget can have a tooltip.
+instance HasTooltip Editor
+
+
+-- -----------------------------------------------------------------------
+-- commands for getting and setting the text content
+-- -----------------------------------------------------------------------
+
+getTextLines :: GUIValue a => Editor -> IO a
+getTextLines tp =
+ do
+ start' <- getBaseIndex tp ((1,0) :: Position)
+ end' <- getBaseIndex tp (EndOfText,BackwardChars 1)
+ evalMethod tp (\nm -> tkGetText nm start' (Just end'))
+ where wid = toGUIObject tp
+
+setTextLines :: GUIValue a => Editor -> a -> IO ()
+setTextLines tp lns =
+ do
+ deleteTextRange tp ((1,0) :: Position) EndOfText
+ start' <- getBaseIndex tp ((1,0) :: Position)
+ execMethod tp (\nm -> tkInsertText nm start' val)
+ where wid = toGUIObject tp
+ val = toGUIValue lns
+
+
+-- -----------------------------------------------------------------------
+-- commands for reading and writing texts
+-- -----------------------------------------------------------------------
+
+-- | Deletes the character at the specified index.
+deleteText :: HasIndex Editor i BaseIndex => Editor
+ -- ^ the concerned editor widget.
+ -> i
+ -- ^ the concerned index.
+ -> IO ()
+ -- ^ None.
+deleteText ed i =
+ do
+ pos <- getBaseIndex ed i
+ execMethod ed (\nm -> tkDeleteText nm pos Nothing)
+
+-- | Deletes the text in the specified range.
+deleteTextRange :: (HasIndex Editor i1 BaseIndex,
+ HasIndex Editor i2 BaseIndex) =>
+ Editor
+ -- ^ the start index.
+ -> i1
+ -- ^ the end index.
+ -> i2
+ -> IO ()
+ -- ^ None.
+deleteTextRange tp start end =
+ do
+ start' <- getBaseIndex tp start
+ end' <- getBaseIndex tp end
+ execMethod tp (\nm -> tkDeleteText nm start' (Just end'))
+
+-- | Gets the text in the specified range.
+getTextRange :: (HasIndex Editor i1 BaseIndex,
+ HasIndex Editor i2 BaseIndex) =>
+ Editor
+ -- ^ the concerned editor widget.
+ -> i1
+ -- ^ the start index.
+ -> i2
+ -- ^ the end index.
+ -> IO String
+ -- ^ The editor\'s text in the specified range.
+getTextRange ed start end =
+ do
+ start' <- getBaseIndex ed start
+ end' <- getBaseIndex ed end
+ evalMethod ed (\nm -> tkGetText nm start' (Just end'))
+
+-- | Inserts the given text at the specified index.
+insertText :: (HasIndex Editor i BaseIndex,GUIValue a) =>
+ Editor
+ -- ^ the concerned editor widget.
+ -> i
+ -- ^ the index to insert the text.
+ -> a
+ -- ^ the text to insert.
+ -> IO ()
+ -- ^ None.
+insertText ed i txt =
+ do
+ pos <- getBaseIndex ed i
+ execMethod ed (\nm -> tkInsertText nm pos val)
+ where val = toGUIValue txt
+
+-- | Inserts a newline character at the end of the editor widget.
+insertNewline :: Editor
+ -- ^ the concerned editor widget.
+ -> IO ()
+ -- ^ None.
+insertNewline ed = execMethod ed (\nm -> tkInsertNewLine nm)
+
+-- | Gets a text line from an editor widget.
+getTextLine :: HasIndex Editor i BaseIndex =>
+ Editor
+ -- ^ the concerned editor widget.
+ -> i
+ -- ^ an index in the requested text line.
+ -> IO String
+ -- ^ The requested line of text.
+getTextLine tp i =
+ do
+ (l,c) <- getIndexPosition tp i
+ getTextRange tp (start l) (end l)
+ where start l = (l,0::Distance)
+ end l = ((l+1,0::Distance ),BackwardChars 1)
+
+-- | Appends text at the end of the editor widget.
+appendText :: Editor
+ -- ^ the concerned editor widget.
+ -> String
+ -- ^ the text to append.
+ -> IO ()
+ -- ^ None.
+appendText ed str =
+ do
+ try (insertText ed EndOfText str)
+ moveto Vertical ed 1.0
+ done
+
+
+-- -----------------------------------------------------------------------
+-- Editor to/from files
+-- -----------------------------------------------------------------------
+
+-- | Writes the contained text to a file.
+writeTextToFile :: Editor
+ -- ^ the concerned editor widget.
+ -> FilePath
+ -- ^ the name of the file.
+ -> IO ()
+ -- ^ None.
+writeTextToFile ed fnm =
+ do
+ str <- getValue ed
+ writeFile fnm str
+
+-- | Reads a text from a file and inserts it into the editor pane.
+readTextFromFile :: Editor
+ -- ^ the concerned editor widget.
+ -> FilePath
+ -- ^ the name of the file.
+ -> IO ()
+ -- ^ None.
+readTextFromFile ed fnm =
+ do
+ str <- readFile fnm
+ configure ed [value str]
+ done
+
+
+-- -----------------------------------------------------------------------
+-- BBox
+-- -----------------------------------------------------------------------
+
+-- | You can find out the bounding box of characters inside an editor
+-- widget.
+instance (HasIndex Editor i BaseIndex) => HasBBox Editor i where
+ -- Returns the bounding box of the character at the specified index.
+ bbox w i =
+ do
+ binx <- getBaseIndex w i
+ ans <- try (evalMethod w (\nm -> [tkBBox nm (binx::BaseIndex)]))
+ case ans of (Left e) -> return Nothing
+ (Right v) -> return (Just v)
+ where tkBBox nm i = show nm ++ " bbox " ++ show i
+
+
+-- -----------------------------------------------------------------------
+-- HasIndex
+-- -----------------------------------------------------------------------
+
+-- | A base index is a valid index for an editor widget.
+instance HasIndex Editor BaseIndex BaseIndex where
+ -- Internal.
+ getBaseIndex w i = return i
+
+-- | The @EndOfText@ index is a valid index for an editor widget.
+instance HasIndex Editor EndOfText BaseIndex where
+ -- Internal.
+ getBaseIndex w _ = return (IndexText "end")
+
+-- | A position in pixels is a valid index for an editor widget.
+instance HasIndex Editor Pixels BaseIndex where
+ -- Internal.
+ getBaseIndex w p = return (IndexText (show p))
+
+-- | A pair of line and character is a valid index for an editor widget.
+instance HasIndex Editor (Distance, Distance) BaseIndex where
+ -- Internal.
+ getBaseIndex w pos = return (IndexPos pos)
+
+-- | A pair of a valid index and a list of index modifiers is a valid index
+-- for an editor widget.
+instance HasIndex Editor i BaseIndex =>
+ HasIndex Editor (i,[IndexModifier]) BaseIndex where
+ -- Internal.
+ getBaseIndex tp (i,ml) =
+ do
+ bi <- getBaseIndex tp i
+ return
+ (IndexText (show (bi::BaseIndex) ++ show (IndexModifiers ml)))
+
+-- | A pair of a valid index and an index modifier is a valid index for an
+-- editor widget.
+instance HasIndex Editor i BaseIndex =>
+ HasIndex Editor (i,IndexModifier) BaseIndex where
+ -- Internal.
+ getBaseIndex tp (i,m) =
+ do
+ bi <- getBaseIndex tp i
+ return (IndexText (show (bi::BaseIndex) ++ show m))
+
+-- | Internal.
+instance HasIndex Editor i BaseIndex =>
+ HasIndex Editor i (Distance,Distance) where
+ -- Internal.
+ getBaseIndex = getIndexPosition
+
+
+-- -----------------------------------------------------------------------
+-- Index modifiers
+-- -----------------------------------------------------------------------
+
+-- | The @IndexModifiers@ datatype.
+newtype IndexModifiers = IndexModifiers [IndexModifier]
+
+-- | The @IndexModifier@ datatype.
+data IndexModifier =
+ ForwardChars Int
+ | BackwardChars Int
+ | ForwardLines Int
+ | BackwardLines Int
+ | LineStart
+ | LineEnd
+ | WordStart
+ | WordEnd
+
+-- | Internal.
+instance Show IndexModifier where
+ -- Internal.
+ showsPrec d (ForwardChars counts) r = "+" ++ show counts ++ "chars " ++ r
+ showsPrec d (BackwardChars counts) r = "-" ++ show counts ++ "chars " ++ r
+ showsPrec d (ForwardLines counts) r = "+" ++ show counts ++ "lines " ++ r
+ showsPrec d (BackwardLines counts) r = "-" ++ show counts ++ "lines " ++ r
+ showsPrec d LineStart r = " linestart " ++ r
+ showsPrec d LineEnd r = " lineend " ++ r
+ showsPrec d WordStart r = " wordstart " ++ r
+ showsPrec d WordEnd r = " wordend " ++ r
+
+-- | Internal.
+instance Show IndexModifiers where
+ -- Internal.
+ showsPrec d (IndexModifiers []) r = r
+ showsPrec d (IndexModifiers (m:ml)) r = show m ++ " " ++ show (IndexModifiers ml) ++ r
+
+
+-- -----------------------------------------------------------------------
+-- Index operations
+-- -----------------------------------------------------------------------
+
+-- | Returns the position on the text widget for a given index.
+getIndexPosition :: HasIndex Editor i BaseIndex
+ => Editor
+ -- ^ the concerned editor widget.
+ -> i
+ -- ^ the concerned index.
+ -> IO Position
+ -- ^ The requested position.
+getIndexPosition ed i = do {
+ inx <- getBaseIndex ed i;
+ pos <- evalMethod ed (\nm -> tkPosition nm inx);
+ case pos of
+ (IndexPos pos) -> return pos
+}
+
+-- | Compares two indizes.
+compareIndices :: (
+ HasIndex Editor i1 BaseIndex,
+ HasIndex Editor i2 BaseIndex
+ ) => Editor
+ -- ^ the concerned editor widget.
+ -> String
+ -- ^ an operation given as a string
+ -> i1
+ -- ^ the first index.
+ -> i2
+ -- ^ the second index.
+ -> IO Bool
+ -- ^ @True@ or @False@, depending on
+ -- the given operation.
+compareIndices ed op i1 i2 = do
+ bi1 <- getBaseIndex ed i1
+ bi2 <- getBaseIndex ed i2
+ evalMethod ed (\nm -> tkCompare nm op bi1 bi2)
+ where tkCompare :: ObjectName -> String -> BaseIndex -> BaseIndex -> TclScript
+ tkCompare nm op i1 i2 =
+ [show nm ++ " compare " ++ show i1 ++ op ++ " " ++ " " ++ show i2]
+
+
+-- -----------------------------------------------------------------------
+-- selection
+-- -----------------------------------------------------------------------
+
+-- | You can select text inside an editor widget.
+instance HasSelection Editor where
+ -- Clears the editors selection.
+ clearSelection tp = synchronize tp (do {
+ start <- getSelectionStart tp;
+ end <- getSelectionEnd tp;
+ case (start,end) of
+ (Just start,Just end) -> do {
+ start' <- getBaseIndex tp (start::Position);
+ end' <- getBaseIndex tp (end::Position);
+ execMethod tp (\nm -> tkClearSelection nm start' end')
+ }
+ _ -> done
+ })
+
+-- | An editor widget\'s characters are selectable.
+instance (HasIndex Editor i BaseIndex) => HasSelectionIndex Editor i
+ where
+ -- Selects the character at the specified index.
+ selection inx tp = synchronize tp (do {
+ binx <- getBaseIndex tp inx;
+ execMethod tp (\nm -> tkSelection nm binx);
+ return tp
+ })
+ -- Queries if the character at the specified index is selected.
+ isSelected tp inx = synchronize tp (do {
+ binx <- getBaseIndex tp inx;
+ start <- getSelectionStart tp;
+ end <- getSelectionEnd tp;
+ case (start,end,binx) of
+ (Just s,Just e,IndexPos i) -> return ((s <= i) && (i < e))
+ _ -> return False
+ })
+
+-- | You can select a text range inside an editor widget.
+instance HasSelectionBaseIndexRange Editor (Distance,Distance) where
+ -- Gets the start index of the editor\'s selection.
+ getSelectionStart tp = do
+ mstart <- try (evalMethod tp (\nm -> tkSelFirst nm))
+ case mstart of
+ (Left e) -> return Nothing -- actually a tk error
+ (Right v) -> (return . Just) v
+ -- Gets the end index of the editor\'s selection.
+ getSelectionEnd tp = do
+ mstart <- try (evalMethod tp (\nm -> tkSelEnd nm))
+ case mstart of
+ (Left e) -> return Nothing -- actually a tk error
+ (Right v) -> (return . Just) v
+
+-- | You can select a text range inside an editor widget.
+instance (
+ HasIndex Editor i1 BaseIndex,
+ HasIndex Editor i2 BaseIndex
+ ) => HasSelectionIndexRange Editor i1 i2
+ where
+ -- Sets the selection range inside the editor widget.
+ selectionRange start end tp = synchronize tp (do {
+ start' <- getBaseIndex tp start;
+ end' <- getBaseIndex tp end;
+ execMethod tp (\nm -> tkSelectionRange nm start' end');
+ return tp
+ })
+
+-- | You can select a text range inside an editor widget.
+instance HasSelectionBaseIndex Editor ((Distance,Distance),(Distance,Distance)) where
+ -- Gets the selection range inside the editor widget.
+ getSelection = getSelectionRange
+
+-- | An editor widget has an X selection.
+instance HasXSelection Editor
+
+
+-- -----------------------------------------------------------------------
+-- Insertion Cursor
+-- -----------------------------------------------------------------------
+
+-- | An editor widget has an insertion cursor.
+instance HasInsertionCursor Editor
+
+-- | The insertion cursor of an editor widget can be set by a base index.
+instance ( HasIndex Editor i BaseIndex
+ ) => HasInsertionCursorIndexSet Editor i
+ where
+ -- Sets the position of the insertion cursor.
+ insertionCursor inx tp = synchronize tp (do {
+ binx <- getBaseIndex tp inx;
+ execMethod tp (\nm -> tkSetInsertMark nm binx);
+ return tp
+ })
+
+-- | You can get the position of the insertion cursor of an editor widget.
+instance HasInsertionCursorIndexGet Editor (Distance,Distance) where
+ -- Gets the position of the insertion cursor.
+ getInsertionCursor tp = evalMethod tp (\nm -> tkGetInsertMark nm)
+
+
+-- -----------------------------------------------------------------------
+-- View
+-- -----------------------------------------------------------------------
+
+-- | Adjusts the view so that the character at the specified position is
+-- visible.
+adjustViewTo :: HasIndex Editor i BaseIndex => Editor
+ -- ^ the concerned editor widget.
+ -> i
+ -- ^ the index to adjust the view to.
+ -> IO ()
+ -- ^ None.
+adjustViewTo ed i =
+ synchronize ed (do {
+ inx <- getBaseIndex ed i;
+ execMethod ed (\nm -> tkSee nm inx)
+ })
+
+
+-- -----------------------------------------------------------------------
+-- Scan
+-- -----------------------------------------------------------------------
+
+-- | Anchor a scrolling operation.
+scanMark :: HasIndex Editor i BaseIndex => Editor
+ -- ^ the concerned editor widget.
+ -> i
+ -- ^ the concerned index.
+ -> IO ()
+ -- ^ None.
+scanMark ed i = do {
+ pos <- getIndexPosition ed i;
+ execMethod ed (\nm -> tkScanMark nm pos)
+}
+
+-- | Scroll based on a new position.
+scanDragTo :: HasIndex Editor i BaseIndex => Editor
+ -- ^ the concerned editor widget.
+ -> i
+ -- ^ the concerned index.
+ -> IO ()
+ -- ^ None.
+scanDragTo ed i =
+ synchronize ed (do {
+ pos <- getIndexPosition ed i;
+ execMethod ed (\nm -> tkScanDragTo nm pos)
+ })
+
+
+-- -----------------------------------------------------------------------
+-- Wrap Mode
+-- -----------------------------------------------------------------------
+
+-- | Sets the editor\'s wrap mode.
+wrap :: WrapMode -> Config Editor
+wrap d tp = cset tp "wrap" d
+
+-- | Gets the editor\'s wrap mode.
+getWrapMode :: Editor -> IO WrapMode
+getWrapMode tp = cget tp "wrap"
+
+
+-- -----------------------------------------------------------------------
+-- WrapMode
+-- -----------------------------------------------------------------------
+
+-- | The @WrapMode@ datatype.
+data WrapMode = NoWrap | CharWrap | WordWrap deriving (Eq,Ord,Enum)
+
+-- | Internal.
+instance GUIValue WrapMode where
+ -- Internal.
+ cdefault = NoWrap
+
+-- | Internal.
+instance Read WrapMode where
+ -- Internal.
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ 'n':'o':'n':'e':xs -> [(NoWrap,xs)]
+ 'c':'h':'a':'r':xs -> [(CharWrap,xs)]
+ 'w':'o':'r':'d':xs -> [(WordWrap,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show WrapMode where
+ -- Internal.
+ showsPrec d p r =
+ (case p of
+ NoWrap -> "none"
+ CharWrap -> "char"
+ WordWrap -> "word"
+ ) ++ r
+
+
+-- -----------------------------------------------------------------------
+-- tabulators
+-- -----------------------------------------------------------------------
+
+-- | Widgets with adjustable tab stops instantiate the
+-- @class HasTabulators@.
+class GUIObject w => HasTabulators w where
+ -- Sets the tab stops.
+ tabs :: String -> Config w
+ -- Gets the tab stops.
+ getTabs :: w -> IO String
+ tabs s w = cset w "tabs" s
+ getTabs w = cget w "tabs"
+
+
+
+-- -----------------------------------------------------------------------
+-- Line Spacings
+-- -----------------------------------------------------------------------
+
+-- | Widgets with an adjustable line spacing instantiate the
+-- @class HasLineSpacing@.
+class GUIObject w => HasLineSpacing w where
+ -- Sets the space above an unwrapped line.
+ spaceAbove :: Distance -> Config w
+ -- Gets the space above an unwrapped line.
+ getSpaceAbove :: w -> IO Distance
+ -- Sets the space above a wrapped line.
+ spaceWrap :: Distance -> Config w
+ -- Gets the space above a wrapped line.
+ getSpaceWrap :: w -> IO Distance
+ -- Sets the space below an unwrapped line.
+ spaceBelow :: Distance -> Config w
+ -- Sets the space below an unwrapped line.
+ getSpaceBelow :: w -> IO Distance
+ getSpaceAbove w = cget w "spacing1"
+ spaceAbove d w = cset w "spacing1" d
+ getSpaceBelow w = cget w "spacing3"
+ spaceBelow d w = cset w "spacing3" d
+ spaceWrap d w = cset w "spacing2" d
+ getSpaceWrap w = cget w "spacing2"
+
+
+-- -----------------------------------------------------------------------
+-- Search Switch
+-- -----------------------------------------------------------------------
+
+-- | The @SearchDirection@ datatype.
+data SearchDirection = Forward | Backward deriving (Eq,Ord,Enum)
+
+-- | Internal.
+instance Show SearchDirection where
+ -- Internal.
+ showsPrec d p r =
+ (case p of
+ Forward -> " -forward"
+ Backward -> " -backward"
+ ) ++ r
+
+-- | The @SearchMode@ datatype.
+data SearchMode = Exact | Nocase deriving (Eq,Ord,Enum)
+
+-- | Internal.
+instance Show SearchMode where
+ -- Internal.
+ showsPrec d p r =
+ (case p of
+ Exact -> " -exact"
+ Nocase -> " -nocase"
+ ) ++ r
+
+-- | The @SearchSwitch@ datatype.
+data SearchSwitch = SearchSwitch {
+ searchdirection :: SearchDirection,
+ searchmode :: SearchMode,
+ rexexp :: Bool
+ }
+
+-- | Internal.
+instance Show SearchSwitch where
+ -- Internal.
+ showsPrec _ (SearchSwitch d m False) r =
+ show d ++ show m ++ r
+ showsPrec _ (SearchSwitch d m True) r =
+ show d ++ show m ++ " -regexp " ++ r
+
+
+-- -----------------------------------------------------------------------
+-- Text Methods
+-- -----------------------------------------------------------------------
+
+textMethods = defMethods {
+ cleanupCmd = tkCleanupText,
+ createCmd = tkCreateText
+ }
+
+
+-- -----------------------------------------------------------------------
+-- Search
+-- -----------------------------------------------------------------------
+
+-- | Searches for text inside an editor widget.
+search :: HasIndex Editor i BaseIndex =>
+ Editor
+ -- ^ the concerned editor widget.
+ -> SearchSwitch
+ -- ^ the search switch.
+ -> String
+ -- ^ the searched text or regular expression.
+ -> i
+ -- ^ the start index.
+ -> IO (Maybe BaseIndex)
+ -- ^ The index of the first match (if successful).
+search ed switch ptn inx = do {
+ binx <- getBaseIndex ed inx;
+ (RawData mb) <- evalMethod ed (\nm -> tkSearch nm switch ptn binx);
+ case dropWhile isSpace mb of
+ "" -> return Nothing
+ s -> creadTk s >>= return . Just
+ }
+
+tkSearch :: ObjectName -> SearchSwitch -> String -> BaseIndex -> TclScript
+tkSearch nm switch ptn inx =
+ [show nm ++ " search " ++ show switch ++ " " ++ ptn ++ " " ++ show inx]
+
+
+-- -----------------------------------------------------------------------
+-- Unparsing of Text Pane
+-- -----------------------------------------------------------------------
+
+tkCreateText :: ObjectName -> ObjectKind -> ObjectName -> ObjectID ->
+ [ConfigOption] -> TclScript
+tkCreateText pnm kind@(TEXT lns) name oid confs =
+ tkDeclVar ("sv" ++ show oid) (show name) ++
+ (createCmd defMethods) pnm kind name oid confs
+{-# INLINE tkCreateText #-}
+
+tkCleanupText :: ObjectID -> ObjectName -> TclScript
+tkCleanupText oid _ = tkUndeclVar ("sv" ++ show oid)
+{-# INLINE tkCleanupText #-}
+
+tkDeleteText :: ObjectName -> BaseIndex -> Maybe BaseIndex -> TclScript
+tkDeleteText name pl Nothing =
+ [show name ++ " delete " ++ ishow pl]
+tkDeleteText name pl1 (Just pl2) =
+ [show name ++ " delete " ++ ishow pl1 ++ " " ++ ishow pl2]
+{-# INLINE tkDeleteText #-}
+
+tkGetText :: ObjectName -> BaseIndex -> Maybe BaseIndex -> TclScript
+tkGetText name pl Nothing =
+ [show name ++ " get " ++ ishow pl]
+tkGetText name pl1 (Just pl2) =
+ [show name ++ " get " ++ ishow pl1 ++ " " ++ ishow pl2]
+{-# INLINE tkGetText #-}
+
+tkInsertText :: ObjectName -> BaseIndex -> GUIVALUE -> TclScript
+tkInsertText name pl val =
+ [show name ++ " insert " ++ ishow pl ++ " " ++ show val ++ " "]
+{-# INLINE tkInsertText #-}
+
+tkInsertNewLine :: ObjectName -> TclScript
+tkInsertNewLine name = [show name ++ " insert end \\n"]
+{-# INLINE tkInsertNewLine #-}
+
+tkPosition :: ObjectName -> BaseIndex -> TclScript
+tkPosition name pl = [show name ++ " index " ++ ishow pl]
+{-# INLINE tkPosition #-}
+
+tkSee :: ObjectName -> BaseIndex -> TclScript
+tkSee name pl = [show name ++ " see " ++ ishow pl]
+{-# INLINE tkSee #-}
+
+tkScanMark :: ObjectName -> Position -> TclScript
+tkScanMark name pos = [show name ++ " scan mark " ++ show pos]
+{-# INLINE tkScanMark #-}
+
+tkScanDragTo :: ObjectName -> Position -> TclScript
+tkScanDragTo name pos = [show name ++ " scan dragto " ++ show pos]
+{-# INLINE tkScanDragTo #-}
+
+tkSetInsertMark :: ObjectName -> BaseIndex -> TclScript
+tkSetInsertMark wn p = [show wn ++ " mark set insert " ++ ishow p]
+{-# INLINE tkSetInsertMark #-}
+
+tkGetInsertMark :: ObjectName -> TclScript
+tkGetInsertMark wn = [show wn ++ " index insert"]
+{-# INLINE tkGetInsertMark #-}
+
+tkSelection :: ObjectName -> BaseIndex -> TclScript
+tkSelection wn i @ (IndexPos (x,y)) = [show wn ++ " tag add sel " ++
+ ishow i ++ " " ++ show (IndexPos(x,(y + 1)))]
+tkSelection wn _ = [show wn ++ " tag add sel end end"]
+{-# INLINE tkSelection #-}
+
+tkSelectionRange :: ObjectName -> BaseIndex -> BaseIndex -> TclScript
+tkSelectionRange wn start end = [show wn ++ " tag add sel " ++
+ ishow start ++ " " ++ ishow end]
+{-# INLINE tkSelectionRange #-}
+
+tkSelFirst :: ObjectName -> TclScript
+tkSelFirst wn = [show wn ++ " index sel.first "]
+{-# INLINE tkSelFirst #-}
+
+tkSelEnd :: ObjectName -> TclScript
+tkSelEnd wn = [show wn ++ " index sel.last "]
+{-# INLINE tkSelEnd #-}
+
+tkClearSelection :: ObjectName -> BaseIndex -> BaseIndex -> TclScript
+tkClearSelection wn start end = [show wn ++ " tag remove sel " ++
+ ishow start ++ " " ++ ishow end]
+{-# INLINE tkClearSelection #-}
+
+tkMarkCreate :: ObjectName -> String -> BaseIndex -> TclScript
+tkMarkCreate tname mname ix =
+ [show tname ++ " mark set " ++ show mname ++ " " ++ ishow ix]
+{-# INLINE tkMarkCreate #-}
+
+ishow :: BaseIndex -> String
+ishow i = "{" ++ show i ++ "}"
diff --git a/HTk/Widgets/Entry.hs b/HTk/Widgets/Entry.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Widgets/Entry.hs
@@ -0,0 +1,357 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | HTk's entry field.
+-- A simple widget that displays an editable line of text.
+module HTk.Widgets.Entry (
+ Entry,
+
+ newEntry,
+
+ XCoord(..),
+
+ showText,
+ getShowText
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import HTk.Kernel.Resources
+import HTk.Kernel.Geometry
+import HTk.Widgets.ScrollBar
+import HTk.Components.Selection
+import HTk.Devices.XSelection
+import HTk.Components.Index
+import HTk.Components.ICursor
+import Util.Computation
+import Events.Destructible
+import Events.Synchronized
+import HTk.Kernel.Packer
+import HTk.Kernel.TkVariables
+import HTk.Kernel.Tooltip
+import HTk.Tix.Subwidget
+
+
+-- -----------------------------------------------------------------------
+-- type
+-- -----------------------------------------------------------------------
+
+-- | The @Entry@ datatype.
+newtype Entry a = Entry GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- creation
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new entry field and returns a handler.
+newEntry :: (Container par, GUIValue a) =>
+ par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> [Config (Entry a)]
+ -- ^ the list of configuration options for this entry
+ -- field.
+ -> IO (Entry a)
+ -- ^ An entry field.
+newEntry par cnf =
+ do
+ wid <- createGUIObject (toGUIObject par) ENTRY entryMethods
+ configure (Entry wid) cnf
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject (Entry a) where
+ toGUIObject (Entry w) = w
+ cname _ = "Entry"
+
+-- | An entry field has a configureable width (height config is ignored).
+instance HasSize (Entry a) where
+ height _ w = return w
+ getHeight w = return 1
+
+-- | An entry field can be destroyed.
+instance Destroyable (Entry a) where
+ destroy = destroy . toGUIObject
+
+-- | An entry field has standard widget properties
+-- (concerning focus, cursor).
+instance Widget (Entry a)
+
+-- | An entry field has a configureable border.
+instance HasBorder (Entry a)
+
+-- | An entry field has a foreground and background colour.
+instance HasColour (Entry a) where
+ legalColourID = hasForeGroundColour
+
+-- | You can specify the font of an entry field.
+instance HasFont (Entry a)
+
+-- | The value of an entry field is associated with a polymorphic variable.
+instance HasVariable (Entry a) where
+ variable var@(TkVariable oid) w =
+ cset w "textvariable" ("v" ++ show oid) >> return w
+
+-- | An entry field has a value that is associated with a polymorphic
+-- variable.
+instance GUIValue a => HasValue (Entry a) a where
+ value val w = execMethod w (\nm-> tkSetText nm (toGUIValue val)) >>
+ return w
+ -- Selector for the value of an entry field.
+ -- w - the concerned entry field.
+ -- result - The concerned entry field.
+ getValue w = evalMethod w (\nm-> tkGetText nm)
+
+-- | An entry field has a configureable text justification.
+instance HasJustify (Entry a)
+
+-- | An entry field is a stateful widget - it can be enabled of disabled.
+instance HasEnable (Entry a)
+
+-- | An entry field is scrollable in horizontal direction.
+instance HasScroller (Entry a) where
+ isWfOrientation _ Horizontal = True
+ isWfOrientation _ Vertical = False
+
+-- | You can synchronize on an entry field (in JAVA-style)
+instance Synchronized (Entry a) where
+ synchronize w = synchronize (toGUIObject w)
+
+-- | An entry can have a tooltip (only displayed if you are using tixwish).
+instance HasTooltip (Entry a)
+
+
+-- -----------------------------------------------------------------------
+-- index
+-- -----------------------------------------------------------------------
+
+-- | The @XCoord@ datatype.
+data XCoord = XCoord Distance
+
+-- | Internal.
+instance Show XCoord where
+ showsPrec d (XCoord x) r = "@"++show x ++ r
+
+
+-- -----------------------------------------------------------------------
+-- HasIndex
+-- -----------------------------------------------------------------------
+
+-- | An integer value is a valid index position for an entry widget.
+instance HasIndex (Entry a) Int BaseIndex where
+ getBaseIndex w i = return (IndexNo i)
+
+-- | A base index is a valid index position for an entry widget.
+instance HasIndex (Entry a) BaseIndex BaseIndex where
+ getBaseIndex w i = return i
+
+-- | The @EndOfText@ index is a valid index position for an
+-- entry widget.
+instance HasIndex (Entry a) EndOfText BaseIndex where
+ getBaseIndex w _ = return (IndexText "end")
+
+-- | An @XCoord@ is a valid index for an entry widget.
+instance HasIndex (Entry a) XCoord BaseIndex where
+ getBaseIndex ent i = return (IndexText (show i))
+
+-- | The entries insertion cursor is a valid index for an entry widget.
+instance HasIndex (Entry a) (ICursor (Entry a)) BaseIndex where
+ getBaseIndex ent i = return (IndexText "insert")
+
+-- | The selection start is a valid index position for an entry widget.
+instance HasIndex (Entry a) (Selection (Entry a),First) BaseIndex where
+ getBaseIndex ent i = return (IndexText "sel.first")
+
+-- | The selection end is a valid index position for an entry widget.
+instance HasIndex (Entry a) (Selection (Entry a),Last) BaseIndex where
+ getBaseIndex ent i = return (IndexText "sel.last")
+
+-- | Internal.
+instance HasIndex (Entry a) i BaseIndex => HasIndex (Entry a) i Int where
+ getBaseIndex w i =
+ do
+ bi <- getBaseIndex w i
+ evalMethod w (\nm -> tkGetIndexNumber nm bi)
+ where tkGetIndexNumber :: ObjectName -> BaseIndex -> TclScript
+ tkGetIndexNumber nm bi = [show nm ++ " index " ++ show bi]
+
+
+-- -----------------------------------------------------------------------
+-- selection
+-- -----------------------------------------------------------------------
+
+-- | You can select text inside an entry widget.
+instance HasSelection (Entry a) where
+ -- Clears the entry\'s selection.
+ clearSelection ent =
+ execMethod ent (\nm -> [show nm ++ " selection clear"])
+
+-- | An entry widget\'s characters are selectable.
+instance HasIndex (Entry a) i BaseIndex =>
+ HasSelectionIndex (Entry a) i where
+ -- Selects the character at the specified index.
+ selection inx ent =
+ synchronize ent
+ (do
+ binx <- getBaseIndex ent inx
+ execMethod ent (\nm -> [tkSelection nm binx])
+ return ent)
+ -- Queries if the character at the specified index is selected.
+ isSelected ent inx =
+ synchronize ent
+ (do
+ binx <- getBaseIndex ent inx
+ start <- getSelectionStart ent
+ end <- getSelectionEnd ent
+ case (start,end,binx) of
+ (Just start, Just end, IndexNo i) ->
+ return (start <= i && i < end)
+ _ -> return False)
+
+-- | You can select a text range inside an entry widget.
+instance HasSelectionBaseIndex (Entry a) (Int,Int) where
+ getSelection = getSelectionRange
+
+-- | You can select a text range inside an entry widget.
+instance (HasIndex (Entry a) i1 BaseIndex,
+ HasIndex (Entry a) i2 BaseIndex) =>
+ HasSelectionIndexRange (Entry a) i1 i2 where
+ -- Sets the selection range inside the entry widget.
+ selectionRange start end ent =
+ synchronize ent
+ (do
+ start' <- getBaseIndex ent start
+ end' <- getBaseIndex ent end
+ execMethod ent (\nm -> [tkSelectionRange nm start' end'])
+ return ent)
+
+-- | You can select a text range inside an entry widget.
+instance HasSelectionBaseIndexRange (Entry a) Int where
+ getSelectionStart ent =
+ do
+ mstart <-
+ try (evalMethod ent (\nm -> [show nm ++ " index sel.first "]))
+ case mstart of
+ Left e -> return Nothing -- actually a tk error
+ Right v -> return (Just v)
+ -- Gets the end index of the entry\'s selection.
+ getSelectionEnd ent =
+ do
+ mend <-
+ try (evalMethod ent (\nm -> [show nm ++ " index sel.last "]))
+ case mend of
+ Left e -> return Nothing -- actually a tk error
+ Right v -> return (Just v)
+
+-- | An editor widget has an X selection.
+instance HasXSelection (Entry a)
+
+
+-- -----------------------------------------------------------------------
+-- insertion cursor
+-- -----------------------------------------------------------------------
+
+-- | An entry widget has an insertion cursor.
+instance HasInsertionCursor (Entry a)
+
+-- |
+instance HasIndex (Entry a) i BaseIndex =>
+ HasInsertionCursorIndexSet (Entry a) i where
+ -- Sets the position of the insertion cursor.
+ insertionCursor inx ent =
+ synchronize ent
+ (do
+ binx <- getBaseIndex ent inx
+ execMethod ent (\nm -> [tkSetInsert nm binx])
+ return ent)
+
+-- | You can get the position of the insertion cursor of an entry widget.
+instance HasInsertionCursorIndexGet (Entry a) Int where
+
+ -- Gets the position of the insertion cursor.
+ getInsertionCursor ent = evalMethod ent (\nm -> [tkGetInsert nm])
+
+
+-- | An entry widget can be a subwidget, e.g. in a combo box
+instance GUIValue a => CanBeSubwidget (Entry a) where
+ createAsSubwidget megaWidget
+ = do e <- createSubwidget ENTRY entryMethods megaWidget
+ return (Entry e)
+
+-- -----------------------------------------------------------------------
+-- configuration options
+-- -----------------------------------------------------------------------
+
+-- | Sets a character to display instead of contents (e.g. for password
+-- fields).
+showText :: GUIValue a => Char
+ -- ^ the character to display.
+ -> Entry a
+ -- ^ the concerned entry field.
+ -> IO (Entry a)
+ -- ^ The concerned entry field.
+showText ch ent = cset ent "show" [ch]
+
+-- | Gets the character to show instead of contents.
+getShowText :: GUIValue a => Entry a -> IO Char
+getShowText w = do {l <- cget w "show"; return (head (l ++ " "))}
+
+
+-- -----------------------------------------------------------------------
+-- entry methods
+-- -----------------------------------------------------------------------
+
+entryMethods = defMethods { cleanupCmd = tkCleanupEntry,
+ createCmd = tkCreateEntry }
+
+
+-- -----------------------------------------------------------------------
+-- Unparsing of Tk Commands
+-- -----------------------------------------------------------------------
+
+tkSetInsert :: ObjectName -> BaseIndex -> TclCmd
+tkSetInsert wn i = show wn ++ " icursor " ++ show i
+{-# INLINE tkSetInsert #-}
+
+tkGetInsert :: ObjectName -> TclCmd
+tkGetInsert wn = show wn ++ " index insert"
+{-# INLINE tkGetInsert #-}
+
+tkSelection :: ObjectName -> BaseIndex -> TclCmd
+tkSelection wn (IndexNo i) =
+ show wn ++ " selection range " ++ show i ++ " " ++ show (i + 1)
+tkSelection wn _ = show wn ++ " selection range end end"
+{-# INLINE tkSelection #-}
+
+tkSelectionRange :: ObjectName -> BaseIndex -> BaseIndex -> TclCmd
+tkSelectionRange wn start end = show wn ++ " selection range " ++
+ show start ++ " " ++ show end
+{-# INLINE tkSelectionRange #-}
+
+tkCreateEntry :: ObjectName -> ObjectKind -> ObjectName -> ObjectID ->
+ [ConfigOption] -> TclScript
+tkCreateEntry pnm kind name oid confs =
+ tkDeclVar ("sv" ++ show oid) (show name) ++
+ (createCmd defMethods) pnm kind name oid confs
+
+tkCleanupEntry :: ObjectID -> ObjectName -> TclScript
+tkCleanupEntry oid _ = []
+{-# INLINE tkCleanupEntry #-}
+
+tkSetText :: ObjectName -> GUIVALUE -> TclScript
+tkSetText nm val = [show nm ++ " delete 0 end",
+ show nm ++ " insert 0 " ++ show val]
+{-# INLINE tkSetText #-}
+
+tkGetText :: ObjectName -> TclScript
+tkGetText nm = [show nm ++ " get"]
+{-# INLINE tkGetText #-}
diff --git a/HTk/Widgets/Label.hs b/HTk/Widgets/Label.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Widgets/Label.hs
@@ -0,0 +1,108 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+-- | HTk\'s /label/ widget.
+-- A label is a simple container for text or images\/bitmaps.
+module HTk.Widgets.Label (
+
+ Label,
+ newLabel
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import HTk.Components.Image
+import HTk.Components.BitMap
+import Util.Computation
+import Events.Destructible
+import Events.Synchronized
+import HTk.Kernel.Packer
+import HTk.Kernel.Tooltip
+
+
+-- -----------------------------------------------------------------------
+-- datatype
+-- -----------------------------------------------------------------------
+
+-- | The @Label@ datatype.
+newtype Label = Label GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- creation
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new label widget and returns a handler.
+newLabel :: Container par => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> [Config Label]
+ -- ^ the list of configuration options for this label.
+ -> IO Label
+ -- ^ A label widget.
+newLabel par cnf =
+ do
+ w <- createWidget (toGUIObject par) LABEL
+ configure (Label w) cnf
+
+
+-- -----------------------------------------------------------------------
+-- instantiations
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject Label where
+ toGUIObject (Label w) = w
+ cname _ = "Label"
+
+-- | A label widget can be destroyed.
+instance Destroyable Label where
+ -- Destroys a label widget.
+ destroy = destroy . toGUIObject
+
+-- | A label widget has standard widget properties
+-- (concerning focus, cursor).
+instance Widget Label
+
+-- | A label widget has a configureable border.
+instance HasBorder Label
+
+-- | A label widget has a foreground and background colour.
+instance HasColour Label where
+ legalColourID = hasForeGroundColour
+
+-- | You can specify the font of a label.
+instance HasFont Label
+
+-- | A label has a configureable text justification.
+instance HasJustify Label
+
+-- | A label can contain an image.
+instance HasPhoto Label
+
+-- | A label can contain a bitmap.
+instance HasBitMap Label
+
+-- | You can specify the size of a label.
+instance HasSize Label
+
+-- | You can set the index of a text character to underline.
+instance HasUnderline Label
+
+-- | A label can contain text.
+instance GUIValue b => HasText Label b
+
+-- | A label widget can have a tooltip (only displayed if you are using
+-- tixwish).
+instance HasTooltip Label
+
+-- | You can synchronize on a label object.
+instance Synchronized Label where
+ -- Synchronizes on a label object.
+ synchronize = synchronize . toGUIObject
+
+-- | A label has a text anchor.
+instance HasAnchor Label
diff --git a/HTk/Widgets/ListBox.hs b/HTk/Widgets/ListBox.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Widgets/ListBox.hs
@@ -0,0 +1,450 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | HTk\'s /listbox widget/ .
+-- A scrollable widget that displays a set of text lines with selection
+-- functionality.
+module HTk.Widgets.ListBox (
+
+ ListBox,
+ newListBox,
+
+ SelectMode(..),
+ selectMode,
+ getSelectMode,
+
+ activateElem,
+ selectionAnchor,
+
+ ListBoxElem(..),
+ elemNotFound
+
+) where
+
+import Data.List
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import HTk.Widgets.ScrollBar
+import HTk.Components.Index
+import HTk.Components.Selection
+import Data.Char(isSpace)
+import HTk.Devices.XSelection
+import Events.Synchronized
+import Util.Computation
+import Events.Destructible
+import HTk.Kernel.Packer
+import HTk.Kernel.Tooltip
+import HTk.Tix.Subwidget
+
+-- -----------------------------------------------------------------------
+-- type
+-- -----------------------------------------------------------------------
+
+-- | The @ListBox@ datatype - parametrised over the type of
+-- the list elements.
+newtype ListBox a = ListBox GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- creation
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new listbox widget and returns a handler.
+newListBox :: (Container par, GUIValue a) => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ ->
+ [Config (ListBox a)]
+ -- ^ the list of configuration options for this listbox
+ -- widget.
+ ->
+ IO (ListBox a)
+ -- ^ A listbox widget.
+newListBox par cnf =
+ do
+ w <- createGUIObject (toGUIObject par) (LISTBOX []) lboxMethods
+ configure (ListBox w) cnf
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject (ListBox a) where
+ toGUIObject (ListBox w) = w
+ cname _ = "ListBox"
+
+-- | A listbox widget can be destroyed.
+instance Destroyable (ListBox a) where
+ -- Destroys a listbox widget
+ destroy = destroy . toGUIObject
+
+-- | A listbox widget has standard widget properties
+-- (concerning focus, cursor).
+instance Widget (ListBox a)
+
+-- | You can synchronize on a listbox object (in JAVA style).
+instance Synchronized (ListBox a) where
+ -- Synchronizes on a listbox object.
+ synchronize = synchronize . toGUIObject
+
+-- | A listbox widget has a configureable border.
+instance HasBorder (ListBox a)
+
+-- | A listbox widget has a foreground and background colour.
+instance HasColour (ListBox a) where
+ legalColourID = hasForeGroundColour
+
+-- | A listbox is a stateful widget - it can be enabled or disabled.
+instance HasEnable (ListBox a)
+
+-- | You can specify the font of a listbox.
+instance HasFont (ListBox a)
+
+instance HasGrid (ListBox a)
+
+-- | A listbox is a scrollable widget.
+instance HasScroller (ListBox a)
+
+-- | You can specify the size of a listbox.
+instance HasSize (ListBox a)
+
+-- | The value of a listbox is the list of the displayed objects (these
+-- are instances of class @GUIValue@ and therefore instances
+-- of class @Show@).
+instance (GUIValue a, GUIValue [a]) => HasValue (ListBox a) [a] where
+ value vals w =
+ execMethod w (\nm -> tkInsert nm 0 (map toGUIValue vals)) >> return w
+ -- Gets the list of displayed objects.
+ getValue w = evalMethod w (\nm -> tkGet nm)
+
+-- | A listbox can have a tooltip (only displayed if you are using tixwish).
+instance HasTooltip (ListBox a)
+
+-- | A listbox widget has an X selection.
+instance HasXSelection (ListBox a)
+
+-- --------------------------------------------------------
+-- A list box widget can be a subwidget, e.g. in a combo box
+-- --------------------------------------------------------
+
+instance GUIValue a => CanBeSubwidget (ListBox a) where
+ createAsSubwidget megaWidget
+ = do lb <- createSubwidget (LISTBOX []) lboxMethods megaWidget
+ return (ListBox lb)
+
+-- -----------------------------------------------------------------------
+-- ListBox configurations
+-- -----------------------------------------------------------------------
+
+-- | Sets the select mode of a listbox.
+selectMode :: GUIValue a => SelectMode
+ -- ^ the select mode to set.
+ -> ListBox a
+ -- ^ the concerned listbox.
+ -> IO (ListBox a)
+ -- ^ The concerned listbox.
+selectMode sm lbox = cset lbox "selectmode" sm
+
+-- | Gets the set select mode from a listbox.
+getSelectMode :: GUIValue a => (ListBox a)
+ -- ^ the concerned listbox.
+ -> IO SelectMode
+ -- ^ The current select mode.
+getSelectMode lbox = cget lbox "selectmode"
+
+
+-- -----------------------------------------------------------------------
+-- BBox
+-- -----------------------------------------------------------------------
+
+-- | You can find out the bounding box of a list box element.
+instance HasIndex (ListBox a) i Int => HasBBox (ListBox a) i where
+ -- Returns the bounding box of the element at the specified index.
+ bbox w i =
+ do
+ binx <- getBaseIndex w i
+ ans <- try (evalMethod w (\nm -> [tkBBox nm (binx::Int)]))
+ case ans of Left e -> return Nothing
+ Right v -> return (Just v)
+ where tkBBox nm i = show nm ++ " bbox " ++ show i
+
+
+-- -----------------------------------------------------------------------
+-- Index
+-- -----------------------------------------------------------------------
+
+-- | The @ListBoxElem@ datatype.
+data Eq a => ListBoxElem a = ListBoxElem a deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- Has Index
+-- -----------------------------------------------------------------------
+
+-- | An integer value is a valid index position inside a listbox widget.
+instance HasIndex (ListBox a) Int Int where
+ getBaseIndex lb i = return i
+
+-- | The @EndOfText@ index is a valid index position inside a
+-- listbox widget.
+instance HasIndex (ListBox a) EndOfText Int where
+ getBaseIndex lb _ = getIndexNumber lb "end"
+
+-- | A position in pixels is a valid index position inside an editor widget.
+instance HasIndex (ListBox a) Pixels Int where
+ getBaseIndex lb p = getIndexNumber lb (show p)
+
+-- | A listbox element is a valid index position inside an editor widget.
+instance (Eq a,GUIValue a) => HasIndex (ListBox [a])
+ (ListBoxElem a) Int where
+ getBaseIndex lb (ListBoxElem val) =
+ do
+ kind <- getObjectKind (toGUIObject lb)
+ case kind of
+ LISTBOX elems ->
+ case findIndex (\e -> show e == val') elems of
+ Nothing -> raise elemNotFound
+ Just i -> return i
+ where val' = show (toGUIValue val)
+
+-- | Internal.
+instance (Eq a, GUIValue a, GUIValue [a]) =>
+ HasIndex (ListBox a) Int (ListBoxElem a) where
+ getBaseIndex lb i =
+ synchronize lb
+ (do
+ elems <- getValue lb
+ (if (i >= 0) && (i <= (length elems - 1)) then
+ return (ListBoxElem (elems !! i))
+ else
+ raise elemNotFound))
+
+getIndexNumber :: ListBox a -> String -> IO Int
+getIndexNumber lb i =
+ evalMethod lb (\lnm -> [show lnm ++ " index " ++ i])
+
+
+-- -----------------------------------------------------------------------
+-- ListBox selection
+-- -----------------------------------------------------------------------
+
+-- | You can select entries inside a listbox widget.
+instance HasSelection (ListBox a) where
+ -- Clears the listbox\'es selection.
+ clearSelection lb = execMethod lb (\nm -> tkSelectionClearAll nm)
+
+-- | A listbox\'es entries are selectable.
+instance (HasIndex (ListBox a) i Int) =>
+ HasSelectionIndex (ListBox a) i where
+ -- Selects the element at the specified index.
+ selection i lb =
+ synchronize lb
+ (do
+ binx <- getBaseIndex lb i
+ execMethod lb (\ nm -> tkSelectionSetItem nm binx)
+ return lb)
+ -- Queries if the element at the specified index is selected.
+ isSelected lb i =
+ synchronize lb
+ (do
+ binx <- getBaseIndex lb i
+ evalMethod lb (\nm -> tkSelectionIncludes nm binx))
+
+-- | You can select a range of elements inside a listbox widget.
+instance HasSelectionBaseIndex (ListBox a) [Int] where
+ -- Gets the selection range inside the listbox.
+ getSelection lb =
+ do
+ sel <- evalMethod lb (\ nm -> tkCurSelection nm)
+ case (((map read) .words) sel) of
+ [] -> return Nothing
+ l -> return (Just l)
+
+-- | You can select a range of elements inside a listbox widget.
+instance (HasIndex (ListBox a) i1 Int, HasIndex (ListBox a) i2 Int) =>
+ HasSelectionIndexRange (ListBox a) i1 i2 where
+ -- Sets the selection range inside the listbox widget.
+ selectionRange start end lb =
+ synchronize lb
+ (do
+ start' <- getBaseIndex lb start
+ end' <- getBaseIndex lb end
+ execMethod lb (\ nm -> tkSelectionSet nm start' end')
+ return lb)
+
+-- | You can select a range of entries inside a listbox widget.
+instance HasSelectionBaseIndexRange (ListBox a) Int where
+ -- Gets the start index of the listbox\'es selection.
+ getSelectionStart lb =
+ do
+ sel <- getSelection lb
+ case sel of
+ Nothing -> return Nothing
+ Just (v:_) -> return (Just v)
+ -- Gets the end index of the listbox\'es selection.
+ getSelectionEnd lb =
+ do
+ sel <- getSelection lb
+ case sel of
+ Nothing -> return Nothing
+ Just l -> (return . Just . head . reverse) l
+
+
+-- -----------------------------------------------------------------------
+-- Other ListBox operations
+-- -----------------------------------------------------------------------
+
+-- | Activates the specified line.
+activateElem :: HasIndex (ListBox a) i Int => ListBox a
+ -- ^ the concerned listbox.
+ -> i
+ -- ^ the index of the line to activate.
+ -> IO ()
+ -- ^ Nothing.
+activateElem lb i =
+ synchronize lb
+ (do
+ binx <- getBaseIndex lb i
+ execMethod lb (\ nm -> tkActivate nm binx))
+
+-- | Anchors the selection at the specified line.
+selectionAnchor :: HasIndex (ListBox a) i Int => ListBox a
+ -- ^ the concerned listbox.
+ -> i
+ -- ^ the index of the line to anchor the selection at.
+ -> IO ()
+ -- ^ Nothing.
+selectionAnchor lb i =
+ synchronize lb
+ (do
+ binx <- getBaseIndex lb i
+ execMethod lb (\nm -> tkSelectionAnchor nm binx)
+ done)
+
+
+-- -----------------------------------------------------------------------
+-- SelectMode
+-- -----------------------------------------------------------------------
+
+data SelectMode =
+ Single | Browse | Multiple | Extended deriving (Eq,Ord,Enum)
+
+instance GUIValue SelectMode where
+ cdefault = Single
+
+instance Read SelectMode where
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ 's':'i':'n':'g':'l':'e':xs -> [(Single,xs)]
+ 'b':'r':'o':'w':'s':'e':xs -> [(Browse,xs)]
+ 'm':'u':'l':'t':'i':'p':'l':'e':xs -> [(Multiple,xs)]
+ 'e':'x':'t':'e':'n':'d':'e':'d':xs -> [(Extended,xs)]
+ _ -> []
+
+instance Show SelectMode where
+ showsPrec d p r =
+ (case p of
+ Single -> "single"
+ Browse -> "browse"
+ Multiple -> "multiple"
+ Extended -> "extended"
+ ) ++ r
+
+
+-- -----------------------------------------------------------------------
+-- exceptions
+-- -----------------------------------------------------------------------
+
+elemNotFound :: IOError
+elemNotFound = userError "listbox element not found"
+
+
+-- -----------------------------------------------------------------------
+-- ListBox methods
+-- -----------------------------------------------------------------------
+
+lboxMethods :: Methods
+lboxMethods =
+ defMethods{ cleanupCmd = tkCleanupListBox,
+ createCmd = tkCreateListBox }
+
+-- -----------------------------------------------------------------------
+-- Tk commands
+-- -----------------------------------------------------------------------
+
+tkCreateListBox :: ObjectName -> ObjectKind -> ObjectName -> ObjectID ->
+ [ConfigOption] -> TclScript
+tkCreateListBox parnm kind@(LISTBOX el) name oid confs =
+ tkDeclVar ("sv" ++ show oid) (show name) ++
+ (createCmd defMethods) parnm kind name oid confs ++
+ tkCreateListBoxElems name el
+{-# INLINE tkCreateListBox #-}
+
+tkCleanupListBox :: ObjectID -> ObjectName -> TclScript
+tkCleanupListBox oid _ = tkUndeclVar ("sv" ++ show oid)
+{-# INLINE tkCleanupListBox #-}
+
+tkCreateListBoxElems :: ObjectName -> [GUIVALUE] -> TclScript
+tkCreateListBoxElems name elems =
+ [show name ++ " insert 0 " ++ showElements elems]
+{-# INLINE tkCreateListBoxElems #-}
+
+showElements :: [GUIVALUE] -> String
+showElements = concatMap (++ " ") . (map show)
+{-# INLINE showElements #-}
+
+tkActivate :: ObjectName -> Int -> TclScript
+tkActivate name inx = [show name ++ " activate " ++ show inx]
+{-# INLINE tkActivate #-}
+
+tkCurSelection :: ObjectName -> TclScript
+tkCurSelection name = [show name ++ " curselection "]
+{-# INLINE tkCurSelection #-}
+
+tkDelete :: ObjectName -> String -> String -> TclCmd
+tkDelete name first last = show name ++ " delete " ++ first ++ " " ++ last
+{-# INLINE tkDelete #-}
+
+tkInsert :: ObjectName -> Int -> [GUIVALUE] -> TclScript
+tkInsert name inx elems =
+ [tkDelete name "0" "end",
+ show name ++ " insert " ++ show inx ++ " " ++ showElements elems]
+{-# INLINE tkInsert #-}
+
+tkGet :: ObjectName -> TclScript
+tkGet name = [show name ++ " get 0 end"]
+{-# INLINE tkGet #-}
+
+tkSelectionAnchor :: ObjectName -> Int -> TclScript
+tkSelectionAnchor name inx =
+ [show name ++ " selection anchor " ++ show inx]
+{-# INLINE tkSelectionAnchor #-}
+
+tkSelectionIncludes :: ObjectName -> Int -> TclScript
+tkSelectionIncludes name inx =
+ [show name ++ " selection includes " ++ show inx]
+{-# INLINE tkSelectionIncludes #-}
+
+tkSelectionClear :: ObjectName -> Int -> Int -> TclScript
+tkSelectionClear name first last =
+ [show name ++ " selection clear " ++ show first ++ " " ++ show last]
+{-# INLINE tkSelectionClear #-}
+
+tkSelectionClearAll :: ObjectName -> TclScript
+tkSelectionClearAll name = [show name ++ " selection clear 0 end"]
+{-# INLINE tkSelectionClearAll #-}
+
+tkSelectionSet :: ObjectName -> Int -> Int -> TclScript
+tkSelectionSet name first last =
+ [show name ++ " selection set " ++ show first ++ " " ++ show last]
+{-# INLINE tkSelectionSet #-}
+
+tkSelectionSetItem :: ObjectName -> Int -> TclScript
+tkSelectionSetItem name first =
+ [show name ++ " selection set " ++ show first]
+{-# INLINE tkSelectionSetItem #-}
diff --git a/HTk/Widgets/MenuButton.hs b/HTk/Widgets/MenuButton.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Widgets/MenuButton.hs
@@ -0,0 +1,123 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module HTk.Widgets.MenuButton (
+
+ MenuButton,
+ newMenuButton
+
+) where
+
+import Util.Computation
+import Events.Destructible
+import Events.Synchronized
+
+import HTk.Kernel.Core
+import HTk.Kernel.ButtonWidget
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import HTk.Components.Image
+import HTk.Components.BitMap
+import HTk.Menuitems.Menu
+import HTk.Kernel.Packer
+import HTk.Kernel.Tooltip
+
+
+-- -----------------------------------------------------------------------
+-- type
+-- -----------------------------------------------------------------------
+
+-- | The @MenuButton@ datatype.
+data MenuButton = MenuButton GUIOBJECT
+
+
+-- -----------------------------------------------------------------------
+-- creation
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new menubutton widget and returns a handler.
+newMenuButton :: Container par => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> [Config MenuButton]
+ -- ^ the list of configuration options for this menubutton.
+ -> IO MenuButton
+ -- ^ A menubutton widget.
+newMenuButton par cnf =
+ do
+ b <- createGUIObject (toGUIObject par) MENUBUTTON defMethods
+ configure (MenuButton b) cnf
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject MenuButton where
+ toGUIObject (MenuButton w) = w
+ cname _ = "MenuButton"
+
+-- | A menubutton widget can be destroyed.
+instance Destroyable MenuButton where
+ -- Destroys a menubutton widget.
+ destroy = destroy . toGUIObject
+
+-- | A menubutton widget has standard widget properties
+-- (concerning focus, cursor).
+instance Widget MenuButton
+
+-- | A menubutton widget can be flashed (redisplayed several times in
+-- alternate colours) and invoked (the associated event).
+instance ButtonWidget MenuButton
+
+-- | A menubutton widget can contain a bitmap.
+instance HasBitMap MenuButton
+
+-- | A menubutton widget has a configureable border.
+instance HasBorder MenuButton
+
+-- | A menu button has a normal foreground and background colour and an
+-- active\/disabled foreground and background colour.
+instance HasColour MenuButton where
+ legalColourID = buttonColours
+
+-- | A menubutton widget is a stateful widget, it can be enabled or
+-- disabled.
+instance HasEnable MenuButton
+
+-- | You can specify the font of a menubutton.
+instance HasFont MenuButton
+
+-- | A menu button has a configureable text justification.
+instance HasJustify MenuButton
+
+-- | A menubutton can contain an image.
+instance HasPhoto MenuButton
+
+-- | You can specify the size of a menubutton.
+instance HasSize MenuButton
+
+-- | A menubutton can contain text.
+instance GUIValue v => HasText MenuButton v
+
+-- | You can set the index of a text character to underline.
+instance HasUnderline MenuButton
+
+-- | You can synchronize on a menubutton object (in JAVA style).
+instance Synchronized MenuButton where
+ -- Synchronizes on a menubutton object.
+ synchronize = synchronize . toGUIObject
+
+-- | When a menubutton is clicked, a corresponding event is invoked.
+instance HasCommand MenuButton
+
+-- | A menubutton is a menu container.
+instance HasMenu MenuButton
+
+-- | A menubutton can have a tooltip (only displayed if you are using
+-- tixwish).
+instance HasTooltip MenuButton
+
+-- | A menubutton has a text anchor.
+instance HasAnchor MenuButton
diff --git a/HTk/Widgets/Message.hs b/HTk/Widgets/Message.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Widgets/Message.hs
@@ -0,0 +1,123 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | HTk's message widget.
+-- A message widget is a simple container for text.
+module HTk.Widgets.Message (
+
+ Message,
+ newMessage,
+
+ aspect,
+ getAspect
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import Events.Destructible
+import Util.Computation
+import Events.Synchronized
+import HTk.Kernel.Packer
+import HTk.Kernel.Tooltip
+
+
+-- -----------------------------------------------------------------------
+-- type
+-- -----------------------------------------------------------------------
+
+-- | The @Message@ datatype.
+newtype Message = Message GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- construction
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new message widget and returns a handler.
+newMessage :: Container par => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> [Config Message]
+ -- ^ the list of configuration options for this message
+ -- widget.
+ -> IO Message
+ -- ^ A message widget.
+newMessage par cnf =
+ do
+ w <- createWidget (toGUIObject par) MESSAGE
+ configure (Message w) cnf
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject Message where
+ toGUIObject (Message w) = w
+ cname _ = "Message"
+
+-- | A message widget can be destroyed.
+instance Destroyable Message where
+ destroy = destroy . toGUIObject
+
+-- | A message widget has standard widget properties
+-- (concerning focus, cursor).
+instance Widget Message
+
+-- | A message widget has a configureable border.
+instance HasBorder Message
+
+-- | A message widget has a foreground and background colour.
+instance HasColour Message where
+ legalColourID = hasForeGroundColour
+
+-- | You can specify the font of a message widget.
+instance HasFont Message
+
+-- | A message widget has a configureable text justification.
+instance HasJustify Message
+
+-- | You can specify the width of a message widget (height configuration
+-- is ignored).
+instance HasSize Message where
+ height _ w = return w
+ getHeight _ = return 1
+
+-- | A message widget can contain text.
+instance GUIValue b => HasText Message b where
+ text t w = cset w "text" t
+
+ -- Gets the text from a message widget.
+ -- w - the concerned message widget.
+ -- result - the set text.
+ getText w = cget w "text"
+
+-- | You can synchronize on a message object (in JAVA style).
+instance Synchronized Message where
+ synchronize = synchronize . toGUIObject
+
+-- | A message widget can have a tooltip (only displayed if you are using
+-- tixwish).
+instance HasTooltip Message
+
+-- | An message widget has a text anchor.
+instance HasAnchor Message
+
+
+-- -----------------------------------------------------------------------
+-- configuration options
+-- -----------------------------------------------------------------------
+
+-- | Sets the aspect of a message widget (100 \* width \/ height).
+aspect :: Int -> Config Message
+aspect i mes = cset mes "aspect" i
+
+-- | Gets the aspect froma message widget.
+getAspect :: Message
+ -- ^ the concerned message widget.
+ -> IO Int
+ -- ^ The current aspect of this message widget.
+getAspect mes = cget mes "aspect"
diff --git a/HTk/Widgets/OptionMenu.hs b/HTk/Widgets/OptionMenu.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Widgets/OptionMenu.hs
@@ -0,0 +1,150 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | HTk\'s /option menu/ widget.
+-- A simple clip up menu displaying a set of radiobuttons.
+module HTk.Widgets.OptionMenu (
+
+ OptionMenu,
+ newOptionMenu
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import HTk.Menuitems.MenuItem
+import Events.Destructible
+import Util.Computation
+import HTk.Kernel.Packer
+import HTk.Kernel.Tooltip
+
+
+-- -----------------------------------------------------------------------
+-- datatype
+-- -----------------------------------------------------------------------
+
+-- | The @OptionMenu@ datatype.
+newtype OptionMenu a = OptionMenu GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- creation
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new option menu and returns a handler.
+newOptionMenu :: (Container par, GUIValue a) =>
+ par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> [a]
+ -- ^ the list of selectable elements.
+ -> [Config (OptionMenu a)]
+ ->
+ IO (OptionMenu a)
+ -- ^ An option menu.
+newOptionMenu par el cnf =
+ do
+ wid <- createGUIObject (toGUIObject par) (OPTIONMENU el')
+ optionMenuMethods
+ configure (OptionMenu wid) cnf
+ where el' = map toGUIValue el
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject (OptionMenu a) where
+ toGUIObject (OptionMenu w) = w
+ cname _ = "OptionMenu"
+
+-- | An option menu can be destroyed.
+instance Destroyable (OptionMenu a) where
+ -- Destroys an option menu.
+ destroy = destroy . toGUIObject
+
+-- | An option menu has standard widget properties
+-- (concerning focus, cursor).
+instance Widget (OptionMenu a)
+
+-- | An option menu has a configureable border.
+instance HasBorder (OptionMenu a)
+
+-- | An option menu has a normal foreground and background colour and an
+-- active\/disabled foreground and background colour.
+instance HasColour (OptionMenu a) where
+ legalColourID = buttonColours
+
+-- | An option menu is a stateful widget, it can be enabled or disabled.
+instance HasEnable (OptionMenu a)
+
+-- | You can specify the font of an option menu.
+instance HasFont (OptionMenu a)
+
+-- | You can specify the size of an option menu.
+instance HasSize (OptionMenu a)
+
+-- | An option menu has a value (the selected element), that corresponds to
+-- a polymorphic @TkVariable@.
+instance GUIValue a => HasValue (OptionMenu a) a where
+ -- Sets the option menu\'s value (the selected element).
+ value v w =
+ setTclVariable ((tvarname . objectID . toGUIObject) w) v >> return w
+ -- Gets the option menu\'s value.
+ getValue w = getTclVariable ((tvarname . objectID . toGUIObject) w)
+
+-- | An option menu can have a tooltip (only displayed if you are using
+-- tixwish).
+instance HasTooltip (OptionMenu a)
+
+-- | An option menu has a text anchor.
+instance HasAnchor (OptionMenu a)
+
+
+-- -----------------------------------------------------------------------
+-- OptionMenu methods
+-- -----------------------------------------------------------------------
+
+optionMenuMethods = defMethods { cleanupCmd = tkCleanupOptionMenu,
+ createCmd = tkCreateOptionMenu,
+ csetCmd = tkSetOptionMenuConfigs }
+
+
+-- -----------------------------------------------------------------------
+-- Unparsing of Tk commands
+-- -----------------------------------------------------------------------
+
+tvarname :: ObjectID -> String
+tvarname oid = "v" ++ (show oid)
+
+tkDeclOptionMenuVar :: GUIOBJECT -> WidgetName
+tkDeclOptionMenuVar = WidgetName . tvarname . objectID
+
+tkCreateOptionMenu :: ObjectName -> ObjectKind -> ObjectName ->
+ ObjectID -> [ConfigOption] -> TclScript
+tkCreateOptionMenu _ (OPTIONMENU els) name oid confs =
+ ["set " ++ tvarname oid ++ " " ++ firstElem els,
+ "tk_optionMenu " ++ show name ++ " " ++ tvarname oid ++ " " ++
+ concatMap (++ " ") (map show els)] ++
+ tkSetOptionMenuConfigs name confs
+ where firstElem [] = ""
+ firstElem ((GUIVALUE _ x):l) = x
+
+tkSetOptionMenuConfigs :: ObjectName -> [ConfigOption] -> TclScript
+tkSetOptionMenuConfigs name @ (ObjectName wname) confs =
+ (csetCmd defMethods) name confs ++
+ (csetCmd defMethods) (ObjectName (wname ++ ".menu"))
+ (filter isMenuConfig confs)
+ where isMenuConfig ("foreground",_) = True
+ isMenuConfig ("background",_) = True
+ isMenuConfig ("activebackground",_) = True
+ isMenuConfig ("activeforeground",_) = True
+ isMenuConfig ("disabledforeground",_) = True
+ isMenuConfig ("font",_) = True
+ isMenuConfig (_,_) = False
+
+tkCleanupOptionMenu :: ObjectID -> ObjectName -> TclScript
+tkCleanupOptionMenu oid _ = tkUndeclVar (tvarname oid)
+{-# INLINE tkCleanupOptionMenu #-}
diff --git a/HTk/Widgets/RadioButton.hs b/HTk/Widgets/RadioButton.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Widgets/RadioButton.hs
@@ -0,0 +1,130 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | HTk\'s /radiobutton/ widget.
+-- A simple radiobutton associated with a polymorphic variable.
+module HTk.Widgets.RadioButton (
+
+ RadioButton,
+ newRadioButton
+
+) where
+
+import Util.Computation
+import Events.Destructible
+import Events.Synchronized
+
+import HTk.Kernel.Core
+import HTk.Kernel.ButtonWidget
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import HTk.Components.Image
+import HTk.Components.BitMap
+import HTk.Kernel.TkVariables
+import HTk.Kernel.Packer
+import HTk.Kernel.Tooltip
+
+
+-- -----------------------------------------------------------------------
+-- datatype
+-- -----------------------------------------------------------------------
+
+-- | The @RadioButton@ datatpe - it is associated with a
+-- polymorphic @TkVariable@.
+newtype RadioButton a = RadioButton GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- creation
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new radiobutton widget and returns a handler.
+newRadioButton :: Container par => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> [Config (RadioButton a)]
+ -- ^ the list of configuration options for this
+ -- radiobutton.
+ ->
+ IO (RadioButton a)
+ -- ^ A radiobutton widget.
+newRadioButton par cnf =
+ do
+ b <- createGUIObject (toGUIObject par) RADIOBUTTON defMethods
+ configure (RadioButton b) cnf
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject (RadioButton a) where
+ toGUIObject (RadioButton w) = w
+ cname _ = "RadioButton"
+
+-- | A radiobutton widget can be destroyed.
+instance Destroyable (RadioButton a) where
+ -- Destroys a radiobutton widget.
+ destroy = destroy . toGUIObject
+
+-- | A radiobutton widget has standard widget properties
+-- (concerning focus, cursor).
+instance Widget (RadioButton a)
+
+-- | A radiobutton widget can be flashed (redisplayed several times in
+-- alternate colours) and invoked (the associated event) as any button
+-- widget.
+instance ButtonWidget (RadioButton a)
+
+-- | A radiobutton widget can contain a bitmap.
+instance HasBitMap (RadioButton a)
+
+-- | A radiobutton widget has a configureable border.
+instance HasBorder (RadioButton a)
+
+-- | A radiobutton widget has a normal foreground and background colour and
+-- an active\/disabled foreground and background colour.
+instance HasColour (RadioButton a) where
+ legalColourID = buttonColours
+
+-- | A radiobutton widget is a stateful widget, it can be enabled or
+-- disabled.
+instance HasEnable (RadioButton a)
+
+-- | You can specify the font of a check button.
+instance HasFont (RadioButton a)
+
+-- | A radiobutton has a configureable text justification.
+instance HasJustify (RadioButton a)
+
+-- | A radiobutton can contain an image.
+instance HasPhoto (RadioButton a)
+
+-- | You can specify the size of a radiobutton.
+instance HasSize (RadioButton a)
+
+-- | A radiobutton can contain text.
+instance GUIValue v => HasText (RadioButton a) v
+
+-- | You can set the index of a text character to underline.
+instance HasUnderline (RadioButton a)
+
+-- | You can synchronize on a radiobutton object.
+instance Synchronized (RadioButton a) where
+ -- Synchronizes on a radiobutton object.
+ synchronize = synchronize . toGUIObject
+
+-- | When a radiobutton is clicked, a corresponding event is invoked.
+instance HasCommand (RadioButton a)
+
+-- | A radiobutton has a value, that corresponds to a polymorphic
+-- @TkVariable@.
+instance GUIValue c => HasValue (RadioButton a) c
+
+-- | The radiobutton\'s value is associated with a polymorphic
+-- @TkVariable@.
+instance HasVariable (RadioButton a)
+
+-- | A radiobutton can have a tooltip.
+instance HasTooltip (RadioButton a)
diff --git a/HTk/Widgets/Scale.hs b/HTk/Widgets/Scale.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Widgets/Scale.hs
@@ -0,0 +1,268 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | HTk\'s /scale/ widget.
+-- A simple slider in a through representing a range of numeric values.
+module HTk.Widgets.Scale (
+
+ ScaleValue(..),
+
+ Scale,
+ newScale,
+
+ digits,
+ getDigits,
+
+ interval,
+ getInterval,
+ intervalTo,
+ getIntervalTo,
+ intervalFrom,
+ getIntervalFrom,
+
+ bigIncrement,
+ getBigIncrement,
+
+ showValue,
+ getShowValue
+
+) where
+
+import Util.Computation
+
+import Events.Synchronized
+import Events.Destructible
+import Reactor.ReferenceVariables
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import HTk.Kernel.Resources
+import HTk.Components.Slider
+import HTk.Kernel.Packer
+import HTk.Kernel.Tooltip
+
+
+-- -----------------------------------------------------------------------
+-- Scale type
+-- -----------------------------------------------------------------------
+
+-- | The @Scale@ datatype.
+data Scale a = Scale GUIOBJECT (Ref Double)
+-- the position should really be part of the kind attribute of the GUIObject
+
+
+-- -----------------------------------------------------------------------
+-- classes
+-- -----------------------------------------------------------------------
+
+-- | Values associated with a scale instansiate the
+-- @class ScaleValue@.
+class (Num a, GUIValue a) => ScaleValue a where
+ toDouble :: a -> Double
+ fromDouble :: Double -> a
+
+-- | A double value is a scale value.
+instance ScaleValue Double where
+ toDouble = id
+ fromDouble = id
+
+
+-- -----------------------------------------------------------------------
+-- Scale creation
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new scale widget and returns a handler.
+newScale :: (GUIValue a, ScaleValue a, Container par) =>
+ par
+ -- ^ the parent widget, which has to be a container widget.
+ -> [Config (Scale a)]
+ -- ^ the list of configuration options for this scale
+ -- widget.
+ -> IO (Scale a)
+ -- ^ A scale widget.
+newScale par cnf =
+ do
+ wid <- createGUIObject (toGUIObject par) SCALE scaleMethods
+ ref <- newRef 0
+ sc <- return (Scale wid ref)
+ configure sc (interval (0,100) : cnf)
+
+
+-- -----------------------------------------------------------------------
+-- Configuration options: Instantiations
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance Eq (Scale a) where
+ w1 == w2 = (toGUIObject w1) == (toGUIObject w2)
+
+-- | Internal.
+instance GUIObject (Scale a) where
+ toGUIObject (Scale w _) = w
+ cname _ = "Scale"
+
+-- | A scale widget can be destroyed.
+instance Destroyable (Scale a) where
+ destroy = destroy . toGUIObject
+
+-- | A scale widget has standard widget properties
+-- (concerning focus, cursor).
+instance Widget (Scale a)
+
+-- | You can synchronize on a scale widget.
+instance Synchronized (Scale a) where
+ -- Synchronizes on a scale widget.
+ synchronize = synchronize . toGUIObject
+
+-- | A scale widget has a configureable border.
+instance HasBorder (Scale a)
+
+-- | A scale widget has a configureable foreground, background and
+-- activebackground colour.
+instance HasColour (Scale a) where
+ legalColourID w "background" = True
+ legalColourID w "foreground" = True
+ legalColourID w "activebackground" = True
+ legalColourID w _ = False
+
+-- | A scale widget is a stateful widget, it can be enabled or disabled.
+instance HasEnable (Scale a)
+
+-- | A scale widget has a configureable font.
+instance HasFont (Scale a)
+
+-- | A scale widget has a configureable incrementation interval.
+instance ScaleValue a => HasIncrement (Scale a) a where
+ -- Sets the scale widget\'s incrementation interval.
+ increment d w = cset w "tickinterval" (toDouble d)
+ -- Gets the scale widget\'s incrementation interval.
+ getIncrement w = cget w "tickinterval" >>= return . fromDouble
+
+-- | A scale widget\'s orientation can either be vertical or horizontal.
+instance HasOrientation (Scale a)
+
+-- | A scale widget has a configureable size.
+instance HasSize (Scale a) where
+ -- Sets the scale widget\'s length.
+ height d w = cset w "length" d
+ -- Gets the scale widget\'s length.
+ getHeight w = cget w "length"
+
+-- | A scale widget has a configureable slider.
+instance HasSlider (Scale a)
+
+-- | A scale widget has a text label.
+instance GUIValue v => HasText (Scale a) v where
+ -- Sets the text of the scale widget\'s label.
+ text s w = cset w "label" s
+ -- Gets the text of the scale widget\'s label.
+ getText w = cget w "label"
+
+-- | A scale widget can have a tooltip.
+instance HasTooltip (Scale a)
+
+
+-- -----------------------------------------------------------------------
+-- Scale specific config options
+-- -----------------------------------------------------------------------
+
+-- | Sets the number of significant values in the scale widget.
+digits :: Int -> Config (Scale a)
+digits d w = cset w "digits" d
+
+-- | Gets the number of significant values in the scale widget.
+getDigits :: Scale a -> IO Int
+getDigits w = cget w "digits"
+
+-- | Sets the maximum value of the scale widget.
+intervalTo :: ScaleValue a => a -> Config (Scale a)
+intervalTo v w = cset w "to" (toDouble v)
+
+-- | Gets the maximum value of the scale widget.
+getIntervalTo :: ScaleValue a => Scale a -> IO a
+getIntervalTo w = cget w "to" >>= return . fromDouble
+
+-- | Sets the minimum value of the scale widget.
+intervalFrom :: ScaleValue a => a -> Config (Scale a)
+intervalFrom v w = cset w "from" (toDouble v)
+
+-- | Gets the minimum value of the scale widget.
+getIntervalFrom :: ScaleValue a => Scale a -> IO a
+getIntervalFrom w = cget w "from" >>= return . fromDouble
+
+-- | Sets the scale widgets maximum and minumum value.
+interval :: ScaleValue a => (a, a) -> Config (Scale a)
+interval (b,e) w =
+ synchronize w (do{
+ cset w "to" (toDouble b);
+ cset w "from" (toDouble e)
+ })
+
+-- | Gets the scale widgets maximum and minumum value.
+getInterval :: ScaleValue a => Scale a -> IO (a,a)
+getInterval w =
+ synchronize w (do {
+ cget w "to" >>= \b ->
+ cget w "from" >>= \e ->
+ return (fromDouble b,fromDouble e)
+ })
+
+
+-- -----------------------------------------------------------------------
+-- Slider specific config options
+-- -----------------------------------------------------------------------
+
+-- | A scale\'s slider has a configureable resulution.
+instance ScaleValue a => HasIncrement (Slider (Scale a)) a where
+ -- Sets the slider\'s resolution.
+ increment d w = cset w "resolution" (toDouble d)
+ -- Gets the slider\'s resolution.
+ getIncrement w = cget w "resolution" >>= return . fromDouble
+
+-- | A scale\'s slider has a configureable size.
+instance HasSize (Slider (Scale a)) where
+ -- Sets the sliders width.
+ width d w = cset w "width" d
+ -- Gets the sliders width.
+ getWidth w = cget w "width"
+ -- Sets the sliders height.
+ height d w = cset w "sliderlength" d
+ -- Gets the sliders height.
+ getHeight w = cget w "sliderlength"
+
+-- | Sets the coarse grain slider adjustment value.
+bigIncrement :: ScaleValue a => a -> Config (Slider (Scale a))
+bigIncrement d w = cset w "bigincrement" (toDouble d)
+
+-- | Gets the coarse grain slider adjustment value.
+getBigIncrement :: ScaleValue a => (Slider (Scale a)) -> IO a
+getBigIncrement w = cget w "bigincrement" >>= return . fromDouble
+
+-- | Shows the sliders value when set.
+showValue :: Toggle -> Config (Slider (Scale a))
+showValue d w = cset w "showvalue" d
+
+-- | Gets the current showvalue setting.
+getShowValue :: (Slider (Scale a)) -> IO Toggle
+getShowValue w = cget w "showvalue"
+
+
+-- -----------------------------------------------------------------------
+-- Scale methods
+-- -----------------------------------------------------------------------
+
+scaleMethods :: Methods
+scaleMethods = defMethods
+
+
+-- -----------------------------------------------------------------------
+-- Tk intrinsics
+-- -----------------------------------------------------------------------
+
+tkScaleCmd :: ObjectID -> TclCmd
+tkScaleCmd (ObjectID i) = "Scaled " ++ show i
+{-# INLINE tkScaleCmd #-}
+
+tkPackScale _ _ name opts oid binds =
+ ("pack " ++ (show name) ++ " " ++ (showConfigs opts))
diff --git a/HTk/Widgets/ScrollBar.hs b/HTk/Widgets/ScrollBar.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Widgets/ScrollBar.hs
@@ -0,0 +1,404 @@
+-- | HTk\'s /scrollbar/ widget.
+--
+-- A scroll bar is a widget which controls scrolling.
+--
+module HTk.Widgets.ScrollBar (
+
+ HasScroller(..),
+ ScrollBar,
+ newScrollBar,
+
+ ScrollUnit(..),
+
+ Slider(..),
+ HasSlider(..),
+
+ ScrollBarElem(..),
+ activateScrollBarElem,
+ getActivatedElem,
+
+ Fraction,
+ fraction,
+ identify,
+ setView
+
+) where
+
+import HTk.Kernel.Core
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Configuration
+import HTk.Kernel.Geometry
+import HTk.Kernel.Resources
+import Events.Destructible
+import HTk.Components.Slider
+import Data.Char
+import Util.Computation
+import HTk.Kernel.Packer
+import HTk.Kernel.Tooltip
+import HTk.Kernel.GUIValue
+
+-- -----------------------------------------------------------------------
+-- fraction type
+-- -----------------------------------------------------------------------
+
+-- | Fractions are floating point values between 0 and 1 representing
+-- relative positions within the scrolled range.
+type Fraction = Double
+
+data FractionPair = FractionPair Fraction Fraction
+
+-- | Internal.
+instance GUIValue FractionPair where
+ cdefault = FractionPair 0.0 0.0
+
+-- | Internal.
+instance Show FractionPair where
+ showsPrec d (FractionPair f1 f2) r = show f1 ++ " " ++ show f2 ++ r
+
+-- | Internal.
+instance Read FractionPair where
+ -- Internal.
+ readsPrec p b =
+ case readsPrec p b of
+ [(x,xs)] -> case readsPrec p xs of
+ [(y,ys)] -> [(FractionPair x y, ys)]
+ _ -> []
+ _ -> []
+
+
+-- -----------------------------------------------------------------------
+-- classes
+-- -----------------------------------------------------------------------
+
+-- | Scrollable widgets instantiate @class HasScroller@.
+class Widget w => HasScroller w where
+ -- @True@ for widgets that are scrollable in the given
+ -- orientation.
+ isWfOrientation :: w -> Orientation -> Bool
+ -- Associates a scrollbar with a scrollable widget.
+ scrollbar :: Orientation -> ScrollBar -> Config w
+ -- Positions the scrolled widget so the give @Fraction@ is
+ -- off-screen to the left.
+ moveto :: Orientation -> w -> Fraction -> IO ()
+ -- Scrolls the associated widget by n pages or units (depending on the
+ -- given @ScrollUnit@).
+ scroll :: Orientation -> w -> Int -> ScrollUnit -> IO ()
+ -- Returns two fractions between 0 and 1 that describe the amount of
+ -- the widget off-screen to the left and the amount of the widget visible.
+ view :: Orientation -> w -> IO (Fraction, Fraction)
+
+
+ isWfOrientation _ _ = True
+
+ scrollbar Horizontal sc w | isWfOrientation w Horizontal =
+ do
+ cset sc "command" (TkCommand (varname w ++ " xview"))
+ execTclScript [tkDeclScrollVar w]
+ cset w "xscrollcommand" (TkCommand (varname sc ++ " set"))
+ execTclScript [tkDeclScrollVar sc]
+ return w
+ scrollbar Vertical sc w | isWfOrientation w Vertical =
+ do
+ cset sc "command" (TkCommand (varname w ++ " yview"))
+ execTclScript [tkDeclScrollVar w]
+ cset w "yscrollcommand" (TkCommand (varname sc ++ " set"))
+ execTclScript [tkDeclScrollVar sc]
+ return w
+ scrollbar _ _ w = return w
+
+ moveto ax w f | isWfOrientation w ax =
+ execMethod w (\nm -> [tkMoveTo ax nm f])
+ moveto _ _ _ = done
+
+ scroll ax w num what | isWfOrientation w ax =
+ execMethod w (\nm -> [tkScroll ax nm num what])
+ scroll ax w num what = done
+
+ view ax w =
+ do
+ FractionPair os vis <- (evalMethod w (tkView ax) :: IO FractionPair)
+ return (os,vis)
+
+
+-- -----------------------------------------------------------------------
+-- datatype
+-- -----------------------------------------------------------------------
+
+-- | The @ScrollBar@ datatype.
+newtype ScrollBar = ScrollBar GUIOBJECT deriving Eq
+
+
+-- -----------------------------------------------------------------------
+-- constructor
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new scrollbar widget and returns a handler.
+newScrollBar :: Container par => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> [Config ScrollBar]
+ -- ^ the list of configuration options for this scrollbar.
+ -> IO ScrollBar
+ -- ^ A scrollbar widget.
+newScrollBar par cnf =
+ do
+ w <- createGUIObject (toGUIObject par) SCROLLBAR scrollbarMethods
+ configure (ScrollBar w) cnf
+
+
+-- -----------------------------------------------------------------------
+-- ScrollBar configuration options
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance GUIObject ScrollBar where
+ toGUIObject (ScrollBar w) = w
+ cname _ = "ScrollBar"
+
+-- | A scrollbar widget can be destroyed.
+instance Destroyable ScrollBar where
+ -- Destroys a scrollbar widget.
+ destroy = destroy . toGUIObject
+
+-- | A scrollbar widget has standard widget properties
+-- (concerning focus, cursor).
+instance Widget ScrollBar
+
+-- | A scrollbar widget has a configureable border.
+instance HasBorder ScrollBar
+
+-- | A scrollbar widget has a background and activebackground
+-- (regarding slider) colour.
+instance HasColour ScrollBar where
+ legalColourID w "bg" = True
+ legalColourID w "activebackground" = True -- regards slider actually
+ legalColourID w _ = False
+
+-- | A scrollbar widget is a stateful widget, it can be enabled or
+-- disabled.
+instance HasEnable ScrollBar
+
+-- | You can specify the width of a scrollbar.
+instance HasSize ScrollBar where
+ -- Dummy.
+ height _ w = return w
+ -- Dummy.
+ getHeight w = return cdefault
+
+-- | The scrollbar has a configureable slider component.
+instance HasSlider ScrollBar
+
+-- | The scrollbars orientation can be @Horizontal@ or
+-- @Vertical@.
+instance HasOrientation ScrollBar
+
+-- | A scrollbar can have a tooltip.
+instance HasTooltip ScrollBar
+
+
+-- -----------------------------------------------------------------------
+-- ScrollBar commands
+-- -----------------------------------------------------------------------
+
+-- | Sets the active element (which can be arrow1, arrow2 or slider).
+activateScrollBarElem :: ScrollBar
+ -- ^ the concerned scrollbar.
+ -> ScrollBarElem
+ -- ^ the element to activate.
+ -> IO ()
+ -- ^ None.
+activateScrollBarElem sc elem =
+ execMethod sc (\nm -> [tkActivate nm elem])
+
+-- | Gets the active element (arrow1, arrow2 or slider).
+getActivatedElem :: ScrollBar
+ -- ^ the concerned scrollbar.
+ -> IO (Maybe ScrollBarElem)
+ -- ^ @Just [elem]@ if an element is active,
+ -- otherwise @Nothing@.
+getActivatedElem sc =
+ do
+ e <- evalMethod sc (\nm -> [tkGetActivate nm])
+ case dropWhile isSpace e of
+ "" -> return Nothing
+ x -> return (Just (read x))
+
+-- | Returns a fraction between 0 and 1 indicating the relative location
+-- of the given position in the through.
+fraction :: ScrollBar
+ -- ^ the concerned scrollbar.
+ -> Position
+ -- ^ the conderned position.
+ -> IO Fraction
+ -- ^ The fraction indicating the relative location in the
+ -- through.
+fraction sc pos@(x, y) = evalMethod sc (\nm -> [tkFraction nm x y])
+
+-- | Returns the @ScrollBarElem@ to indicate what is under
+-- the given position.
+identify :: ScrollBar
+ -- ^ the concerned scrollbar.
+ -> Position
+ -- ^ the concerned position.
+ -> IO (Maybe ScrollBarElem)
+ -- ^ @Just [elem]@ if @[elem]@ is
+ -- under the given position, otherwise
+ -- @Nothing@.
+identify sc pos@(x, y) =
+ do
+ e <- evalMethod sc (\nm -> [tkIdentify nm x y])
+ case dropWhile (isSpace) e of
+ "" -> return Nothing
+ x -> return (Just (read x))
+
+-- | Sets the scrollbar parameters.
+setView :: ScrollBar
+ -- ^ the concerned scrollbar.
+ -> Fraction
+ -- ^ fraction between 0 and 1 representing the relative
+ -- position of the top left of the display.
+ -> Fraction
+ -- ^ fraction between 0 and 1 representing the relative
+ -- position of the bottom right of the display.
+ -> IO ()
+ -- ^ None.
+setView sc first last = execMethod sc (\nm -> [tkSet nm first last])
+
+
+-- -----------------------------------------------------------------------
+-- ScrollBar elem
+-- -----------------------------------------------------------------------
+
+-- | The @ScrollBarElem@ datatype - representing the elements
+-- of the scrollbar.
+data ScrollBarElem =
+ Arrow1
+ | Trough1
+ | ScrollBarSlider
+ | Trough2
+ | Arrow2
+ deriving (Eq,Ord,Enum)
+
+-- | Internal.
+instance GUIValue ScrollBarElem where
+ cdefault = ScrollBarSlider
+
+-- | Internal.
+instance Read ScrollBarElem where
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ 'a':'r':'r':'o':'w':'1':xs -> [(Arrow1,xs)]
+ 't':'r':'o':'u':'g':'h':'1':xs -> [(Trough1,xs)]
+ 's':'l':'i':'d':'e':'r':xs -> [(ScrollBarSlider,xs)]
+ 't':'r':'o':'u':'g':'h':'2':xs -> [(Trough2,xs)]
+ 'a':'r':'r':'o':'w':'2':xs -> [(Arrow2,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show ScrollBarElem where
+ showsPrec d p r =
+ (case p of
+ Arrow1 -> "arrow1"
+ Trough1 -> "trough1"
+ ScrollBarSlider -> "slider"
+ Trough2 -> "trough2"
+ Arrow2 -> "arrow2"
+ ) ++ r
+
+
+-- -----------------------------------------------------------------------
+-- scroll unit
+-- -----------------------------------------------------------------------
+
+-- | The @ScrollUnit@ datatype - units for scrolling operations.
+data ScrollUnit = Units | Pages
+
+-- | Internal.
+instance GUIValue ScrollUnit where
+ cdefault = Units
+
+-- | Internal.
+instance Read ScrollUnit where
+ -- Internal.
+ readsPrec p b =
+ case dropWhile (isSpace) b of
+ 'u':'n':'i':'t':'s':xs -> [(Units,xs)]
+ 'p':'a':'g':'e':'s':xs -> [(Pages,xs)]
+ _ -> []
+
+-- | Internal.
+instance Show ScrollUnit where
+ -- Internal.
+ showsPrec d p r =
+ (case p of
+ Units -> "units"
+ Pages -> "pages"
+ ) ++ r
+
+
+-- -----------------------------------------------------------------------
+-- Scrollbar methods
+-- -----------------------------------------------------------------------
+
+scrollbarMethods = defMethods { cleanupCmd = tkCleanupScrollBar,
+ createCmd = tkCreateScrollBar }
+
+
+-- -----------------------------------------------------------------------
+-- Tk commands
+-- -----------------------------------------------------------------------
+
+tkCreateScrollBar :: ObjectName -> ObjectKind -> ObjectName -> ObjectID ->
+ [ConfigOption] -> TclScript
+tkCreateScrollBar pnm kind name oid confs =
+ tkDeclVar ("sv" ++ show oid) (show name) ++
+ (createCmd defMethods) pnm kind name oid confs
+{-# INLINE tkCreateScrollBar #-}
+
+tkCleanupScrollBar :: ObjectID -> ObjectName -> TclScript
+tkCleanupScrollBar oid _ = tkUndeclVar ("sv" ++ show oid)
+{-# INLINE tkCleanupScrollBar #-}
+
+varname :: GUIObject w => w -> String
+varname w = (tkDeclScrollVar w) ++ "; $sv" ++ ((show .getObjectNo . toGUIObject) w)
+{-# INLINE varname #-}
+
+tkDeclScrollVar :: GUIObject w => w -> String
+tkDeclScrollVar w = "global sv" ++ ((show .getObjectNo . toGUIObject) w)
+{-# INLINE tkDeclScrollVar #-}
+
+tkScroll :: Orientation -> ObjectName -> Int -> ScrollUnit -> TclCmd
+tkScroll ax nm no what = show nm ++ " " ++ oshow ax ++ "view scroll " ++ show no ++ " " ++ show what
+{-# INLINE tkScroll #-}
+
+-- added Oct. '01, still experimental (ludi)
+tkView :: Orientation -> ObjectName -> TclScript
+tkView ax nm = [show nm ++ " " ++ oshow ax ++ "view"]
+{-# INLINE tkView #-}
+
+tkMoveTo :: Orientation -> ObjectName -> Fraction -> String
+tkMoveTo ax nm f = show nm ++ " " ++ oshow ax ++ "view moveto " ++ show f
+{-# INLINE tkMoveTo #-}
+
+tkActivate :: ObjectName -> ScrollBarElem -> String
+tkActivate nm e = show nm ++ " activate " ++ show e
+{-# INLINE tkActivate #-}
+
+tkGetActivate :: ObjectName -> String
+tkGetActivate nm = show nm ++ " activate"
+{-# INLINE tkGetActivate #-}
+
+tkFraction :: ObjectName -> Distance -> Distance -> String
+tkFraction nm x y = show nm ++ " fraction " ++ show x ++ " " ++ show y
+{-# INLINE tkFraction #-}
+
+tkIdentify :: ObjectName -> Distance -> Distance -> String
+tkIdentify nm x y = show nm ++ " identify " ++ show x ++ " " ++ show y
+{-# INLINE tkIdentify #-}
+
+tkSet :: ObjectName -> Fraction -> Fraction -> String
+tkSet nm x y = show nm ++ " set " ++ show x ++ " " ++ show y
+{-# INLINE tkSet #-}
+
+oshow Horizontal = "x"
+oshow Vertical = "y"
diff --git a/HTk/Widgets/Space.hs b/HTk/Widgets/Space.hs
new file mode 100644
--- /dev/null
+++ b/HTk/Widgets/Space.hs
@@ -0,0 +1,93 @@
+-- | HTk\'s /space/ widget.
+-- A simple spacer for special packing purposes.
+module HTk.Widgets.Space (
+
+ Space,
+ newSpace,
+
+) where
+
+import HTk.Containers.Frame
+import HTk.Kernel.Configuration
+import HTk.Kernel.Resources
+import HTk.Kernel.GUIObject
+import Events.Destructible
+import Events.Synchronized
+import HTk.Kernel.Geometry
+import Util.Computation
+import HTk.Kernel.BaseClasses(Widget)
+import HTk.Kernel.Packer
+
+
+-- -----------------------------------------------------------------------
+-- datatype
+-- -----------------------------------------------------------------------
+
+-- | The @Space@ datatype.
+data Space = Space Distance Frame
+
+
+-- -----------------------------------------------------------------------
+-- constructor
+-- -----------------------------------------------------------------------
+
+-- | Constructs a new space widget and returns a handler.
+newSpace :: Container par => par
+ -- ^ the parent widget, which has to be a container widget
+ -- (an instance of @class Container@).
+ -> Distance
+ -- ^ the horizontal or vertical distance (depending on the
+ -- space widget\'s orientation).
+ -> [Config Space]
+ -- ^ the list of configuration options for this
+ -- space widget.
+ -> IO Space
+ -- ^ A space widget.
+newSpace par dist cnf =
+ do
+ f <- newFrame par []
+ configure (Space dist f) (defaults : cnf)
+ where defaults = orient Vertical
+
+
+-- -----------------------------------------------------------------------
+-- instances
+-- -----------------------------------------------------------------------
+
+-- | Internal.
+instance Eq Space where
+ (Space _ f1) == (Space _ f2) = f1 == f2
+
+-- | Internal.
+instance GUIObject Space where
+ toGUIObject (Space d f) = toGUIObject f
+ cname _ = "Space"
+
+-- | A space widget can be destroyed.
+instance Destroyable Space where
+ -- Destroys a space widget.
+ destroy = destroy . toGUIObject
+
+-- | A radiobutton widget has standard widget properties
+-- (concerning focus, cursor).
+instance Widget Space
+
+-- | You can synchronize on a space widget.
+instance Synchronized Space where
+ -- Synchronizes on a space widget.
+ synchronize w = synchronize (toGUIObject w)
+
+-- | A space widget has a configureable background colour.
+instance HasColour Space where
+ legalColourID = hasBackGroundColour
+
+-- | The space widgets orientation can either be @vertical@ or
+-- @Horizontal@.
+instance HasOrientation Space where
+ -- Sets the orientation of the space widget.
+ orient or s @ (Space d f) =
+ configure f (case or of Horizontal -> [{-fill Vertical,-} width d,
+ height 0]
+ Vertical -> [{-fill Horizontal,-} height d,
+ width 0]) >>
+ return s
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,123 @@
+License Agreement
+
+Preamble
+
+The aim of this licence agreement is to enable the free use of the
+software that is described in the sequel by anyone. In order to
+guarantee this, it is necessary to set up rules for the use of the
+software that hold for any user.
+
+Provider of this licence is the University of Bremen, represented by
+its principal (called "licence provider" in the sequel). The provider
+of the licence has developed the "Uniform Workbench" (just
+called "software" in the sequel). The software includes a
+graphical tool for accessing documents stored in a versioned repository,
+but also contains libraries and some other tools.
+
+Following the ideas of open source software, the licence provider
+gives access to the software without fee for anyone (called "licence
+taker" in the sequel) under the following conditions which are similar
+to the Lesser Gnu Public License (LGPL). Each licence taker obligates
+himself to follow the terms of use below.
+
+
+
+1 Principle
+
+Each licence taker appreciating these terms of use receives a simple
+right, not resctricted in time and space and without any fee, to use
+the software, in particular, to copy, distribute and process
+it. Exclusively the following terms of use do hold. The licence
+provider explicitly contradicts any conflicting terms of business. By
+making use of the rights described below, in particular by copying or
+distributing it, a licence treaty between the licence provider and the
+licence takes is concluded.
+
+
+
+2 Copying
+
+The licence taker has the right to make and distribute unmodified
+copies of the software on any media. Prerequisite for this is that the
+licence provider and this licence agreement is clearly recognizable,
+and that the sources are distributed together with the software.
+
+
+
+3 Modification and Distribution
+
+The licence taker has the right to modify copies of the software (or
+parts thereof) and to distribute these modifications under the terms
+of 2 above and the following conditions:
+
+1. The modified software has to carry a clear mark that points to the
+original licence provider, the modification that has been made, and
+the date of the modification.
+
+2. The licence taker has to ensure that the software as a whole or
+parts of it are accessible to third parties under the terms of this
+licence agreement without fee.
+
+3. If during the modification a copyright of the licence taker
+emerges, then this copyright must be put under the terms of this
+licence if the modified software is distributed.
+
+
+4 Other duties
+
+1. Reference to the validity of this licence agreement must not be
+modified or deleted by the licence taker.
+
+2. The use of the software by third parties must not be conditioned by
+the fulfilment of duties that are not mentioned in this licence
+agreement.
+
+3. The use of the software must not be prevented or complicated by
+means fo technical protection, in particular copy protection means.
+
+
+
+5 Liability, Update
+
+1. Liability of the licence provider is restriced to fraudulent
+withheld factual or legal errors. The licence provider does not give
+any warranty, and neither ensures any properties of the
+software. Furthermore, he is liable only for those damages that are
+caused by willful or grossly negligent violation of duty.
+
+2. The licence provider has the right to update these terms of use at
+any time.
+
+
+
+
+6 Forum for users
+
+The licence provider does provide neither support nor
+consultation. Without acknowledgement of any legal duty, the licence
+provider will care about the installation of a user forum for
+discussions about the software and its further development.
+
+
+7 Legal domicile
+
+It is agreed that the law of the Federal Republic of Germany is valid
+for this licence agreement. For any lawsuits or legal actions emerging
+from this licence agreement, it is agreed that exclusively German
+courts are competent. Legal domicile is Bremen.
+
+
+8 Termination through Offence
+
+Any violation of a duty of this agreement automatically terminates the
+rights of use of the offender.
+
+
+
+9 Salvatorian Clause
+
+If any rule of this agreement should be or become inoperative,
+validity of the other rules is not affected. The parties will care
+about replacing the invalid rule by some valid rule that comes close
+to the purpose of this agreement.
+
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/uni-htk.cabal b/uni-htk.cabal
new file mode 100644
--- /dev/null
+++ b/uni-htk.cabal
@@ -0,0 +1,69 @@
+name: uni-htk
+version: 2.2.0.0
+build-type: Simple
+license: LGPL
+license-file: LICENSE
+author: uniform@informatik.uni-bremen.de
+maintainer: Christian.Maeder@dfki.de
+homepage: http://www.informatik.uni-bremen.de/htk/
+category: GUI
+synopsis: Graphical User Interface for Haskell Programs
+description: GUI toolkit based on Tcl\/Tk
+cabal-version: >= 1.4
+Tested-With: GHC==6.8.3, GHC==6.10.4, GHC==6.12.3
+
+flag debug
+ description: add debug traces
+ default: False
+
+library
+ exposed-modules: HTk.Kernel.BaseClasses, HTk.Kernel.ButtonWidget,
+ HTk.Kernel.CallWish, HTk.Kernel.Colour, HTk.Kernel.Configuration,
+ HTk.Kernel.Core, HTk.Kernel.Cursor, HTk.Kernel.EventInfo, HTk.Kernel.Font,
+ HTk.Kernel.GUIObject, HTk.Kernel.GUIObjectKind, HTk.Kernel.GUIObjectName,
+ HTk.Kernel.GUIValue, HTk.Kernel.Geometry, HTk.Kernel.GridPackOptions,
+ HTk.Kernel.PackOptions, HTk.Kernel.Packer, HTk.Kernel.Resources,
+ HTk.Kernel.TkVariables, HTk.Kernel.Tooltip, HTk.Kernel.Wish,
+ HTk.Containers.Box, HTk.Containers.Frame, HTk.Containers.Toplevel,
+ HTk.Containers.Window, HTk.Components.BitMap, HTk.Components.Focus,
+ HTk.Components.ICursor, HTk.Components.Icon, HTk.Components.Image,
+ HTk.Components.Index, HTk.Components.Selection, HTk.Components.Slider,
+ HTk.Devices.Bell, HTk.Devices.Printer, HTk.Devices.Screen,
+ HTk.Devices.XSelection, HTk.Tix.LabelFrame, HTk.Tix.NoteBook,
+ HTk.Tix.PanedWindow, HTk.Tix.Subwidget, HTk.Menuitems.Indicator,
+ HTk.Menuitems.Menu, HTk.Menuitems.MenuCascade,
+ HTk.Menuitems.MenuCheckButton, HTk.Menuitems.MenuCommand,
+ HTk.Menuitems.MenuItem, HTk.Menuitems.MenuRadioButton,
+ HTk.Menuitems.MenuSeparator, HTk.Widgets.Button, HTk.Widgets.Canvas,
+ HTk.Widgets.CheckButton, HTk.Widgets.ComboBox, HTk.Widgets.Editor,
+ HTk.Widgets.Entry, HTk.Widgets.Label, HTk.Widgets.ListBox,
+ HTk.Widgets.MenuButton, HTk.Widgets.Message, HTk.Widgets.OptionMenu,
+ HTk.Widgets.RadioButton, HTk.Widgets.Scale, HTk.Widgets.ScrollBar,
+ HTk.Widgets.Space, HTk.Canvasitems.Arc, HTk.Canvasitems.BitMapItem,
+ HTk.Canvasitems.CanvasItem, HTk.Canvasitems.CanvasItemAux,
+ HTk.Canvasitems.CanvasTag, HTk.Canvasitems.EmbeddedCanvasWin,
+ HTk.Canvasitems.ImageItem, HTk.Canvasitems.Line, HTk.Canvasitems.Oval,
+ HTk.Canvasitems.Polygon, HTk.Canvasitems.Rectangle,
+ HTk.Canvasitems.TextItem, HTk.Textitems.EmbeddedTextWin, HTk.Textitems.Mark,
+ HTk.Textitems.TextTag, HTk.Toplevel.HTk, HTk.Toolkit.CItem,
+ HTk.Toolkit.DialogWin, HTk.Toolkit.FileDialog, HTk.Toolkit.GenGUI,
+ HTk.Toolkit.GenericBrowser, HTk.Toolkit.HTkMenu, HTk.Toolkit.IconBar,
+ HTk.Toolkit.InputForm, HTk.Toolkit.InputWin, HTk.Toolkit.LogWin,
+ HTk.Toolkit.MarkupText, HTk.Toolkit.MenuType, HTk.Toolkit.ModalDialog,
+ HTk.Toolkit.Name, HTk.Toolkit.Notepad, HTk.Toolkit.Prompt,
+ HTk.Toolkit.ScrollBox, HTk.Toolkit.SelectBox, HTk.Toolkit.Separator,
+ HTk.Toolkit.SimpleForm, HTk.Toolkit.SimpleListBox, HTk.Toolkit.SpinButton,
+ HTk.Toolkit.TextDisplay, HTk.Toolkit.TreeList
+
+ build-depends: base >=3 && < 4, containers, directory, uni-util, uni-events,
+ uni-posixutil, uni-reactor
+
+-- extensions: OverlappingInstances
+
+ if flag(debug)
+ cpp-options: -DDEBUG
+
+ if impl(ghc < 6.10)
+ extensions: PatternSignatures
+ else
+ ghc-options: -fwarn-unused-imports -fno-warn-warnings-deprecations