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
data Mark = Mark Editor String deriving Eq
createMark :: HasIndex Editor i BaseIndex =>
Editor
-> String
-> i
-> IO Mark
createMark ed name i =
synchronize ed (do
ix <- getBaseIndex ed i
execMethod ed (\nm -> tkMarkSet nm name ix)
return (Mark ed name))
setMarkGravity :: Mark
-> Gravity
-> IO ()
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]
getMarkGravity :: Mark
-> IO Gravity
getMarkGravity mark @ (Mark tp name) =
evalMethod tp (\nm -> tkGetMarkGravity nm name)
where tkGetMarkGravity tnm mnm =
[show tnm ++ " mark gravity " ++ show mnm]
unsetMark :: Mark
-> IO ()
unsetMark mark@(Mark tp name) = execMethod tp (\nm -> tkMarkUnset nm name)
where tkMarkUnset nm mname = [show nm ++ " mark unset " ++ show mname]
setMark :: HasIndex Editor i BaseIndex => Mark
-> i
-> IO ()
setMark mark@(Mark tp name) i =
do
binx <- getBaseIndex tp i
execMethod tp (\nm -> tkMarkSet nm name binx)
getCurrentMarks :: Editor
-> IO [Mark]
getCurrentMarks ed =
do
str <- evalMethod ed (\nm -> [show nm ++ " mark names "])
return (map (Mark ed) (words str))
data MousePosition = MousePosition Editor
instance HasIndex Editor Mark BaseIndex where
getBaseIndex w (Mark _ str) = return (IndexText str)
instance HasIndex Editor (Selection Editor) BaseIndex where
getBaseIndex w p = return (IndexText "sel")
instance HasIndex Editor (ICursor Editor) BaseIndex where
getBaseIndex w p = return (IndexText "insert")
instance HasIndex Editor MousePosition BaseIndex where
getBaseIndex w p = return (IndexText "current")
data Gravity = ToLeft | ToRight deriving (Eq,Ord,Enum)
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)]
_ -> []
instance Show Gravity where
showsPrec d p r =
(case p of
ToLeft -> "left"
ToRight -> "right"
) ++ r
instance GUIValue Gravity where
cdefault = ToLeft
tkMarkSet :: ObjectName -> String -> BaseIndex -> TclScript
tkMarkSet tname mname ix =
[show tname ++ " mark set " ++ show mname ++ " " ++ ishow ix]
ishow :: BaseIndex -> String
ishow i = "{" ++ show i ++ "}"