MODULE RehearseCode EXPORTS Main;

IMPORT AutoRepeat, Axis, CodeView, FileRd, Fmt, FormsVBT, HVBar,
       HVSplit, ListVBT, OSError, Params, Rd, RefList,
       RehearseCodeBundle, Rsrc, SortedIntRefTbl,
       SortedTextRefTbl, Split, Stdio, Text, TextEditVBT,
       TextPort, Thread, Trestle, TrestleComm, VBT, Wr, WrClass;

<* FATAL Rsrc.NotFound, Rd.Failure, Wr.Failure, Thread.Alerted *>
<* FATAL Split.NotAChild, TrestleComm.Failure *>
<* FATAL FormsVBT.Error *>

TYPE
  View = REF RECORD
               filename: TEXT         := NIL;
               codeview: CodeView.T;
             END;

  Writer = Wr.T OBJECT
             typescript: TextEditVBT.T;
           OVERRIDES
             seek  := Seek;
             flush := Flush;
           END;

  Repeater = AutoRepeat.T OBJECT OVERRIDES
               repeat := RepeatStep
             END;

VAR
  procNames   : RefList.T (* of TEXT *);
  regions     : RefList.T (* of REF INTEGER *);
  views       : RefList.T (* of View *);
  running                  := FALSE;
  currentProc : TEXT       := NIL;
  fv          : FormsVBT.T;
  typescriptWr: Writer;
  codeViews   : HVSplit.T;
  repeater                 := NEW (Repeater).init (0, 400);

PROCEDURE NewWriter (ts: TextEditVBT.T): Writer =
  CONST BufferSize = 100;
  BEGIN
    RETURN
      NEW (Writer, typescript := ts, lo := 0, cur := 0, hi := BufferSize,
           st := 0, buff := NEW (REF ARRAY OF CHAR, BufferSize),
           closed := FALSE, seekable := FALSE, buffered := FALSE);
  END NewWriter;

PROCEDURE Seek (wr: Writer; <* UNUSED *> n: CARDINAL)
  RAISES {Wr.Failure, Thread.Alerted} =
  BEGIN
    wr.flush ()
  END Seek;

PROCEDURE Flush (wr: Writer) RAISES {Thread.Alerted} =
  BEGIN
    TextPort.PutText (
      wr.typescript.tp,
      Text.FromChars (SUBARRAY (wr.buff^, 0, wr.cur - wr.lo)));
    wr.lo := wr.cur;
    wr.hi := wr.lo + NUMBER (wr.buff^);
    IF Thread.TestAlert () THEN RAISE Thread.Alerted END
  END Flush;

PROCEDURE PickAction (             fv  : FormsVBT.T;
                      <* UNUSED *> name: Text.T;
                      <* UNUSED *> cl  : REFANY;
                      <* UNUSED *> time: VBT.TimeStamp) =
  BEGIN Pick(fv)
  END PickAction;

PROCEDURE Pick (fv: FormsVBT.T) =
  VAR
    list := views;
    browser : ListVBT.T := FormsVBT.GetVBT (fv, "procedures");
    cell: ListVBT.Cell;
  BEGIN
    IF running THEN AutoRepeat.Stop (repeater); running := FALSE; END;
    IF NOT browser.getFirstSelected (cell) THEN RETURN; END;
    WITH name = RefList.Nth (procNames, cell) DO
      WHILE list # NIL DO
        WITH view = NARROW (list.head, View) DO
          view.codeview.exitAll ();
          view.codeview.enter (name, 0);
        END;
        list := list.tail
      END;
      regions := UnionOfRegions (name, views).tail;
      currentProc := name;
    END;
  END Pick;

PROCEDURE ReparseAction (             fv  : FormsVBT.T;
                         <* UNUSED *> name: Text.T;
                         <* UNUSED *> cl  : REFANY;
                         <* UNUSED *> time: VBT.TimeStamp) =
  VAR list := views;
  BEGIN
    IF running THEN
      AutoRepeat.Stop(repeater);
      running := FALSE;
    END;
    WHILE list # NIL DO
      WITH view = NARROW(list.head, View) DO
        Wr.PutText(typescriptWr, Fmt.F("Reloading file %s ...\n",
                                       view.filename));
        TRY
          WITH new = CodeView.New(
                       FileRd.Open(view.filename), typescriptWr) DO
            Split.Replace(
              VBT.Parent(view.codeview), view.codeview, new);
            view.codeview := new;
          END;
        EXCEPT
          OSError.E =>
            Wr.PutText(
              typescriptWr,
              Fmt.F("*** OSError.E on file %s\n", view.filename));
        END;
      END;
      list := list.tail;
    END;
    WITH view = NARROW(views.head, View) DO
      procNames := view.codeview.listNames();
    END;
    StuffBrowser(fv, procNames);
    regions := NIL;
    currentProc := NIL;
  END ReparseAction;

PROCEDURE StepAction (<* UNUSED *> fv  : FormsVBT.T;
                      <* UNUSED *> name: Text.T;
                      <* UNUSED *> cl  : REFANY;
                      <* UNUSED *> time: VBT.TimeStamp) =
  BEGIN
    IF running THEN AutoRepeat.Stop (repeater); running := FALSE; END;
    IF (regions = NIL) AND (currentProc # NIL) THEN
      regions := UnionOfRegions (currentProc, views);
    END;
    IF regions # NIL THEN
      WITH region = NARROW (regions.head, REF INTEGER) DO
        At (region^, views);
      END;
      regions := regions.tail;
    END;
  END StepAction;

PROCEDURE RunAction (<* UNUSED *> fv  : FormsVBT.T;
                     <* UNUSED *> name: Text.T;
                     <* UNUSED *> cl  : REFANY;
                     <* UNUSED *> time: VBT.TimeStamp) =
  BEGIN
    IF running THEN AutoRepeat.Stop (repeater); running := FALSE; RETURN; END;
    IF (regions = NIL) AND (currentProc # NIL) THEN
      regions := UnionOfRegions (currentProc, views);
    END;
    AutoRepeat.Start (repeater);
    running := TRUE;
  END RunAction;

PROCEDURE RepeatStep (repeater: Repeater) =
  BEGIN
    IF regions = NIL THEN
      AutoRepeat.Stop (repeater);
      running := FALSE;
    ELSE
      WITH region = NARROW (regions.head, REF INTEGER) DO
        LOCK VBT.mu DO At (region^, views); END;
      END;
      regions := regions.tail;
    END;
  END RepeatStep;

PROCEDURE ExitAction (             fv  : FormsVBT.T;
                      <* UNUSED *> name: Text.T;
                      <* UNUSED *> cl  : REFANY;
                      <* UNUSED *> time: VBT.TimeStamp) =
  BEGIN
    IF running THEN AutoRepeat.Stop (repeater); running := FALSE; END;
    Trestle.Delete (codeViews);
    Trestle.Delete (fv);
  END ExitAction;

PROCEDURE At (line: INTEGER; viewList: RefList.T) =
  BEGIN
    WHILE viewList # NIL DO
      WITH view = NARROW (viewList.head, View) DO
        view.codeview.at (line, 0);
      END;
      viewList := viewList.tail;
    END;
  END At;

PROCEDURE StuffBrowser (fv: FormsVBT.T; names: RefList.T) =
  VAR browser: ListVBT.T := FormsVBT.GetVBT (fv, "procedures");
      oldCount := browser.count();
      oldSelection := -1;
      newCount := RefList.Length(names);
  BEGIN
    EVAL browser.getFirstSelected(oldSelection);
    browser.selectNone();
    browser.removeCells (0, LAST(INTEGER));
    browser.insertCells (oldCount, newCount);
    IF newCount > 0 THEN
      FOR j := 0 TO newCount - 1 DO
        browser.setValue (j, NARROW (names.head, TEXT));
        names := names.tail;
      END;
      IF oldCount = newCount AND oldSelection # -1 THEN
        browser.selectOnly(oldSelection)
      ELSE
        browser.selectOnly(0)
      END;
      Pick(fv)
    END;
  END StuffBrowser;

PROCEDURE CheckNames (names: RefList.T; viewList: RefList.T) =
  VAR nameList: RefList.T;
  BEGIN
    WHILE viewList # NIL DO
      WITH view = NARROW(viewList.head, View) DO
        nameList := names;
        WHILE nameList # NIL DO
          WITH name = NARROW(nameList.head, TEXT) DO
            IF NOT TextListMember(
                     name, view.codeview.listNames()) THEN
              Wr.PutText(
                typescriptWr,
                Fmt.F("procedure annotation %s not in file %s\n",
                      name, view.filename));
            END;
          END;
          nameList := nameList.tail
        END
      END;
      viewList := viewList.tail
    END
  END CheckNames;

PROCEDURE TextListMember (x: TEXT; l: RefList.T): BOOLEAN =
  BEGIN
    WHILE l # NIL DO
      IF Text.Equal(NARROW(l.head, TEXT), x) THEN
        RETURN TRUE
      END;
      l := l.tail;
    END;
    RETURN FALSE;
  END TextListMember;

PROCEDURE UnionOfNames (viewList: RefList.T): RefList.T =
  VAR
    list : RefList.T;
    name : TEXT;
    value: REFANY;
    tbl  : SortedTextRefTbl.T;
  BEGIN
    WHILE viewList # NIL DO
      WITH view = NARROW(viewList.head, View) DO
        list := RefList.Append(list, view.codeview.listNames());
      END;
      viewList := viewList.tail;
    END;
    (* build a SortedTextRefTbl of unique keys: *)
    tbl := NEW(SortedTextRefTbl.Default).init();
    WHILE list # NIL DO
      name := list.head;
      EVAL tbl.put(name, NIL);
      list := list.tail;
    END;
    (* build a new list with items in sorted order: *)
    WITH iter = tbl.iterateOrdered(FALSE) DO
      WHILE iter.next(name, value) DO
        list := RefList.Cons(name, list)
      END
    END;
    RETURN list
  END UnionOfNames;

PROCEDURE UnionOfRegions (proc: TEXT; viewList: RefList.T):
  RefList.T =
  VAR
    list     : RefList.T;
    refRegion: REFANY;
    region   : INTEGER;
    tbl      : SortedIntRefTbl.T;
  BEGIN
    WHILE viewList # NIL DO
      WITH view = NARROW(viewList.head, View) DO
        list :=
          RefList.Append(list, view.codeview.listRegions(proc));
      END;
      viewList := viewList.tail;
    END;
    (* build a SortedIntRefTbl of unique keys: *)
    tbl := NEW(SortedIntRefTbl.Default).init();
    WHILE list # NIL DO
      refRegion := list.head;
      region := NARROW(refRegion, REF INTEGER)^;
      EVAL tbl.put(region, refRegion);
      list := list.tail;
    END;
    (* build a new list with items in sorted order: *)
    WITH iter = tbl.iterateOrdered(FALSE) DO
      WHILE iter.next(region, refRegion) DO
        list := RefList.Cons(refRegion, list)
      END
    END;
    RETURN list
  END UnionOfRegions;

PROCEDURE Main () =
  VAR hsplit, vsplit: HVSplit.T;
  BEGIN
    fv := NEW(FormsVBT.T).initFromRsrc (
            "RehearseCode.fv",
            Rsrc.BuildPath ("$REHEARSECODE",  RehearseCodeBundle.Get()));
    FormsVBT.AttachProc (fv, "reparse", ReparseAction);
    FormsVBT.AttachProc (fv, "step", StepAction);
    FormsVBT.AttachProc (fv, "run", RunAction);
    FormsVBT.AttachProc (fv, "exit", ExitAction);
    FormsVBT.AttachProc (fv, "procedures", PickAction);

    typescriptWr := NewWriter (FormsVBT.GetVBT (fv, "typescript"));

    IF (Params.Count < 2) OR (Params.Count > 5) THEN
      Wr.PutText (Stdio.stderr,
        "usage: RehearseCode filename1 [... filename4]\n");
      RETURN
    END;

    FOR i := 1 TO Params.Count - 1 DO
      WITH source = Params.Get (i),
           view   = NEW (View)      DO
        TRY
          Wr.PutText (
            typescriptWr, Fmt.F ("Loading file %s ...\n", source));
          view.filename := source;
          view.codeview :=
            CodeView.New (FileRd.Open (source), typescriptWr);
          views := RefList.Cons(view, views);
          IF vsplit = NIL THEN
            vsplit := HVSplit.Cons (Axis.T.Ver, view.codeview);
          ELSE
            Split.AddChild (vsplit, HVBar.New (1.5), view.codeview);
          END;
        EXCEPT
        |  OSError.E =>
            Wr.PutText (
              Stdio.stderr,
              Fmt.F ("RehearseCode: Error trying to open file %s\n", source));
            Wr.PutText (
              typescriptWr, Fmt.F ("*** Error trying to open file %s\n", source));
        END;
      END;
    END;

    IF views = NIL THEN
      Wr.PutText (Stdio.stderr, "RehearseCode: no source files found\n");
      RETURN
    END;

    IF hsplit = NIL THEN
      codeViews := vsplit;
    ELSE
      codeViews := hsplit;
    END;

    procNames := UnionOfNames (views);
    CheckNames (procNames, views);
    StuffBrowser (fv, procNames);
    Trestle.Install (
      codeViews, "RehearseCode", NIL, "RehearseCode Code Views");
    Trestle.Install (fv, "RehearseCode", NIL, "RehearseCode Controller");
    Trestle.AwaitDelete (fv);
  END Main;

BEGIN
  Main ();
END RehearseCode.