(* Copyright (C) 1992, Digital Equipment Corporation *)
(* All rights reserved. *)
(* See the file COPYRIGHT for a full description. *)
(* Last modified on Tue Jan  5 20:04:15 PST 1993 by johnh *)
(*      modified on Sat Oct 17 23:13:08 PDT 1992 by mhb *)
(*      modified on Wed Aug 19 16:34:43 PDT 1992 by sclafani*)
(* modified on Wed May 20 20:51:02 1992 by steveg *)
<*PRAGMA LL*>

MODULE CodeView;

IMPORT Axis, BorderedVBT, Char, ColorName, Fmt, Font, IntRefTbl, List,
       PaintOp, Pixmap, Point, Rd, Rect, Scan, Split, Stdio,
       TextPort, TxtRefTbl, Text, TextWr, TextureVBT, Thread, Time, VBT,
       VText, VTDef, Wr, ZSplit;

<* FATAL Rd.Failure, Wr.Failure, Thread.Alerted, Rd.EndOfFile *>
<* FATAL VTDef.Error, Split.NotAChild *>
<* FATAL TxtRefTbl.NotFound, Scan.BadFormat *>

TYPE
  ProcInfo = REF RECORD
                   source : TEXT;
                   offsets: IntRefTbl.T;
                 END;
  Position = REF RECORD start, end: CARDINAL;  END;

REVEAL
  T = Public BRANDED OBJECT
        procTable: TxtRefTbl.T;
        font     : Font.T;
        delta    : CARDINAL;
      OVERRIDES
        shape       := ZShape;
        enter       := Enter;
        exit        := Exit;
        at          := At;
        event       := Event;
        exitAll     := ExitAll;
        listNames   := ListNames;
        listRegions := ListRegions;
        init        := Init;
      END;

TYPE
  AlgVBT = TextPort.T OBJECT
             interval: VText.Interval;
             proc    : ProcInfo;
           OVERRIDES
             shape := Shape;
           END;

<* FATAL ColorName.NotFound *>
VAR
  highlightStyle := VText.MakeIntervalOptions (
                      VText.IntervalStyle.InverseStyle,
                      PaintOp.MakeColorScheme (
                        PaintOp.Fg, PaintOp.FromRGB (
                                        ColorName.ToRGB ("LightGreen").r,
                                        ColorName.ToRGB ("LightGreen").g,
                                        ColorName.ToRGB ("LightGreen").b)),
                      PaintOp.bgFg, PaintOp.Bg);

PROCEDURE ZShape (v: VBT.T; ax: Axis.T; n: CARDINAL): VBT.SizeRange =
  VAR res := ZSplit.T.shape (v, ax, n);
  BEGIN
    IF res.pref < 100 THEN
      IF ax = Axis.T.Ver THEN res.pref := 200 ELSE res.pref := 400 END;
      IF res.pref >= res.hi THEN res.hi := res.pref + 1; END;
    END;
    RETURN res;
  END ZShape;

PROCEDURE Shape (<*UNUSED*> v : VBT.T;
                 <*UNUSED*> ax: Axis.T;
                 <*UNUSED*> n : CARDINAL): VBT.SizeRange =
  VAR res: VBT.SizeRange;
  BEGIN
    res.pref := 2000;
    res.lo := res.pref;
    res.hi := res.lo + 1;
    RETURN res;
  END Shape;

PROCEDURE Enter (t: T; procedureName: TEXT; pauseTime := -1) =
  VAR
    algVBT: AlgVBT;
    point : Point.T;
    depth : INTEGER;
    pos   : Position;
    refany: REFANY;
  BEGIN
    IF NOT t.procTable.in (procedureName, refany) THEN RETURN; END;
    algVBT := NewAlgVBT (t, refany);
    depth := Split.NumChildren (t) - 1;
    point := Point.Add (
               Rect.NorthWest (ZSplit.GetParentDomain (t)),
               Point.FromCoords (t.delta * depth, t.delta * depth));
    ZSplit.InsertAt (t, BorderedVBT.New (algVBT, 0.5), point);
    IF algVBT.proc.offsets.in (0, refany) THEN
      pos := refany;
      VText.MoveInterval (algVBT.interval, pos.start, pos.end);
      VBT.Mark (algVBT);
      IF pauseTime < 0 THEN pauseTime := t.pauseTime; END;
      Time.Pause (pauseTime);
    END;
  END Enter;

PROCEDURE Exit (t: T; pauseTime := -1) =
  BEGIN
    IF Split.NumChildren (t) < 2 THEN RETURN; END;
    Split.Delete (t, Split.Succ (t, NIL));
    IF pauseTime < 0 THEN pauseTime := t.pauseTime; END;
    Time.Pause (pauseTime);
  END Exit;

PROCEDURE At (t: T; highlight: CARDINAL; pauseTime := -1) =
  VAR
    algVBT: AlgVBT;
    pos   : Position;
    refany: REFANY;
  BEGIN
    IF Split.NumChildren (t) < 2 THEN RETURN; END;
    algVBT := Split.Succ (Split.Succ (t, NIL), NIL);
    IF algVBT.proc.offsets.in (highlight, refany) THEN
      pos := refany;
      VText.MoveInterval (algVBT.interval, pos.start, pos.end);
      VBT.Mark (algVBT);
      IF pauseTime < 0 THEN pauseTime := t.pauseTime; END;
      Time.Pause (pauseTime);
    END;
  END At;

PROCEDURE Event (t            : T;
                 highlight           := 0;
                 pauseTime           := -1;
                 procedureName: TEXT := NIL ) =
  BEGIN
    IF procedureName # NIL THEN
      t.enter (procedureName, pauseTime);
    ELSIF highlight < 0 THEN
      t.exit (pauseTime);
    ELSE
      t.at (highlight, pauseTime);
    END;
  END Event;

PROCEDURE ExitAll (t: T) =
  VAR
    bg := Split.Pred (t, NIL);
    ch := Split.Pred (t, bg);
  BEGIN
    WHILE ch # NIL DO Split.Delete (t, ch); ch := Split.Pred (t, bg); END;
  END ExitAll;

PROCEDURE NewAlgVBT (t: T; proc: ProcInfo): AlgVBT =
  VAR
    vbt: AlgVBT;
    vt : VText.T;
  BEGIN
    vbt := NEW (AlgVBT).init (font := t.font);
    TextPort.SetText (vbt, proc.source);
    vbt.setReadOnly(TRUE);  (* replaces TextPort.SetReadOnly (vbt, TRUE);*)
    TextPort.SetWrap (vbt, FALSE);
    vt := TextPort.GetVText (vbt);
    vbt.interval := VText.CreateInterval (vt, 0, 0, highlightStyle);
    VText.SwitchInterval (vbt.interval, VText.OnOffState.On);
    vbt.proc := proc;
    RETURN vbt;
  END NewAlgVBT;

PROCEDURE Dump (source: Rd.T; wr: Wr.T; errorWr: Wr.T := NIL) =
  VAR
    procList: List.T;
    assoc   : List.T;
    name    : TEXT;
    proc    : ProcInfo;
    posList : List.T;
    pos     : Position;
    line    : REF INTEGER;
  BEGIN
    procList := List.Sort (ParseAlg (source, errorWr).toAssocList ());
    WHILE procList # NIL DO
      assoc := List.Pop (procList);
      name := List.Pop (assoc);
      proc := List.Pop (assoc);
      Wr.PutText (wr, name & "\n");
      posList := List.Sort (proc.offsets.toAssocList ());
      WHILE posList # NIL DO
        assoc := List.Pop (posList);
        line := List.Pop (assoc);
        pos := List.Pop (assoc);
        Wr.PutText (wr, Fmt.F ("%5s  %s\n", Fmt.Int (line^),
                               Text.Sub (proc.source, pos.start,
                                         pos.end - pos.start)));
      END;
      Wr.PutChar (wr, '\n');
    END;
  END Dump;

PROCEDURE ParseAlg (rd: Rd.T; errorWr: Wr.T): TxtRefTbl.T =
  TYPE
    State = {Top, TopAt, TopTag, InProc, ProcAt, ProcTag, StatTag, InStat,
             StatAt};
  VAR
    procTable           := TxtRefTbl.New ();
    procWr              := TextWr.New ();
    tagWr               := TextWr.New ();
    state               := State.Top;
    c        : CHAR;
    name     : TEXT;
    tag      : TEXT;
    id       : CARDINAL;
    any      : REFANY;
    proc     : ProcInfo;
    pos      : Position;
  BEGIN
    IF errorWr = NIL THEN errorWr := Stdio.stderr; END;
    WHILE NOT Rd.EOF (rd) DO
      c := Rd.GetChar (rd);
      CASE state OF
      | State.Top => IF c = '@' THEN state := State.TopAt; END;
      | State.TopAt =>
          IF c IN Char.AlphaNumerics THEN
            Wr.PutChar (tagWr, c);
            state := State.TopTag;
          ELSE
            state := State.Top;
          END;
      | State.TopTag =>
          IF c IN Char.Punctuation + Char.Spaces THEN
            name := TextWr.ToText (tagWr);
            proc := NEW (ProcInfo);
            proc.offsets := IntRefTbl.New (4);
            pos := NEW (Position);
            tag := "0";
            id := 0;
            pos.start := Wr.Index (procWr);
            state := State.InStat;
          ELSE
            Wr.PutChar (tagWr, c);
          END;
      | State.InProc =>
          IF c = '@' THEN
            state := State.ProcAt;
          ELSE
            Wr.PutChar (procWr, c);
          END;
      | State.ProcAt =>
          IF c IN Char.Letters THEN
            Wr.PutChar (tagWr, c);
            state := State.ProcTag;
          ELSIF c IN Char.Digits THEN
            Wr.PutChar (tagWr, c);
            state := State.StatTag;
          ELSE
            state := State.InProc;
          END;
      | State.ProcTag =>
          IF c IN Char.Punctuation + Char.Spaces THEN
            tag := TextWr.ToText (tagWr);
            IF NOT Text.Equal (tag, name) THEN
              Wr.PutText (
                errorWr,
                Fmt.F (
                  "procedure trailer for '%s' does not match header\n",
                  name));
            END;
            proc.source := TextWr.ToText (procWr);
            EVAL procTable.put (name, proc);
            state := State.Top;
          ELSE
            Wr.PutChar (tagWr, c);
          END;
      | State.StatTag =>
          IF c IN Char.Digits THEN
            Wr.PutChar (tagWr, c);
          ELSE
            tag := TextWr.ToText (tagWr);
            id := Scan.Int (tag);
            IF proc.offsets.in (id, any) THEN
              Wr.PutText (
                errorWr,
                Fmt.F (
                  "duplicate statement tag '@%s' at offsets %s and %s\n",
                  tag, Fmt.Int (pos.start), Fmt.Int (Rd.Index (rd))));
            END;
            pos := NEW (Position);
            pos.start := Wr.Index (procWr);
            state := State.InStat;
          END;
      | State.InStat =>
          IF c = '@' THEN
            state := State.StatAt;
          ELSE
            Wr.PutChar (procWr, c);
          END;
      | State.StatAt =>
          IF c = '@' THEN
            Wr.PutChar (procWr, c);
            state := State.InStat;
          ELSE
            pos.end := Wr.Index (procWr);
            EVAL proc.offsets.put (id, pos);
            Wr.PutChar (procWr, c);
            state := State.InProc;
          END;
      END;
    END;

    CASE state OF
    | State.TopTag =>
        Wr.PutText (
          errorWr, "unterminated procedure header (@name) at end-of-file\n");
    | State.InProc, State.ProcAt =>
        Wr.PutText (errorWr,
                    Fmt.F (
                      "unmatched procedure header (@%s) at end-of-file\n",
                      name));
    | State.ProcTag =>
        Wr.PutText (
          errorWr,
          Fmt.F (
            "unterminated procedure trailer for '%s' at end-of-file\n",
            name));
    | State.StatTag =>
        Wr.PutText (
          errorWr,
          Fmt.F ("unterminated statement tag for '%s' at end-of-file\n",
                 name));
    | State.InStat =>
        Wr.PutText (
          errorWr,
          Fmt.F ("unterminated statement marker ('@%s') at end-of-file\n",
                 tag));
        Wr.PutText (errorWr,
                    Fmt.F (
                      "unmatched procedure header (@%s) at end-of-file\n",
                      name));
    | State.StatAt =>
        pos.end := Wr.Index (procWr);
        EVAL proc.offsets.put (Scan.Int (tag), pos);
        Wr.PutText (errorWr,
                    Fmt.F (
                      "unmatched procedure header (@%s) at end-of-file\n",
                      name));
    ELSE
    END;
    Wr.Flush (errorWr);
    RETURN procTable;
  END ParseAlg;

PROCEDURE ListNames (t: T): List.T =
  BEGIN
    RETURN t.procTable.toKeyList ();
  END ListNames;

PROCEDURE ListRegions (t: T; procedureName: TEXT): List.T =
  VAR
    refany: REFANY;
    proc  : ProcInfo;
  BEGIN
    IF t.procTable.in (procedureName, refany) THEN
      proc := refany;
      RETURN proc.offsets.toKeyList ();
    ELSE
      RETURN NIL;
    END;
  END ListRegions;

PROCEDURE Init (t         : T;
                source    : Rd.T;
                errorWr   : Wr.T     := NIL;
                fontName             := DefaultFont;
                paneOffset: CARDINAL := 20;
                background: VBT.T    := NIL          ): T =
  BEGIN
    IF background = NIL THEN
      background := BorderedVBT.New (TextureVBT.New (txt := Pixmap.Gray),
                                     0.5);
    END;
    EVAL ZSplit.T.init (t, background);
    t.procTable := ParseAlg (source, errorWr);
    t.font := Font.FromName (fontName);
    t.delta := paneOffset;
    RETURN t;
  END Init;

PROCEDURE New (source    : Rd.T;
               errorWr   : Wr.T     := NIL;
               fontName             := DefaultFont;
               paneOffset: CARDINAL := 20;
               background: VBT.T    := NIL          ): T =
  BEGIN
    RETURN Init (
             NEW (T), source, errorWr, fontName, paneOffset, background);
  END New;

BEGIN
END CodeView.