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 Control.Exception
import Data.Char(isSpace)
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 Util.Computation
import Events.Destructible
import Events.Synchronized
import HTk.Kernel.Packer
import HTk.Kernel.Tooltip
newtype Editor = Editor GUIOBJECT deriving Eq
newEditor :: Container par => par
-> [Config Editor]
-> IO Editor
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
instance GUIObject Editor where
toGUIObject (Editor w) = w
cname _ = "Text"
instance Destroyable Editor where
destroy = destroy . toGUIObject
instance Widget Editor
instance Container Editor
instance HasBorder Editor
instance HasColour Editor where
legalColourID = hasForeGroundColour
instance HasSize Editor
instance HasFont Editor
instance HasEnable Editor
instance HasLineSpacing Editor
instance HasTabulators Editor
instance HasScroller Editor
instance Synchronized Editor where
synchronize = synchronize . toGUIObject
instance GUIValue a => HasValue Editor a where
value val w = setTextLines w val >> return w
getValue w = getTextLines w
instance HasTooltip Editor
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
deleteText :: HasIndex Editor i BaseIndex => Editor
-> i
-> IO ()
deleteText ed i =
do
pos <- getBaseIndex ed i
execMethod ed (\nm -> tkDeleteText nm pos Nothing)
deleteTextRange :: (HasIndex Editor i1 BaseIndex,
HasIndex Editor i2 BaseIndex) =>
Editor
-> i1
-> i2
-> IO ()
deleteTextRange tp start end =
do
start' <- getBaseIndex tp start
end' <- getBaseIndex tp end
execMethod tp (\nm -> tkDeleteText nm start' (Just end'))
getTextRange :: (HasIndex Editor i1 BaseIndex,
HasIndex Editor i2 BaseIndex) =>
Editor
-> i1
-> i2
-> IO String
getTextRange ed start end =
do
start' <- getBaseIndex ed start
end' <- getBaseIndex ed end
evalMethod ed (\nm -> tkGetText nm start' (Just end'))
insertText :: (HasIndex Editor i BaseIndex,GUIValue a) =>
Editor
-> i
-> a
-> IO ()
insertText ed i txt =
do
pos <- getBaseIndex ed i
execMethod ed (\nm -> tkInsertText nm pos val)
where val = toGUIValue txt
insertNewline :: Editor
-> IO ()
insertNewline ed = execMethod ed (\nm -> tkInsertNewLine nm)
getTextLine :: HasIndex Editor i BaseIndex =>
Editor
-> i
-> IO String
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)
appendText :: Editor
-> String
-> IO ()
appendText ed str =
do
try (insertText ed EndOfText str)
:: IO (Either SomeException ())
moveto Vertical ed 1.0
done
writeTextToFile :: Editor
-> FilePath
-> IO ()
writeTextToFile ed fnm =
do
str <- getValue ed
writeFile fnm str
readTextFromFile :: Editor
-> FilePath
-> IO ()
readTextFromFile ed fnm =
do
str <- readFile fnm
configure ed [value str]
done
instance (HasIndex Editor i BaseIndex) => HasBBox Editor i where
bbox w i =
do
binx <- getBaseIndex w i
ans <- try (evalMethod w (\nm -> [tkBBox nm (binx::BaseIndex)]))
case ans of
Left (e :: SomeException) -> return Nothing
Right v -> return (Just v)
where tkBBox nm i = show nm ++ " bbox " ++ show i
instance HasIndex Editor BaseIndex BaseIndex where
getBaseIndex w i = return i
instance HasIndex Editor EndOfText BaseIndex where
getBaseIndex w _ = return (IndexText "end")
instance HasIndex Editor Pixels BaseIndex where
getBaseIndex w p = return (IndexText (show p))
instance HasIndex Editor (Distance, Distance) BaseIndex where
getBaseIndex w pos = return (IndexPos pos)
instance HasIndex Editor i BaseIndex =>
HasIndex Editor (i,[IndexModifier]) BaseIndex where
getBaseIndex tp (i,ml) =
do
bi <- getBaseIndex tp i
return
(IndexText (show (bi::BaseIndex) ++ show (IndexModifiers ml)))
instance HasIndex Editor i BaseIndex =>
HasIndex Editor (i,IndexModifier) BaseIndex where
getBaseIndex tp (i,m) =
do
bi <- getBaseIndex tp i
return (IndexText (show (bi::BaseIndex) ++ show m))
instance HasIndex Editor i BaseIndex =>
HasIndex Editor i (Distance,Distance) where
getBaseIndex = getIndexPosition
newtype IndexModifiers = IndexModifiers [IndexModifier]
data IndexModifier =
ForwardChars Int
| BackwardChars Int
| ForwardLines Int
| BackwardLines Int
| LineStart
| LineEnd
| WordStart
| WordEnd
instance Show IndexModifier where
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
instance Show IndexModifiers where
showsPrec d (IndexModifiers []) r = r
showsPrec d (IndexModifiers (m:ml)) r = show m ++ " " ++ show (IndexModifiers ml) ++ r
getIndexPosition :: HasIndex Editor i BaseIndex
=> Editor
-> i
-> IO Position
getIndexPosition ed i = do {
inx <- getBaseIndex ed i;
pos <- evalMethod ed (\nm -> tkPosition nm inx);
case pos of
(IndexPos pos) -> return pos
}
compareIndices :: (
HasIndex Editor i1 BaseIndex,
HasIndex Editor i2 BaseIndex
) => Editor
-> String
-> i1
-> i2
-> IO Bool
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]
instance HasSelection Editor where
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
})
instance (HasIndex Editor i BaseIndex) => HasSelectionIndex Editor i
where
selection inx tp = synchronize tp (do {
binx <- getBaseIndex tp inx;
execMethod tp (\nm -> tkSelection nm binx);
return tp
})
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
})
instance HasSelectionBaseIndexRange Editor (Distance,Distance) where
getSelectionStart tp = do
mstart <- try (evalMethod tp (\nm -> tkSelFirst nm))
case mstart of
Left (e :: SomeException) -> return Nothing
Right v -> return $ Just v
getSelectionEnd tp = do
mstart <- try (evalMethod tp (\nm -> tkSelEnd nm))
case mstart of
Left (e :: SomeException) -> return Nothing
Right v -> return $ Just v
instance (
HasIndex Editor i1 BaseIndex,
HasIndex Editor i2 BaseIndex
) => HasSelectionIndexRange Editor i1 i2
where
selectionRange start end tp = synchronize tp (do {
start' <- getBaseIndex tp start;
end' <- getBaseIndex tp end;
execMethod tp (\nm -> tkSelectionRange nm start' end');
return tp
})
instance HasSelectionBaseIndex Editor ((Distance,Distance),(Distance,Distance)) where
getSelection = getSelectionRange
instance HasXSelection Editor
instance HasInsertionCursor Editor
instance ( HasIndex Editor i BaseIndex
) => HasInsertionCursorIndexSet Editor i
where
insertionCursor inx tp = synchronize tp (do {
binx <- getBaseIndex tp inx;
execMethod tp (\nm -> tkSetInsertMark nm binx);
return tp
})
instance HasInsertionCursorIndexGet Editor (Distance,Distance) where
getInsertionCursor tp = evalMethod tp (\nm -> tkGetInsertMark nm)
adjustViewTo :: HasIndex Editor i BaseIndex => Editor
-> i
-> IO ()
adjustViewTo ed i =
synchronize ed (do {
inx <- getBaseIndex ed i;
execMethod ed (\nm -> tkSee nm inx)
})
scanMark :: HasIndex Editor i BaseIndex => Editor
-> i
-> IO ()
scanMark ed i = do {
pos <- getIndexPosition ed i;
execMethod ed (\nm -> tkScanMark nm pos)
}
scanDragTo :: HasIndex Editor i BaseIndex => Editor
-> i
-> IO ()
scanDragTo ed i =
synchronize ed (do {
pos <- getIndexPosition ed i;
execMethod ed (\nm -> tkScanDragTo nm pos)
})
wrap :: WrapMode -> Config Editor
wrap d tp = cset tp "wrap" d
getWrapMode :: Editor -> IO WrapMode
getWrapMode tp = cget tp "wrap"
data WrapMode = NoWrap | CharWrap | WordWrap deriving (Eq,Ord,Enum)
instance GUIValue WrapMode where
cdefault = NoWrap
instance Read WrapMode where
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)]
_ -> []
instance Show WrapMode where
showsPrec d p r =
(case p of
NoWrap -> "none"
CharWrap -> "char"
WordWrap -> "word"
) ++ r
class GUIObject w => HasTabulators w where
tabs :: String -> Config w
getTabs :: w -> IO String
tabs s w = cset w "tabs" s
getTabs w = cget w "tabs"
class GUIObject w => HasLineSpacing w where
spaceAbove :: Distance -> Config w
getSpaceAbove :: w -> IO Distance
spaceWrap :: Distance -> Config w
getSpaceWrap :: w -> IO Distance
spaceBelow :: Distance -> Config w
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"
data SearchDirection = Forward | Backward deriving (Eq,Ord,Enum)
instance Show SearchDirection where
showsPrec d p r =
(case p of
Forward -> " -forward"
Backward -> " -backward"
) ++ r
data SearchMode = Exact | Nocase deriving (Eq,Ord,Enum)
instance Show SearchMode where
showsPrec d p r =
(case p of
Exact -> " -exact"
Nocase -> " -nocase"
) ++ r
data SearchSwitch = SearchSwitch {
searchdirection :: SearchDirection,
searchmode :: SearchMode,
rexexp :: Bool
}
instance Show SearchSwitch where
showsPrec _ (SearchSwitch d m False) r =
show d ++ show m ++ r
showsPrec _ (SearchSwitch d m True) r =
show d ++ show m ++ " -regexp " ++ r
textMethods = defMethods {
cleanupCmd = tkCleanupText,
createCmd = tkCreateText
}
search :: HasIndex Editor i BaseIndex =>
Editor
-> SearchSwitch
-> String
-> i
-> IO (Maybe BaseIndex)
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]
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
tkCleanupText :: ObjectID -> ObjectName -> TclScript
tkCleanupText oid _ = tkUndeclVar ("sv" ++ show oid)
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]
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]
tkInsertText :: ObjectName -> BaseIndex -> GUIVALUE -> TclScript
tkInsertText name pl val =
[show name ++ " insert " ++ ishow pl ++ " " ++ show val ++ " "]
tkInsertNewLine :: ObjectName -> TclScript
tkInsertNewLine name = [show name ++ " insert end \\n"]
tkPosition :: ObjectName -> BaseIndex -> TclScript
tkPosition name pl = [show name ++ " index " ++ ishow pl]
tkSee :: ObjectName -> BaseIndex -> TclScript
tkSee name pl = [show name ++ " see " ++ ishow pl]
tkScanMark :: ObjectName -> Position -> TclScript
tkScanMark name pos = [show name ++ " scan mark " ++ show pos]
tkScanDragTo :: ObjectName -> Position -> TclScript
tkScanDragTo name pos = [show name ++ " scan dragto " ++ show pos]
tkSetInsertMark :: ObjectName -> BaseIndex -> TclScript
tkSetInsertMark wn p = [show wn ++ " mark set insert " ++ ishow p]
tkGetInsertMark :: ObjectName -> TclScript
tkGetInsertMark wn = [show wn ++ " index insert"]
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"]
tkSelectionRange :: ObjectName -> BaseIndex -> BaseIndex -> TclScript
tkSelectionRange wn start end = [show wn ++ " tag add sel " ++
ishow start ++ " " ++ ishow end]
tkSelFirst :: ObjectName -> TclScript
tkSelFirst wn = [show wn ++ " index sel.first "]
tkSelEnd :: ObjectName -> TclScript
tkSelEnd wn = [show wn ++ " index sel.last "]
tkClearSelection :: ObjectName -> BaseIndex -> BaseIndex -> TclScript
tkClearSelection wn start end = [show wn ++ " tag remove sel " ++
ishow start ++ " " ++ ishow end]
tkMarkCreate :: ObjectName -> String -> BaseIndex -> TclScript
tkMarkCreate tname mname ix =
[show tname ++ " mark set " ++ show mname ++ " " ++ ishow ix]
ishow :: BaseIndex -> String
ishow i = "{" ++ show i ++ "}"