uni-htk 2.2.1.1 → 2.2.1.2

+ HTk.Toolkit.SimpleForm: instance [overlap ok] Typeable Radio

+ HTk.Canvasitems.CanvasItem: class CanvasItem w => FilledCanvasItem w where 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"

+ HTk.Canvasitems.CanvasItem: class CanvasItem w => SegmentedCanvasItem w where splinesteps c w = cset w "splinesteps" c getSplinesteps w = cget w "splinesteps" smooth c w = cset w "smooth" c getSmooth w = cget w "smooth"

+ HTk.Canvasitems.CanvasTag: class CanvasItem w => TaggedCanvasItem w where tags cts item = mapM (\ ct -> do { CanvasItemName name tid <- getObjectName (toGUIObject ct); cset item "tag" (show tid) }) cts >> return item

+ HTk.Components.BitMap: class GUIObject w => HasBitMap w where bitmap d w = setBitMapHandle w "bitmap" (toBitMap d) True getBitMap w = getBitMapHandle w "bitmap"

+ HTk.Components.Image: class GUIObject w => HasPhoto w where photo img w = imageToInt img >>= cset w "image" getPhoto w = cget w "image" >>= intToImage

+ HTk.Components.Selection: class HasSelectionIndex w i => HasSelectionBaseIndexRange w i where getSelectionRange w = do { start <- getSelectionStart w; end <- getSelectionEnd w; case (start, end) of { ((Just start), (Just end)) -> return (Just (start, end)) _ -> return Nothing } }

+ HTk.Components.Slider: class Widget w => HasSlider w where repeatInterval c w = cset w "repeatinterval" c getRepeatInterval w = cget w "repeatinterval" repeatDelay c w = cset w "repeatdelay" c getRepeatDelay w = cget w "repeatdelay"

+ HTk.Containers.Window: class GUIObject w => Window w where 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"

+ HTk.Devices.Printer: class GUIObject w => HasPostscript w where postscript target confs = do { confstr <- showCreationConfigs confs; try (execMethod target (\ nm -> [tkPostScript nm confstr])) :: IO (Either SomeException ()); return () } where tkPostScript :: ObjectName -> String -> TclCmd tkPostScript name confstr = show name ++ " postscript " ++ confstr

+ HTk.Devices.XSelection: class HasSelection w => HasXSelection w where exportSelection b w = cset w "exportselection" b getExportSelection w = cget w "exportselection"

+ HTk.Kernel.BaseClasses: class GUIObject w => Widget w where 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: class Widget w => ButtonWidget w where flash w = do { try (execMethod w (\ nm -> tkFlash nm)) :: IO (Either SomeException ()); return () } invoke w = execMethod (toGUIObject w) (\ nm -> tkInvoke nm)

+ HTk.Kernel.Configuration: class GUIObject w => HasAlign w where align a w = cset w "align" a getAlign w = cget w "align"

+ HTk.Kernel.Configuration: class GUIObject w => HasAnchor w where anchor a w = cset w "anchor" a getAnchor w = cget w "anchor"

+ HTk.Kernel.Configuration: class GUIObject w => HasBorder w where borderwidth s w = cset w "borderwidth" s getBorderwidth w = cget w "borderwidth" relief r w = cset w "relief" r getRelief w = cget w "relief"

+ HTk.Kernel.Configuration: class GUIObject w => HasColour w where 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

+ HTk.Kernel.Configuration: class GUIObject w => HasEnable w where 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.Configuration: class GUIObject w => HasFont w where font f w = cset w "font" (toFont f) getFont w = cget w "font"

+ HTk.Kernel.Configuration: class GUIObject w => HasGrid w where setgrid b w = cset w "setgrid" b getGrid w = cget w "setgrid"

+ HTk.Kernel.Configuration: class GUIObject w => HasJustify w where justify js w = cset w "justify" js getJustify w = cget w "justify"

+ HTk.Kernel.Configuration: class GUIObject w => HasOrientation w where orient o w = cset w "orient" o getOrient w = cget w "orient"

+ HTk.Kernel.Configuration: class GUIObject w => HasSize w where 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)

+ HTk.Kernel.Configuration: class (GUIObject w, GUIValue v) => HasText w v where text t w = cset w "text" t getText w = cget w "text"

+ HTk.Kernel.Configuration: class GUIObject w => HasUnderline w where underline i w = cset w "underline" i getUnderline w = cget w "underline" wraplength l w = cset w "wraplength" l getWraplength w = cget w "wraplength"

+ HTk.Kernel.Configuration: class (GUIObject w, GUIValue v) => HasValue w v where value v w = cset w "value" v >> return w getValue w = cget w "value"

+ HTk.Kernel.Core: class GUIObject w where cset w cid v = setConfig (toGUIObject w) cid v >> return w cget w cid = getConfig (toGUIObject w) cid

+ HTk.Kernel.Core: class GUIObject w => HasCommand w where 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 ()) }

+ HTk.Kernel.Core: class GUIObject w => HasEnable w where 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.GUIObject: class GUIObject w where cset w cid v = setConfig (toGUIObject w) cid v >> return w cget w cid = getConfig (toGUIObject w) cid

+ HTk.Kernel.GUIValue: class (Show a, Read a) => GUIValue a where 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 }

+ HTk.Kernel.TkVariables: class GUIObject w => HasVariable w where variable (TkVariable oid) w = cset w "variable" ("v" ++ show oid) >> return w

+ HTk.Kernel.Tooltip: class GUIObject w => HasTooltip w where 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.Menuitems.Indicator: class GUIObject w => HasColour w where 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

+ HTk.Menuitems.Indicator: class GUIObject w => HasIndicator w where indicator i w = cset w "indicatoron" i getIndicator w = cget w "indicatoron"

+ HTk.Menuitems.Indicator: class GUIObject w => HasPhoto w where photo img w = imageToInt img >>= cset w "image" getPhoto w = cget w "image" >>= intToImage

+ HTk.Menuitems.Indicator: class ButtonWidget w => SelectButton w where selectionState On w = execMethod (toGUIObject w) (\ nm -> tkSelect nm) >> return w selectionState Off w = execMethod (toGUIObject w) (\ nm -> tkDeselect nm) >> return w

+ HTk.Menuitems.Menu: class GUIObject w => HasMenu w where menu m w = do { let (GUIOBJECT _ mostref) = toGUIObject m; most <- getRef mostref; cset w "menu" (show (objectname most)) }

+ HTk.Menuitems.MenuItem: class GUIObject w => HasAccelerator w where accelerator s w = cset w "accelerator" s getAccelerator w = cget w "accelerator"

+ HTk.Menuitems.MenuItem: class GUIObject w => HasColour w where 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

+ HTk.Menuitems.MenuItem: class GUIObject w => HasPhoto w where photo img w = imageToInt img >>= cset w "image" getPhoto w = cget w "image" >>= intToImage

+ HTk.Menuitems.MenuItem: class ButtonWidget w => SelectButton w where selectionState On w = execMethod (toGUIObject w) (\ nm -> tkSelect nm) >> return w selectionState Off w = execMethod (toGUIObject w) (\ nm -> tkDeselect nm) >> return w

+ HTk.Menuitems.MenuItem: class SelectButton w => ToggleButton w where toggleButton w = execMethod (toGUIObject w) (\ nm -> tkToggle nm)

+ HTk.Toplevel.HTk: class GUIObject w => HasCommand w where 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 ()) }

+ HTk.Widgets.Editor: class GUIObject w => HasLineSpacing w where 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"

+ HTk.Widgets.Editor: class GUIObject w => HasTabulators w where tabs s w = cset w "tabs" s getTabs w = cget w "tabs"

+ HTk.Widgets.ScrollBar: class Widget w => HasScroller w where 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) }

+ HTk.Widgets.ScrollBar: class Widget w => HasSlider w where repeatInterval c w = cset w "repeatinterval" c getRepeatInterval w = cget w "repeatinterval" repeatDelay c w = cset w "repeatdelay" c getRepeatDelay w = cget w "repeatdelay"