{-# LANGUAGE ExistentialQuantification #-}-- | A simple markup language for convenient writing into an editor widget.moduleHTk.Toolkit.MarkupText(-- typeMarkupText,-- combinatorsprose,font,newline,bold,underline,italics,spaces,offset,colour,bgcolour,flipcolour,flipunderline,action,rangeaction,clipup,leftmargin,wrapmargin,rightmargin,centered,flushright,flushleft,href,window,window1,-- special charactersalpha,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,-- container class for markup textsHasMarkupText(..),scrollMarkupText,)whereimportData.CharimportPreludehiding(pi,not,and,or,sum)importqualifiedPrelude(not)importSystem.IO.UnsafeimportUtil.ObjectimportUtil.ComputationimportEvents.ChannelsimportEvents.EventsimportReactor.ReferenceVariablesimportHTk.Toplevel.HTkhiding(font,underline,offset)importHTk.Kernel.GUIObjectimportqualifiedHTk.Kernel.ConfigurationasConfiguration(font)importqualifiedHTk.Textitems.TextTagasTextTag(offset)importHTk.Kernel.Font-- ------------------------------------------------------------------------- state-- -----------------------------------------------------------------------unbinds::Ref[(ObjectID,[IO()])]unbinds=unsafePerformIO(newRef[]){-# NOINLINE unbinds #-}addToState::Editor->[IO()]->IO()addToStateedacts=doletGUIOBJECToid_=toGUIObjectedub<-getRefunbindssetRefunbinds((oid,acts):ub)-- ------------------------------------------------------------------------- types-- ------------------------------------------------------------------------- | The @MarkupText@ datatype.dataMarkupText=MarkupText[MarkupText]|MarkupProse[String]|MarkupSpecialCharFontInt|MarkupFontFont[MarkupText]|MarkupNewline|MarkupBold[MarkupText]|MarkupItalics[MarkupText]|MarkupOffsetInt[MarkupText]|MarkupColourColour[MarkupText]|MarkupBgColourColour[MarkupText]|MarkupFlipColourColourColour[MarkupText]|MarkupFlipUnderline[MarkupText]|MarkupUnderline[MarkupText]|MarkupJustifyJustify[MarkupText]|MarkupAction(IO())[MarkupText]|MarkupClipUp[MarkupText][MarkupText]|MarkupRangeAction(Maybe(IO()))(Maybe(IO()))[MarkupText]|MarkupLeftMarginInt[MarkupText]|MarkupWrapMarginInt[MarkupText]|MarkupRightMarginInt[MarkupText]|MarkupHRef[MarkupText][MarkupText]|forallw.Widgetw=>MarkupWindow(Editor->IO(w,IO()))typeTagFun=Editor->BaseIndex->BaseIndex->IOTextTagtypeTag=(Position,Position,TagFun)typeEmbWindowFun=Editor->BaseIndex->IOEmbeddedTextWintypeEmbWindow=(Position,EmbWindowFun)-- ------------------------------------------------------------------------ combinators-- ------------------------------------------------------------------------- | The markup prose combinator.prose::String->MarkupTextprosestr=MarkupProse(linesstr)-- | The markup font combinator.font::FontDesignatorf=>f->[MarkupText]->MarkupTextfontf=MarkupFont(toFontf)-- | The markup newline combinator.newline::MarkupTextnewline=MarkupNewline-- | The markup bold combinator.bold::[MarkupText]->MarkupTextbold=MarkupBold-- | The markup underline combinator.underline::[MarkupText]->MarkupTextunderline=MarkupUnderline-- | Center this part of the textcentered::[MarkupText]->MarkupTextcentered=MarkupJustifyJustCenter-- | Flush this part of the against the left marginflushleft::[MarkupText]->MarkupTextflushleft=MarkupJustifyJustLeft------ Flush this part of the against the right marginflushright::[MarkupText]->MarkupTextflushright=MarkupJustifyJustRight-- | The markup italics combinator.italics::[MarkupText]->MarkupTextitalics=MarkupItalics-- | The markup baseline offset combinator.offset::Int->[MarkupText]->MarkupTextoffset=MarkupOffset-- | The markup foreground colour combinator.colour::ColourDesignatorc=>c->[MarkupText]->MarkupTextcolourc=MarkupColour(toColourc)-- | The markup background colour combinator.bgcolour::ColourDesignatorc=>c->[MarkupText]->MarkupTextbgcolourc=MarkupBgColour(toColourc)-- | The markup space combinator (a number of space characters).spaces::Int->MarkupTextspacesn=MarkupProse[replicaten' ']-- | The markup flipcolour combinator (flips the colour when the mouse-- is over this text segment).flipcolour::ColourDesignatorc=>c->c->[MarkupText]->MarkupTextflipcolourc1c2=MarkupFlipColour(toColourc1)(toColourc2)-- | The markup flipunderline combinator (underlines this text segment when-- the mouse is over this segment).flipunderline::[MarkupText]->MarkupTextflipunderline=MarkupFlipUnderline-- | The markup action combinator (binds an action for mouse clicks on this-- text segment).action::IO()->[MarkupText]->MarkupTextaction=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]->MarkupTextrangeaction=MarkupRangeAction-- | The markup clipup combinator (clips up a text segment on a mouse-- click).clipup::[MarkupText]->[MarkupText]->MarkupTextclipup=MarkupClipUp-- | The markup left margin combinator (normal left intend for a line).leftmargin::Int->[MarkupText]->MarkupTextleftmargin=MarkupLeftMargin-- | The markup wrap margin combinator (intend for a part of a line-- that gets wrapped).wrapmargin::Int->[MarkupText]->MarkupTextwrapmargin=MarkupWrapMargin-- | The markup right margin combinator.rightmargin::Int->[MarkupText]->MarkupTextrightmargin=MarkupRightMargin-- | The markup window combinator (a widget container inside the editor-- widget).window1::Widgetw=>(Editor->IO(w,IO()))->MarkupTextwindow1=MarkupWindowwindow::Widgetw=>IO(w,IO())->MarkupTextwindowact=window1(constact)-- | The markup href combinator (a link to another markup text).href::[MarkupText]->[MarkupText]->MarkupTexthref=MarkupHRef-- ------------------------------------------------------------------------- special characters-- ------------------------------------------------------------------------- grk letters, lowercase-- | Special character.alpha::MarkupTextalpha=symbchr97-- | Special character.beta::MarkupTextbeta=symbchr98-- | Special character.chi::MarkupTextchi=symbchr99-- | Special character.delta::MarkupTextdelta=symbchr100-- | Special character.epsilon::MarkupTextepsilon=symbchr101-- | Special character.phi::MarkupTextphi=symbchr102-- | Special character.gamma::MarkupTextgamma=symbchr103-- | Special character.eta::MarkupTexteta=symbchr104-- | Special character.varphi::MarkupTextvarphi=symbchr106-- | Special character.iota::MarkupTextiota=symbchr105-- | Special character.kappa::MarkupTextkappa=symbchr107-- | Special character.lambda::MarkupTextlambda=symbchr108-- | Special character.mu::MarkupTextmu=symbchr109-- | Special character.nu::MarkupTextnu=symbchr110-- | Special character.omikron::MarkupTextomikron=symbchr111-- | Special character.pi::MarkupTextpi=symbchr112-- | Special character.theta::MarkupTexttheta=symbchr113-- | Special character.vartheta::MarkupTextvartheta=symbchr74-- | Special character.rho::MarkupTextrho=symbchr114-- | Special character.sigma::MarkupTextsigma=symbchr115-- | Special character.varsigma::MarkupTextvarsigma=symbchr86-- | Special character.tau::MarkupTexttau=symbchr116-- | Special character.upsilon::MarkupTextupsilon=symbchr117-- | Special character.varpi::MarkupTextvarpi=symbchr118-- | Special character.omega::MarkupTextomega=symbchr119-- | Special character.xi::MarkupTextxi=symbchr120-- | Special character.psi::MarkupTextpsi=symbchr121-- | Special character.zeta::MarkupTextzeta=symbchr122-- grk letters, uppercase-- | Special character (uppercase).aalpha::MarkupTextaalpha=symbchr65-- | Special character (uppercase).bbeta::MarkupTextbbeta=symbchr66-- | Special character (uppercase).cchi::MarkupTextcchi=symbchr67-- | Special character (uppercase).ddelta::MarkupTextddelta=symbchr68-- | Special character (uppercase).eeps::MarkupTexteeps=symbchr69-- | Special character (uppercase).pphi::MarkupTextpphi=symbchr70-- | Special character (uppercase).ggamma::MarkupTextggamma=symbchr71-- | Special character (uppercase).eeta::MarkupTexteeta=symbchr72-- | Special character (uppercase).iiota::MarkupTextiiota=symbchr73-- | Special character (uppercase).kkappa::MarkupTextkkappa=symbchr75-- | Special character (uppercase).llambda::MarkupTextllambda=symbchr76-- | Special character (uppercase).mmu::MarkupTextmmu=symbchr77-- | Special character (uppercase).nnu::MarkupTextnnu=symbchr78-- | Special character (uppercase).oomikron::MarkupTextoomikron=symbchr79-- | Special character (uppercase).ppi::MarkupTextppi=symbchr80-- | Special character (uppercase).ttheta::MarkupTextttheta=symbchr81-- | Special character (uppercase).rrho::MarkupTextrrho=symbchr82-- | Special character (uppercase).ssigma::MarkupTextssigma=symbchr83-- | Special character (uppercase).ttau::MarkupTextttau=symbchr84-- | Special character (uppercase).uupsilon::MarkupTextuupsilon=symbchr85-- | Special character (uppercase).oomega::MarkupTextoomega=symbchr87-- | Special character (uppercase).xxi::MarkupTextxxi=symbchr88-- | Special character (uppercase).ppsi::MarkupTextppsi=symbchr89-- | Special character (uppercase).zzeta::MarkupTextzzeta=symbchr90-- quantifiers and junctors-- | Special character.forallsmall::MarkupTextforallsmall=symbchr34-- | Special character.exists::MarkupTextexists=symbchr36-- | Special character.forallbig::MarkupTextforallbig=bigsymbchr34-- | Special character.eexists::MarkupTexteexists=bigsymbchr36-- | Special character.existsone::MarkupTextexistsone=symbstr[36,33]-- | Special character.not::MarkupTextnot=symbchr216-- | Special character.and::MarkupTextand=symbchr217-- | Special character.bigand::MarkupTextbigand=bigsymbchr217-- | Special character.or::MarkupTextor=symbchr218-- other operations-- | Special character.times::MarkupTexttimes=symbchr180-- | Special character.sum::MarkupTextsum=symbchr229-- | Special character.prod::MarkupTextprod=symbchr213-- | Special character.comp::MarkupTextcomp=symbchr183-- | Special character.bullet::MarkupTextbullet=symbchr183-- | Special character.tensor::MarkupTexttensor=symbchr196-- | Special character.otimes::MarkupTextotimes=symbchr196-- | Special character.oplus::MarkupTextoplus=symbchr197-- | Special character.bot::MarkupTextbot=symbchr94-- arrows-- | Special character.rightarrow::MarkupTextrightarrow=symbchr174-- | Special character.rrightarrow::MarkupTextrrightarrow=symbchr222-- | Special character.longrightarrow::MarkupTextlongrightarrow=symbstr[190,174]-- | Special character.llongrightarrow::MarkupTextllongrightarrow=symbstr[61,222]-- | Special character.leftrightarrow::MarkupTextleftrightarrow=symbchr171-- | Special character.lleftrightarrow::MarkupTextlleftrightarrow=symbchr219-- | Special character.ddownarrow::MarkupTextddownarrow=symbchr223-- | Special character.uuparrow::MarkupTextuuparrow=symbchr221-- | Special character.vline::MarkupTextvline=symbchr189-- | Special character.hline::MarkupTexthline=symbchr190-- | Special character.rbrace1::MarkupTextrbrace1=symbchr236-- | Special character.rbrace2::MarkupTextrbrace2=symbchr237-- | Special character.rbrace3::MarkupTextrbrace3=symbchr238-- set operations-- | Special character.emptyset::MarkupTextemptyset=symbchr198-- | Special character.inset::MarkupTextinset=symbchr206-- | Special character.notin::MarkupTextnotin=symbchr207-- | Special character.intersect::MarkupTextintersect=symbchr199-- | Special character.union::MarkupTextunion=symbchr200-- | Special character.subset::MarkupTextsubset=symbchr204-- | Special character.subseteq::MarkupTextsubseteq=symbchr205-- | Special character.setminus::MarkupTextsetminus=symbchr164-- | Special character.powerset::MarkupTextpowerset=symbchr195-- | Special character.inf::MarkupTextinf=symbchr165-- | Special character.iintersect::MarkupTextiintersect=bigsymbchr199-- | Special character.uunion::MarkupTextuunion=bigsymbchr200-- relations-- | Special character.equiv::MarkupTextequiv=symbchr186-- | Special character.neq::MarkupTextneq=symbchr185-- | Special character.leq::MarkupTextleq=symbchr163-- | Special character.grteq::MarkupTextgrteq=symbchr179-- | Special character.lsem::MarkupTextlsem=symbstr[91,91]-- | Special character.rsem::MarkupTextrsem=symbstr[93,93]-- misc other symbols-- | Special character.dots::MarkupTextdots=symbchr188-- | Special character.copyright::MarkupTextcopyright=symbchr227-- auxsymbchr::Int->MarkupTextsymbchri=MarkupSpecialChar(Font"-*-symbol-medium-r-normal-*-14-*-*-*-*-*-*-*")ibigsymbchr::Int->MarkupTextbigsymbchri=MarkupSpecialChar(Font"-*-symbol-medium-r-normal-*-18-*-*-*-*-*-*-*")isymbstr::[Int]->MarkupTextsymbstris=MarkupText(mapsymbchris)-- ------------------------------------------------------------------------- parse markup text structures-- -----------------------------------------------------------------------checkfont::Font->Bool->Bool->Fontcheckfontf@(Fontstr)bolditalics=letxf=readstrincasexfofXFontAlias_->f_->case(bold,italics)of(True,True)->toFontxf{weight=JustBold,slant=JustItalic}(True,False)->toFontxf{weight=JustBold}(False,True)->toFontxf{slant=JustItalic}_->fclipact::Editor->Mark->Mark->RefBool->Ref[TextTag]->String->[Tag]->IO()clipactedmark1mark2opensettagstxttags=dob<-getRefopensetRefopen(Prelude.notb)(ifbthendotags'<-getRefsettagsst<-getStateedifst==Disabledthened#stateNormal>>doneelsedonemapMdestroytags'deleteTextRangeedmark1mark2ed#statest-- restore statedoneelsedost<-getStateedifst==Disabledthened#stateNormal>>doneelsedoneinsertTextedmark1txttags'<-insertTagstagsed#statest-- restore statesetRefsettagstags')whereinsertTags::[Tag]->IO[TextTag]insertTags(((l1,c1),(l2,c2),f):ts)=dopos1<-getBaseIndexed(mark1,[ForwardLines(fromDistancel1),ForwardChars(fromDistancec1)])pos2<-getBaseIndexed(mark1,[ForwardLines(fromDistancel2),ForwardChars(fromDistancec2)])tag<-fedpos1pos2tags<-insertTagstsreturn(tag:tags)insertTags_=return[]parseMarkupText::[MarkupText]->Font->IO(String,[EmbWindow],[Tag])parseMarkupTextmf=do(ret,_)<-parseMarkupText'm[][][](1,0)FalseFalsefreturnretwheresimpleProperty::[MarkupText]->[MarkupText]->String->[Tag]->[EmbWindow]->Position->Bool->Bool->Font->[ConfigTextTag]->IO((String,[EmbWindow],[Tag]),Position)simplePropertymsm'txttagswins(line,char)bolditalicscurrent_fontcnf=do((txt',wins',tags'),(line',char'))<-parseMarkupText'm'txttagswins(line,char)bolditalicscurrent_fontlettag=((line,char),(line',char'),\edpos1pos2->createTextTagedpos1pos2cnf)parseMarkupText'mstxt'(tag:tags')wins'(line',char')bolditalicscurrent_fontparseMarkupText'::[MarkupText]->String->[Tag]->[EmbWindow]->Position->Bool->Bool->Font->IO((String,[EmbWindow],[Tag]),Position)parseMarkupText'(m:ms)txttagswins(line,char)bolditalicscurrent_font=casemofMarkupTextm'->parseMarkupText'(m'++ms)txttagswins(line,char)bolditalicscurrent_fontMarkupProse[str]->parseMarkupText'ms(txt++str)tagswins(line,char+Distance(lengthstr))bolditalicscurrent_fontMarkupProse(l:rest)->parseMarkupText'(MarkupProserest:ms)(txt++l++"\n")tagswins(line+1,0)bolditalicscurrent_fontMarkupProse[]->parseMarkupText'mstxttagswins(line,char)bolditalicscurrent_fontMarkupSpecialCharfi->parseMarkupText'(MarkupFontf[prose[chri]]:ms)txttagswins(line,char)bolditalicscurrent_fontMarkupNewline->parseMarkupText'ms(txt++"\n")tagswins(line+1,0)bolditalicscurrent_fontMarkupColourcm'->simplePropertymsm'txttagswins(line,char)bolditalicscurrent_font[fgc]MarkupOffsetim'->simplePropertymsm'txttagswins(line,char)bolditalicscurrent_font[TextTag.offset(Distancei)]MarkupBgColourcm'->simplePropertymsm'txttagswins(line,char)bolditalicscurrent_font[bgc]MarkupLeftMarginim'->simplePropertymsm'txttagswins(line,char)bolditalicscurrent_font[lmargin1(Distancei)]MarkupWrapMarginim'->simplePropertymsm'txttagswins(line,char)bolditalicscurrent_font[lmargin2(Distancei)]MarkupRightMarginim'->simplePropertymsm'txttagswins(line,char)bolditalicscurrent_font[rmargin(Distancei)]MarkupUnderlinem'->simplePropertymsm'txttagswins(line,char)bolditalicscurrent_font[underlinedOn]MarkupJustifyjm'->simplePropertymsm'txttagswins(line,char)bolditalicscurrent_font[justifyj]MarkupFontfm'->do((txt',wins',tags'),(line',char'))<-parseMarkupText'm'txttagswins(line,char)bolditalicsflet(Fontfstr)=flettag=((line,char),(line',char'),\edpos1pos2->createTextTagedpos1pos2[Configuration.font(checkfontfbolditalics)])parseMarkupText'mstxt'(tag:tags')wins'(line',char')bolditalicscurrent_fontMarkupBoldm'->do((txt',wins',tags'),(line',char'))<-parseMarkupText'm'txttagswins(line,char)Trueitalicscurrent_fontlet(Fontfstr)=current_fontlettag=((line,char),(line',char'),\edpos1pos2->createTextTagedpos1pos2[Configuration.font(checkfontcurrent_fontTrueitalics)])parseMarkupText'mstxt'(tag:tags')wins'(line',char')bolditalicscurrent_fontMarkupItalicsm'->do((txt',wins',tags'),(line',char'))<-parseMarkupText'm'txttagswins(line,char)boldTruecurrent_fontlet(Fontfstr)=current_fontlettag=((line,char),(line',char'),\edpos1pos2->createTextTagedpos1pos2[Configuration.font(checkfontcurrent_fontboldTrue)])parseMarkupText'mstxt'(tag:tags')wins'(line',char')bolditalicscurrent_fontMarkupFlipColourc1c2m'->do((txt',wins',tags'),(line',char'))<-parseMarkupText'm'txttagswins(line,char)bolditalicscurrent_fontlettag=((line,char),(line',char'),\edpos1pos2->dotag<-createTextTagedpos1pos2[]tag#fgc1(entered,u_entered)<-bindSimpletagEnter(left,u_left)<-bindSimpletagLeavedeath<-newChannelletlistenTag::Event()listenTag=(entered>>(always(tag#fgc2)>>listenTag))+>(left>>(always(tag#fgc1)>>listenTag))+>receivedeath_<-spawnEventlistenTagaddToStateed[u_entered,u_left,syncNoWait(senddeath())]returntag)parseMarkupText'mstxt'(tag:tags')wins'(line',char')bolditalicscurrent_fontMarkupFlipUnderlinem'->do((txt',wins',tags'),(line',char'))<-parseMarkupText'm'txttagswins(line,char)bolditalicscurrent_fontlettag=((line,char),(line',char'),\edpos1pos2->dotag<-createTextTagedpos1pos2[](entered,u_entered)<-bindSimpletagEnter(left,u_left)<-bindSimpletagLeavedeath<-newChannelletlistenTag::Event()listenTag=(entered>>(always(tag#underlinedOn)>>listenTag))+>(left>>(always(tag#underlinedOff)>>listenTag))+>receivedeath_<-spawnEventlistenTagaddToStateed[u_entered,u_left,syncNoWait(senddeath())]returntag)parseMarkupText'mstxt'(tag:tags')wins'(line',char')bolditalicscurrent_fontMarkupActionactm'->do((txt',wins',tags'),(line',char'))<-parseMarkupText'm'txttagswins(line,char)bolditalicscurrent_fontlettag=((line,char),(line',char'),\edpos1pos2->dotag<-createTextTagedpos1pos2[](click,u_click)<-bindSimpletag(ButtonPress(Just1))death<-newChannelletlistenTag::Event()listenTag=(click>>alwaysact>>listenTag)+>receivedeath_<-spawnEventlistenTagaddToStateed[u_click,syncNoWait(senddeath())]returntag)parseMarkupText'mstxt'(tag:tags')wins'(line',char')bolditalicscurrent_fontMarkupRangeActionmenteractmleaveactm'->do((txt',wins',tags'),(line',char'))<-parseMarkupText'm'txttagswins(line,char)bolditalicscurrent_fontlettag=((line,char),(line',char'),\edpos1pos2->dotag<-createTextTagedpos1pos2[](enter,enter_u)<-bindSimpletagEnter(leave,leave_u)<-bindSimpletagLeavedeath<-newChannelletlistenTag::Event()listenTag=(enter>>always(casementeractofJustact->actNothing->done)>>listenTag)+>(leave>>always(casemleaveactofJustact->actNothing->done)>>listenTag)+>receivedeath_<-spawnEventlistenTagaddToStateed[enter_u,leave_u,syncNoWait(senddeath())]returntag)parseMarkupText'mstxt'(tag:tags')wins'(line',char')bolditalicscurrent_fontMarkupClipUpm'cliptext->doletpos=(ifchar>0thenline+1elseline,0)s=ifchar>0then"\n"else""((txt',wins',tags'),(line',char'))<-parseMarkupText'm'(s++txt)tagswinsposbolditalicscurrent_fontlettag=(pos,(line',char'),\edpos1pos2->do((txt',wins',tags'),(line',char'))<-parseMarkupText'(cliptext++[newline])""[][](0,0)bolditalicsfoid1<-newObjectmark1<-createMarked("m"++showoid1)(pos1,[ForwardLines1])setMarkGravitymark1ToLeftoid2<-newObjectmark2<-createMarked("m"++showoid2)(pos1,[ForwardLines1])tag<-createTextTagedpos1pos2[](click,u_click)<-bindSimpletag(ButtonPress(Just1))open<-newRefFalsesettags<-newRef[]death<-newChannelletlistenTag::Event()listenTag=(click>>always(clipactedmark1mark2opensettagstxt'tags')>>listenTag)+>receivedeath_<-spawnEventlistenTagaddToStateed[u_click,syncNoWait(senddeath())]returntag)parseMarkupText'ms(txt'++"\n")(tag:tags')wins'(line'+1,0)bolditalicscurrent_fontMarkupHRefm'linktext->do((txt',wins',tags'),(line',char'))<-parseMarkupText'm'txttagswins(line,char)bolditalicscurrent_fontlettag=((line,char),(line',char'),\edpos1pos2->dotag<-createTextTagedpos1pos2[](click,u_click)<-bindSimpletag(ButtonPress(Just1))death<-newChannelletlistenTag::Event()listenTag=(click>>always(ed#clear>>ed#newlinktext)>>listenTag)+>receivedeath_<-spawnEventlistenTagaddToStateed[u_click,syncNoWait(senddeath())]returntag)parseMarkupText'mstxt'(tag:tags')wins'(line',char')bolditalicscurrent_fontMarkupWindowiowid->letwin=((line,char),\edpos->do(wid,cleanup)<-iowidedw<-createEmbeddedTextWinedposwid[]addToStateed[cleanup]returnw)inparseMarkupText'mstxttags(win:wins)(line,char)bolditalicscurrent_fontparseMarkupText'_txttagswins(line,char)___=return((txt,wins,tags),(line,char))-- ------------------------------------------------------------------------- class HasMarkupText-- ------------------------------------------------------------------------- | Widgets that can contain markup text instantiate the-- @class HasMarkupText@.classHasMarkupTextwwhere-- Clears the editor widget and inserts the given markup text.new::[MarkupText]->w->IOw-- Inserts the given markup text at the specified position.insertAt::[MarkupText]->Position->Configw-- Clears the editor widget.clear::Configw-- | An editor widget is a container for markup text.instanceHasMarkupTextEditorwhere-- Clears the editor widget and inserts the given markup text.newmed=dost<-getStateedifst==Disabledthened#stateNormal>>doneelsedonef<-getFonted(txt,wins,tags)<-parseMarkupTextmfed#valuetxtmapM(\(pos1,pos2,f)->dopos1'<-getBaseIndexedpos1pos2'<-getBaseIndexedpos2fedpos1'pos2')tagsmapM(\(pos,f)->dopos'<-getBaseIndexedposew<-fedpos'addToStateed[destroyew])winsed#statest-- restore statereturned-- Inserts the given markup text at the specified position.insertAtmpos@(line,char)ed=dof<-getFonted(txt,wins,tags)<-parseMarkupTextmfl<-getTextLineedposst<-getStateedifst==Disabledthened#stateNormal>>doneelsedoneinsertTextedpos(replicate(fromDistancechar-lengthl)' '++txt)lettags'=shiftTagspostagsmapM(\(pos1,pos2,f)->dopos1'<-getBaseIndexedpos1pos2'<-getBaseIndexedpos2fedpos1'pos2')tags'ed#statest-- restore statereturnedwhereshiftTags::Position->[Tag]->[Tag]shiftTagsptags=map(shiftTagp)tagsshiftTag::Position->Tag->TagshiftTag(line,char)(p1@(line1,char1),p2@(line2,char2),tag)=((shiftLinelineline1,shiftCharcharp1),(shiftLinelineline2,shiftCharcharp2),tag)shiftLine::Distance->Distance->DistanceshiftLineplineline=pline+(line-1)shiftChar::Distance->Position->DistanceshiftCharpchar(line,char)=ifline==1thenchar+pcharelsechar-- Clears the editor widget.cleared=doletobj@(GUIOBJECToid_)=toGUIObjectedunbinds'<-getRefunbindsmapM(\(oid',ubs)->ifoid==oid'then(mapM(\act->act)ubs)>>doneelsedone)unbinds'setRefunbinds[]returnedfromDistance::Distance->IntfromDistance(Distancei)=i-- ------------------------------------------------------------------------- A utility for putting a scroll-bar around MarkupText.-- -----------------------------------------------------------------------scrollMarkupText::Size->[MarkupText]->MarkupTextscrollMarkupTextsize1markups=letaction::Editor->IO(Frame,IO())actioneditor=doeditorFrame<-newFrameeditor[]editorFrame2<-newFrameeditorFrame[]editor<-newEditoreditorFrame2[wrapNoWrap,disable,newmarkups,sizesize1]scrollBar1<-newScrollBareditorFrame2[orientVertical]scrollBar2<-newScrollBareditorFrame[orientHorizontal]editor#scrollbarVerticalscrollBar1editor#scrollbarHorizontalscrollBar2packeditor[SideAtRight,FillBoth]packscrollBar1[SideAtRight,FillY,ExpandOn]packeditorFrame2[SideAtTop]packscrollBar2[SideAtTop,FillX]return(editorFrame,destroyeditorFrame)inwindow1action