(* Copyright (C) 1991-1992, Digital Equipment Corporation                *)
(* All rights reserved.                                                  *)
(* See the file COPYRIGHT for a full description.                        *)
(*                                                                       *)
(* Last modified on Sat Jan  2 15:14:57 PST 1993 by meehan               *)
<* PRAGMA LL *>

MODULE TextPortClass;

IMPORT Char, Fmt, KeyboardKey, MText, MTextRd, MTextUnit, PaintOp, Range, Rd,
       RdUtils, Rect, SmallIO, Text, TextPort, Thread, TypescriptVBT, VBT,
       VTDef, VText;

FROM TextPort IMPORT Extent, NotFound;

REVEAL
  Model = PublicModel BRANDED OBJECT
          OVERRIDES
            init            := Init;
            close           := Close;
            arrowKey        := ArrowKey;
            clear           := Clear;
            cut             := Cut;
            filter          := Filter;
            getSelectedText := GetSelectedText;
            isReplaceMode   := IsReplaceMode;
            paste           := Paste;
            read            := Read;
            seek            := Seek;
            write           := Write;
          END;

PROCEDURE Init (m: Model; <* UNUSED *> cs: PaintOp.ColorScheme): Model =
  BEGIN
    RETURN m
  END Init;

PROCEDURE Close (m: Model) =
  CONST name = "Close";
  VAR v := m.v;
  BEGIN
    VBT.Release (v, VBT.KBFocus);
    VBT.Release (v, VBT.Source);
    VBT.Release (v, VBT.Target);
    TRY
      VText.SwitchCaret (v.vtext, VText.OnOffState.Off);
      m.walkIntervals (VText.DeleteInterval)
    EXCEPT
    | VTDef.Error (ec) => v.vterror (name, ec)
    | Rd.EndOfFile => v.rdeoferror (name)
    | Rd.Failure (ref) => v.rdfailure (name, ref)
    | Thread.Alerted =>
    END
  END Close;

PROCEDURE Cut (m: Model; time: VBT.TimeStamp) =
  BEGIN
    m.copy (time);
    m.clear ()
  END Cut;

PROCEDURE Clear (m: Model) =
  BEGIN
    m.putSelectedText ("", Primary)
  END Clear;

(*
 * Caret and interval-twiddling
 *)

PROCEDURE ArrowKey (m: Model; ch: Arrow; <* UNUSED *> READONLY cd: VBT.KeyRec) =
  BEGIN
    CASE ch OF
    | KeyboardKey.Left => ToPrevChar (m.v)
    | KeyboardKey.Right => ToNextChar (m.v)
    | KeyboardKey.Up => UpOneLine (m.v)
    | KeyboardKey.Down => DownOneLine (m.v)
    END
  END ArrowKey;

PROCEDURE FindNextWord (v: T): Extent =
  VAR
    right := LocateNextWordBoundary (v);
    left  := MTextUnit.StartOfRun (v.vtext.mtext, right);
  BEGIN
    IF left >= 0 THEN RETURN Extent {left, right} ELSE RETURN NotFound END
  END FindNextWord;

PROCEDURE FindPrevWord (v: T): Extent =
  VAR
    left  := LocateNextWordBoundary (v, reverse := TRUE);
    right := MTextUnit.EndOfRun (v.vtext.mtext, left);
  BEGIN
    IF right >= 0 THEN RETURN Extent {left, right} ELSE RETURN NotFound END
  END FindPrevWord;

VAR
  readerLock := NEW (MUTEX);
  reader     := NEW (MTextRd.T); <* LL = readerLock *>

PROCEDURE LocateNextWordBoundary (v: T; reverse := FALSE): CARDINAL =
  VAR
    index       := v.index ();
    rd   : Rd.T;
    c    : CHAR;
    count       := 0;
  BEGIN
    LOCK readerLock DO
      TRY
        rd := reader.init (v.vtext.mtext, index, reverse := reverse);
        REPEAT
          c := Rd.GetChar (rd);
          INC (count);
        UNTIL c IN Char.AlphaNumerics;
        REPEAT
          c := Rd.GetChar (rd);
          INC (count);
        UNTIL NOT c IN Char.AlphaNumerics;
        DEC (count)
      EXCEPT
        Rd.EndOfFile, Rd.Failure, Thread.Alerted =>
      END
    END;
    IF reverse THEN RETURN index - count ELSE RETURN index + count END
  END LocateNextWordBoundary;

PROCEDURE ToPrevChar (v: T) =
  VAR index := v.index ();
  BEGIN
    IF index > 0 THEN v.m.seek (index - 1) END
  END ToPrevChar;

PROCEDURE ToNextChar (v: T) =
  BEGIN
    v.m.seek (v.index () + 1)
  END ToNextChar;

PROCEDURE ToStartOfLine (v: T) =
  BEGIN
    v.m.seek (MTextUnit.LineInfo (v.vtext.mtext, v.index ()).left)
  END ToStartOfLine;

PROCEDURE ToEndOfLine (v: T) =
  BEGIN
    v.m.seek (MTextUnit.LineInfo (v.vtext.mtext, v.index ()).rightEnd)
  END ToEndOfLine;

PROCEDURE ToOtherEnd (v: T) =
  VAR x := v.m.getSelection ();
  BEGIN
    IF v.index () = x.l THEN v.m.seek (x.r) ELSE v.m.seek (x.l) END
  END ToOtherEnd;


(*
 * Vertical movement commands.
 *)

PROCEDURE UpOneLine (v: T) =
  BEGIN
    GoUpDown (v, goUp := TRUE)
  END UpOneLine;

PROCEDURE DownOneLine (v: T) =
  BEGIN
    GoUpDown (v, goUp := FALSE)
  END DownOneLine;

PROCEDURE GoUpDown (v: T; goUp: BOOLEAN) =
  VAR
    mtext                   := v.vtext.mtext;
    e    : MTextUnit.Extent := MTextUnit.LineExtent (mtext, v.index ());
  BEGIN
    (* Vertical movement commands *)
    IF v.lastCmdKind # CommandKind.VertCommand THEN
      v.wishCol := v.index () - e.left
    END;
    v.thisCmdKind := CommandKind.VertCommand;
    IF goUp THEN
      IF e.left = 0 THEN RETURN END;
      e := MTextUnit.LineExtent (mtext, e.left - 1)
    ELSE
      e.left := e.right
    END;
    v.m.seek (
      MIN (e.left + v.wishCol, MTextUnit.LineInfo (mtext, e.left).rightEnd))
  END GoUpDown;

(*
 * Deletion commands.
 *)

PROCEDURE DeletePrevChar (v: T): Extent =
  VAR here := v.index ();
  BEGIN
    IF here > 0 THEN
      RETURN v.replace (here - 1, here, "")
    ELSE
      RETURN NotFound
    END
  END DeletePrevChar;

PROCEDURE DeleteNextChar (v: T): Extent =
  VAR here := v.index ();
  BEGIN
    RETURN v.replace (here, here + 1, "")
  END DeleteNextChar;

PROCEDURE DeleteToEndOfWord (v: T): Extent =
  VAR
    start := v.index ();
    end   := LocateNextWordBoundary (v);
  BEGIN
    RETURN v.replace (start, end, "")
  END DeleteToEndOfWord;

PROCEDURE DeleteToStartOfWord (v: T): Extent =
  VAR
    end   := v.index ();
    start := LocateNextWordBoundary (v, reverse := TRUE);
  BEGIN
    RETURN v.replace (start, end, "")
  END DeleteToStartOfWord;

PROCEDURE DeleteCurrentWord (v: T): Extent =
  PROCEDURE WordAt (mtext: MText.T; index: CARDINAL): Extent =
    (** A word is
        - a run of alphanumerics
        - a run of blanks
        - any other single character
       We find a word such that left <= index < right.
    **)
    VAR e: MTextUnit.Extent;
    BEGIN
      e := MTextUnit.RunExtent (mtext, index, Char.AlphaNumerics);
      IF e.inside THEN
        RETURN Extent {e.left, e.right}
      ELSE
        e := MTextUnit.RunExtent (mtext, index, Char.Spaces);
        IF e.inside THEN
          RETURN Extent {e.left, e.right}
        ELSE
          RETURN Extent {index, index + 1}
        END
      END
    END WordAt;
  VAR extent := WordAt (v.vtext.mtext, v.index ());
  BEGIN
    RETURN v.replace (extent.l, extent.r, "")
  END DeleteCurrentWord;

PROCEDURE DeleteToStartOfLine (v: T): Extent =
  VAR
    here := v.index ();
    left := MTextUnit.StartOfLine (v.vtext.mtext, here);
  BEGIN
    IF here = left THEN
      (* We're already at the start of line; delete one char. *)
      RETURN v.replace (here - 1, here, "")
    ELSE
      RETURN v.replace (left, here, "")
    END
  END DeleteToStartOfLine;

PROCEDURE DeleteToEndOfLine (v: T): Extent =
  VAR
    here := v.index ();
    info := MTextUnit.LineInfo (v.vtext.mtext, here);
  BEGIN
    IF here = info.rightEnd THEN
      (* We're already at the end of line. *)
      RETURN v.replace (here, info.right, "")
    ELSE
      RETURN v.replace (here, info.rightEnd, "")
    END
  END DeleteToEndOfLine;

PROCEDURE DeleteCurrentLine (v: T): Extent =
  VAR
    here := v.index ();
    info := MTextUnit.LineInfo (v.vtext.mtext, here);
  BEGIN
    RETURN v.replace (info.left, info.right, "")
  END DeleteCurrentLine;

(*
 * Other modifications.
 *)

PROCEDURE SwapChars (v: T) =
  (* Swap the two characters to the left of the caret. *)
  VAR
    here                         := v.index ();
    two : ARRAY [0 .. 1] OF CHAR;
  BEGIN
    IF here - 2 < v.typeinStart THEN RETURN END;
    two [1] := MText.GetChar (v.vtext.mtext, here - 2);
    two [0] := MText.GetChar (v.vtext.mtext, here - 1);
    EVAL v.replace (here - 2, here, Text.FromChars (two))
  END SwapChars;

PROCEDURE InsertNewline (v: T) =
  (* Insert a newline without moving the cursor. *)
  VAR here := v.index ();
  BEGIN
    v.m.seek (v.replace (here, here, "\n").l)
  END InsertNewline;

(*
 * Searching
 *)

PROCEDURE Find (v         : T;
                pattern   : TEXT;
                direction          := Direction.Forward;
                fromWhere          := Where.Here;
                ignoreCase         := TRUE               ): Extent =
  CONST
    name = "Find";
    Etext = ARRAY Range.ErrorCode OF
              TEXT {"Start-value too big", "End-value too big"};
  VAR
    len  : CARDINAL;
    found: INTEGER;
    start           := v.index ();
  BEGIN
    IF pattern = NIL OR Text.Empty (pattern) THEN RETURN NotFound END;
    len := Text.Length (pattern);
    TRY
      CASE direction OF
      | Direction.Forward =>
          IF fromWhere = Where.Beginning THEN start := 0 END;
          LOCK readerLock DO
            EVAL reader.init (v.vtext.mtext, start := start);
            found := RdUtils.Find (reader, pattern, ignoreCase := ignoreCase);
            IF found >= 0 THEN RETURN Extent {found, found + len} END
          END
      | Direction.Backward =>
          IF fromWhere # Where.Beginning THEN
            LOCK readerLock DO
              EVAL
                reader.init (v.vtext.mtext, start := start, rangeStart := 0,
                             rangeEnd := start, reverse := TRUE);
              found := RdUtils.Find (reader, TextReverse (pattern),
                                     ignoreCase := ignoreCase);
              IF found >= 0 THEN
                RETURN Extent {start - found - len, start - found}
              END                (* IF *)
            END                  (* LOCK *)
          END                    (* IF *)
      END                        (* CASE *)
    EXCEPT
    | VTDef.Error (ec) => v.vterror (name, ec)
    | Rd.EndOfFile => v.rdeoferror (name)
    | Rd.Failure (ref) => v.rdfailure (name, ref)
    | Range.Error (ec) => v.error ("Range error in Find: " & Etext [ec])
    | Thread.Alerted =>
    END;
    RETURN NotFound
  END Find;

PROCEDURE TextReverse (t: TEXT): TEXT =
  VAR
    len : CARDINAL          := Text.Length (t);
    buf : REF ARRAY OF CHAR;
    i, j: CARDINAL;
    c   : CHAR;
  BEGIN
    buf := NEW (REF ARRAY OF CHAR, len);
    Text.SetChars (buf^, t);
    i := 0;
    j := len - 1;
    WHILE i < j DO
      c := buf [i];
      buf [i] := buf [j];
      buf [j] := c;
      INC (i);
      DEC (j)
    END;
    RETURN Text.FromChars (buf^)
  END TextReverse;

PROCEDURE GetRange (         v   : T;
                    READONLY cp  : VBT.CursorPosition;
                             mode: VText.SelectionMode ): IRange =
  <* LL = v.mu *>
  CONST name = "GetRange";
  VAR
    whichEnd  : VText.WhichEnd;
    rect      : Rect.T;
    lineNum   : CARDINAL;
    ch        : CHAR;
    atEnd     : BOOLEAN;
    lt, md, rt: CARDINAL;
    e         : MTextUnit.Extent;
  VAR vt := v.vtext;
  BEGIN
    TRY
      VText.PounceLocate (vt, 0, cp.pt, lt, rt, lineNum, ch);
      atEnd := lt = rt;
      IF atEnd AND lt > 0 THEN DEC (lt) END;
      CASE mode OF
      | VText.SelectionMode.ParagraphSelection =>
          (* paragraph strategy differs from VText's strategy *)
          e := MTextUnit.ParagraphExtent (vt.mtext, lt);
          lt := e.left;
          rt := e.right
      | VText.SelectionMode.LineSelection =>
          e := MTextUnit.LineExtent (vt.mtext, lt);
          lt := e.left;
          rt := e.right
      ELSE
        VText.PounceExtend (vt, 0, lt, rt, lineNum, ch, mode)
      END;
      whichEnd := VText.PounceEncage (vt, 0, cp.pt, lt, md, rt, rect);
      VBT.SetCage (vt.vbt, VBT.CageFromRect (rect, cp));
      IF (mode = VText.SelectionMode.CharSelection
            OR mode = VText.SelectionMode.WordSelection) AND ch # Char.NL
           AND (whichEnd = VText.WhichEnd.Right OR atEnd) THEN
        md := rt
      ELSE
        md := lt
      END
    EXCEPT
    | VTDef.Error (ec) => v.vterror (name, ec)
    | Rd.EndOfFile => v.rdeoferror (name)
    | Rd.Failure (ref) => v.rdfailure (name, ref)
    | Thread.Alerted =>
    END;
    RETURN IRange {lt, md, rt}
  END GetRange;


(* \subsection {Scrolling the display} *)

PROCEDURE ScrollOneLineUp (v: T) =
  CONST name = "Scroll 1 line up";
  BEGIN
    TRY
      VText.Scroll (v.vtext, 0, 1)
    EXCEPT
    | VTDef.Error (ec) => v.vterror (name, ec)
    | Rd.EndOfFile => v.rdeoferror (name)
    | Rd.Failure (ref) => v.rdfailure (name, ref)
    | Thread.Alerted =>
    END;
    TextPort.MarkAndUpdate (v)
  END ScrollOneLineUp;

PROCEDURE ScrollOneLineDown (v: T) =
  CONST name = "Scroll 1 line down";
  BEGIN
    TRY
      VText.Scroll (v.vtext, 0, -1);
    EXCEPT
    | VTDef.Error (ec) => v.vterror (name, ec)
    | Rd.EndOfFile => v.rdeoferror (name)
    | Rd.Failure (ref) => v.rdfailure (name, ref)
    | Thread.Alerted =>
    END;
    TextPort.MarkAndUpdate (v)
  END ScrollOneLineDown;

PROCEDURE ScrollOneScreenUp (v: T) =
  CONST name = "Scroll 1 screen up";
  BEGIN
    TRY
      VText.Scroll (v.vtext, 0, MAX (1, v.vtext.region [0].nLines - 2));
    EXCEPT
    | VTDef.Error (ec) => v.vterror (name, ec)
    | Rd.EndOfFile => v.rdeoferror (name)
    | Rd.Failure (ref) => v.rdfailure (name, ref)
    | Thread.Alerted =>
    END;
    TextPort.MarkAndUpdate (v)
  END ScrollOneScreenUp;

PROCEDURE ScrollOneScreenDown (v: T) =
  CONST name = "Scroll 1 screen down";
  BEGIN
    TRY
      VText.Scroll (v.vtext, 0, -MAX (1, v.vtext.region [0].nLines - 2));
    EXCEPT
    | VTDef.Error (ec) => v.vterror (name, ec)
    | Rd.EndOfFile => v.rdeoferror (name)
    | Rd.Failure (ref) => v.rdfailure (name, ref)
    | Thread.Alerted =>
    END;
    TextPort.MarkAndUpdate (v)
  END ScrollOneScreenDown;

(***************************** Undo  ********************************)

REVEAL
  UndoRec = BRANDED OBJECT
                          begin, end: VText.Index := 0;
                          text                    := "";
                          next, prev: UndoRec     := NIL
                        END;

PROCEDURE AddToUndo (v: T; begin, end: CARDINAL; newText: TEXT) =
  <* LL = v.mu *>
  VAR
    n := Text.Length (newText);
    r := v.cur;
  BEGIN
    IF v.readOnly OR begin = end AND n = 0 OR ISTYPE (v, TypescriptVBT.Port) THEN
      RETURN
    END;
    IF r.prev # NIL AND begin = end AND n = 1 AND r.prev.end = begin
         AND Text.GetChar (newText, 0) IN Char.Graphics THEN
      (* It's straight typing.  Extend the previous record. *)
      INC (r.prev.end)
    ELSE
      r.begin := begin;
      r.end := begin + n;
      r.text := MText.GetText (v.vtext.mtext, begin, end);
      IF r.next = NIL THEN r.next := NEW (UndoRec, prev := r) END;
      v.cur := r.next
    END;
    TraceUndo (v)
  END AddToUndo;

VAR tracingUndo := FALSE; (* For runtime debugging *)

PROCEDURE TraceUndo (v: T) =
  <* LL = v.mu *>
  VAR
    r          := v.cur;
    t: TEXT;
    n: INTEGER := 0;
  BEGIN
    IF NOT tracingUndo THEN RETURN END;
    WHILE r.prev # NIL DO r := r.prev; INC (n) END;
    WHILE r.next # NIL DO
      t := r.text;
      IF Text.Length (t) > 20 THEN t := Text.Sub (t, 0, 20) & "..." END;
      IF n = 0 THEN SmallIO.PutText (SmallIO.stderr, "***** ") END;
      SmallIO.PutText (SmallIO.stderr,
                       Fmt.F ("[%s .. %s] = \"%s\"\n", Fmt.Int (r.begin),
                              Fmt.Int (r.end), t));
      r := r.next;
      DEC (n)
    END;
    SmallIO.PutText (SmallIO.stderr, "-------------------\n")
  END TraceUndo;
  
PROCEDURE Undo (v: T) =
  BEGIN
    IF v.cur.prev # NIL THEN v.cur := v.cur.prev; Exchange (v) END
  END Undo;

PROCEDURE Redo (v: T) =
  BEGIN
    IF v.cur.next # NIL THEN Exchange (v); v.cur := v.cur.next END
  END Redo; 

PROCEDURE UndoCount (v: T): CARDINAL =
  <* LL < v.mu *>
  VAR
    n: CARDINAL := 0;
    r: UndoRec;
  BEGIN
    LOCK v.mu DO
      r := v.cur;
      WHILE r.prev # NIL DO INC (n); r := r.prev END;
      RETURN n
    END
  END UndoCount;

PROCEDURE RedoCount (v: T): CARDINAL =
  <* LL < v.mu *>
  VAR
    n: CARDINAL := 0;
    r: UndoRec;
  BEGIN
    LOCK v.mu DO
      r := v.cur;
      WHILE r.next # NIL DO INC(n); r := r.next END;
      RETURN n
    END
  END RedoCount;

PROCEDURE ResetUndo (v: T) =
  <* LL < v.mu *>
  BEGIN
    LOCK v.mu DO v.cur := NEW(UndoRec) END
  END ResetUndo;

PROCEDURE Exchange (v: T) =
  <* LL = v.mu *>
  CONST name = "Undo";
  VAR
    prev := "";
    r    := v.cur;
  BEGIN
    IF r.begin < r.end AND r.begin < v.length () THEN
      prev := v.getText (r.begin, r.end)
    END;
    v.normalize (r.begin);
    TRY
      VText.Replace (v.vtext, r.begin, r.end, r.text)
    EXCEPT
    | VTDef.Error (ec) => v.vterror (name, ec)
    | Rd.EndOfFile => v.rdeoferror (name)
    | Rd.Failure (ref) => v.rdfailure (name, ref)
    | Thread.Alerted =>
    END;
    r.end := r.begin + Text.Length (r.text);
    r.text := prev;
    TraceUndo (v)
  END Exchange;

(********************* Default methods *****************************)

PROCEDURE GetSelectedText (m: Model; sel: TextPort.SelectionType): TEXT =
  VAR extent := m.getSelection (sel);
  BEGIN
    IF extent.l = extent.r THEN
      RETURN ""
    ELSE
      RETURN m.v.getText (extent.l, extent.r)
    END
  END GetSelectedText;

PROCEDURE Paste (m: Model; time: VBT.TimeStamp) =
  BEGIN
    TRY
      m.v.insert (m.read (VBT.Source, time))
    EXCEPT
    | VBT.Error (ec) => m.v.vbterror ("Paste", ec)
    END
  END Paste;

PROCEDURE Read (m: Model; READONLY s: VBT.Selection; time: VBT.TimeStamp): TEXT
  RAISES {VBT.Error} =
  BEGIN
    TYPECASE VBT.Read (m.v, s, time).toRef () OF
    | NULL => RAISE VBT.Error (VBT.ErrorCode.WrongType)
    | TEXT (t) => RETURN t
    ELSE
      RAISE VBT.Error (VBT.ErrorCode.WrongType)
    END
  END Read;

PROCEDURE Write (         m   : Model;
                 READONLY s   : VBT.Selection;
                          time: VBT.TimeStamp;
                          t   : TEXT           ) RAISES {VBT.Error} =
  BEGIN
    VBT.Write (m.v, s, time, VBT.FromRef (t))
  END Write; 
  
PROCEDURE Seek (m: Model; position: CARDINAL) =
  CONST name = "Seek";
  BEGIN
    TRY
      VText.MoveCaret (m.v.vtext, position);
      VBT.Mark (m.v)
    EXCEPT
    | VTDef.Error (ec) => m.v.vterror (name, ec)
    | Rd.EndOfFile => m.v.rdeoferror (name)
    | Rd.Failure (ref) => m.v.rdfailure (name, ref)
    | Thread.Alerted =>
    END
  END Seek;

PROCEDURE IsReplaceMode (<* UNUSED *> m: Model): BOOLEAN =
  BEGIN
    RETURN FALSE
  END IsReplaceMode; 

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

BEGIN END TextPortClass.