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
data TextTag = TextTag Editor GUIOBJECT
createTextTag :: (HasIndex Editor i1 BaseIndex,
HasIndex Editor i2 BaseIndex) =>
Editor
-> i1
-> i2
-> [Config TextTag]
-> IO TextTag
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 ++ " ")
instance Eq TextTag where
(TextTag _ w1) == (TextTag _ w2) = (toGUIObject w1) == (toGUIObject w2)
instance GUIObject TextTag where
toGUIObject (TextTag _ w) = w
cname _ = "TextTag"
instance Destroyable TextTag where
destroy = destroy . toGUIObject
instance HasBorder TextTag
instance HasColour TextTag where
legalColourID = hasForeGroundColour
instance HasFont TextTag
instance HasJustify TextTag
instance HasLineSpacing TextTag
instance HasTabulators TextTag
instance Synchronized TextTag where
synchronize = synchronize . toGUIObject
addTextTag :: (HasIndex Editor i1 BaseIndex,
HasIndex Editor i2 BaseIndex) =>
TextTag
-> i1
-> i2
-> IO ()
addTextTag tag@(TextTag tp _) start end =
synchronize tag (
do
start' <- getBaseIndex tp start
end' <- getBaseIndex tp end
execMethod tag (\nm -> tkTagAdd nm start' end')
)
removeTextTag :: (HasIndex Editor i1 BaseIndex,
HasIndex Editor i2 BaseIndex) =>
TextTag
-> i1
-> i2
-> IO ()
removeTextTag tag @ (TextTag tp _) start end =
synchronize tag (
do
start' <- getBaseIndex tp start
end' <- getBaseIndex tp end
execMethod tag (\nm -> tkTagRemove nm start' end')
)
lowerTextTag :: TextTag
-> IO ()
lowerTextTag tag = execMethod tag (\nm -> tkTagLower nm)
raiseTextTag :: TextTag
-> IO ()
raiseTextTag tag = execMethod tag (\nm -> tkTagRaise nm)
lmargin1 :: Distance -> Config TextTag
lmargin1 s tag = cset tag "lmargin1" s
getLmargin1 :: TextTag -> IO Distance
getLmargin1 tag = cget tag "lmargin1"
lmargin2 :: Distance -> Config TextTag
lmargin2 s tag = cset tag "lmargin2" s
getLmargin2 :: TextTag -> IO Distance
getLmargin2 tag = cget tag "lmargin2"
rmargin :: Distance -> Config TextTag
rmargin s tag = cset tag "rmargin" s
getRmargin :: TextTag -> IO Distance
getRmargin tag = cget tag "rmargin"
offset :: Distance -> Config TextTag
offset s tag = cset tag "offset" s
getOffset :: TextTag -> IO Distance
getOffset tag = cget tag "offset"
overstrike :: Toggle -> Config TextTag
overstrike s tag = cset tag "overstrike" s
getOverstrike :: TextTag -> IO Toggle
getOverstrike tag = cget tag "overstrike"
underlined :: Toggle -> Config TextTag
underlined s tag = cset tag "underline" s
getUnderlined :: TextTag -> IO Toggle
getUnderlined tag = cget tag "underline"
bgstipple :: BitMapHandle -> Config TextTag
bgstipple s tag = setBitMapHandle tag "bgstipple" s False
getBgstipple ::TextTag -> IO BitMapHandle
getBgstipple tag = getBitMapHandle tag "bgstipple"
fgstipple :: BitMapHandle -> Config TextTag
fgstipple s tag = setBitMapHandle tag "fgstipple" s False
getFgstipple :: TextTag -> IO BitMapHandle
getFgstipple tag = getBitMapHandle tag "fgstipple"
instance HasIndex Editor (TextTag, First) BaseIndex where
getBaseIndex tp (tag,_) =
synchronize tag (
do
(pnm, tnm) <- getTagName tag
return (IndexText (show tnm ++ ".first"))
)
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)
tagMethods =
Methods
tkGetTextTagConfig
tkSetTextTagConfigs
tkCreateTextTag
(packCmd voidMethods)
(gridCmd voidMethods)
tkTagDelete
tkBindTextTag
tkUnbindTextTag
(cleanupCmd defMethods)
tkGetTextTagConfig :: ObjectName -> ConfigID -> TclScript
tkGetTextTagConfig (TextPaneItemName name tnm) cid =
[(show name) ++ " tag cget " ++ (show tnm) ++ " -" ++ cid]
tkGetTextTagConfig _ _ = []
tkSetTextTagConfigs :: ObjectName -> [ConfigOption] -> TclScript
tkSetTextTagConfigs _ [] = []
tkSetTextTagConfigs (TextPaneItemName name (tnm @ (TextTagID k))) args =
[show name ++ " tag configure " ++ show tnm ++ " " ++ showConfigs args]
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 ++ " "
tkTagAdd :: ObjectName -> BaseIndex -> BaseIndex -> TclScript
tkTagAdd (TextPaneItemName name tnm) start end =
[show name ++ " tag add " ++ show tnm ++ " " ++ show start ++ " " ++
show end]
tkTagAdd _ _ _ = []
tkTagDelete :: ObjectName -> TclScript
tkTagDelete (TextPaneItemName name tnm) =
[show name ++ " tag delete " ++ show tnm]
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]
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) ++ " {}"]
tkTagLower :: ObjectName -> TclScript
tkTagLower (TextPaneItemName name tnm) =
[show name ++ " tag lower " ++ show tnm]
tkTagLower _ = []
tkTagRaise :: ObjectName -> TclScript
tkTagRaise (TextPaneItemName name tnm) =
[show name ++ " tag raise " ++ show tnm]
tkTagRaise _ = []
tkTagRemove :: ObjectName -> BaseIndex -> BaseIndex -> TclScript
tkTagRemove (TextPaneItemName name tnm) start end =
[show name ++ " tag remove " ++ show tnm ++ " " ++ show start ++ " " ++
show end]
tkTagRemove _ _ _ = []