packages feed

uni-htk (empty) → 2.2.0.0

raw patch · 107 files changed

+24779/−0 lines, 107 filesdep +basedep +containersdep +directorysetup-changed

Dependencies added: base, containers, directory, uni-events, uni-posixutil, uni-reactor, uni-util

Files

+ HTk/Canvasitems/Arc.hs view
@@ -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"
+ HTk/Canvasitems/BitMapItem.hs view
@@ -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)
+ HTk/Canvasitems/CanvasItem.hs view
@@ -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
+ HTk/Canvasitems/CanvasItemAux.hs view
@@ -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 _ _ = []
+ HTk/Canvasitems/CanvasTag.hs view
@@ -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]
+ HTk/Canvasitems/EmbeddedCanvasWin.hs view
@@ -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"
+ HTk/Canvasitems/ImageItem.hs view
@@ -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
+ HTk/Canvasitems/Line.hs view
@@ -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
+ HTk/Canvasitems/Oval.hs view
@@ -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
+ HTk/Canvasitems/Polygon.hs view
@@ -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
+ HTk/Canvasitems/Rectangle.hs view
@@ -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
+ HTk/Canvasitems/TextItem.hs view
@@ -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
+ HTk/Components/BitMap.hs view
@@ -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 #-}
+ HTk/Components/Focus.hs view
@@ -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
+ HTk/Components/ICursor.hs view
@@ -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"
+ HTk/Components/Icon.hs view
@@ -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"
+ HTk/Components/Image.hs view
@@ -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 #-}
+ HTk/Components/Index.hs view
@@ -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
+ HTk/Components/Selection.hs view
@@ -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
+ HTk/Components/Slider.hs view
@@ -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
+ HTk/Containers/Box.hs view
@@ -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
+ HTk/Containers/Frame.hs view
@@ -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
+ HTk/Containers/Toplevel.hs view
@@ -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
+ HTk/Containers/Window.hs view
@@ -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 #-}
+ HTk/Devices/Bell.hs view
@@ -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 #-}
+ HTk/Devices/Printer.hs view
@@ -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)
+ HTk/Devices/Screen.hs view
@@ -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
+ HTk/Devices/XSelection.hs view
@@ -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])
+ HTk/Kernel/BaseClasses.hs view
@@ -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"
+ HTk/Kernel/ButtonWidget.hs view
@@ -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
+ HTk/Kernel/CallWish.hs view
@@ -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+++
+ HTk/Kernel/Colour.hs view
@@ -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 -}
+ HTk/Kernel/Configuration.hs view
@@ -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)}
+ HTk/Kernel/Core.hs view
@@ -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+
+ HTk/Kernel/Cursor.hs view
@@ -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 ++ "}"
+ HTk/Kernel/EventInfo.hs view
@@ -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}+
+ HTk/Kernel/Font.hs view
@@ -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
+ HTk/Kernel/GUIObject.hs view
@@ -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 }++
+ HTk/Kernel/GUIObjectKind.hs view
@@ -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
+ HTk/Kernel/GUIObjectName.hs view
@@ -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
+ HTk/Kernel/GUIValue.hs view
@@ -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+
+ HTk/Kernel/Geometry.hs view
@@ -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
+ HTk/Kernel/GridPackOptions.hs view
@@ -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 <code>StickyKind</code>)+  | 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
+ HTk/Kernel/PackOptions.hs view
@@ -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
+ HTk/Kernel/Packer.hs view
@@ -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
+ HTk/Kernel/Resources.hs view
@@ -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
+ HTk/Kernel/TkVariables.hs view
@@ -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
+ HTk/Kernel/Tooltip.hs view
@@ -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)
+ HTk/Kernel/Wish.hs view
@@ -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
+ HTk/Menuitems/Indicator.hs view
@@ -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
+ HTk/Menuitems/Menu.hs view
@@ -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 #-}
+ HTk/Menuitems/MenuCascade.hs view
@@ -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+
+ HTk/Menuitems/MenuCheckButton.hs view
@@ -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
+ HTk/Menuitems/MenuCommand.hs view
@@ -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
+ HTk/Menuitems/MenuItem.hs view
@@ -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
+ HTk/Menuitems/MenuRadioButton.hs view
@@ -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
+ HTk/Menuitems/MenuSeparator.hs view
@@ -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
+ HTk/Textitems/EmbeddedTextWin.hs view
@@ -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 #-}
+ HTk/Textitems/Mark.hs view
@@ -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 ++ "}"
+ HTk/Textitems/TextTag.hs view
@@ -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 #-}
+ HTk/Tix/LabelFrame.hs view
@@ -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
+ HTk/Tix/NoteBook.hs view
@@ -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
+ HTk/Tix/PanedWindow.hs view
@@ -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
+ HTk/Tix/Subwidget.hs view
@@ -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.+
+ HTk/Toolkit/CItem.hs view
@@ -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
+ HTk/Toolkit/DialogWin.hs view
@@ -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 #-}
+ HTk/Toolkit/FileDialog.hs view
@@ -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=="]
+ HTk/Toolkit/GenGUI.hs view
@@ -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)
+ HTk/Toolkit/GenericBrowser.hs view
@@ -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)
+ HTk/Toolkit/HTkMenu.hs view
@@ -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)
+ HTk/Toolkit/IconBar.hs view
@@ -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
+ HTk/Toolkit/InputForm.hs view
@@ -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})
+ HTk/Toolkit/InputWin.hs view
@@ -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 <code>InputWindow</code>, 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
+ HTk/Toolkit/LogWin.hs view
@@ -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
+ HTk/Toolkit/MarkupText.hs view
@@ -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
+ HTk/Toolkit/MenuType.hs view
@@ -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+
+ HTk/Toolkit/ModalDialog.hs view
@@ -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+++++++++++
+ HTk/Toolkit/Name.hs view
@@ -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
+ HTk/Toolkit/Notepad.hs view
@@ -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
+ HTk/Toolkit/Prompt.hs view
@@ -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
+ HTk/Toolkit/ScrollBox.hs view
@@ -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
+ HTk/Toolkit/SelectBox.hs view
@@ -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)
+ HTk/Toolkit/Separator.hs view
@@ -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+                }++
+ HTk/Toolkit/SimpleForm.hs view
@@ -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+            })+     )
+ HTk/Toolkit/SimpleListBox.hs view
@@ -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)
+ HTk/Toolkit/SpinButton.hs view
@@ -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 #-}
+ HTk/Toolkit/TextDisplay.hs view
@@ -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
+ HTk/Toolkit/TreeList.hs view
@@ -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 #-}
+ HTk/Toplevel/HTk.hs view
@@ -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
+ HTk/Widgets/Button.hs view
@@ -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
+ HTk/Widgets/Canvas.hs view
@@ -0,0 +1,303 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | HTk's <strong>canvas widget</strong>.<br>+-- A canvas is a drawing pad, that can also contain widgets in embedded+-- windows.<br>+-- A canvas widget contains <strong>canvas items</strong>.+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
+ HTk/Widgets/CheckButton.hs view
@@ -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)
+ HTk/Widgets/ComboBox.hs view
@@ -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 #-}+
+ HTk/Widgets/Editor.hs view
@@ -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 ++ "}"
+ HTk/Widgets/Entry.hs view
@@ -0,0 +1,357 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}++-- | HTk's <strong>entry field</strong>.<br>+-- 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 #-}
+ HTk/Widgets/Label.hs view
@@ -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
+ HTk/Widgets/ListBox.hs view
@@ -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 #-}
+ HTk/Widgets/MenuButton.hs view
@@ -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
+ HTk/Widgets/Message.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | HTk's <strong>message widget</strong>.<br>+-- 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"
+ HTk/Widgets/OptionMenu.hs view
@@ -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 #-}
+ HTk/Widgets/RadioButton.hs view
@@ -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)
+ HTk/Widgets/Scale.hs view
@@ -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))
+ HTk/Widgets/ScrollBar.hs view
@@ -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"
+ HTk/Widgets/Space.hs view
@@ -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
+ LICENSE view
@@ -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.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ uni-htk.cabal view
@@ -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