-- -----------------------------------------------------------------------
--
-- $Source: /repository/uni/htk/toolkit/MarkupText.hs,v $
--
-- HTk - a GUI toolkit for Haskell  -  (c) Universitaet Bremen
--
-- $Revision: 1.17 $ from $Date: 2002/03/05 19:09:09 $
-- Last modification by $Author: ger $
--
-- -----------------------------------------------------------------------

---
-- A simple markup language for convenient writing into an editor widget.
module MarkupText (

-- type
  MarkupText,

-- combinators
  prose,
  MarkupText.font,
  newline,
  bold,
  MarkupText.underline,
  italics,
  spaces,
  MarkupText.offset,
  colour,
  bgcolour,
  flipcolour,
  flipunderline,
  action,
  rangeaction,
  clipup,
  leftmargin,
  wrapmargin,
  rightmargin,
  centered,
  flushright,
  flushleft,
  href,
  window,

-- special characters
  alpha,
  beta,
  chi,
  delta,
  epsilon,
  phi,
  gamma,
  eta,
  varphi,
  iota,
  kappa,
  lambda,
  mu,
  nu,
  omikron,
  MarkupText.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,
  MarkupText.not,
  MarkupText.and,
  MarkupText.or,
  times,
  MarkupText.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,


-- container class for markup texts
  HasMarkupText(..)

) where

import HTk
import GUIObject
import Configuration
import Editor
import TextTag
import Font
import Editor
import Object
import ReferenceVariables
import Char
import IOExts(unsafePerformIO)
import Object
import Wish
import Concurrent(threadDelay)


-- -----------------------------------------------------------------------
-- state
-- -----------------------------------------------------------------------

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)


-- -----------------------------------------------------------------------
-- types
-- -----------------------------------------------------------------------

---
-- The <code>MarkupText</code> datatype.
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 (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)


-- ----------------------------------------------------------------------
-- combinators
-- -----------------------------------------------------------------------

---
-- The markup prose combinator.
prose :: String -> MarkupText
prose str = MarkupProse (lines str)

---
-- The markup font combinator.
font :: FontDesignator f => f -> [MarkupText] -> MarkupText
font f = MarkupFont (toFont f)

---
-- The markup newline combinator.
newline :: MarkupText
newline = MarkupNewline

---
-- The markup bold combinator.
bold :: [MarkupText] -> MarkupText
bold = MarkupBold

---
-- The markup underline combinator.
underline :: [MarkupText] -> MarkupText
underline = MarkupUnderline

---
-- Center this part of the text
centered :: [MarkupText]-> MarkupText
centered = MarkupJustify JustCenter

---
-- Flush this part of the against the left margin
flushleft :: [MarkupText]-> MarkupText
flushleft = MarkupJustify JustLeft

----
-- Flush this part of the against the right margin
flushright :: [MarkupText]-> MarkupText
flushright = MarkupJustify JustRight

---
-- The markup italics combinator.
italics :: [MarkupText] -> MarkupText
italics = MarkupItalics

---
-- The markup baseline offset combinator.
offset :: Int-> [MarkupText]-> MarkupText
offset = MarkupOffset

---
-- The markup foreground colour combinator.
colour :: ColourDesignator c => c -> [MarkupText] -> MarkupText
colour c = MarkupColour (toColour c)

---
-- The markup background colour combinator.
bgcolour :: ColourDesignator c => c -> [MarkupText] -> MarkupText
bgcolour c = MarkupBgColour (toColour c)

---
-- The markup space combinator (a number of space characters).
spaces :: Int -> MarkupText
spaces n = MarkupProse [replicate n ' ']

---
-- The markup flipcolour combinator (flips the colour when the mouse
-- is over this text segment).
flipcolour :: ColourDesignator c => c -> c -> [MarkupText] -> MarkupText
flipcolour c1 c2 = MarkupFlipColour (toColour c1) (toColour c2)

---
-- The markup flipunderline combinator (underlines this text segment when 
-- the mouse is over this segment).
flipunderline :: [MarkupText] -> MarkupText
flipunderline = MarkupFlipUnderline

---
-- The markup action combinator (binds an action for mouse clicks on this
-- text segment).
action :: IO () -> [MarkupText] -> MarkupText
action = MarkupAction

---
-- The markup range action combinator (binds actions for entering and/or
-- leaving this text segment with the mouse cursor).
rangeaction :: Maybe (IO ()) -> Maybe (IO ()) -> [MarkupText] ->
               MarkupText
rangeaction = MarkupRangeAction

---
-- The markup clipup combinator (clips up a text segment on a mouse
-- click).
clipup :: [MarkupText] -> [MarkupText] -> MarkupText
clipup = MarkupClipUp

---
-- The markup left margin combinator (normal left intend for a line).
leftmargin :: Int -> [MarkupText] -> MarkupText
leftmargin = MarkupLeftMargin

---
-- The markup wrap margin combinator (intend for a part of a line
-- that gets wrapped).
wrapmargin :: Int -> [MarkupText] -> MarkupText
wrapmargin = MarkupWrapMargin

---
-- The markup right margin combinator.
rightmargin :: Int -> [MarkupText] -> MarkupText
rightmargin = MarkupRightMargin


---
-- The markup window combinator (a widget container inside the editor
-- widget).
window :: Widget w => IO (w, IO()) -> MarkupText
window = MarkupWindow

---
-- The markup href combinator (a link to another markup text).
href :: [MarkupText] -> [MarkupText] -> MarkupText
href = MarkupHRef


-- -----------------------------------------------------------------------
-- special characters
-- -----------------------------------------------------------------------

-- grk letters, lowercase

---
-- Special character.
alpha :: MarkupText
alpha = symbchr 97

---
-- Special character.
beta :: MarkupText
beta = symbchr 98

---
-- Special character.
chi ::MarkupText
chi = symbchr 99

---
-- Special character.
delta :: MarkupText
delta = symbchr 100

---
-- Special character.
epsilon :: MarkupText
epsilon = symbchr 101

---
-- Special character.
phi :: MarkupText
phi = symbchr 102

---
-- Special character.
gamma :: MarkupText
gamma = symbchr 103

---
-- Special character.
eta :: MarkupText
eta = symbchr 104

---
-- Special character.
varphi :: MarkupText
varphi = symbchr 106

---
-- Special character.
iota :: MarkupText
iota = symbchr 105

---
-- Special character.
kappa :: MarkupText
kappa = symbchr 107

---
-- Special character.
lambda :: MarkupText
lambda = symbchr 108

---
-- Special character.
mu :: MarkupText
mu = symbchr 109

---
-- Special character.
nu :: MarkupText
nu = symbchr 110

---
-- Special character.
omikron :: MarkupText
omikron = symbchr 111 

---
-- Special character.
pi :: MarkupText
pi = symbchr 112

---
-- Special character.
theta :: MarkupText
theta = symbchr 113 

---
-- Special character.
vartheta :: MarkupText
vartheta = symbchr 74 

---
-- Special character.
rho :: MarkupText
rho = symbchr 114

---
-- Special character.
sigma :: MarkupText
sigma = symbchr 115

---
-- Special character.
varsigma :: MarkupText
varsigma = symbchr 86

---
-- Special character.
tau :: MarkupText
tau = symbchr 116

---
-- Special character.
upsilon :: MarkupText
upsilon = symbchr 117

---
-- Special character.
varpi :: MarkupText
varpi = symbchr 118

---
-- Special character.
omega :: MarkupText
omega = symbchr 119

---
-- Special character.
xi :: MarkupText
xi = symbchr 120

---
-- Special character.
psi :: MarkupText
psi = symbchr 121

---
-- Special character.
zeta :: MarkupText
zeta = symbchr 122



-- grk letters, uppercase

---
-- Special character (uppercase).
aalpha :: MarkupText
aalpha = symbchr 65

---
-- Special character (uppercase).
bbeta :: MarkupText
bbeta = symbchr 66

---
-- Special character (uppercase).
cchi :: MarkupText
cchi = symbchr 67

---
-- Special character (uppercase).
ddelta :: MarkupText
ddelta = symbchr 68

---
-- Special character (uppercase).
eeps :: MarkupText
eeps = symbchr 69

---
-- Special character (uppercase).
pphi :: MarkupText
pphi = symbchr 70

---
-- Special character (uppercase).
ggamma :: MarkupText
ggamma = symbchr 71 

---
-- Special character (uppercase).
eeta :: MarkupText
eeta = symbchr 72

---
-- Special character (uppercase).
iiota :: MarkupText
iiota = symbchr 73 

---
-- Special character (uppercase).
kkappa :: MarkupText
kkappa = symbchr 75 

---
-- Special character (uppercase).
llambda :: MarkupText
llambda = symbchr 76

---
-- Special character (uppercase).
mmu :: MarkupText
mmu = symbchr 77

---
-- Special character (uppercase).
nnu :: MarkupText
nnu = symbchr 78

---
-- Special character (uppercase).
oomikron :: MarkupText
oomikron = symbchr 79

---
-- Special character (uppercase).
ppi :: MarkupText
ppi = symbchr 80

---
-- Special character (uppercase).
ttheta :: MarkupText
ttheta = symbchr 81

---
-- Special character (uppercase).
rrho :: MarkupText
rrho = symbchr 82

---
-- Special character (uppercase).
ssigma :: MarkupText
ssigma = symbchr 83

---
-- Special character (uppercase).
ttau :: MarkupText
ttau = symbchr 84

---
-- Special character (uppercase).
uupsilon :: MarkupText
uupsilon = symbchr 85 

---
-- Special character (uppercase).
oomega :: MarkupText
oomega = symbchr 87

---
-- Special character (uppercase).
xxi :: MarkupText
xxi = symbchr 88

---
-- Special character (uppercase).
ppsi :: MarkupText
ppsi = symbchr 89

---
-- Special character (uppercase).
zzeta :: MarkupText
zzeta = symbchr 90



-- quantifiers and junctors

---
-- Special character.
forallsmall :: MarkupText
forallsmall = symbchr 34

---
-- Special character.
exists :: MarkupText
exists = symbchr 36

---
-- Special character.
forallbig :: MarkupText
forallbig = bigsymbchr 34

---
-- Special character.
eexists :: MarkupText
eexists = bigsymbchr 36

---
-- Special character.
existsone :: MarkupText
existsone = symbstr [36, 33]

---
-- Special character.
not :: MarkupText
not = symbchr 216

---
-- Special character.
and :: MarkupText
and = symbchr 217

---
-- Special character.
or :: MarkupText
or = symbchr 218


-- other operations

---
-- Special character.
times :: MarkupText
times = symbchr 180

---
-- Special character.
sum :: MarkupText
sum = symbchr 229

---
-- Special character.
prod :: MarkupText
prod = symbchr 213

---
-- Special character.
comp :: MarkupText
comp = symbchr 183

---
-- Special character.
bullet :: MarkupText
bullet = symbchr 183

---
-- Special character.
tensor :: MarkupText
tensor = symbchr 196

---
-- Special character.
otimes :: MarkupText
otimes = symbchr 196

---
-- Special character.
oplus :: MarkupText
oplus = symbchr 197

---
-- Special character.
bot :: MarkupText
bot = symbchr 94


-- arrows

---
-- Special character.
rightarrow :: MarkupText
rightarrow = symbchr 174

---
-- Special character.
rrightarrow :: MarkupText
rrightarrow = symbchr 222

---
-- Special character.
longrightarrow :: MarkupText
longrightarrow = symbstr [190, 174]

---
-- Special character.
llongrightarrow :: MarkupText
llongrightarrow = symbstr [61, 222]

---
-- Special character.
leftrightarrow :: MarkupText
leftrightarrow = symbchr 171

---
-- Special character.
lleftrightarrow :: MarkupText
lleftrightarrow = symbchr 219

---
-- Special character.
ddownarrow :: MarkupText
ddownarrow = symbchr 223

---
-- Special character.
uuparrow :: MarkupText
uuparrow = symbchr 221

---
-- Special character.
vline :: MarkupText
vline = symbchr 189

---
-- Special character.
hline :: MarkupText
hline = symbchr 190

---
-- Special character.
rbrace1 :: MarkupText
rbrace1 = symbchr 236

---
-- Special character.
rbrace2 :: MarkupText
rbrace2 = symbchr 237

---
-- Special character.
rbrace3 :: MarkupText
rbrace3 = symbchr 238


-- set operations

---
-- Special character.
emptyset :: MarkupText
emptyset = symbchr 198

---
-- Special character.
inset :: MarkupText
inset = symbchr 206

---
-- Special character.
notin :: MarkupText
notin = symbchr 207

---
-- Special character.
intersect :: MarkupText
intersect = symbchr 199

---
-- Special character.
union :: MarkupText
union = symbchr 200

---
-- Special character.
subset :: MarkupText
subset = symbchr 204

---
-- Special character.
subseteq :: MarkupText
subseteq = symbchr 205

---
-- Special character.
setminus :: MarkupText
setminus = symbchr 164

---
-- Special character.
powerset :: MarkupText
powerset = symbchr 195

---
-- Special character.
inf :: MarkupText
inf = symbchr 165

---
-- Special character.
iintersect :: MarkupText
iintersect = bigsymbchr 199

---
-- Special character.
uunion :: MarkupText
uunion = bigsymbchr 200


-- relations

---
-- Special character.
equiv :: MarkupText
equiv = symbchr 186

---
-- Special character.
neq :: MarkupText
neq = symbchr 185

---
-- Special character.
leq :: MarkupText
leq = symbchr 163

---
-- Special character.
grteq :: MarkupText
grteq = symbchr 179

---
-- Special character.
lsem :: MarkupText
lsem = symbstr [91, 91]

---
-- Special character.
rsem :: MarkupText
rsem = symbstr [93, 93]


-- misc other symbols

---
-- Special character.
dots :: MarkupText
dots = symbchr 188

---
-- Special character.
copyright :: MarkupText
copyright = symbchr 227

-- aux
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)


-- -----------------------------------------------------------------------
-- parse markup text structures
-- -----------------------------------------------------------------------

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 -- restore state
         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 -- restore state
         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
                                  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
-- -----------------------------------------------------------------------

---
-- Widgets that can contain markup text instantiate the
-- <code>class HasMarkupText</code>.
class HasMarkupText w where
---
-- Clears the editor widget and inserts the given markup text.
  new :: [MarkupText] -> w -> IO w
---
-- Inserts the given markup text at the specified position.
  insertAt :: [MarkupText] -> Position -> Config w
---
-- Clears the editor widget.
  clear :: Config w

---
-- An editor widget is a container for markup text.
instance HasMarkupText Editor where
---
-- Clears the editor widget and inserts the given markup text.
  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 -- restore state
      return ed
---
-- Inserts the given markup text at the specified position.
  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 -- restore state
      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
---
-- Clears the editor widget.
  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