module HTk.Toolkit.MarkupText (
MarkupText,
prose,
font,
newline,
bold,
underline,
italics,
spaces,
offset,
colour,
bgcolour,
flipcolour,
flipunderline,
action,
rangeaction,
clipup,
leftmargin,
wrapmargin,
rightmargin,
centered,
flushright,
flushleft,
href,
window,
window1,
alpha,
beta,
chi,
delta,
epsilon,
phi,
gamma,
eta,
varphi,
iota,
kappa,
lambda,
mu,
nu,
omikron,
pi,
theta,
vartheta,
rho,
sigma,
varsigma,
tau,
upsilon,
varpi,
omega,
xi,
psi,
zeta,
aalpha,
bbeta,
cchi,
ddelta,
eeps,
pphi,
ggamma,
eeta,
iiota,
kkappa,
llambda,
mmu,
nnu,
oomikron,
ppi,
ttheta,
rrho,
ssigma,
ttau,
uupsilon,
oomega,
xxi,
ppsi,
zzeta,
forallsmall,
exists,
forallbig,
eexists,
existsone,
not,
and,
bigand,
or,
times,
sum,
prod,
comp,
bullet,
tensor,
otimes,
oplus,
bot,
rightarrow,
rrightarrow,
longrightarrow,
llongrightarrow,
leftrightarrow,
lleftrightarrow,
ddownarrow,
uuparrow,
vline,
hline,
rbrace1,
rbrace2,
rbrace3,
emptyset,
inset,
notin,
intersect,
union,
subset,
subseteq,
setminus,
powerset,
inf,
iintersect,
uunion,
equiv,
neq,
leq,
grteq,
lsem,
rsem,
dots,
copyright,
HasMarkupText(..),
scrollMarkupText,
) where
import Data.Char
import Prelude hiding (pi, not, and, or, sum)
import qualified Prelude (not)
import System.IO.Unsafe
import Util.Object
import Util.Computation
import Events.Channels
import Events.Events
import Reactor.ReferenceVariables
import HTk.Toplevel.HTk hiding (font, underline, offset)
import HTk.Kernel.GUIObject
import qualified HTk.Kernel.Configuration as Configuration (font)
import qualified HTk.Textitems.TextTag as TextTag (offset)
import HTk.Kernel.Font
unbinds :: Ref [(ObjectID, [IO ()])]
unbinds = unsafePerformIO (newRef [])
addToState :: Editor -> [IO ()] -> IO ()
addToState ed acts =
do
let GUIOBJECT oid _ = toGUIObject ed
ub <- getRef unbinds
setRef unbinds ((oid, acts) : ub)
data MarkupText =
MarkupText [MarkupText]
| MarkupProse [String]
| MarkupSpecialChar Font Int
| MarkupFont Font [MarkupText]
| MarkupNewline
| MarkupBold [MarkupText]
| MarkupItalics [MarkupText]
| MarkupOffset Int [MarkupText]
| MarkupColour Colour [MarkupText]
| MarkupBgColour Colour [MarkupText]
| MarkupFlipColour Colour Colour [MarkupText]
| MarkupFlipUnderline [MarkupText]
| MarkupUnderline [MarkupText]
| MarkupJustify Justify [MarkupText]
| MarkupAction (IO ()) [MarkupText]
| MarkupClipUp [MarkupText] [MarkupText]
| MarkupRangeAction (Maybe (IO ())) (Maybe (IO ())) [MarkupText]
| MarkupLeftMargin Int [MarkupText]
| MarkupWrapMargin Int [MarkupText]
| MarkupRightMargin Int [MarkupText]
| MarkupHRef [MarkupText] [MarkupText]
| forall w . Widget w => MarkupWindow (Editor -> IO (w, IO()))
type TagFun = Editor -> BaseIndex -> BaseIndex -> IO TextTag
type Tag = (Position, Position, TagFun)
type EmbWindowFun =
Editor -> BaseIndex -> IO EmbeddedTextWin
type EmbWindow = (Position, EmbWindowFun)
prose :: String -> MarkupText
prose str = MarkupProse (lines str)
font :: FontDesignator f => f -> [MarkupText] -> MarkupText
font f = MarkupFont (toFont f)
newline :: MarkupText
newline = MarkupNewline
bold :: [MarkupText] -> MarkupText
bold = MarkupBold
underline :: [MarkupText] -> MarkupText
underline = MarkupUnderline
centered :: [MarkupText]-> MarkupText
centered = MarkupJustify JustCenter
flushleft :: [MarkupText]-> MarkupText
flushleft = MarkupJustify JustLeft
flushright :: [MarkupText]-> MarkupText
flushright = MarkupJustify JustRight
italics :: [MarkupText] -> MarkupText
italics = MarkupItalics
offset :: Int-> [MarkupText]-> MarkupText
offset = MarkupOffset
colour :: ColourDesignator c => c -> [MarkupText] -> MarkupText
colour c = MarkupColour (toColour c)
bgcolour :: ColourDesignator c => c -> [MarkupText] -> MarkupText
bgcolour c = MarkupBgColour (toColour c)
spaces :: Int -> MarkupText
spaces n = MarkupProse [replicate n ' ']
flipcolour :: ColourDesignator c => c -> c -> [MarkupText] -> MarkupText
flipcolour c1 c2 = MarkupFlipColour (toColour c1) (toColour c2)
flipunderline :: [MarkupText] -> MarkupText
flipunderline = MarkupFlipUnderline
action :: IO () -> [MarkupText] -> MarkupText
action = MarkupAction
rangeaction :: Maybe (IO ()) -> Maybe (IO ()) -> [MarkupText] ->
MarkupText
rangeaction = MarkupRangeAction
clipup :: [MarkupText] -> [MarkupText] -> MarkupText
clipup = MarkupClipUp
leftmargin :: Int -> [MarkupText] -> MarkupText
leftmargin = MarkupLeftMargin
wrapmargin :: Int -> [MarkupText] -> MarkupText
wrapmargin = MarkupWrapMargin
rightmargin :: Int -> [MarkupText] -> MarkupText
rightmargin = MarkupRightMargin
window1 :: Widget w => (Editor -> IO (w, IO())) -> MarkupText
window1 = MarkupWindow
window :: Widget w => IO (w, IO()) -> MarkupText
window act = window1 (const act)
href :: [MarkupText] -> [MarkupText] -> MarkupText
href = MarkupHRef
alpha :: MarkupText
alpha = symbchr 97
beta :: MarkupText
beta = symbchr 98
chi ::MarkupText
chi = symbchr 99
delta :: MarkupText
delta = symbchr 100
epsilon :: MarkupText
epsilon = symbchr 101
phi :: MarkupText
phi = symbchr 102
gamma :: MarkupText
gamma = symbchr 103
eta :: MarkupText
eta = symbchr 104
varphi :: MarkupText
varphi = symbchr 106
iota :: MarkupText
iota = symbchr 105
kappa :: MarkupText
kappa = symbchr 107
lambda :: MarkupText
lambda = symbchr 108
mu :: MarkupText
mu = symbchr 109
nu :: MarkupText
nu = symbchr 110
omikron :: MarkupText
omikron = symbchr 111
pi :: MarkupText
pi = symbchr 112
theta :: MarkupText
theta = symbchr 113
vartheta :: MarkupText
vartheta = symbchr 74
rho :: MarkupText
rho = symbchr 114
sigma :: MarkupText
sigma = symbchr 115
varsigma :: MarkupText
varsigma = symbchr 86
tau :: MarkupText
tau = symbchr 116
upsilon :: MarkupText
upsilon = symbchr 117
varpi :: MarkupText
varpi = symbchr 118
omega :: MarkupText
omega = symbchr 119
xi :: MarkupText
xi = symbchr 120
psi :: MarkupText
psi = symbchr 121
zeta :: MarkupText
zeta = symbchr 122
aalpha :: MarkupText
aalpha = symbchr 65
bbeta :: MarkupText
bbeta = symbchr 66
cchi :: MarkupText
cchi = symbchr 67
ddelta :: MarkupText
ddelta = symbchr 68
eeps :: MarkupText
eeps = symbchr 69
pphi :: MarkupText
pphi = symbchr 70
ggamma :: MarkupText
ggamma = symbchr 71
eeta :: MarkupText
eeta = symbchr 72
iiota :: MarkupText
iiota = symbchr 73
kkappa :: MarkupText
kkappa = symbchr 75
llambda :: MarkupText
llambda = symbchr 76
mmu :: MarkupText
mmu = symbchr 77
nnu :: MarkupText
nnu = symbchr 78
oomikron :: MarkupText
oomikron = symbchr 79
ppi :: MarkupText
ppi = symbchr 80
ttheta :: MarkupText
ttheta = symbchr 81
rrho :: MarkupText
rrho = symbchr 82
ssigma :: MarkupText
ssigma = symbchr 83
ttau :: MarkupText
ttau = symbchr 84
uupsilon :: MarkupText
uupsilon = symbchr 85
oomega :: MarkupText
oomega = symbchr 87
xxi :: MarkupText
xxi = symbchr 88
ppsi :: MarkupText
ppsi = symbchr 89
zzeta :: MarkupText
zzeta = symbchr 90
forallsmall :: MarkupText
forallsmall = symbchr 34
exists :: MarkupText
exists = symbchr 36
forallbig :: MarkupText
forallbig = bigsymbchr 34
eexists :: MarkupText
eexists = bigsymbchr 36
existsone :: MarkupText
existsone = symbstr [36, 33]
not :: MarkupText
not = symbchr 216
and :: MarkupText
and = symbchr 217
bigand :: MarkupText
bigand = bigsymbchr 217
or :: MarkupText
or = symbchr 218
times :: MarkupText
times = symbchr 180
sum :: MarkupText
sum = symbchr 229
prod :: MarkupText
prod = symbchr 213
comp :: MarkupText
comp = symbchr 183
bullet :: MarkupText
bullet = symbchr 183
tensor :: MarkupText
tensor = symbchr 196
otimes :: MarkupText
otimes = symbchr 196
oplus :: MarkupText
oplus = symbchr 197
bot :: MarkupText
bot = symbchr 94
rightarrow :: MarkupText
rightarrow = symbchr 174
rrightarrow :: MarkupText
rrightarrow = symbchr 222
longrightarrow :: MarkupText
longrightarrow = symbstr [190, 174]
llongrightarrow :: MarkupText
llongrightarrow = symbstr [61, 222]
leftrightarrow :: MarkupText
leftrightarrow = symbchr 171
lleftrightarrow :: MarkupText
lleftrightarrow = symbchr 219
ddownarrow :: MarkupText
ddownarrow = symbchr 223
uuparrow :: MarkupText
uuparrow = symbchr 221
vline :: MarkupText
vline = symbchr 189
hline :: MarkupText
hline = symbchr 190
rbrace1 :: MarkupText
rbrace1 = symbchr 236
rbrace2 :: MarkupText
rbrace2 = symbchr 237
rbrace3 :: MarkupText
rbrace3 = symbchr 238
emptyset :: MarkupText
emptyset = symbchr 198
inset :: MarkupText
inset = symbchr 206
notin :: MarkupText
notin = symbchr 207
intersect :: MarkupText
intersect = symbchr 199
union :: MarkupText
union = symbchr 200
subset :: MarkupText
subset = symbchr 204
subseteq :: MarkupText
subseteq = symbchr 205
setminus :: MarkupText
setminus = symbchr 164
powerset :: MarkupText
powerset = symbchr 195
inf :: MarkupText
inf = symbchr 165
iintersect :: MarkupText
iintersect = bigsymbchr 199
uunion :: MarkupText
uunion = bigsymbchr 200
equiv :: MarkupText
equiv = symbchr 186
neq :: MarkupText
neq = symbchr 185
leq :: MarkupText
leq = symbchr 163
grteq :: MarkupText
grteq = symbchr 179
lsem :: MarkupText
lsem = symbstr [91, 91]
rsem :: MarkupText
rsem = symbstr [93, 93]
dots :: MarkupText
dots = symbchr 188
copyright :: MarkupText
copyright = symbchr 227
symbchr :: Int -> MarkupText
symbchr i = MarkupSpecialChar
(Font "-*-symbol-medium-r-normal-*-14-*-*-*-*-*-*-*") i
bigsymbchr :: Int -> MarkupText
bigsymbchr i = MarkupSpecialChar
(Font "-*-symbol-medium-r-normal-*-18-*-*-*-*-*-*-*") i
symbstr :: [Int] -> MarkupText
symbstr is = MarkupText (map symbchr is)
checkfont :: Font -> Bool -> Bool -> Font
checkfont f@(Font str) bold italics =
let xf = read str
in case xf of
XFontAlias _ -> f
_ ->
case (bold, italics) of
(True, True) -> toFont xf {weight = Just Bold,
slant = Just Italic}
(True, False) -> toFont xf {weight = Just Bold}
(False, True) -> toFont xf {slant = Just Italic}
_ -> f
clipact :: Editor -> Mark -> Mark -> Ref Bool -> Ref [TextTag] ->
String -> [Tag] -> IO ()
clipact ed mark1 mark2 open settags txt tags =
do
b <- getRef open
setRef open (Prelude.not b)
(if b then
do
tags' <- getRef settags
st <- getState ed
if st == Disabled then ed # state Normal >> done else done
mapM destroy tags'
deleteTextRange ed mark1 mark2
ed # state st
done
else
do
st <- getState ed
if st == Disabled then ed # state Normal >> done else done
insertText ed mark1 txt
tags' <- insertTags tags
ed # state st
setRef settags tags')
where insertTags :: [Tag] -> IO [TextTag]
insertTags (((l1,c1), (l2,c2), f) : ts) =
do
pos1 <- getBaseIndex ed
(mark1, [ForwardLines (fromDistance l1),
ForwardChars (fromDistance c1)])
pos2 <- getBaseIndex ed
(mark1, [ForwardLines (fromDistance l2),
ForwardChars (fromDistance c2)])
tag <- f ed pos1 pos2
tags <- insertTags ts
return (tag : tags)
insertTags _ = return []
parseMarkupText :: [MarkupText] -> Font -> IO (String, [EmbWindow], [Tag])
parseMarkupText m f =
do
(ret, _) <- parseMarkupText' m [] [] [] (1,0) False False f
return ret
where
simpleProperty :: [MarkupText] -> [MarkupText] -> String ->
[Tag] -> [EmbWindow] -> Position -> Bool -> Bool ->
Font -> [Config TextTag] ->
IO ((String, [EmbWindow], [Tag]), Position)
simpleProperty ms m' txt tags wins (line, char) bold italics
current_font cnf =
do
((txt', wins', tags'), (line', char')) <-
parseMarkupText' m' txt tags wins (line, char) bold italics
current_font
let tag = ((line, char), (line', char'),
\ed pos1 pos2 ->
createTextTag ed pos1 pos2 cnf)
parseMarkupText' ms txt' (tag : tags') wins' (line', char') bold
italics current_font
parseMarkupText' :: [MarkupText] -> String -> [Tag] -> [EmbWindow] ->
Position -> Bool -> Bool -> Font ->
IO ((String, [EmbWindow], [Tag]), Position)
parseMarkupText' (m : ms) txt tags wins (line, char) bold italics
current_font =
case m of
MarkupText m' -> parseMarkupText' (m' ++ ms) txt tags wins
(line, char) bold italics
current_font
MarkupProse [str] -> parseMarkupText' ms
(txt ++ str) tags wins
(line, char + Distance (length str))
bold italics current_font
MarkupProse (l:rest) -> parseMarkupText' (MarkupProse rest:ms)
(txt++ l++ "\n") tags wins
(line+ 1, 0)
bold italics current_font
MarkupProse [] -> parseMarkupText' ms txt tags wins
(line, char) bold italics current_font
MarkupSpecialChar f i ->
parseMarkupText' (MarkupFont f [prose [chr i]] : ms) txt tags
wins (line, char) bold italics current_font
MarkupNewline -> parseMarkupText' ms (txt ++ "\n") tags wins
(line + 1, 0) bold italics
current_font
MarkupColour c m' -> simpleProperty ms m' txt tags wins
(line, char) bold italics current_font
[fg c]
MarkupOffset i m' -> simpleProperty ms m' txt tags wins
(line, char) bold italics current_font
[TextTag.offset (Distance i)]
MarkupBgColour c m' -> simpleProperty ms m' txt tags wins
(line, char) bold italics current_font
[bg c]
MarkupLeftMargin i m' ->
simpleProperty ms m' txt tags wins (line, char)
bold italics current_font [lmargin1 (Distance i)]
MarkupWrapMargin i m' ->
simpleProperty ms m' txt tags wins (line, char)
bold italics current_font [lmargin2 (Distance i)]
MarkupRightMargin i m' ->
simpleProperty ms m' txt tags wins (line, char)
bold italics current_font [rmargin (Distance i)]
MarkupUnderline m' ->
simpleProperty ms m' txt tags wins (line, char)
bold italics current_font [underlined On]
MarkupJustify j m' ->
simpleProperty ms m' txt tags wins (line, char)
bold italics current_font [justify j]
MarkupFont f m' ->
do
((txt', wins', tags'), (line', char')) <-
parseMarkupText' m' txt tags wins (line, char) bold italics
f
let (Font fstr) = f
let tag = ((line, char), (line', char'),
\ed pos1 pos2 ->
createTextTag ed pos1 pos2
[Configuration.font
(checkfont f bold italics)])
parseMarkupText' ms txt' (tag : tags') wins' (line', char')
bold italics current_font
MarkupBold m' ->
do
((txt', wins', tags'), (line', char')) <-
parseMarkupText' m' txt tags wins (line, char) True italics
current_font
let (Font fstr) = current_font
let tag = ((line, char), (line', char'),
\ed pos1 pos2 ->
createTextTag ed pos1 pos2
[Configuration.font
(checkfont current_font True italics)])
parseMarkupText' ms txt' (tag : tags') wins' (line', char')
bold italics current_font
MarkupItalics m' ->
do
((txt', wins', tags'), (line', char')) <-
parseMarkupText' m' txt tags wins (line, char) bold True
current_font
let (Font fstr) = current_font
let tag = ((line, char), (line', char'),
\ed pos1 pos2 ->
createTextTag ed pos1 pos2
[Configuration.font
(checkfont current_font bold True)])
parseMarkupText' ms txt' (tag : tags') wins' (line', char')
bold italics current_font
MarkupFlipColour c1 c2 m' ->
do
((txt', wins', tags'), (line', char')) <-
parseMarkupText' m' txt tags wins (line, char) bold italics
current_font
let tag = ((line, char), (line', char'),
\ed pos1 pos2 ->
do
tag <- createTextTag ed pos1 pos2 []
tag # fg c1
(entered, u_entered) <- bindSimple tag Enter
(left, u_left) <- bindSimple tag Leave
death <- newChannel
let listenTag :: Event ()
listenTag =
(entered >>
(always (tag # fg c2) >>
listenTag))
+> (left >>
(always (tag # fg c1) >>
listenTag))
+> receive death
_ <- spawnEvent listenTag
addToState ed [u_entered, u_left,
syncNoWait(send death ())]
return tag)
parseMarkupText' ms txt' (tag : tags') wins' (line', char')
bold italics current_font
MarkupFlipUnderline m' ->
do
((txt', wins', tags'), (line', char')) <-
parseMarkupText' m' txt tags wins (line, char) bold italics
current_font
let tag = ((line, char), (line', char'),
\ed pos1 pos2 ->
do
tag <- createTextTag ed pos1 pos2 []
(entered, u_entered) <- bindSimple tag Enter
(left, u_left) <- bindSimple tag Leave
death <- newChannel
let listenTag :: Event ()
listenTag =
(entered >>
(always (tag # underlined On) >>
listenTag))
+> (left >>
(always (tag # underlined Off) >>
listenTag))
+> receive death
_ <- spawnEvent listenTag
addToState ed [u_entered, u_left,
syncNoWait (send death ())]
return tag)
parseMarkupText' ms txt' (tag : tags') wins' (line', char')
bold italics current_font
MarkupAction act m' ->
do
((txt', wins', tags'), (line', char')) <-
parseMarkupText' m' txt tags wins (line, char) bold italics
current_font
let tag = ((line, char), (line', char'),
\ed pos1 pos2 ->
do
tag <- createTextTag ed pos1 pos2 []
(click, u_click) <-
bindSimple tag (ButtonPress (Just 1))
death <- newChannel
let listenTag :: Event ()
listenTag =
(click >> always act >> listenTag)
+> receive death
_ <- spawnEvent listenTag
addToState ed [u_click,
syncNoWait (send death ())]
return tag)
parseMarkupText' ms txt' (tag : tags') wins' (line', char')
bold italics current_font
MarkupRangeAction menteract mleaveact m' ->
do
((txt', wins', tags'), (line', char')) <-
parseMarkupText' m' txt tags wins (line, char) bold italics
current_font
let tag = ((line, char), (line', char'),
\ed pos1 pos2 ->
do
tag <- createTextTag ed pos1 pos2 []
(enter, enter_u) <- bindSimple tag Enter
(leave, leave_u) <- bindSimple tag Leave
death <- newChannel
let listenTag :: Event ()
listenTag =
(enter >> always (case menteract of
Just act -> act
Nothing -> done) >>
listenTag) +>
(leave >> always (case mleaveact of
Just act -> act
Nothing -> done) >>
listenTag) +>
receive death
_ <- spawnEvent listenTag
addToState ed [enter_u, leave_u,
syncNoWait (send death ())]
return tag)
parseMarkupText' ms txt' (tag : tags') wins' (line', char')
bold italics current_font
MarkupClipUp m' cliptext ->
do
let pos = (if char > 0 then line + 1 else line, 0)
s = if char > 0 then "\n" else ""
((txt', wins', tags'), (line', char')) <-
parseMarkupText' m' (s ++ txt) tags wins pos bold italics
current_font
let tag = (pos, (line', char'),
\ed pos1 pos2 ->
do
((txt', wins', tags'), (line', char')) <-
parseMarkupText' (cliptext ++ [newline]) ""
[] [] (0, 0) bold italics f
oid1 <- newObject
mark1 <- createMark ed ("m" ++ show oid1)
(pos1, [ForwardLines 1])
setMarkGravity mark1 ToLeft
oid2 <- newObject
mark2 <- createMark ed ("m" ++ show oid2)
(pos1, [ForwardLines 1])
tag <- createTextTag ed pos1 pos2 []
(click, u_click) <-
bindSimple tag (ButtonPress (Just 1))
open <- newRef False
settags <- newRef []
death <- newChannel
let listenTag :: Event ()
listenTag =
(click >>
always (clipact ed mark1 mark2 open
settags txt' tags') >>
listenTag)
+> receive death
_ <- spawnEvent listenTag
addToState ed [u_click,
syncNoWait (send death ())]
return tag)
parseMarkupText' ms (txt' ++ "\n") (tag : tags') wins'
(line' + 1, 0) bold italics current_font
MarkupHRef m' linktext ->
do
((txt', wins', tags'), (line', char')) <-
parseMarkupText' m' txt tags wins (line, char) bold italics
current_font
let tag = ((line, char), (line', char'),
\ed pos1 pos2 ->
do
tag <- createTextTag ed pos1 pos2 []
(click, u_click) <-
bindSimple tag (ButtonPress (Just 1))
death <- newChannel
let listenTag :: Event ()
listenTag =
(click >>
always (ed # clear >>
ed # new linktext) >>
listenTag)
+> receive death
_ <- spawnEvent listenTag
addToState ed [u_click,
syncNoWait (send death ())]
return tag)
parseMarkupText' ms txt' (tag : tags') wins' (line', char')
bold
italics current_font
MarkupWindow iowid ->
let win = ((line, char),
\ed pos -> do
(wid, cleanup) <- iowid ed
w <- createEmbeddedTextWin ed pos wid []
addToState ed [cleanup]
return w)
in parseMarkupText' ms txt tags (win : wins) (line, char)
bold italics current_font
parseMarkupText' _ txt tags wins (line, char) _ _ _ =
return ((txt, wins, tags), (line, char))
class HasMarkupText w where
new :: [MarkupText] -> w -> IO w
insertAt :: [MarkupText] -> Position -> Config w
clear :: Config w
instance HasMarkupText Editor where
new m ed =
do
st <- getState ed
if st == Disabled then ed # state Normal >> done else done
f <- getFont ed
(txt, wins, tags) <- parseMarkupText m f
ed # value txt
mapM (\ (pos1, pos2, f) -> do
pos1' <- getBaseIndex ed pos1
pos2' <- getBaseIndex ed pos2
f ed pos1' pos2')
tags
mapM (\ (pos, f) -> do
pos' <- getBaseIndex ed pos
ew <- f ed pos'
addToState ed [destroy ew])
wins
ed # state st
return ed
insertAt m pos@(line, char) ed =
do
f <- getFont ed
(txt, wins, tags) <- parseMarkupText m f
l <- getTextLine ed pos
st <- getState ed
if st == Disabled then ed # state Normal >> done else done
insertText ed pos (replicate (fromDistance char length l) ' ' ++
txt)
let tags' = shiftTags pos tags
mapM (\ (pos1, pos2, f) -> do
pos1' <- getBaseIndex ed pos1
pos2' <- getBaseIndex ed pos2
f ed pos1' pos2')
tags'
ed # state st
return ed
where
shiftTags :: Position -> [Tag] -> [Tag]
shiftTags p tags = map (shiftTag p) tags
shiftTag :: Position -> Tag -> Tag
shiftTag (line, char) (p1@(line1, char1), p2@(line2, char2), tag) =
((shiftLine line line1, shiftChar char p1),
(shiftLine line line2, shiftChar char p2), tag)
shiftLine :: Distance -> Distance -> Distance
shiftLine pline line = pline + (line 1)
shiftChar :: Distance -> Position -> Distance
shiftChar pchar (line, char) =
if line == 1 then char + pchar else char
clear ed =
do
let obj@(GUIOBJECT oid _) = toGUIObject ed
unbinds' <- getRef unbinds
mapM (\ (oid', ubs) -> if oid == oid' then
(mapM (\ act -> act) ubs) >> done
else done)
unbinds'
setRef unbinds []
return ed
fromDistance :: Distance -> Int
fromDistance (Distance i) = i
scrollMarkupText :: Size -> [MarkupText] -> MarkupText
scrollMarkupText size1 markups =
let
action :: Editor -> IO (Frame,IO ())
action editor =
do
editorFrame <- newFrame editor []
editorFrame2 <- newFrame editorFrame []
editor <- newEditor editorFrame2 [wrap NoWrap,disable,new markups,size size1]
scrollBar1 <- newScrollBar editorFrame2 [orient Vertical]
scrollBar2 <- newScrollBar editorFrame [orient Horizontal]
editor # scrollbar Vertical scrollBar1
editor # scrollbar Horizontal scrollBar2
pack editor [Side AtRight,Fill Both]
pack scrollBar1 [Side AtRight,Fill Y,Expand On]
pack editorFrame2 [Side AtTop]
pack scrollBar2 [Side AtTop,Fill X]
return (editorFrame,destroy editorFrame)
in
window1 action