{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | HTk's entry field.
-- A simple widget that displays an editable line of text.
module HTk.Widgets.Entry (
Entry,
newEntry,
XCoord(..),
showText,
getShowText
) where
import Control.Exception
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 :: SomeException) -> 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 :: SomeException) -> 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 #-}