gef/src/GEFView.m3


Copyright (C) 1994, Digital Equipment Corp.

MODULE GEFView EXPORTS GEFView, GEFViewClass;

IMPORT Algorithm, Bundle, CodeView, Filename, FileRd, Filter, Fmt,
       FormsVBT, gefBundle, gefeventAlgClass, gefeventViewClass,
       gefeventTranscriptView, gefeventIE, GEF, GEFAlg,
       GEFClass, GEFError, GEFLisp, GraphVBTExtras,
       OSError, RefList, Rd, IntRefTbl, Rect, Rsrc,
       SLisp, SLispClass, Sx, Text, TextRd, Thread, VBT, View AS ZeusView,
       ZeusClass, ZeusCodeView, ZeusPanel, ZeusPanelFriends;
--------------------------- Interpreter -----------------------

REVEAL
  Interp = SLisp.T BRANDED OBJECT
    rd: Rd.T;
    intervals: IntRefTbl.T;
    view: ZeusView.T;
  OVERRIDES
    init := InitInterp;
    error := ParseError;
  END;

PROCEDURE InitInterp (interp: SLisp.T): SLisp.T =
  BEGIN
    EVAL SLisp.T.init(interp);
    interp.defineFun(NEW(SLisp.Builtin, name := "Feedback", minArgs := 1,
                         maxArgs := LAST(INTEGER), apply := SLispFeedback));
    RETURN interp;
  END InitInterp;

PROCEDURE SLispFeedback (<*UNUSED*> self: SLisp.Builtin; i: SLisp.T; args: RefList.T):
  REFANY RAISES {SLisp.Error} =
  VAR
    interp: Interp := i;
    name           := interp.eval(args.head);
    <* FATAL Sx.PrintError *>
  BEGIN
    TRY
      TYPECASE name OF
      | NULL => RETURN interp.error("No name given for feedback event");
      | TEXT (nm) =>
          gefeventIE.Feedback(
            interp.view, nm, GEFLisp.QuoteList(GEFLisp.EvalList(interp, args.tail)));
      ELSE
        RETURN interp.error(Fmt.F("Bad value given for feedback event name: %s",
                                  SLispClass.SxToText(name)));
      END;
    EXCEPT
    | Thread.Alerted => RAISE SLisp.Error
    END;
    RETURN NIL;
  END SLispFeedback;

TYPE
  ErrorClosure = Thread.Closure OBJECT
                   msg      : TEXT;
                   interp   : Interp;
                   evalStack: RefList.T;
                 OVERRIDES
                   apply := ErrorApply;
                 END;

PROCEDURE FindSx (t: IntRefTbl.T; form: SLisp.Sexp): SLispClass.Range =
  VAR
    iter: IntRefTbl.Iterator;
    start: INTEGER;
    ref  : REFANY;
    r    : SLispClass.Range;
  BEGIN
    IF t = NIL THEN RETURN NIL END;
    iter                    := t.iterate();
    WHILE iter.next(start, ref) DO
      r := ref;
      IF r.form = form THEN RETURN r END
    END;
    RETURN NIL
  END FindSx;

PROCEDURE ErrorApply (cl: ErrorClosure): REFANY =
  <* FATAL Rd.Failure, Thread.Alerted, SLisp.Error *>
  BEGIN
    LOCK VBT.mu DO
      ZeusPanel.ReportError(cl.msg);
      VAR
        evalStack                   := cl.evalStack;
        range    : SLispClass.Range;
      BEGIN
        WHILE evalStack # NIL DO
          range := FindSx(cl.interp.intervals, evalStack.head);
          IF range # NIL THEN
            Rd.Seek(cl.interp.rd, range.start);
            ZeusPanel.ReportError(
              Fmt.F("  at char %s: %s", Fmt.Int(range.start),
                    Rd.GetText(cl.interp.rd, range.end - range.start + 1)));
            EXIT
          END;
          evalStack := evalStack.tail;
        END;
      END;
      ZeusPanel.ReportError("Backtrace");
      EVAL cl.interp.sEval("(backtrace)");
      ZeusPanel.Abort();
    END;
    RETURN NIL
  END ErrorApply;

PROCEDURE ParseError (t: Interp; msg: TEXT): REFANY RAISES {SLisp.Error} =
  BEGIN
    EVAL Thread.Fork(NEW(ErrorClosure, interp := t,
                         evalStack := t.evalStack, msg := msg));
    RAISE SLisp.Error;
  END ParseError;
--------------------------- View -------------------------------

REVEAL
  ViewClass = gefeventViewClass.T BRANDED OBJECT END;
  View = ViewPublic BRANDED OBJECT
           name: TEXT;
         OVERRIDES
           init    := InitView;
           oeInit  := OEInit;
           oeEvent := OEEvent;
           ueUpdate := UEUpdate;
         END;

TYPE MouseGEF = GEF.T OBJECT OVERRIDES mouse := Mouse END;

PROCEDURE Mouse (graph: MouseGEF; READONLY cd: VBT.MouseRec) =
  BEGIN
    IF cd.clickType = VBT.ClickType.LastUp AND cd.clickCount = 1
         AND NOT cd.cp.gone THEN
      VAR
        rect       := Rect.FromPoint(cd.cp.pt);
        vertices   := graph.verticesAt(rect);
        edges      := graph.edgesAt(rect);
        highlights := graph.vertexHighlightsAt(rect);
        polygons   := graph.polygonsAt(rect);
        worldPt    := GraphVBTExtras.ScreenPtToWorldPos(graph, cd.cp.pt);
      <* FATAL GEFError.T *>
      BEGIN
        TRY
          GEF.InvokeEvent(
            graph, "MouseFeedback",
            GEFLisp.QuoteList(
              RefList.FromArray(
                ARRAY [0 .. 4] OF
                  REFANY{RefList.List2(Sx.FromReal(worldPt[0]),
                                       Sx.FromReal(worldPt[1])), vertices,
                         highlights, edges, polygons})));
        EXCEPT
          Thread.Alerted =>
        END;
      END;
    END;
  END Mouse;

PROCEDURE InitView (v: View): View =
  <* FATAL SLisp.Error *>
  VAR
    interp := NEW(Interp, view := v).init();
    gef    := NEW(MouseGEF).init(interp);
  BEGIN
    RETURN gefeventViewClass.T.init(v, gef);
  END InitView;

PROCEDURE ReportError(msg: TEXT) =
  BEGIN
    ZeusPanel.ReportError(msg);
    ZeusPanel.Abort();
  END ReportError;

PROCEDURE OEInit (v: View; files: RefList.T) =
  VAR file := MatchName(files, v.name);
  BEGIN
    TRY
      GEF.InitFromRsrc(Filter.Child(v), file, ZeusPanel.GetPath());
    EXCEPT
    | Thread.Alerted =>
    | Rsrc.NotFound =>
        ReportError(
          Fmt.F("GEF View error: Could not find file: %s", file));
    | Rd.Failure =>
        ReportError(
          Fmt.F("GEF View error finding or parsing file: %s", file));
    | GEFError.T (msg) =>
        ReportError(
          Fmt.F("GEF View error (%s) parsing file: %s", msg, file));
    END;
  END OEInit;

PROCEDURE OEEvent (v: View; name: TEXT; data: RefList.T) =
  <* FATAL GEFError.T *>
  VAR gef: GEF.T := Filter.Child(v);
  BEGIN
    TRY
      GEF.InvokeEvent(gef, name, data, FALSE);
      gef.redisplay();
      gef.animate(0.0, 1.0);
    EXCEPT
    | Thread.Alerted =>
    END;
  END OEEvent;

PROCEDURE UEUpdate (v: View; name: TEXT; data: RefList.T) =
  <* FATAL GEFError.T *>
  VAR gef: GEF.T := Filter.Child(v);
  BEGIN
    TRY
      GEF.InvokeEvent(gef, name, data, FALSE);
      gef.redisplay();
      gef.animate(0.0, 1.0);
    EXCEPT
    | Thread.Alerted =>
    END;
  END UEUpdate;

PROCEDURE NewView(): ZeusView.T =
  BEGIN
    RETURN NEW(View, name := ZeusPanelFriends.whichView).init();
  END NewView;
------------------- Algorithm -------------------------

REVEAL
  AlgClass = gefeventAlgClass.T BRANDED OBJECT
               interp: GEFAlg.Interp;
             OVERRIDES
               feFeedback := FeedbackAlg;
             END;

  Alg = AlgPublic BRANDED OBJECT
          sx       : REFANY;
          viewFiles: RefList.T;
        OVERRIDES
          init := InitAlg;
          run  := RunAlg;
        END;

PROCEDURE InitAlg (alg: Alg; algFile: TEXT; viewFiles: RefList.T): Alg =
  (* If it doesn't work, it should crash *)
  BEGIN
    TRY
      alg.viewFiles := viewFiles;
      alg.interp := NEW(GEFAlg.Interp).init(alg);
      alg.sx := SLisp.Read(Rsrc.Open(algFile, ZeusPanel.GetPath()));
      RETURN gefeventAlgClass.T.init(alg);
    EXCEPT
    | Rsrc.NotFound =>
        ReportError(
          Fmt.F("GEF Alg error: Could not find file: %s", algFile));
    | Rd.EndOfFile, Rd.Failure, Sx.ReadError =>
        ReportError(
          Fmt.F("GEF Alg error: Problem reading file: %s", algFile));
    END;
    RETURN NIL; (* will crash *)
  END InitAlg;

PROCEDURE MatchName (list: RefList.T; name: TEXT): TEXT =
  VAR assoc: RefList.T;
  BEGIN
    WHILE list # NIL DO
      assoc := list.head;
      IF Text.Equal(assoc.head, name) THEN
        RETURN assoc.tail.head
      END;
      list := list.tail;
    END;
    RETURN NIL
  END MatchName;

PROCEDURE NewAlg (): Algorithm.T =
  VAR algFile := MatchName(algsGlobal, ZeusPanelFriends.whichAlg);
  BEGIN
    IF algFile = NIL THEN
      ReportError(Fmt.F("No algorithm file given for algorithm: %s",
                        ZeusPanelFriends.whichAlg));
      RETURN NIL
    ELSE
      RETURN
        NEW(Alg, codeViews := codeViewsGlobal).init(algFile, viewsGlobal)
    END;
  END NewAlg;

PROCEDURE RunAlg(alg: Alg) RAISES {Thread.Alerted} =
  BEGIN
    TRY
      gefeventIE.Init(alg, alg.viewFiles);
      EVAL alg.interp.eval(alg.sx)
    EXCEPT
    | SLisp.Error => RAISE Thread.Alerted
    END;
  END RunAlg;

PROCEDURE FeedbackAlg(alg: AlgClass; function: TEXT; args: RefList.T) =
  BEGIN
    GEFAlg.Feedback(alg.interp, function, args);
  END FeedbackAlg;
--------------------- generic procs -----------------------

VAR
  algsGlobal, viewsGlobal, codeViewsGlobal: RefList.T;

PROCEDURE Create (sessionName: TEXT; views, algs, codeViews: RefList.T) =
  BEGIN
    algsGlobal := algs;
    viewsGlobal := views;
    codeViewsGlobal := codeViews;
    WHILE algs # NIL DO
      ZeusPanel.RegisterAlg(NewAlg, NARROW(algs.head, RefList.T).head, sessionName);
      algs := algs.tail;
    END;
    WHILE views # NIL DO
      ZeusPanel.RegisterView(NewView, NARROW(views.head, RefList.T).head, sessionName);
      views := views.tail;
    END;
    ZeusPanel.RegisterView(
      NewTranscriptView, sessionName & " Transcript View", sessionName);
  END Create;

PROCEDURE Event (alg: AlgClass; event: TEXT; data: RefList.T)
  RAISES {Thread.Alerted} =
  BEGIN
    gefeventIE.Event(alg, event, data);
  END Event;

PROCEDURE Update (alg: AlgClass; event: TEXT; data: RefList.T)
  RAISES {Thread.Alerted} =
  BEGIN
    gefeventIE.Update(alg, event, data);
  END Update;

PROCEDURE Pause(alg: AlgClass) RAISES {Thread.Alerted} =
  BEGIN
    gefeventIE.Pause(alg);
  END Pause;

PROCEDURE Init(alg: AlgClass; file: TEXT) RAISES {Thread.Alerted} =
  BEGIN
    gefeventIE.Init(alg, RefList.List1(RefList.List2("Test view", file)));
  END Init;

PROCEDURE NewTranscriptView(): ZeusView.T =
  BEGIN
    RETURN NEW(gefeventTranscriptView.T).init();
  END NewTranscriptView;
------------------------- Testing alg and view --------------------------

TYPE
  TestAlg = AlgClass OBJECT
  OVERRIDES
    run := TestAlgRun;
  END;

PROCEDURE NewTestAlg (): Algorithm.T =
  VAR
    fv  := ZeusPanel.NewForm("geftest.fv");
    alg := NEW(TestAlg, data := fv).init();
  BEGIN
    RETURN alg;
  END NewTestAlg;

PROCEDURE TestAlgRun (alg: TestAlg) RAISES {Thread.Alerted} =
  VAR
    algFile, viewFile, codeviewFile: TEXT;
    interp                                := NEW(GEFAlg.Interp).init(alg);
    sx: REFANY;
    cv: CodeView.T;
  <* FATAL FormsVBT.Error, FormsVBT.Unimplemented *>
  BEGIN
    alg.interp := interp;
    LOCK VBT.mu DO
      algFile := FormsVBT.GetText(alg.data, "algFile");
      viewFile := FormsVBT.GetText(alg.data, "viewFile");
      codeviewFile := FormsVBT.GetText(alg.data, "codeviewFile");
    END;

    IF Text.Length(algFile) = 0 THEN
      ReportError("Need file name for algorithm file.");
      RETURN
    END;
    IF Text.Length(viewFile) = 0 THEN
      ReportError("Need file name for view file.");
      RETURN
    END;

    IF testCodeview # NIL AND Text.Length(codeviewFile) # 0 THEN
      TRY
        cv := NEW(CodeView.T).init(
                FileRd.Open(Filename.ExpandTilde(codeviewFile)));
        EVAL Filter.Replace(testCodeview, cv);
        testCodeview.cv := cv;
      EXCEPT
      | Rd.EndOfFile =>
          ReportError(
            "Unexpected end of file in codeview file: " & codeviewFile);
      | Rd.Failure, Filename.Error, OSError.E =>
          ReportError(
            "Could not open codeview file: " & codeviewFile);
      END;
    END;
    Init(alg, viewFile);
    TRY
      sx := SLisp.Read(FileRd.Open(Filename.ExpandTilde(algFile)));
      EVAL interp.eval(sx)
    EXCEPT
    | Sx.ReadError (msg) =>
        ReportError("Error reading algorithm file: " & msg);
    | Rd.EndOfFile =>
        ReportError(
          "Unexpected end of file in algorithm file: " & algFile);
    | Rd.Failure, Filename.Error, OSError.E =>
        ReportError("Could not open algorithm file: " & algFile);
    | SLisp.Error =>
    END;
  END TestAlgRun;

TYPE
  TestView = View OBJECT
    OVERRIDES
      oeInit := TestOEInit;
    END;

PROCEDURE NewTestView(): ZeusView.T =
  BEGIN
    RETURN NEW(TestView).init();
  END NewTestView;

VAR
  testCodeview: ZeusCodeView.T;

TYPE
  ZCV = ZeusCodeView.T OBJECT
  OVERRIDES
    isCompat:= CodeViewCompat;
  END;

PROCEDURE CodeViewCompat(<* UNUSED *> v: ZCV; alg: ZeusClass.T): BOOLEAN =
  BEGIN
    RETURN ISTYPE(alg, TestAlg)
  END CodeViewCompat;

PROCEDURE NewTestCodeView (): ZeusView.T =
  VAR cv := NEW(CodeView.T).init(TextRd.New(""));
  BEGIN
    testCodeview := NEW(ZCV, cv := cv).init(cv);
    RETURN testCodeview;
  END NewTestCodeView;

PROCEDURE TestOEInit (v: View; files: RefList.T) RAISES {Thread.Alerted} =
  VAR
    gef      : GEF.T  := Filter.Child(v);
    interp   : Interp := gef.interp;
    intervals         := NEW(IntRefTbl.Default).init();
    file     : TEXT   := NARROW(files.head, RefList.T).tail.head;
  BEGIN
    interp.intervals := intervals;
    TRY
      interp.rd := FileRd.Open(Filename.ExpandTilde(file));
      GEF.InitFromRd(gef, interp.rd, intervals);
    EXCEPT
    | OSError.E, Filename.Error =>
        ReportError("TextView error opening file: " & file)
    | Rd.Failure =>
        ReportError(
          Fmt.F("TestView error finding or parsing file: %s", file));
    | GEFError.T (msg) =>
        ReportError(
          Fmt.F("TestView error (%s) parsing file: %s", msg, file));
    END;
  END TestOEInit;

VAR
  inited := FALSE;
  mu := NEW(MUTEX);

PROCEDURE RegisterSession () =
  VAR init: BOOLEAN;
  BEGIN
    LOCK mu DO init := NOT inited; inited := TRUE; END;
    IF init THEN
      ZeusPanel.SetSessTitle("gefevent", "GEF Testing");
      ZeusPanel.RegisterAlg(NewTestAlg, "Test algorithm", "gefevent");
      ZeusPanel.RegisterView(
        NewTestCodeView, "Test Codeview", "gefevent", TRUE);
      ZeusPanel.RegisterView(NewTestView, "Test view", "gefevent");
    END;
  END RegisterSession;

PROCEDURE GetBundle (): Bundle.T =
  BEGIN
    RETURN gefBundle.Get();
  END GetBundle;

BEGIN
END GEFView.

interface CodeView is in:


interface Filename is in: