(* Copyright (C) 1991-1992, Digital Equipment Corporation                    *)
(* All rights reserved.                                                      *)
(* See the file COPYRIGHT for a full description.                            *)
(*                                                                           *)
(* Last modified on Tue Jan  5 21:06:59 PST 1993 by meehan                   *)
(*      modified on Thu Oct  2 12:48:00 1992 by nichols@parc.xerox.com       *)
(*      modified on Tue May 19 16:21:47 1992 by mhb                          *)
(*      modified on Thu May 14 01:45:33 1992 by steveg                       *)
(*      modified on Thu Mar 14 12:16:11 PST 1991 by brooks                   *)
(*      modified on Thu Feb  7 14:03:27 PST 1991 by chan                     *)
<* PRAGMA LL *>
<* PRAGMA EXPORTED *>

MODULE TextPort;

IMPORT Axis, Char, Env, Font, KeyboardKey, KeyTrans, MacModel, MText,
       MTextUnit, PaintOp, Palette, Pts, Rd, RdUtils, Rect, Region,
       ScrollerVBT, Text, TextPortClass, Thread, VBT, VBTRep, VTDef, VText,
       WeakRef;

IMPORT EmacsModel, IvyModel, XtermModel;

IMPORT SmallIO; (* debugging *)
IMPORT VBTutils, TextWr;

CONST
  Backspace = Char.BS;
  Tab       = Char.HT;
  Return    = Char.NL;
  Del       = Char.DEL;

REVEAL
  T = TextPortClass.T BRANDED OBJECT
        <* LL = v.mu *>
        modifiedP: BOOLEAN;
        location : RECORD margin, align: ARRAY Axis.T OF REAL END;
        <* LL.sup = VBT.mu.self *>
        lastNonEmptyWidth := 0;
      OVERRIDES
        (* Exported methods *)
        init := Init;

        getFont        := GetFont;
        setFont        := SetFont;
        getColorScheme := GetColorScheme;
        setColorScheme := SetColorScheme;
        getModel       := GetModel;
        setModel       := SetModel;
        getReadOnly    := GetReadOnly;
        setReadOnly    := SetReadOnly;
        getKFocus      := GetKFocus;
        scrollUpdate   := ScrollUpdate;

        (* Callbacks *)
        returnAction  := ReturnAction;
        tabAction     := Insert4spaces;
        defaultAction := IgnoreKey;
        focus         := IgnoreFocus;
        filter        := Filter;
        modified      := IgnoreModification;
        error         := Error;

        (* VBT.T overrides *)
        key       := Key;
        misc      := Misc;
        mouse     := Mouse;
        position  := Position;
        read      := Read;
        redisplay := Redisplay;
        repaint   := Repaint;
        rescreen  := Rescreen;
        reshape   := Reshape;
        shape     := Shape;
        write     := Write;

        (* Exception handlers *)
        rdeoferror := rdeoferror;
        rdfailure  := rdfailure;
        vbterror   := vbterror;
        vterror    := vterror;

        (* Locked methods *)
        getText          := LockedGetText;
        index            := LockedIndex;
        length           := LockedLength;
        normalize        := LockedNormalize;
        replace          := LockedReplace;
        unsafeReplace    := UnsafeReplace;
        insert           := LockedInsert;
        unsafeInsert     := UnsafeInsert;
        newlineAndIndent := LockedNewlineAndIndent;

        (* Unlocked methods for callbacks *)
        ULreturnAction  := UnlockedReturnAction;
        ULtabAction     := UnlockedTabAction;
        ULdefaultAction := UnlockedDefaultAction;
        ULfocus         := UnlockedFocus;
        ULmodified      := UnlockedModified;
        ULerror         := UnlockedError;

      END;

VAR debug: BOOLEAN;

PROCEDURE Init (v             : T;
                singleLine                          := FALSE;
                hMargin                             := 1.5;
                vMargin                             := 1.5;
                font                                := Font.BuiltIn;
                colorScheme   : PaintOp.ColorScheme := NIL;
                expandOnDemand                      := FALSE;
                wrap                                := TRUE;
                readOnly                            := FALSE;
                turnMargin                          := 2.0;
                model                               := Model.Default ): T =
  CONST PRINTABLE = (Char.All - Char.Controls) + SET OF CHAR {'\t'};
  VAR
    vFont   : VText.VFont;
    vOptions: VText.VOptions;
  BEGIN
    TRY
      IF colorScheme = NIL THEN colorScheme := PaintOp.bgFg END;
      vFont := VText.MakeVFont (
                 font := font, printable := PRINTABLE, whiteTabs := TRUE);
      vOptions :=
        VText.MakeVOptions (
          vFont := vFont, leftMargin := hMargin, rightMargin := hMargin,
          turnMargin := turnMargin, topMargin := vMargin, leading := 0.0,
          whiteBlack := colorScheme, whiteStroke := colorScheme,
          leftOffset := 0.0, wrap := wrap AND NOT singleLine, eob := FALSE,
          intervalStylePrecedence := NIL);
      v.font := font;
      v.mu := NEW (MUTEX);
      v.vtext := VText.New (MText.New ("", 256), v, VBT.Domain (v), vOptions);
      v.singleLine := singleLine;
      v.readOnly := readOnly;
      v.modifiedP := FALSE;
      v.visible := TRUE;
      v.location.margin [Axis.T.Hor] := hMargin;
      v.location.margin [Axis.T.Ver] := vMargin;
      v.location.align [Axis.T.Hor] := 0.0;
      v.location.align [Axis.T.Ver] := 0.0;
      v.typeinStart := 0;
      v.expandOnDemand := expandOnDemand AND NOT singleLine;
      v.cur := NEW (TextPortClass.UndoRec);
      LockedSetModel (v, model);
      Register (v);
      RETURN v
    EXCEPT
    | VTDef.Error (ec) => v.vterror ("Init", ec)
    | Rd.EndOfFile => v.rdeoferror ("Init")
    | Rd.Failure (ref) => v.rdfailure ("Init", ref)
    | Thread.Alerted =>
    END;
    RETURN NIL
  END Init;

(***************************  Client Interface  ***************************)

<* EXPORTED *>
PROCEDURE SetScrollBar (v: T; scrollBar: Scroller)  =
  BEGIN
    v.scrollBar := scrollBar;
    scrollBar.textport := v
  END SetScrollBar;

PROCEDURE GetReadOnly (v: T): BOOLEAN =
  BEGIN
    LOCK v.mu DO RETURN v.readOnly END
  END GetReadOnly;

PROCEDURE SetReadOnly (v: T; flag: BOOLEAN) =
  BEGIN
    LOCK v.mu DO v.readOnly := flag END
  END SetReadOnly;

<* EXPORTED *>
PROCEDURE SetWrap (v: T; wrap: BOOLEAN) =
  BEGIN
    LOCK v.mu DO
      IF v.vtext.vOptions.wrap # wrap THEN
        v.vtext.vOptions.wrap := wrap;
        TRY
          VText.ChangeVOptions (v.vtext, v.vtext.vOptions);
          VBT.Mark (v)
        EXCEPT
        | VTDef.Error (ec) => v.vterror ("SetWrap", ec)
        | Rd.EndOfFile => v.rdeoferror ("SetWrap")
        | Rd.Failure (ref) => v.rdfailure ("SetWrap", ref)
        | Thread.Alerted =>
        END
      END
    END
  END SetWrap;

<* EXPORTED *>
PROCEDURE Length (v: T): CARDINAL =
  BEGIN
    LOCK v.mu DO RETURN v.length () END
  END Length;

PROCEDURE LockedLength (v: T): CARDINAL =
  BEGIN
    RETURN MText.Length (v.vtext.mtext)
  END LockedLength;

<* EXPORTED *>
PROCEDURE GetText (v    : T;
                   begin: CARDINAL := 0;
                   end  : CARDINAL := LAST (CARDINAL)): TEXT =
  <* LL = VBT.mu *>
  BEGIN
    LOCK v.mu DO RETURN v.getText (begin, end) END
  END GetText;

PROCEDURE LockedGetText (v: T; begin, end: CARDINAL): TEXT =
  <* LL = v.mu *>
  BEGIN
    RETURN MText.GetText (v.vtext.mtext, begin, end)
  END LockedGetText;

<* EXPORTED *>
PROCEDURE SetText (v: T; t: TEXT) =
  <* LL <= VBT.mu *>
  BEGIN
    LOCK v.mu DO
      EVAL v.unsafeReplace (0, LAST (CARDINAL), t);
      TRY
        VText.SetStart (v.vtext, 0, 0);
        MarkAndUpdate (v)
      EXCEPT
      | VTDef.Error (ec) => v.vterror ("SetText", ec)
      | Rd.EndOfFile => v.rdeoferror ("SetText")
      | Rd.Failure (ref) => v.rdfailure ("SetText", ref)
      | Thread.Alerted =>
      END;
    END
  END SetText;

<* EXPORTED *>
PROCEDURE PutText (v: T; t: TEXT) =
  <* LL <= VBT.mu *>
  BEGIN
    LOCK v.mu DO
      EVAL v.unsafeReplace (LAST (CARDINAL), LAST (CARDINAL), t);
      MarkAndUpdate (v)
    END
  END PutText;

PROCEDURE GetFont (v: T): Font.T =
  BEGIN
    LOCK v.mu DO RETURN v.font END
  END GetFont;

PROCEDURE SetFont (v: T; font: Font.T) =
  (* By the book, we should call ExplodeVText, ExplodeVOptions, ExplodeVFont,
     MakeVFont, and MakeVOptions before calling ChangeVOptions, but we cheat
     by looking at the implementation and consing only a new VFont. *)
  VAR
    vtext   : VText.T;
    vOptions: VText.VOptions;
    vFont   : VText.VFont;
  BEGIN
    LOCK v.mu DO
      IF font = v.font THEN RETURN END;
      vtext := v.vtext;
      vOptions := vtext.vOptions;
      vFont := vOptions.vFontxxx;
      TRY
        vOptions.vFontxxx :=
          VText.MakeVFont (font := font, printable := vFont.vFont.printable,
                           whiteTabs := vFont.vFont.whiteTabs);
        v.font := font;          (* For convenience only *)
        VText.ChangeVOptions (vtext, vOptions);
        SetFontDimensions (v);
        VBT.NewShape (v);
        MarkAndUpdate (v)
      EXCEPT
      | VTDef.Error (ec) => v.vterror ("SetFont", ec)
      | Rd.EndOfFile => v.rdeoferror ("SetFont")
      | Rd.Failure (ref) => v.rdfailure ("SetFont", ref)
      | Thread.Alerted =>
      END;
    END
  END SetFont;
      
PROCEDURE GetColorScheme (v: T): PaintOp.ColorScheme  =
  BEGIN
    LOCK v.mu DO
      RETURN v.vtext.vOptions.whiteBlack (* one of several choices *)
    END
  END GetColorScheme;

PROCEDURE SetColorScheme (v: T; colorScheme: PaintOp.ColorScheme) =
  CONST name = "SetColorScheme";
  VAR vOptions: VText.VOptions;
  PROCEDURE changeIntervalOptions (i: VText.Interval) RAISES {VTDef.Error} =
    VAR options := i.getOptions ();
    BEGIN
      options.whiteBlack := colorScheme;
      options.whiteStroke := colorScheme;
      options.leading := colorScheme.bg;
      VText.ChangeIntervalOptions (i, options)
    END changeIntervalOptions;
  BEGIN
    LOCK v.mu DO
      TRY
        vOptions := v.vtext.vOptions;
        IF vOptions.whiteBlack = colorScheme THEN RETURN END;
        vOptions.whiteBlack := colorScheme;
        vOptions.whiteStroke := colorScheme;
        VText.ChangeVOptions (v.vtext, vOptions);
        v.m.walkIntervals (changeIntervalOptions);
        VBT.Mark (v)
      EXCEPT
      | VTDef.Error (ec) => v.vterror (name, ec)
      | Rd.EndOfFile => v.rdeoferror (name)
      | Rd.Failure (ref) => v.rdfailure (name, ref)
      | Thread.Alerted =>
      END
    END
  END SetColorScheme;

PROCEDURE GetModel (v: T): [Model.Ivy .. Model.Xterm] =
  BEGIN
    LOCK v.mu DO
      TYPECASE v.m OF
      | IvyModel.T => RETURN Model.Ivy
      | EmacsModel.T => RETURN Model.Emacs
      | XtermModel.T => RETURN Model.Xterm
      | MacModel.T => RETURN Model.Mac
      ELSE                       <* ASSERT FALSE *>
      END
    END
  END GetModel;

PROCEDURE SetModel (v: T; model: Model) =
  BEGIN
    LOCK v.mu DO LockedSetModel (v, model) END
  END SetModel; 

PROCEDURE LockedSetModel (v: T; model: Model) =
  VAR cs := v.vtext.vOptions.whiteBlack;
  BEGIN
    IF v.m # NIL THEN v.m.close () END;
    IF model = Model.Default THEN model := DefaultModel END;
    CASE model OF
    | Model.Ivy => v.m := NEW (IvyModel.T, v := v).init (cs)
    | Model.Xterm => v.m := NEW (XtermModel.T, v := v).init (cs)
    | Model.Emacs => v.m := NEW (EmacsModel.T, v := v).init (cs)
    | Model.Mac => v.m := NEW (MacModel.T, v := v).init (cs)
    ELSE                         <* ASSERT FALSE *>
    END
  END LockedSetModel;

PROCEDURE GetKFocus (v: T; t: VBT.TimeStamp): BOOLEAN =
  <* LL = v.mu *>
  CONST name = "GetKFocus";
  BEGIN
    IF NOT v.hasFocus THEN
      v.ULfocus (TRUE, t);
      TRY
        VBT.Acquire (v, VBT.KBFocus, t);
        VText.SwitchCaret (v.vtext, VText.OnOffState.On);
        v.hasFocus := TRUE
      EXCEPT
      | VBT.Error (ec) => v.vbterror (name, ec)
      | VTDef.Error (ec) => v.vterror (name, ec)
      | Rd.EndOfFile => v.rdeoferror (name)
      | Rd.Failure (ref) => v.rdfailure (name, ref)
      | Thread.Alerted =>
      END
    END;
    RETURN v.hasFocus
  END GetKFocus;

TYPE
  WeakRefList = REF RECORD
                      first: WeakRef.T;
                      tail : WeakRefList := NIL
                    END;

VAR mu := NEW (MUTEX);
    ports: WeakRefList := NIL; <* LL = mu *>

PROCEDURE ChangeAllTextPorts (newModel := Model.Default) =
  VAR
    a   : WeakRefList;
    port: T;
  BEGIN
    LOCK mu DO
      a := ports;
      WHILE a # NIL DO
        port := WeakRef.ToRef (a.first);
        IF port # NIL THEN port.setModel (newModel); VBT.Mark (port) END;
        a := a.tail
      END
    END
  END ChangeAllTextPorts;

PROCEDURE Register (v: T) =
  BEGIN
    LOCK mu DO
      ports := NEW (WeakRefList, first := WeakRef.FromRef (v, Cleanup),
                    tail := ports)
    END
  END Register;

PROCEDURE Cleanup (READONLY w: WeakRef.T; <* UNUSED *> r: REFANY) =
  (* Delete "w" from "ports". *)
  BEGIN
    LOCK mu DO
      IF ports = NIL THEN        (* skip *)
      ELSIF ports.first = w THEN
        ports := ports.tail
      ELSE
        VAR
          a              := ports;
          b: WeakRefList;
        BEGIN
          LOOP
            b := a.tail;
            IF b = NIL THEN RETURN END;
            IF b.first = w THEN a.tail := b.tail; RETURN END;
            a := b
          END
        END
      END
    END
  END Cleanup;





PROCEDURE SetFontDimensions (v: T) =
  <* LL = v.mu *>
  BEGIN
    (* metrics := FontClass.FontMetrics(vbt, v.font); *)
    WITH st = VBT.ScreenTypeOf (v) DO
      IF st # NIL THEN
        WITH bounds = Palette.ResolveFont (
                        st, v.font).metrics.maxBounds,
             box = bounds.boundingBox DO
          v.fontHeight := Rect.VerSize (box);
          v.charWidth := bounds.printWidth
          (* not "Rect.HorSize (box)", alas *)
        END
      END
    END
  END SetFontDimensions;

PROCEDURE Width (v: T): CARDINAL =
  BEGIN
    WITH n = v.shape (Axis.T.Hor, 0).pref DO
      LOCK v.mu DO
        IF v.charWidth = 0 THEN
          RETURN 0
        ELSE
          RETURN n DIV v.charWidth
        END
      END
    END
  END Width;
      
<* EXPORTED *>
PROCEDURE Height (v: T): CARDINAL =
  BEGIN
    RETURN v.shape (Axis.T.Ver, 0).pref
  END Height;

(**************** Focus, selections, etc. *****************)

<* EXPORTED *>
PROCEDURE TryFocus (v: T; t: VBT.TimeStamp): BOOLEAN =
  <* LL < v.mu, LL.sup = VBT.mu *>
  BEGIN
    (* Force all pending redisplays: *)
    VBTRep.Redisplay ();
    IF Rect.IsEmpty (VBT.Domain (v)) THEN
      RETURN FALSE
    ELSE
      LOCK v.mu DO
        IF NOT v.getKFocus (t) THEN
          RETURN FALSE
        ELSIF NOT v.m.takeSelection (SelectionType.Primary, t) THEN
          VBT.Release (v, VBT.KBFocus);
          v.hasFocus := FALSE;
          RETURN FALSE
        ELSE
          VBT.Mark (v);
          RETURN TRUE
        END
      END
    END
  END TryFocus;

<* EXPORTED *>
PROCEDURE HasFocus (v: T): BOOLEAN =
  BEGIN
    LOCK v.mu DO RETURN v.hasFocus END
  END HasFocus;

<* EXPORTED *>
PROCEDURE Select (v          : T;
                  time       : VBT.TimeStamp;
                  begin, end : CARDINAL;
                  sel                          := SelectionType.Primary;
                  replaceMode                  := FALSE;
                  caretEnd                     := VText.WhichEnd.Right   ) =
  BEGIN
    LOCK v.mu DO v.m.select (time, begin, end, sel, replaceMode, caretEnd) END
  END Select;

<* EXPORTED *>
PROCEDURE HasSelection (v: T; sel := SelectionType.Primary): BOOLEAN =
  <* LL.sup = VBT.mu *>
  BEGIN
    LOCK v.mu DO RETURN v.m.hasVBTselection (sel) END
  END HasSelection;

<* EXPORTED *>
PROCEDURE IsReplaceMode (v: T): BOOLEAN =
  BEGIN
    LOCK v.mu DO RETURN v.m.isReplaceMode () END
  END IsReplaceMode;

<* EXPORTED *>
PROCEDURE GetSelection (v: T; sel := SelectionType.Primary): Extent =
  BEGIN
    LOCK v.mu DO RETURN v.m.getSelection (sel) END
  END GetSelection;

<* EXPORTED *>
PROCEDURE GetSelectedText (v: T; sel := SelectionType.Primary): TEXT =
  <* LL.sup = VBT.mu *>
  BEGIN
    LOCK v.mu DO RETURN v.m.getSelectedText (sel) END
  END GetSelectedText;

<* EXPORTED *>
PROCEDURE PutSelectedText (v: T; t: TEXT; sel := SelectionType.Primary) =
  <* LL.sup = VBT.mu *>
  BEGIN
    LOCK v.mu DO v.m.putSelectedText (t, sel) END
  END PutSelectedText;

<* EXPORTED *>
PROCEDURE Index (v: T): CARDINAL =
  BEGIN
    LOCK v.mu DO RETURN v.index () END
  END Index;

<* EXPORTED *>
PROCEDURE Seek (v: T; n: CARDINAL) =
  BEGIN
    LOCK v.mu DO v.m.seek (n) END
  END Seek;

PROCEDURE LockedIndex (v: T): CARDINAL =
  BEGIN
    TRY
      RETURN VText.CaretIndex (v.vtext)
    EXCEPT
    | VTDef.Error (ec) => v.vterror ("Index", ec); RETURN 0
    END
  END LockedIndex;

<* EXPORTED *>
PROCEDURE IsVisible (v: T; pos: CARDINAL): BOOLEAN =
  CONST name = "IsVisible";
  BEGIN
    TRY
      RETURN VText.InRegion (v.vtext, 0, pos)
    EXCEPT
    | VTDef.Error (ec) => v.vterror (name, ec)
    | Rd.EndOfFile => v.rdeoferror (name)
    | Rd.Failure (ref) => v.rdfailure (name, ref)
    | Thread.Alerted =>
    END;
    RETURN FALSE
  END IsVisible;

<* EXPORTED *>
PROCEDURE IsModified (v: T): BOOLEAN =
  BEGIN
    RETURN v.modifiedP
  END IsModified;

<* EXPORTED *>
PROCEDURE SetModified (v: T; modified: BOOLEAN) =
  BEGIN
    v.modifiedP := modified
  END SetModified;

<* EXPORTED *>
PROCEDURE GetVText (v: T): VText.T =
  BEGIN
    LOCK v.mu DO RETURN v.vtext END
  END GetVText;

(***************************  Replace & Insert  ****************************)

<* EXPORTED *>
PROCEDURE Replace (v: T; begin, end: CARDINAL; newText: TEXT) =
  BEGIN
    LOCK v.mu DO EVAL v.unsafeReplace (begin, end, newText) END
  END Replace;

PROCEDURE LockedReplace (v: T; begin, end: CARDINAL; newText: TEXT): Extent =
  <* LL = v.mu *>
  BEGIN
    IF v.readOnly OR end < v.typeinStart THEN
      RETURN NotFound
    ELSE
      RETURN v.unsafeReplace (MAX (begin, v.typeinStart), end, newText)
    END
  END LockedReplace;

PROCEDURE UnsafeReplace (v: T; begin, end: CARDINAL; newText: TEXT): Extent =
  <* LL = v.mu *>
  CONST name = "Replace";
  VAR len := v.length ();
  BEGIN
    begin := MIN (MAX (begin, v.typeinStart), len);
    end := MIN (MAX (begin, end), len);
    IF begin <= end THEN
      TextPortClass.AddToUndo (v, begin, end, newText);
      TRY
        VText.Replace (v.vtext, begin, end, newText);
        IF NOT v.modifiedP THEN v.modifiedP := TRUE; v.ULmodified () END;
        MarkAndUpdate (v);
        RETURN Extent {begin, begin + Text.Length (newText)}
      EXCEPT
      | VTDef.Error (ec) => v.vterror (name, ec)
      | Rd.EndOfFile => v.rdeoferror (name)
      | Rd.Failure (ref) => v.rdfailure (name, ref)
      | Thread.Alerted =>
      END
    END;
    RETURN NotFound
  END UnsafeReplace;

<* EXPORTED *>
PROCEDURE Insert (v: T; t: TEXT) =
  BEGIN
    IF NOT Text.Empty (t) THEN LOCK v.mu DO v.unsafeInsert (t) END END
  END Insert;

PROCEDURE LockedInsert (v: T; t: TEXT) =
  BEGIN
    IF NOT v.readOnly THEN v.unsafeInsert (t) END
  END LockedInsert;

PROCEDURE UnsafeInsert (v: T; t: TEXT) =
  VAR m := v.m;
  BEGIN
    IF m.isReplaceMode () THEN
      WITH ext = m.getSelection (SelectionType.Primary) DO
        EVAL v.unsafeReplace (ext.l, ext.r, t)
      END
    ELSE
      VAR p := v.index ();
      BEGIN
        IF p < v.typeinStart THEN p := v.length (); m.seek (p) END;
        EVAL v.unsafeReplace (p, p, t)
      END
    END
  END UnsafeInsert;
  
(************************  Shape of current text  *************************)

PROCEDURE Shape (v: T; ax: Axis.T; n: CARDINAL): VBT.SizeRange =
  <* LL = VBT.mu.v *>
  CONST name = "Shape";
  VAR
    extraHeight, lines: CARDINAL;
    pref              : INTEGER;
  BEGIN
    IF VBT.ScreenTypeOf (v) = NIL THEN RETURN VBT.DefaultShape END;
    IF v.fontHeight = 0 THEN     (* ScreenType just became non-NIL. *)
      LOCK v.mu DO
        SetFontDimensions (v)    (* Sets v.fontHeight and v.charWidth *)
      END
    END;
    IF ax = Axis.T.Hor THEN
      pref := v.lastNonEmptyWidth;
      IF pref = 0 THEN LOCK v.mu DO pref := 30 * v.charWidth END END;
      RETURN VBT.SizeRange {0, pref, 99999}
    END;
    (* ax = Axis.T.Ver *)
    IF n = 0 THEN n := v.shape (Axis.T.Hor, 0).pref END;
    LOCK v.mu DO
      extraHeight := 2 * Pts.ToScreenPixels (
                       v, v.location.margin [Axis.T.Ver], Axis.T.Ver);
      IF v.singleLine THEN
        pref := v.fontHeight + extraHeight
      ELSE
        (* How many lines would it take to display the whole vtext?  Make sure
           there is room for at least one line (vertically) or vtext gets very
           confused.  width (res.pref) = 0 => vtext has not been reshaped
           yet *)
        IF n = 0 THEN
          lines := 1
        ELSE
          TRY
            lines := 1 + VText.LinesBetween (
                           v.vtext, 0, LAST (CARDINAL), LAST (CARDINAL),
                           (* fudge n appropriately *)
                           n - (v.vtext.leftMargin + v.vtext.rightMargin
                                  + 2 * v.vtext.turnMargin))
          EXCEPT
          | VTDef.Error (ec) => v.vterror (name, ec); lines := 1
          | Rd.EndOfFile => v.rdeoferror (name); lines := 1
          | Rd.Failure (ref) => v.rdfailure (name, ref); lines := 1
          | Thread.Alerted => lines := 1
          END
        END;
        (* How many pixels is that? *)
        pref := lines * v.vtext.lineSpacing + v.vtext.topMargin + extraHeight
      END
    END;
    (* v.vtext.lineSpacing is not guaranteed to be reasonable, so we need some
       defensive code. *)
    IF pref > VBT.DefaultShape.hi THEN
      RETURN VBT.DefaultShape
    ELSE
      RETURN VBT.SizeRange {pref, pref, pref + 1}
    END
  END Shape;

PROCEDURE Reshape (v: T; READONLY cd: VBT.ReshapeRec) =
  CONST name = "Reshape";
  VAR
    newRect                                 := cd.new;
    dividers: ARRAY [0 .. 0] OF VText.Coord;
  BEGIN
    IF newRect = cd.prev AND NOT cd.marked OR Rect.IsEmpty (newRect) THEN
      RETURN
    END;
    IF Rect.HorSize (newRect) # v.lastNonEmptyWidth THEN
      v.lastNonEmptyWidth := Rect.HorSize (newRect);
      VBT.NewShape (v)
    END;
    LOCK v.mu DO
      IF NOT v.vtext.vOptions.wrap THEN
        newRect.east := LAST (INTEGER) DIV 2
      END;
      TRY
        VText.Move (v.vtext, newRect, cd.saved, dividers);
        VText.Update (v.vtext);
        v.linesShown := 1 + VText.WhichLine (v.vtext, 0, cd.new.south);
        (* if it will all fit, normalize to fit *)
        IF Rect.IsEmpty (cd.prev) AND NOT Rect.IsEmpty (cd.new)
             AND VText.LinesBetween (v.vtext, 0, v.length (), v.linesShown)
                   < v.linesShown THEN
          v.normalize (0)        (* Normalize calls MarkAndUpdate *)
        ELSE
          MarkAndUpdate (v)
        END
      EXCEPT
      | VBT.Error (ec) => v.vbterror (name, ec)
      | VTDef.Error (ec) => v.vterror (name, ec)
      | Rd.EndOfFile => v.rdeoferror (name)
      | Rd.Failure (ref) => v.rdfailure (name, ref)
      | Thread.Alerted =>
      END
    END
  END Reshape;

PROCEDURE ShapeInfo (v: T; VAR lineCount, lineLength: INTEGER) =
  BEGIN
    LOCK v.mu DO
      VAR
        e      := MTextUnit.Extent {0, 0, TRUE};
        length := v.length ();
      BEGIN
        lineCount := 0;
        lineLength := 0;
        IF length = 0 THEN RETURN END;
        WHILE e.right < length DO
          e := MTextUnit.LineExtent (v.vtext.mtext, e.right);
          INC (lineCount);
          lineLength := MAX (lineLength, e.right - e.left - 1)
        END;
        (* adjust for last line: if ends with \n, increment lineCount;
           otherwise, len of last line is right-left, not right-left-1. *)
        IF MText.GetChar (v.vtext.mtext, length - 1) = '\n' THEN
          INC (lineCount);
          lineLength := MAX (lineLength, e.right - e.left - 1)
        ELSE
          lineLength := MAX (lineLength, e.right - e.left)
        END                      (* IF *)
      END                        (* BEGIN *)
    END                          (* LOCK *)
  END ShapeInfo;

PROCEDURE Key (v: T; READONLY cd: VBT.KeyRec) =
  BEGIN
    (* "cd" must be a VALUE parameter in KeyCode1 so that a filter proc can
       change it. *)
    IF NOT v.expandOnDemand THEN
      KeyCode1 (v, cd)
    ELSE
      WITH oldVsizeRange = Shape (v, Axis.T.Ver, 0) DO
        KeyCode1 (v, cd);
        IF Shape (v, Axis.T.Ver, 0) # oldVsizeRange THEN
          (* Scroll back to the top, so we can see the whole text. *)
          Normalize (v, 0);
          VBT.NewShape (v)
        END                     (* IF *)
      END                       (* WITH *)
    END                         (* IF *)
  END Key;
  
PROCEDURE KeyCode1 (v: T; VALUE cd: VBT.KeyRec) =
  VAR
    ch: CHAR;
    m        := v.m;
  BEGIN
    LOCK v.mu DO
      IF NOT cd.wentDown OR NOT v.hasFocus OR Rect.IsEmpty (VBT.Domain (v)) THEN
        RETURN
      END
    END;

    v.filter (cd);
    IF cd.whatChanged = VBT.NoKey THEN RETURN END;

    LOCK v.mu DO
      m.filter (cd);
      IF cd.whatChanged = VBT.NoKey THEN RETURN END;
      v.lastCmdKind := v.thisCmdKind;
      v.thisCmdKind := TextPortClass.CommandKind.OtherCommand;
      ch := KeyTrans.Latin1 (cd.whatChanged);

      IF ch = Return THEN
        IF VBT.Modifier.Shift IN cd.modifiers THEN
          v.insert ("\n")
        ELSIF VBT.Modifier.Option IN cd.modifiers THEN
          TextPortClass.InsertNewline (v)
        ELSE
          v.ULreturnAction (cd)
        END
      ELSIF ch = Tab THEN
        v.ULtabAction (cd)
      ELSIF VBT.Modifier.Control IN cd.modifiers THEN
        m.controlChord (ch, cd);
        RETURN
      ELSIF VBT.Modifier.Option IN cd.modifiers THEN
        m.optionChord (ch, cd);
        RETURN
      ELSIF KeyboardKey.Left <= cd.whatChanged
              AND cd.whatChanged <= KeyboardKey.Down THEN
        m.arrowKey (cd.whatChanged, cd)
      ELSIF ch = Backspace OR ch = Del THEN
        IF m.isReplaceMode () THEN
          m.putSelectedText ("")
        ELSE
          EVAL TextPortClass.DeletePrevChar (v)
        END
      ELSIF ch IN Char.Graphics THEN (* real typing *)
        v.insert (Text.FromChar (ch))
      ELSE
        (* including NullKey, for untranslatable keys *)
        v.ULdefaultAction (cd);
        RETURN
      END;
      v.normalize ()
    END
  END KeyCode1;

<* EXPORTED *>
PROCEDURE Newline (v: T) =
  BEGIN
    LOCK v.mu DO IF NOT v.readOnly THEN v.insert ("\n") END END
  END Newline;

<* EXPORTED *>
PROCEDURE NewlineAndIndent (v: T) =
  BEGIN
    LOCK v.mu DO v.newlineAndIndent () END
  END NewlineAndIndent;

PROCEDURE LockedNewlineAndIndent (v: T) =
  BEGIN
    IF v.readOnly THEN RETURN END;
    VAR
      index := v.index ();
      a     := MTextUnit.LineInfo (v.vtext.mtext, index);
    BEGIN
      IF a.leftMargin = a.rightEnd AND index = a.rightEnd
           AND NOT v.m.isReplaceMode () THEN
        (* We're at the end of an all-blank line. *)
        EVAL v.replace (a.left, a.left, "\n")
      ELSIF a.leftMargin = a.rightMargin THEN (* line is all blanks *)
        v.insert ("\n")
      ELSE
        (* Copy all the leading blanks onto the new line. *)
        v.insert (
          "\n" & MText.GetText (v.vtext.mtext, a.left, a.leftMargin))
      END
    END
  END LockedNewlineAndIndent;

PROCEDURE Repaint (v: T; READONLY rgn: Region.T) =
  CONST name = "Repaint";
  BEGIN
    TRY
      LOCK v.mu DO
        VText.Bad (v.vtext, Region.BoundingBox (rgn));
        VText.Update (v.vtext)
      END
    EXCEPT
    | VBT.Error (ec) => v.vbterror (name, ec)
    | VTDef.Error (ec) => v.vterror (name, ec)
    | Rd.EndOfFile => v.rdeoferror (name)
    | Rd.Failure (ref) => v.rdfailure (name, ref)
    | Thread.Alerted =>
    END
  END Repaint;

PROCEDURE Rescreen (v: T; READONLY cd: VBT.RescreenRec) =
  BEGIN
    LOCK v.mu DO
      VText.Rescreen (v.vtext, cd);
      SetFontDimensions (v);
      VBT.NewShape (v)
    END
  END Rescreen;

PROCEDURE Redisplay (v: T) =
  CONST name = "Redisplay";
  BEGIN
    TRY
      LOCK v.mu DO VText.Update (v.vtext) END
    EXCEPT
    | VBT.Error (ec) => v.vbterror (name, ec)
    | VTDef.Error (ec) => v.vterror (name, ec)
    | Rd.EndOfFile => v.rdeoferror (name)
    | Rd.Failure (ref) => v.rdfailure (name, ref)
    | Thread.Alerted =>
    END
  END Redisplay;

<* EXPORTED *>
PROCEDURE MarkAndUpdate (v: T)  =
  BEGIN
    VBT.Mark (v);
    v.scrollUpdate ()
  END MarkAndUpdate;

(******************************  Scrolling  ******************************)

REVEAL
  Scroller = ScrollerVBT.T BRANDED OBJECT
               textport: T
             OVERRIDES
               scroll     := Scroll;
               autoScroll := AutoScroll;
               thumb      := Thumb
             END;

PROCEDURE ScrollUpdate (v: T) =
  <* LL = v.mu *>
  CONST name = "ScrollUpdate";
  BEGIN
    TRY
      IF v.scrollBar = NIL THEN RETURN END;
      WITH start = VText.StartIndex (v.vtext, 0) DO
        ScrollerVBT.Update (
          v.scrollBar, start, start + VText.CharsInRegion (v.vtext, 0),
          v.length ())
      END
    EXCEPT
    | VBT.Error (ec) => v.vbterror (name, ec)
    | VTDef.Error (ec) => v.vterror (name, ec)
    | Rd.EndOfFile => v.rdeoferror (name)
    | Rd.Failure (ref) => v.rdfailure (name, ref)
    | Thread.Alerted =>
    END
  END ScrollUpdate;

CONST NearEdge = 13;
(* Thumbing closer than this to top/bottom of scroll bar is treated as
       being exactly at the top/bottom. *)

PROCEDURE Scroll (                      s         : Scroller;
                  <* UNUSED *> READONLY cd        : VBT.MouseRec;
                                        part      : INTEGER;
                  <* UNUSED *>          height    : INTEGER;
                                        towardsEOF: BOOLEAN       ) =
  CONST name = "Scroll";
  VAR distance: INTEGER;
  BEGIN
    WITH v     = s.textport,
         vtext = v.vtext     DO
      TRY
        distance := MAX (1, VText.WhichLine (vtext, 0, part));
        IF NOT towardsEOF THEN distance := -distance END;
        VText.Scroll (vtext, 0, distance);
        VText.Update (vtext);
        v.scrollUpdate ()
      EXCEPT
      | VBT.Error (ec) => v.vbterror (name, ec)
      | VTDef.Error (ec) => v.vterror (name, ec)
      | Rd.EndOfFile => v.rdeoferror (name)
      | Rd.Failure (ref) => v.rdfailure (name, ref)
      | Thread.Alerted =>
      END
    END
  END Scroll;

PROCEDURE AutoScroll (                      s            : Scroller;
                      <* UNUSED *> READONLY cd           : VBT.MouseRec;
                                            linesToScroll: CARDINAL;
                                            towardsEOF   : BOOLEAN       ) =
  CONST name = "AutoScroll";
  VAR distance: INTEGER := linesToScroll;
  BEGIN
    IF NOT towardsEOF THEN distance := -distance END;
    WITH v     = s.textport,
         vtext = v.vtext     DO
      TRY
        VText.Scroll (vtext, 0, distance);
        VText.Update (vtext);
        v.scrollUpdate ()
      EXCEPT
      | VBT.Error (ec) => v.vbterror (name, ec)
      | VTDef.Error (ec) => v.vterror (name, ec)
      | Rd.EndOfFile => v.rdeoferror (name)
      | Rd.Failure (ref) => v.rdfailure (name, ref)
      | Thread.Alerted =>
      END
    END
  END AutoScroll;

PROCEDURE Thumb (                      s     : Scroller;
                 <* UNUSED *> READONLY cd    : VBT.MouseRec;
                                       part  : INTEGER;
                                       height: INTEGER       ) =
  CONST name = "Thumb";
  VAR position: INTEGER;
  BEGIN
    WITH v      = s.textport,
         vtext  = v.vtext,
         length = MText.Length (vtext.mtext) DO
      TRY
        IF length = 0 OR part < NearEdge THEN
          position := 0
        ELSIF part + NearEdge > height THEN
          position := length - 1
        ELSE
          position := (part * length) DIV height
        END;
        VText.SetStart (vtext, 0, position);
        VText.Update (vtext);
        v.scrollUpdate ()
      EXCEPT
      | VBT.Error (ec) => v.vbterror (name, ec)
      | VTDef.Error (ec) => v.vterror (name, ec)
      | Rd.EndOfFile => v.rdeoferror (name)
      | Rd.Failure (ref) => v.rdfailure (name, ref)
      | Thread.Alerted =>
      END
    END
  END Thumb;

(****************************  callback methods  ****************************)

PROCEDURE ReturnAction (v: T; READONLY event: VBT.KeyRec) =
  BEGIN
    IF v.singleLine THEN
      v.defaultAction (event)
    ELSE
      NewlineAndIndent (v)
    END
  END ReturnAction;

PROCEDURE UnlockedReturnAction (v: T; READONLY event: VBT.KeyRec) =
  BEGIN
    Thread.Release (v.mu);
    TRY v.returnAction (event) FINALLY Thread.Acquire (v.mu) END
  END UnlockedReturnAction; 
  
PROCEDURE Insert4spaces (v: T; <* UNUSED *> READONLY event: VBT.KeyRec) =
  BEGIN
    LOCK v.mu DO v.insert ("    ") END
  END Insert4spaces;

PROCEDURE UnlockedTabAction (v: T; READONLY event: VBT.KeyRec) =
  BEGIN
    Thread.Release (v.mu);
    TRY v.tabAction (event) FINALLY Thread.Acquire (v.mu) END
  END UnlockedTabAction; 
  
PROCEDURE UnlockedDefaultAction (v: T; READONLY event: VBT.KeyRec) =
  BEGIN
    Thread.Release (v.mu);
    TRY v.defaultAction (event) FINALLY Thread.Acquire (v.mu) END
  END UnlockedDefaultAction;
  
PROCEDURE IgnoreKey (<* UNUSED *> v: T;
                     <* UNUSED *> READONLY event: VBT.KeyRec) =
  BEGIN
  END IgnoreKey;

(*************************  Miscellany  ************************)

<* EXPORTED *>
PROCEDURE Normalize (v: T; to: INTEGER := -1) =
  BEGIN
    LOCK v.mu DO v.normalize (to) END
  END Normalize;

PROCEDURE LockedNormalize (v: T; to: INTEGER) =
  <* LL = v.mu *>
  CONST name = "Normalize";
  VAR point: CARDINAL;
  BEGIN
    TRY
      IF to < 0 THEN
        point := v.index ()
      ELSE
        point := MIN (to, v.length ())
      END;
      IF NOT VText.InRegion (v.vtext, 0, point) THEN
        VText.SetStart (v.vtext, 0, point, v.linesShown DIV 2)
      END;
      MarkAndUpdate (v)
    EXCEPT
    | VBT.Error (ec) => v.vbterror (name, ec)
    | VTDef.Error (ec) => v.vterror (name, ec)
    | Rd.EndOfFile => v.rdeoferror (name)
    | Rd.Failure (ref) => v.rdfailure (name, ref)
    | Thread.Alerted =>
    END
  END LockedNormalize;

PROCEDURE UnlockedFocus (v: T; gaining: BOOLEAN; time: VBT.TimeStamp) =
  BEGIN
    Thread.Release (v.mu);
    TRY v.focus (gaining, time) FINALLY Thread.Acquire (v.mu) END
  END UnlockedFocus;

PROCEDURE IgnoreFocus (<* UNUSED *> v:     T;
                       <* UNUSED *> gaining: BOOLEAN;
                       <* UNUSED *> time   : VBT.TimeStamp) =
  BEGIN
  END IgnoreFocus;

PROCEDURE UnlockedModified (v: T) =
  BEGIN
    Thread.Release (v.mu);
    TRY v.modified () FINALLY Thread.Acquire (v.mu) END
  END UnlockedModified;

PROCEDURE IgnoreModification (<* UNUSED *> v: T)  =
  BEGIN
  END IgnoreModification;

PROCEDURE Filter (<* UNUSED *> v: T; <* UNUSED *> VAR cd: VBT.KeyRec) =
  BEGIN
  END Filter;

(************************** VBT methods ***************************)

(* In this section, we lock v.mu and relay the method-calls to the Model,
   which handles selections, the mouse, etc. *)

VAR
  miscwr    := TextWr.New ();
  debugMisc := FALSE;

PROCEDURE Misc (v: T; READONLY cd: VBT.MiscRec) =
  BEGIN
    LOCK v.mu DO
      IF debugMisc THEN
        VBTutils.WriteMiscRec (miscwr, cd);
        v.error (TextWr.ToText (miscwr))
      END;
      v.m.misc (cd)
    END
  END Misc;

PROCEDURE Read (v: T; s: VBT.Selection; typecode: CARDINAL): VBT.Value
  RAISES {VBT.Error} =
  <* LL.sup <= VBT.mu *>
  BEGIN
    IF typecode # TYPECODE (TEXT) THEN
      RAISE VBT.Error (VBT.ErrorCode.WrongType)
    ELSE
      LOCK v.mu DO RETURN VBT.FromRef (v.m.read (s, 0)) END
    END
  END Read;

PROCEDURE Write (v       : T;
                 s       : VBT.Selection;
                 value   : VBT.Value;
                 typecode: CARDINAL       ) RAISES {VBT.Error} =
  <* LL.sup <= VBT.mu *>
  BEGIN
    LOCK v.mu DO
      IF typecode # TYPECODE (TEXT) THEN
        RAISE VBT.Error (VBT.ErrorCode.WrongType)
      ELSIF v.readOnly THEN
        RAISE VBT.Error (VBT.ErrorCode.Unwritable)
      ELSE
        TYPECASE value.toRef () OF
        | NULL => RAISE VBT.Error (VBT.ErrorCode.WrongType)
        | TEXT (t) => v.m.write (s, 0, t)
        ELSE
          RAISE VBT.Error (VBT.ErrorCode.WrongType)
        END
      END
    END
  END Write;

PROCEDURE Mouse (v: T; READONLY cd: VBT.MouseRec) =
  BEGIN
    LOCK v.mu DO v.m.mouse (cd) END
  END Mouse;

PROCEDURE Position (v: T; READONLY cd: VBT.PositionRec) =
  BEGIN
    LOCK v.mu DO v.m.position (cd) END
  END Position;

PROCEDURE vbterror (v: T; msg: TEXT; ec: VBT.ErrorCode) =
  BEGIN
    v.ULerror (msg & ": " & TextPortClass.VBTErrorCodeTexts [ec])
  END vbterror;

PROCEDURE vterror (v: T; msg: TEXT; ec: VTDef.ErrorCode) =
  BEGIN
    v.ULerror (msg & ": " & VTDef.ErrorCodeTexts [ec])
  END vterror;

PROCEDURE rdfailure (v: T; msg: TEXT; ref: REFANY) =
  BEGIN
    v.ULerror (msg & ": " & RdUtils.FailureText (ref))
  END rdfailure; 

PROCEDURE rdeoferror (v: T; msg: TEXT) =
  BEGIN
    v.ULerror (msg & ": End of file")
  END rdeoferror;

PROCEDURE UnlockedError (v: T; msg: TEXT) =
  BEGIN
    Thread.Release (v.mu);
    TRY v.error (msg) FINALLY Thread.Acquire (v.mu) END
  END UnlockedError;

PROCEDURE Error (<* UNUSED *> v: T; msg: TEXT) =
  BEGIN
    IF debug THEN
      SmallIO.PutText (SmallIO.stderr, msg);
      SmallIO.PutChar (SmallIO.stderr, '\n')
    END
  END Error;

(*************************  Module Initialization  ************************)

BEGIN
  VAR s: TEXT;
  BEGIN
    IF Env.Get ("TextPortModel", s) THEN
      IF Text.Equal (s, "emacs") THEN
        DefaultModel := Model.Emacs
      ELSIF Text.Equal (s, "xterm") THEN
        DefaultModel := Model.Xterm
      ELSIF Text.Equal (s, "mac") THEN
        DefaultModel := Model.Mac
      ELSE
        DefaultModel := Model.Ivy
      END
    END;
    debug := Env.Get ("TextPortDebug", s)
  END
END TextPort.