(* text-window.sml *) (* Copyright (C) 2004 Dominic Gelinas improvements Copyright (C) 2006 Cole Hoosier This file is part of crypto, a cryptogram encoder/decoder. See the file COPYING.txt for copying and usage restrictions *) structure TextWindow : TEXT_WINDOW = struct structure EXB = EXeneBase structure W = Widget structure A = Attrs structure Q = Quark structure TR = TextRenderer open CML Geometry Interact SyncVar val textwindowTM = TraceCML.traceModule(XDebug.eXeneTM, "textwindow"); fun trace f = TraceCML.trace(textwindowTM, f) fun debug str = trace(fn () => [str]) val attr_text = Q.quark "text" val attr_active = Q.quark "active" val attr_editable = Q.quark "editable" val attr_rows = Q.quark "rows" val attr_columns = Q.quark "columns" val attr_font = A.attr_font val attr_activeFgColor = Q.quark "activeFgColor" val attr_activeBgColor = Q.quark "activeBgColor" val attr_inactiveFgColor = Q.quark "inactiveFgColor" val attr_inactiveBgColor = Q.quark "inactiveBgColor" val defaultText = "" val defaultActive = true val defaultEditable = true val defaultRows = 0 val defaultColumns = 0 val defaultFont = "9x15" val defaultActiveFg = "black" val defaultActiveBg = "white" val defaultInactiveFg = "grey" val defaultInactiveBg = "white" val attrs = [(attr_text, A.AT_Str, A.AV_Str defaultText), (attr_active, A.AT_Bool, A.AV_Bool defaultActive), (attr_editable, A.AT_Bool, A.AV_Bool defaultEditable), (attr_rows, A.AT_Int, A.AV_Int defaultRows), (attr_columns, A.AT_Int, A.AV_Int defaultColumns), (attr_font, A.AT_Font, A.AV_Str defaultFont), (attr_activeFgColor, A.AT_Color, A.AV_Str defaultActiveFg), (attr_activeBgColor, A.AT_Color, A.AV_Str defaultActiveBg), (attr_inactiveFgColor, A.AT_Color, A.AV_Str defaultInactiveFg), (attr_inactiveBgColor, A.AT_Color, A.AV_Str defaultInactiveBg)] datatype font_info = FI of {font : W.EXB.font, fonta : int, fontd : int, maxc : int} datatype rqst = DoRealize of {env : Interact.in_env, win : W.EXB.window, sz : Geometry.size} | GetBounds of W.bounds ivar | GetText of string ivar | SetText of string | GetActive of bool ivar | SetActive of bool | GetEditable of bool ivar | SetEditable of bool | GetRows of int ivar | SetRows of int | GetCols of int ivar | SetCols of int | GetPosition of int ivar | SetPosition of int | GetFont of W.EXB.font ivar | SetFont of W.EXB.font | GetActiveFC of W.EXB.color ivar | SetActiveFC of W.EXB.color | GetActiveBC of W.EXB.color ivar | SetActiveBC of W.EXB.color | GetInactiveFC of W.EXB.color ivar | SetInactiveFC of W.EXB.color | GetInactiveBC of W.EXB.color ivar | SetInactiveBC of W.EXB.color datatype input_message = Insert of char | Backspace | Delete | MoveLeft | MoveRight | MoveUp | MoveDown | MouseDown of point * W.EXB.XTime.time | MouseUp of point * W.EXB.XTime.time | MouseDrag of point * W.EXB.XTime.time | Cut | Paste of W.EXB.XTime.time datatype textwindow = TextWindow of {widget : W.widget, rqst : rqst chan} (* For efficiency, this is a record of references. This way, when we need to modify a single element in the record, we don't have to copy everything. *) datatype textwindowview = TWV of {text : TR.textrenderer, textEvt : unit event, active : bool ref, editable : bool ref, pos : int ref, selection : (int * int) ref, selectEvt : unit event option ref, activeFg : W.EXB.color ref, activeBg : W.EXB.color ref, inactiveFg : W.EXB.color ref, inactiveBg : W.EXB.color ref} datatype redraw_pos = EOL | EOF | POS of int (* (redraw_pos * redraw_pos) , is a set of bounded coordinates to redraw bool , is whether to fill in everything after the cursor with the bg color *) datatype handlereq_return = REDRAW_POS of textwindowview * (redraw_pos * redraw_pos) * bool | REDRAW_ALL of textwindowview | REDRAW_NONE (* val fontInfo : Font.font -> font_info *) fun fontInfo font = let val {ascent,descent} = Font.fontHt font val {max_bounds,...} = Font.fontInfoOf font val Font.CharInfo {char_wid,...} = max_bounds in FI{font=font,fonta=ascent,fontd=descent,maxc=char_wid} end fun gtBounds (TWV{text,...}) = TR.getDim text fun gtText (TWV{text,...}) = TR.getText text fun stText (str, twv as TWV{text, selection, selectEvt, ...}) = (case !selectEvt of NONE => () | SOME _ => (selection := (0,0); selectEvt := NONE); TR.setText text str; twv) fun gtActive (TWV{active,...}) = !active fun stActive (b, twv as TWV{active,...}) = (active := b; twv) fun gtEditable (TWV{editable,...}) = !editable fun stEditable (b, twv as TWV{editable,...}) = (editable := b; twv) fun gtRows (TWV{text,...}) = TR.getRows text fun stRows (r, twv as TWV{text,...}) = (TR.setRows text r; twv) fun gtCols (TWV{text,...}) = TR.getColumns text fun stCols (c, twv as TWV{text,...}) = (TR.setColumns text c; twv) fun gtPos (TWV{pos,...}) = !pos fun stPos (n, twv as TWV{pos,...}) = (pos := n; twv) fun gtFont (TWV{text,...}) = TR.getFont text fun stFont (f, twv as TWV{text,...}) = (TR.setFont text f; twv) fun gtActiveFC (TWV{activeFg,...}) = !activeFg fun stActiveFC (c, twv as TWV{activeFg,...}) = (activeFg := c; twv) fun gtActiveBC (TWV{activeBg,...}) = !activeBg fun stActiveBC (c, twv as TWV{activeBg,...}) = (activeBg := c; twv) fun gtInactiveFC (TWV{inactiveFg,...}) = !inactiveFg fun stInactiveFC (c, twv as TWV{inactiveFg,...}) = (inactiveFg := c; twv) fun gtInactiveBC (TWV{inactiveBg,...}) = !inactiveBg fun stInactiveBC (c, twv as TWV{inactiveBg,...}) = (inactiveBg := c; twv) fun stripNewline str = let val size = String.size str in if size > 0 andalso String.sub (str, size-1) = #"\n" then String.substring (str, 0, size-1) else str end fun draw (dr, SIZE{wid,ht}) (twv as TWV{text,active,editable,pos,selection, activeFg,activeBg,inactiveFg,inactiveBg,...}) = let open Drawing val fg = if (!active) then (!activeFg) else (!inactiveFg) val bg = if (!active) then (!activeBg) else (!inactiveBg) val FI{font,fonta,fontd,maxc} = fontInfo (TR.getFont text) val start = Int.min (!selection) val stop = Int.max (!selection) val fpen = newPen[PV_Foreground fg] val bpen = newPen[PV_Foreground bg] val rect = RECT{x=0,y=0,wid=wid,ht=ht} val rt = TR.getRt text val textWidth = Font.textWidth font fun drawRt (nil, _, _) = () | drawRt ((pt as PT{x,y}, str) :: ls, fp, bp) = let val str' = stripNewline str val rect = RECT{x = x, y = y - fonta, wid = textWidth str', ht = fonta + fontd} in fillRect dr bp rect; drawString dr fp font (pt, str'); drawRt (ls, fp, bp) end fun drawCursor () = let val p = !pos val pen = if p < start orelse p >= stop then fpen else bpen val PT{x,y} = TR.posToPt text p val p1 = PT{x=x, y=y-(fonta-1)} val p2 = PT{x=x, y=y+(fontd-1)} in drawLines dr pen [p1, p2] end in fillRect dr bpen rect; drawRt (rt, fpen, bpen); if start <> stop then drawRt (TR.getRtInRange text (start,stop), bpen, fpen) else (); if (!editable) then drawCursor() else () end (* drawPos is designed to draw only the area of the text window between two positions of the text. It also supports the special positions EOL and EOF which designate the end of the current line and the end of the text respectively it has an additional argument 'fillBg' which tells it whether to fill all of the space after the terminal position with the bgColor *) fun drawPos (dr, SIZE{wid,ht}) (twv as TWV{text,active,editable,pos,selection, activeFg,activeBg,inactiveFg,inactiveBg,...}, posSet, fillBg) = let open Drawing val fg = if (!active) then (!activeFg) else (!inactiveFg) val bg = if (!active) then (!activeBg) else (!inactiveBg) val FI{font,fonta,fontd,maxc} = fontInfo (TR.getFont text) val start = Int.min (!selection) val stop = Int.max (!selection) val fpen = newPen[PV_Foreground fg] val bpen = newPen[PV_Foreground bg] val textWidth = Font.textWidth font fun drawRt (nil, _, _) = () | drawRt ((pt as PT{x,y}, str) :: ls, fp, bp) = let val str' = stripNewline str val rect = RECT{x = x, y = y - fonta, wid = textWidth str', ht = fonta + fontd} in fillRect dr bp rect; drawString dr fp font (pt, str'); drawRt (ls, fp, bp) end fun drawCursor () = let val p = !pos val pen = if p < start orelse p >= stop then fpen else bpen val PT{x,y} = TR.posToPt text p val p1 = PT{x=x, y=y-(fonta-1)} val p2 = PT{x=x, y=y+(fontd-1)} in drawLines dr pen [p1, p2] end fun fillBgPos (x, y) = case x of POS(x') => (case y of POS(y') => () | EOL => let val PT{x,y} = TR.posToPt text x' val rect = RECT{x = x, y = y - fonta, wid = wid - x, ht = fonta + fontd} in fillRect dr bpen rect end | EOF => let val PT{x,y} = TR.posToPt text x' val rect1 = RECT{x = x, y = y - fonta, wid = wid - x, ht = fonta + fontd} val rect2 = RECT{x = 0, y = y + fontd, wid = wid, ht = ht - y} in fillRect dr bpen rect1; fillRect dr bpen rect2 end) | EOL => () | EOF => () fun drawRtPosWrapper (x, y) = case x of POS(x') => (case y of POS(y') => drawRt (TR.getRtInRange text (x',y'), fpen, bpen) | EOL => drawRt (TR.getRtToEndOfLine text x', fpen, bpen) | EOF => drawRt (TR.getRtToEndOfText text x', fpen, bpen)) | EOL => () | EOF => () in if fillBg then fillBgPos posSet else (); drawRtPosWrapper posSet; if start <> stop then drawRt (TR.getRtInRange text (start,stop), bpen, fpen) else (); if (!editable) then drawCursor() else () end fun realize {env=InEnv{m,k,ci,co}, win, sz} (root, reqc, twv) = let val dr = Drawing.drawableOfWin win val inchan = channel() fun mseP (m, ch) = let fun loopUp () = case msgBodyOf (sync m) of MOUSE_FirstDown {pt,time,...} => (send (ch, MouseDown (pt, time)); loopDown ()) | _ => loopUp () and loopDown () = case msgBodyOf (sync m) of MOUSE_Motion {pt,time,...} => (send (ch, MouseDrag (pt, time)); loopDown ()) | MOUSE_LastUp {but,pt,time,...} => (send (ch, MouseUp (pt, time)); case but of MButton 2 => send (ch, Paste time) | MButton 3 => send (ch, Cut) | _ => (); loopUp ()) | _ => loopDown () in loopUp () end fun keyP (k, ch) = let val lookup = lookupString defaultTranslation fun isReturn c = (ord c = 13) fun isBackspace c = (ord c = 8) fun isDelete c = (ord c = 127) fun isCut c = (ord c = 24) (* it would be nice to support paste, but I can't get the time fun isPaste c = (ord c = 22) *) fun isLeftArrow i = (i = 65361) fun isRightArrow i = (i = 65363) fun isUpArrow i = (i = 65362) fun isDownArrow i = (i = 65364) fun isPrintable c = Char.isAlphaNum c orelse Char.isPunct c orelse c = #" " fun doChars (nil) = () | doChars (c :: cs) = (if isPrintable c then send (ch, Insert c) else if isReturn c then send (ch, Insert #"\n") else if isBackspace c then send (ch, Backspace) else if isDelete c then send (ch, Delete) else if isCut c then send (ch, Cut) else debug ("key: '" ^ Char.toString c ^ "' = " ^ Int.toString (ord c) ^ "\n"); doChars cs) fun doNonChar (NoSymbol, _) = () | doNonChar (KEYSYM(keysym), _) = (if isLeftArrow keysym then send (ch, MoveLeft) else if isRightArrow keysym then send (ch, MoveRight) else if isDownArrow keysym then send (ch, MoveDown) else if isUpArrow keysym then send (ch, MoveUp) else debug ("keysym: " ^ (Int.toString keysym) ^ "\n")) fun loop () = case msgBodyOf (sync k) of KEY_Press key => (doChars (explode (lookup key)) handle KeysymNotFound => doNonChar key; loop()) | _ => loop() in loop () end fun handleReq (GetBounds iv, twv) = (iPut (iv, gtBounds twv); REDRAW_NONE) | handleReq (GetText iv, twv) = (iPut (iv, gtText twv); REDRAW_NONE) | handleReq (SetText str, twv) = REDRAW_ALL (stText (str, twv)) | handleReq (GetActive iv, twv) = (iPut (iv, gtActive twv); REDRAW_NONE) | handleReq (SetActive b, twv) = REDRAW_ALL (stActive (b, twv)) | handleReq (GetEditable iv, twv) = (iPut (iv, gtEditable twv); REDRAW_NONE) | handleReq (SetEditable b, twv) = REDRAW_ALL (stEditable (b, twv)) | handleReq (GetRows iv, twv) = (iPut (iv, gtRows twv); REDRAW_NONE) | handleReq (SetRows n, twv) = REDRAW_ALL (stRows (n, twv)) | handleReq (GetCols iv, twv) = (iPut (iv, gtCols twv); REDRAW_NONE) | handleReq (SetCols n, twv) = REDRAW_ALL (stCols (n, twv)) | handleReq (GetPosition iv, twv) = (iPut (iv, gtPos twv); REDRAW_NONE) | handleReq (SetPosition n, twv) = REDRAW_ALL (stPos (n, twv)) | handleReq (GetFont iv, twv) = (iPut (iv, gtFont twv); REDRAW_NONE) | handleReq (SetFont f, twv) = REDRAW_ALL (stFont (f, twv)) | handleReq (GetActiveFC iv, twv) = (iPut (iv, gtActiveFC twv); REDRAW_NONE) | handleReq (SetActiveFC c, twv) = REDRAW_ALL (stActiveFC (c, twv)) | handleReq (GetActiveBC iv, twv) = (iPut (iv, gtActiveBC twv); REDRAW_NONE) | handleReq (SetActiveBC c, twv) = REDRAW_ALL (stActiveBC (c, twv)) | handleReq (GetInactiveFC iv, twv) = (iPut (iv, gtInactiveFC twv); REDRAW_NONE) | handleReq (SetInactiveFC c, twv) = REDRAW_ALL (stInactiveFC (c, twv)) | handleReq (GetInactiveBC iv, twv) = (iPut (iv, gtInactiveBC twv); REDRAW_NONE) | handleReq (SetInactiveBC c, twv) = REDRAW_ALL (stInactiveBC (c, twv)) | handleReq (_, twv) = REDRAW_NONE fun handleIn (msg, twv) = let fun insert (c, twv as TWV{text,selection,pos, active,editable,...}) = (debug "insert\n"; if !editable andalso !active then let val s = TR.getText text val p = !pos val start = Int.min (!selection) val stop = Int.max (!selection) in if start <> stop then let val s1 = String.substring(s,0,start) val s2 = String.extract(s,stop,NONE) val cstring = Char.toString c in TR.setText text (s1 ^ cstring ^ s2); selection := (0, 0); pos := start+1; REDRAW_POS (twv, (POS(start), EOF), true) end else let val es = ExtStr.mkExtStr s val es = ExtStr.es_ins (es, !pos, c) val s = ExtStr.es_gets es in TR.setText text s; pos := p + 1; selection := (0, 0); if TR.getLineWrap text then if c = #"\n" then REDRAW_POS (twv, (POS p, EOF), true) else REDRAW_POS (twv, (POS p, EOF), false) else if c = #"\n" then REDRAW_POS (twv, (POS p, EOF), true) else REDRAW_POS (twv, (POS p, EOL), false) end end else REDRAW_NONE) fun backspace (twv as TWV{text,selection,pos, active,editable,...}) = (debug "backspace\n"; if !editable andalso !active then let val s = TR.getText text val p = !pos val start = Int.min (!selection) val stop = Int.max (!selection) in if start <> stop then let val s1 = String.substring(s,0,start) val s2 = String.extract(s,stop,NONE) in TR.setText text (s1 ^ s2); selection := (0, 0); pos := start; REDRAW_POS (twv, (POS(start), EOF), true) end else if 0 < p andalso p <= String.size s then let val es = ExtStr.mkExtStr s val c = ExtStr.es_charAt (es, p) val es = ExtStr.es_del (es, p) val s = ExtStr.es_gets es in TR.setText text s; pos := p - 1; selection := (0, 0); if TR.getLineWrap text then REDRAW_POS (twv, (POS (p-1), EOF), true) else if c = #"\n" then REDRAW_POS (twv, (POS (p-1), EOF), true) else REDRAW_POS (twv, (POS (p-1), EOL), true) end else REDRAW_NONE end else REDRAW_NONE) fun delete (twv as TWV{text,selection,pos, active,editable,...}) = (debug "delete\n"; if !editable andalso !active then let val s = TR.getText text val p = !pos val start = Int.min (!selection) val stop = Int.max (!selection) in if start <> stop then let val s1 = String.substring(s,0,start) val s2 = String.extract(s,stop,NONE) in TR.setText text (s1 ^ s2); selection := (0, 0); pos := start; REDRAW_POS (twv, (POS(start), EOF), true) end else if 0 <= p andalso p < String.size s then let val es = ExtStr.mkExtStr s val c = ExtStr.es_charAt (es, p+1) val es = ExtStr.es_del (es, p + 1) val s = ExtStr.es_gets es in TR.setText text s; selection := (0, 0); if TR.getLineWrap text then REDRAW_POS (twv, (POS (p), EOF), true) else if c = #"\n" then REDRAW_POS (twv, (POS (p), EOF), true) else REDRAW_POS (twv, (POS (p), EOL), true) end else REDRAW_NONE end else REDRAW_NONE) fun moveLeft (twv as TWV{selection,pos,active,...}) = (debug "moveLeft\n"; if !pos > 0 andalso !active then (let val p = !pos val start = Int.min (!selection) val stop = Int.max (!selection) in pos := p - 1; selection := (0, 0); if start <> stop then REDRAW_ALL twv else REDRAW_POS (twv, (POS p, EOL), true) end) else REDRAW_NONE) fun moveRight (twv as TWV{text,selection, pos,active,...}) = (debug "moveRight\n"; if !pos < String.size (TR.getText text) andalso !active then (let val p = !pos val start = Int.min (!selection) val stop = Int.max (!selection) in pos := p + 1; selection := (0, 0); if start <> stop then REDRAW_ALL twv else REDRAW_POS (twv, (POS p, EOL), true) end) else REDRAW_NONE) fun moveUp (twv as TWV{text,selection,pos,active,...}) = (debug "moveUp\n"; if !pos > 0 andalso !active then (let val p = !pos val FI{font,fonta,fontd,maxc} = fontInfo (TR.getFont text) val PT{x,y} = TR.posToPt text p val p' =(let val y' = y-(fonta+fontd) in if y' < 0 then 0 else TR.ptToPos text (PT{x=x,y=y'}) end) val start = Int.min (!selection) val stop = Int.max (!selection) in pos := p'; selection := (0, 0); if start <> stop then REDRAW_ALL twv else REDRAW_POS (twv, (POS p, EOL), true) end) else REDRAW_NONE) fun moveDown (twv as TWV{text,selection, pos,active,...}) = (debug "moveDown\n"; if !pos < String.size (TR.getText text) andalso !active then (let val p = !pos val FI{font,fonta,fontd,maxc} = fontInfo (TR.getFont text) val PT{x,y} = TR.posToPt text p val pt' = PT{x=x,y=y+(fonta+fontd)} val p' = TR.ptToPos text pt' val start = Int.min (!selection) val stop = Int.max (!selection) in pos := p'; selection := (0, 0); if start <> stop then REDRAW_ALL twv else REDRAW_POS (twv, (POS p, EOL), true) end) else REDRAW_NONE) fun mouseDown ((pt as PT{x,y}, time), twv as TWV{text,selection, pos,active,...}) = (debug "mouseDown @ "; if !active then let val p = TR.ptToPos text pt val p' = !pos val _ = debug (Int.toString p ^ " : " ^ Int.toString x ^ "," ^ Int.toString y ^ "\n") val start = Int.min (!selection) val stop = Int.max (!selection) in pos := p; selection := (p, p); if start <> stop then REDRAW_ALL twv else REDRAW_POS (twv, (POS p', EOL), true) end else REDRAW_NONE) fun mouseUp ((pt as PT{x,y}, time), twv as TWV{text,selection, selectEvt,pos,active,...}) = (debug "mouseUp @ "; if !active then let val p = TR.ptToPos text pt val p' = !pos val _ = debug (Int.toString p ^ " : " ^ Int.toString x ^ "," ^ Int.toString y ^ "\n") val (start, stop) = !selection in pos := p; if start < p then let val str = TR.getText text val sel = substring (str, start, p - start) in selection := (start, p); selectEvt := SOME (Select.set (win, time, sel)) end else if start > p then let val str = TR.getText text val sel = substring (str, p, start - p) in selection := (p, start); selectEvt := SOME (Select.set (win, time, sel)) end else selection := (0, 0); if start <> stop then REDRAW_ALL twv else REDRAW_POS (twv, (POS p', EOL), true) end else REDRAW_NONE) fun mouseDrag ((pt, time), twv as TWV{text,selection,active,...}) = (debug "mouseDrag\n"; if !active then let val p = TR.ptToPos text pt val (start, stop) = !selection in if p <> stop then (selection := (start, p); REDRAW_POS(twv, (POS (Int.min(stop,p)), POS (Int.max(stop,p))), false)) else REDRAW_NONE end else REDRAW_NONE) fun cut (twv as TWV{text,selection,pos, active,editable,...}) = (debug "cut\n"; if !editable andalso !active then let val str = TR.getText text val (start, stop) = !selection in if (start < stop andalso start >= 0 andalso stop <= size str) then let val s1 = String.extract(str, 0, SOME start) val s2 = String.extract(str, stop, NONE) in TR.setText text (s1 ^ s2); pos := start; selection := (0, 0); REDRAW_POS (twv, (POS start, EOF), true) end else REDRAW_NONE end else REDRAW_NONE) fun paste (time, twv as TWV{text,selection,pos, active,editable,...}) = (debug "paste\n"; if !editable andalso !active then case Select.get (win, time) of NONE => REDRAW_NONE | SOME str => let val s = TR.getText text val s1 = String.extract (s, 0, SOME (!pos)) val s2 = String.extract (s, !pos, NONE) val s = s1 ^ str ^ s2 in TR.setText text s; let val p = !pos in pos := p + size str; selection := (0, 0); REDRAW_POS (twv, (POS p, EOF), true) end end else REDRAW_NONE) in case msg of Insert c => insert (c, twv) | Backspace => backspace twv | Delete => delete twv | MoveLeft => moveLeft twv | MoveRight => moveRight twv | MoveUp => moveUp twv | MoveDown => moveDown twv | MouseDown m => mouseDown (m, twv) | MouseUp m => mouseUp (m, twv) | MouseDrag m => mouseDrag (m, twv) | Cut => cut twv | Paste t => paste (t, twv) end fun handleCI (CI_Redraw _, me as (twv, drawf, drawPosf)) = (drawf twv; me) | handleCI (CI_Resize (RECT{wid,ht,...}), me as (twv, _, _)) = (debug "resize\n"; (twv, draw (dr, SIZE{wid=wid,ht=ht}), drawPos (dr, SIZE{wid=wid,ht=ht}))) | handleCI (_, me) = me fun releaseSelection (twv as TWV{selectEvt,selection,...}) = (debug "release\n"; selectEvt := NONE; selection := (0, 0); twv) fun loop (me as (twv as TWV{selectEvt,textEvt,...}, drawf,drawPosf)) = select [wrap (recvEvt reqc, fn req => case handleReq (req, twv) of REDRAW_NONE => loop me | REDRAW_POS (twv', posSet, fillBg) => (drawPosf (twv', posSet, fillBg); loop (twv', drawf, drawPosf)) | REDRAW_ALL twv' => (drawf twv'; loop (twv', drawf, drawPosf))), wrap (recvEvt inchan, fn msg => case handleIn (msg, twv) of REDRAW_NONE => loop me | REDRAW_POS (twv', posSet, fillBg) => (drawPosf (twv', posSet, fillBg); loop (twv', drawf, drawPosf)) | REDRAW_ALL twv' => (drawf twv'; loop (twv', drawf, drawPosf))), wrap (ci, fn msg => loop (handleCI (msgBodyOf msg, me))), case !selectEvt of NONE => never | SOME evt => wrap (evt, fn () => (drawf (releaseSelection twv); loop me)), wrap (textEvt, fn _ => (debug "resizeReq\n"; sync (co CO_ResizeReq); loop me))] in XDebug.xspawn ("mseP", fn () => mseP(m, inchan)); XDebug.xspawn ("keyP", fn () => keyP(k, inchan)); loop (twv, draw (dr, sz), drawPos (dr, sz)) end fun init (root, reqc, twv) = let fun loop twv = case recv reqc of DoRealize arg => realize arg (root, reqc, twv) | GetBounds iv => (iPut (iv, gtBounds twv); loop twv) | GetText iv => (iPut (iv, gtText twv); loop twv) | SetText str => loop (stText (str, twv)) | GetActive iv => (iPut (iv, gtActive twv); loop twv) | SetActive b => loop (stActive (b, twv)) | GetEditable iv => (iPut (iv, gtEditable twv); loop twv) | SetEditable b => loop (stEditable (b, twv)) | GetRows iv => (iPut (iv, gtRows twv); loop twv) | SetRows n => loop (stRows (n, twv)) | GetCols iv => (iPut (iv, gtCols twv); loop twv) | SetCols n => loop (stCols (n, twv)) | GetPosition iv => (iPut (iv, gtPos twv); loop twv) | SetPosition n => loop (stPos (n, twv)) | GetFont iv => (iPut (iv, gtFont twv); loop twv) | SetFont f => loop (stFont (f, twv)) | GetActiveFC iv => (iPut (iv, gtActiveFC twv); loop twv) | SetActiveFC c => loop (stActiveFC (c, twv)) | GetActiveBC iv => (iPut (iv, gtActiveBC twv); loop twv) | SetActiveBC c => loop (stActiveBC (c, twv)) | GetInactiveFC iv => (iPut (iv, gtInactiveFC twv); loop twv) | SetInactiveFC c => loop (stInactiveFC (c, twv)) | GetInactiveBC iv => (iPut (iv, gtInactiveBC twv); loop twv) | SetInactiveBC c => loop (stInactiveBC (c, twv)) in loop twv end fun textWindowView (root, view, args) = let val attrs = W.findAttr (W.attrs (view, attrs, args)) val str = A.getString (attrs attr_text) val active = A.getBool (attrs attr_active) val editable = A.getBool (attrs attr_editable) val activeFg = A.getColor (attrs attr_activeFgColor) val activeBg = A.getColor (attrs attr_activeBgColor) val inactiveFg = A.getColor (attrs attr_inactiveFgColor) val inactiveBg = A.getColor (attrs attr_inactiveBgColor) val tr = TR.textRenderer (view, args) in TWV{text = tr, textEvt = TR.evtOf tr, active = ref active, editable = ref editable, pos = ref 0, selection = ref (0, 0), selectEvt = ref NONE, activeFg = ref activeFg, activeBg = ref activeBg, inactiveFg = ref inactiveFg, inactiveBg = ref inactiveBg} end fun textWindow (args as (root,_,_)) = let val twv = textWindowView args val reqc = channel() fun getBounds() = let val iv = iVar() in send (reqc, GetBounds iv); iGet iv end in XDebug.xspawn ("textWindow", fn () => init(root, reqc, twv)); TextWindow {widget = W.mkWidget {root = root, args = fn () => {background = NONE}, boundsOf = getBounds, realize = fn arg => send (reqc, DoRealize arg)}, rqst = reqc} end fun textArea (root, view, args) = let val attr_linewrap = Q.quark "linewrap" val linewrap = A.AV_Bool true val args = (attr_linewrap, linewrap) :: args val twv = textWindowView (root, view, args) val reqc = channel() fun getBounds() = let val iv = iVar() in send (reqc, GetBounds iv); iGet iv end in XDebug.xspawn ("textWindow", fn () => init(root, reqc, twv)); TextWindow {widget = W.mkWidget {root = root, args = fn () => {background = NONE}, boundsOf = getBounds, realize = fn arg => send (reqc, DoRealize arg)}, rqst = reqc} end fun textField (root, view, args) = let val attr_linewrap = Q.quark "linewrap" val linewrap = A.AV_Bool false val args = (attr_linewrap, linewrap) :: args val twv = textWindowView (root, view, args) val reqc = channel() fun getBounds() = let val iv = iVar() in send (reqc, GetBounds iv); iGet iv end in XDebug.xspawn ("textWindow", fn () => init(root, reqc, twv)); TextWindow {widget = W.mkWidget {root = root, args = fn () => {background = NONE}, boundsOf = getBounds, realize = fn arg => send (reqc, DoRealize arg)}, rqst = reqc} end fun widgetOf (TextWindow{widget,...}) = widget fun set msg (TextWindow{rqst,...}) arg = send(rqst, msg arg) fun get msg (TextWindow{rqst,...}) = let val iv = iVar() in send(rqst, msg iv); iGet iv end val getText = get GetText val setText = set SetText val getActive = get GetActive val setActive = set SetActive val getEditable = get GetEditable val setEditable = set SetEditable val getRows = get GetRows val setRows = set SetRows val getColumns = get GetCols val setColumns = set SetCols val getCaretPosition = get GetPosition val setCaretPosition = set SetPosition val getFont = get GetFont val setFont = set SetFont val getActiveFgColor = get GetActiveFC val setActiveFgColor = set SetActiveFC val getActiveBgColor = get GetActiveBC val setActiveBgColor = set SetActiveBC val getInactiveFgColor = get GetInactiveFC val setInactiveFgColor = set SetInactiveFC val getInactiveBgColor = get GetInactiveBC val setInactiveBgColor = set SetInactiveBC end