<<>>
    <<FeedbackOpsImpl.mesa>>
        <<Copyright Ó 1988, 1990, 1991 by Xerox Corporation.  All rights reserved.>>
        <<Last edited by Bier on July 12, 1990 2:16 pm PDT>>
        <<Last tweaked by Mike Spreitzer on July 17, 1990 11:32 am PDT>>
        <<Michael Plass, November 27, 1991 9:23 am PST>>

    <<Contents:  Routines that determine where a MsgRouter will send its output.>>
    <<>>
    DIRECTORY Feedback, FeedbackClasses, FeedbackConcreteTypes, FeedbackOps, FeedbackTypes, IO, Labels, MessageWindow, Process, RefTab, 
    Rope, ViewerClasses, ViewerIO, ViewerOps, ViewerPrivate;

    FeedbackOpsImpl: CEDAR MONITOR
        LOCKS script USING script: Script
        IMPORTS Feedback, FeedbackClasses, IO, Labels, MessageWindow, Process, RefTab, Rope, ViewerIO, ViewerOps, ViewerPrivate
        EXPORTS FeedbackOps = BEGIN OPEN Feedback;

        Viewer: TYPE = ViewerClasses.Viewer;
        LOR: TYPE ~ LIST OF ROPE;

<<Typescripts>>
    <<>>
    gTypescripts: RefTab.Ref Ź RefTab.Create[]; -- all of the named typescripts that FeedbackOps knows about

    Script: TYPE = REF ScriptObj;
    ScriptObj: TYPE = MONITORED RECORD [
        viewer: Viewer, -- viewer can be NIL, if stream does not belong to a viewer
        stream: IO.STREAM,
        typescriptName: ATOM,
        storing: BOOL,
        queueHead, queueTail: FList Ź NIL, --list of PutF tasks to do
        putter: PROCESS Ź NIL, --the process, if any, doing PutFs
        change: CONDITION
        ];

    FList: TYPE ~ REF FCons;
    FCons: TYPE ~ RECORD [
        rest: FList,
        first: SELECT kind: * FROM
            blink => [],
            putf => [format: Rope.ROPE, list: LIST OF IO.Value],
            putc => [c: CHAR],
            ENDCASE];

    blinkF: FCons ~ [NIL, blink[]];

    CreateNamedTypescript: PUBLIC PROC [headerText: Rope.ROPE, typescriptName: ATOM, openHeight: NAT Ź 120, storing: BOOL Ź FALSE] 
    RETURNS [alreadyExists: BOOL Ź FALSE, typescript: Viewer] = {
        newStream: IO.STREAM;
        script: Script Ź FindScript[typescriptName];
        IF script=NIL OR script.viewer=NIL OR script.viewer.destroyed THEN {
            typescript Ź ViewerOps.CreateViewer[
                flavor: $TypeScript,
                info: [name: headerText, menu: NIL, data: NIL, iconic: TRUE, column: right, scrollable: TRUE, icon: unInit], paint: FALSE];
            ViewerOps.SetOpenHeight[typescript, openHeight];
            ViewerOps.OpenIcon[icon: typescript, closeOthers: FALSE, bottom: TRUE, paint: TRUE];
            [, newStream] Ź ViewerIO.CreateViewerStreams[headerText, typescript, NIL, TRUE];
            IF script=NIL THEN {
                script Ź NEW[ScriptObj Ź [viewer: typescript, stream: newStream, typescriptName: typescriptName, storing: storing]];
                TRUSTED {Process.InitializeCondition[@script.change, Process.MsecToTicks[1D4]]};
                [] Ź gTypescripts.Store[typescriptName, script];
                }
            ELSE SetStuff[script, newStream, typescript, storing];
            }
        ELSE { -- nothing wrong with the current typescript
            alreadyExists Ź TRUE;
            typescript Ź script.viewer};
        };

    CreateTypescriptFromStream: PUBLIC PROC [stream: IO.STREAM, typescriptName: ATOM, storing: BOOL Ź FALSE] RETURNS [alreadyExists: 
    BOOL Ź FALSE, oldStream: IO.STREAM Ź NIL] = {
        script: Script Ź FindScript[typescriptName];
        IF script=NIL THEN {
            newScript: Script Ź NEW[ScriptObj Ź [viewer: NIL, stream: stream, typescriptName: typescriptName, storing: storing]];
            TRUSTED {Process.InitializeCondition[@script.change, Process.MsecToTicks[1D4]]};
            [] Ź gTypescripts.Store[typescriptName, newScript];
            }
        ELSE {
            alreadyExists Ź TRUE; oldStream Ź script.stream;
            SetStuff[script, stream, NIL, storing];
            };
        };

    FindScript: PROC [typescriptName: ATOM] RETURNS [script: Script Ź NIL] = {
        found: BOOL Ź FALSE;
        val: REF;
        [found, val] Ź gTypescripts.Fetch[typescriptName];
        IF found THEN script Ź NARROW[val];
        };

    GetTypescriptStream: PUBLIC PROC [typescriptName: ATOM] RETURNS [IO.STREAM] = {
        script: Script Ź FindScript[typescriptName];
        IF script = NIL THEN RETURN[NIL];
        RETURN[script.stream];
        };

    GetTypescripts: PUBLIC PROC [] RETURNS [names: LIST OF ATOM] = {
        AddToList: PROC [key: RefTab.Key, val: RefTab.Val] RETURNS [quit: BOOL Ź FALSE] = {
            names Ź CONS[NARROW[key, ATOM], names];
            };
        [] Ź gTypescripts.Pairs[AddToList];
        };
<<Our two-headed handlers>>
    FeedbackData: TYPE = REF FeedbackDataObj;
    FeedbackDataObj: TYPE = RECORD [
        lp: RECORD [label: Viewer, blink: BOOL] Ź [NIL, FALSE],
        tn: ATOM Ź NIL,
        default: FeedbackData Ź NIL,
        bounded: BOOL Ź TRUE
        ];
        <<NIL label or tn means to consult default, if any.>>

    messageWindow: PUBLIC Viewer ~ ViewerPrivate.messageWindow;
    noLabel: Viewer ~ NEW [ViewerClasses.ViewerRec];

    Iv: PROC [v: Viewer] RETURNS [Viewer]
        ~ INLINE {RETURN [IF v=NIL THEN noLabel ELSE v]};

    Ov: PROC [v: Viewer] RETURNS [Viewer]
        ~ INLINE {RETURN [IF v=noLabel THEN NIL ELSE v]};

    It: PROC [a: ATOM] RETURNS [ATOM]
        ~ INLINE {RETURN [IF a=NIL THEN $None ELSE a]};

    Ot: PROC [a: ATOM] RETURNS [ATOM]
        ~ INLINE {RETURN [IF a=$None THEN NIL ELSE a]};

    CreateViewersHandler: PUBLIC PROC [typescriptName: ATOM Ź $None, label: Viewer Ź NIL, blink: BOOL Ź FALSE] RETURNS [MsgHandler] ~ {
        fd: FeedbackData ~ NEW [FeedbackDataObj Ź [[Iv[label], blink], typescriptName]];
        IF label=NIL THEN label Ź noLabel;
        RETURN FeedbackClasses.CreateHandler[VPutFL, VClearHerald, VBlink, fd]};

    IsViewersHandler: PUBLIC PROC [mh: MsgHandler] RETURNS [is: BOOL, typescriptName: ATOM Ź $None, label: Viewer Ź NIL, blink: BOOL Ź 
    FALSE] ~ {
        WITH FeedbackClasses.GetHandlerData[mh] SELECT FROM
            fd: FeedbackData => RETURN [TRUE, fd.tn, Ov[fd.lp.label], fd.lp.blink];
            ENDCASE => RETURN [FALSE]};

    HandleToLabel: PUBLIC PROC [vh: MsgHandler, label: Viewer, blink: BOOL Ź FALSE] ~ {
        WITH FeedbackClasses.GetHandlerData[vh] SELECT FROM
            fd: FeedbackData => fd.lp Ź [Iv[label], blink];
            ENDCASE => ERROR Problem["not a Viewers handler"]};

    HandleToTypescript: PUBLIC PROC [vh: MsgHandler, typescriptName: ATOM Ź $None] ~ {
        WITH FeedbackClasses.GetHandlerData[vh] SELECT FROM
            fd: FeedbackData => fd.tn Ź typescriptName;
            ENDCASE => ERROR Problem["not a Viewers handler"]};

    SetFD: PROC [router: MsgRouter, msgClass: MsgClass, label: Viewer, blink: BOOL, tn: ATOM] = {
        mh: MsgHandler;
        dh: MsgHandler Ź GetHandler[router, $Default];
        dd: FeedbackData Ź IF dh=NIL THEN NIL
            ELSE WITH FeedbackClasses.GetHandlerData[dh] SELECT FROM
                x: FeedbackData => x,
                ENDCASE => NIL;
        IF msgClass=$Every OR msgClass=$Default THEN {
            e: BOOL ~ msgClass=$Every;
            toclear: LIST OF MsgClass Ź NIL;
            PerDirection: PROC [msgClass: MsgClass, msgHandler: MsgHandler] RETURNS [BOOL] ~ {
                WITH FeedbackClasses.GetHandlerData[msgHandler] SELECT FROM
                    x: FeedbackData => IF e
                        THEN {
                            IF label#NIL THEN x.lp Ź [label, blink];
                            IF tn#NIL THEN x.tn Ź tn}
                        ELSE x.default Ź dd;
                    ENDCASE => IF e THEN toclear Ź CONS[msgClass, toclear];
                RETURN [FALSE]};
            IF dd#NIL THEN {
                IF label#NIL THEN dd.lp Ź [label, blink];
                IF tn#NIL THEN dd.tn Ź tn}
            ELSE {
                dd Ź NEW [FeedbackDataObj Ź [[Iv[label], blink], It[tn]]];
                dh Ź FeedbackClasses.CreateHandler[VPutFL, VClearHerald, VBlink, dd];
                [] Ź SetHandler[router, $Default, dh]};
            IF ScanHandlers[router, PerDirection].stopped THEN ERROR;
            SetMultiHandler[router, toclear, NIL];
            RETURN};
        mh Ź GetHandler[router, msgClass];
        IF mh#NIL THEN WITH FeedbackClasses.GetHandlerData[mh] SELECT FROM
            x: FeedbackData => {
                IF label#NIL THEN x.lp Ź [label, blink];
                IF tn#NIL THEN x.tn Ź tn;
                RETURN};
            ENDCASE => NULL;
        mh Ź FeedbackClasses.CreateHandler[VPutFL, VClearHerald, VBlink, NEW [FeedbackDataObj Ź [[label, blink], tn, dd]]];
        [] Ź SetHandler[router, msgClass, mh];
        RETURN};

    GetFD: PROC [router: MsgRouter, msgClass: MsgClass] RETURNS [fd: FeedbackData] = {
        mh: MsgHandler Ź GetHandler[router, msgClass];
        IF mh#NIL THEN WITH FeedbackClasses.GetHandlerData[mh] SELECT FROM
            x: FeedbackData => RETURN [x];
            ENDCASE => NULL;
        RETURN [NIL]};

<<Wiring up a MsgRouter to specific output streams>>
    <<>>
    SetLabel: PUBLIC PROC [router: MsgRouter, label: Viewer, blink: BOOL Ź FALSE, msgClass: MsgClass Ź $Every] = {
        SetFD[router, msgClass, Iv[label], blink, NIL];
        };

    SetMultiLabel: PUBLIC PROC [router: MsgRouter, label: Viewer, blink: BOOL Ź FALSE, msgClasses: LIST OF ATOM] = {
        FOR list: LIST OF ATOM Ź msgClasses, list.rest UNTIL list = NIL DO
            SetLabel[router, label, blink, list.first];
            ENDLOOP;
        };

    SetMessageWindow: PUBLIC PROC [router: MsgRouter, blink: BOOL Ź FALSE, msgClass: MsgClass Ź $Every] = {
        SetFD[router, msgClass, messageWindow, blink, NIL];
        };

    SetMultiMessageWindow: PUBLIC PROC [router: MsgRouter, blink: BOOL Ź FALSE, msgClasses: LIST OF ATOM] = {
        FOR list: LIST OF ATOM Ź msgClasses, list.rest UNTIL list = NIL DO
            SetMessageWindow[router, blink, list.first];
            ENDLOOP;
        };
    <<>>
    SetTypescript: PUBLIC PROC [router: MsgRouter, typescriptName: ATOM Ź $None, msgClass: MsgClass Ź $Every] = {
        SetFD[router, msgClass, NIL, FALSE, typescriptName];
        };

    SetMultiTypescript: PUBLIC PROC [router: MsgRouter, typescriptName: ATOM Ź $None, msgClasses: LIST OF ATOM] = {
        FOR list: LIST OF ATOM Ź msgClasses, list.rest UNTIL list = NIL DO
            SetTypescript[router, typescriptName, list.first];
            ENDLOOP;
        };

    CreateSimpleRouter: PUBLIC PROC [label: Viewer, blink: BOOL Ź FALSE, typescriptName: ATOM] RETURNS [router: MsgRouter] = {
        router Ź CreateRouter[];
        SetLabel[router, label, blink, $Every];
        SetTypescript[router, typescriptName, $Every];
        };

    CreateMultiFeedback: PUBLIC PROC [label: Viewer, blink: BOOL Ź FALSE, labelClasses: LIST OF ATOM, typescriptName: ATOM, 
    typescriptClasses: LIST OF ATOM] RETURNS [router: MsgRouter] = {
        router Ź CreateRouter[];
        SetMultiLabel[router, label, blink, labelClasses];
        SetMultiTypescript[router, typescriptName, typescriptClasses];
        };

<<Queries on routers (mostly for debugging)>>
    <<>>
    GetLabel: PUBLIC PROC [router: MsgRouter, msgClass: MsgClass Ź $Default] RETURNS [label: Viewer, blink: BOOL Ź FALSE] = {
        feedback: FeedbackData ~ GetFD[router, msgClass];
        IF feedback#NIL THEN RETURN [Ov[feedback.lp.label], feedback.lp.blink];
        RETURN [NIL]};

    GetTypescriptName: PUBLIC PROC [router: MsgRouter, msgClass: MsgClass Ź $Default] RETURNS [typescriptName: ATOM Ź $None] = {
        feedback: FeedbackData ~ GetFD[router, msgClass];
        IF feedback#NIL THEN RETURN [feedback.tn];
        RETURN};


<<Viewers Output Routines>>
    <<>>
    VPutFL: PROC [mh: MsgHandler, msgType: MsgType, msgClass: MsgClass, format: Rope.ROPE, list: LIST OF IO.Value Ź NIL ] ~ {
        fd: FeedbackData ~ NARROW[FeedbackClasses.GetHandlerData[mh]];
        lfd: FeedbackData ~ IF fd.lp.label#NIL OR fd.default=NIL THEN fd ELSE fd.default;
        tfd: FeedbackData ~ IF fd.tn#NIL OR fd.default=NIL THEN fd ELSE fd.default;
        lcf: BOOL ~ typeBreaksAt[msgType].begin OR lfd.bounded;
        tcf: BOOL ~ typeBreaksAt[msgType].begin OR tfd.bounded;
        msg: Rope.ROPE ~ IO.PutFLR[format, list];
        IF lfd.lp.label=noLabel OR lfd.lp.label=NIL THEN NULL
        ELSE IF lfd.lp.label=messageWindow THEN {
            MessageWindow.Append[msg, lcf];
            IF lfd.lp.blink THEN MessageWindow.Blink[]}
        ELSE {
            Labels.Set[lfd.lp.label, IF lcf THEN msg ELSE Rope.Concat[NARROW[lfd.lp.label.class.get[lfd.lp.label]], msg]];
            IF lfd.lp.blink THEN BlinkLabel[lfd.lp.label]};
        IF tfd.tn # $None THEN PutFToTypescript[tfd.tn, IF tcf THEN Rope.Concat["\n", format] ELSE format, list];
        lfd.bounded Ź tfd.bounded Ź typeBreaksAt[msgType].end;
        };

    PutFToTypescript: PROC [typescriptName: ATOM, format: Rope.ROPE, list: LIST OF IO.Value Ź NIL ] ~ {
        script: Script Ź FindScript[typescriptName];
        IF script=NIL THEN RETURN;
        IF format.Length[]=1 AND list = NIL THEN Enqueue[script, [NIL, putc[format.Fetch[0]]]]
        ELSE Enqueue[script, [NIL, putf[format, list]]];
        RETURN};

    Enqueue: ENTRY PROC [script: Script, fp: FCons] ~ {
        ENABLE UNWIND => NULL;
        IF script.stream=NIL AND NOT script.storing THEN RETURN;
        {this: FList ~ NEW [FCons Ź fp];
        IF script.queueHead=NIL
            THEN script.queueHead Ź this
            ELSE script.queueTail.rest Ź this;
        script.queueTail Ź this;
        IF script.stream=NIL THEN NULL
        ELSE IF script.putter=NIL THEN TRUSTED {Process.Detach[script.putter Ź FORK Putter[script]]}
        ELSE NOTIFY script.change;
        RETURN}};

    Deque: TYPE ~ RECORD [fh: FList, stream: IO.STREAM, sv: Viewer, quit: BOOL];

    Dequeue: ENTRY PROC [script: Script] RETURNS [Deque] ~ {
        ENABLE UNWIND => NULL;
        RETURN InnerDequeue[script]};

    InnerDequeue: INTERNAL PROC [script: Script] RETURNS [Deque] ~ {
        n: INTEGER Ź 2;
        UNTIL script.queueHead#NIL AND script.stream#NIL DO
            IF (n Ź n.PRED) < 0 THEN {
                script.putter Ź NIL;
                RETURN [[NIL, NIL, NIL, TRUE]]};
            WAIT script.change;
            ENDLOOP;
        {fh: FList ~ script.queueHead;
        script.queueHead Ź script.queueHead.rest;
        fh.rest Ź NIL;
        IF script.queueHead=NIL THEN script.queueTail Ź NIL;
        RETURN [[fh, script.stream, script.viewer, FALSE]]}};

    ClearStreamAndRequeue: ENTRY PROC [script: Script, bad: IO.STREAM, fh: FList] ~ {
        ENABLE UNWIND => NULL;
        IF fh.rest # NIL THEN ERROR;
        IF script.stream=bad THEN script.stream Ź NIL;
        fh.rest Ź script.queueHead;
        script.queueHead Ź fh;
        IF script.queueTail=NIL THEN script.queueTail Ź script.queueHead;
        RETURN};

    SetStuff: ENTRY PROC [script: Script, stream: IO.STREAM, sv: Viewer, storing: BOOL] ~ {
        script.stream Ź stream;
        script.viewer Ź sv;
        script.storing Ź storing;
        IF script.stream=NIL THEN NULL
        ELSE IF script.putter=NIL THEN TRUSTED {Process.Detach[script.putter Ź FORK Putter[script]]}
        ELSE NOTIFY script.change;
        RETURN};

    Putter: PROC [script: Script] ~ {
        <<This routine is forked to avoid deadlock.  Deadlock can occur if a client in a paint-proc calls PutFToTypescript while another 
        typescript is trying to paint.  This routine will have the paint lock and need to acquire the typescript painting process; 
        the other typescript will have the typescript editRepaintProcess and need to acquire the paint lock.  By forking this 
        routine, we allow our client to finish painting and release the paint lock, which then allows the other Typescript to 
        finish painting and release the typescript editRepaintProcess.>>
        <<Structure contorted to let Cirio see some frame (InnerPut's).>>
        InnerPut[script !UNWIND => script.putter Ź NIL];
        RETURN};

    InnerPut: PROC [script: Script] ~ {
        DO
            dq: Deque ~ Dequeue[script];
            IF dq.quit THEN RETURN;
            InnerInnerPut[script, dq];
            ENDLOOP};

    InnerInnerPut: PROC [script: Script, dq: Deque] ~ {
        WITH dq.fh SELECT FROM
            x: REF blink FCons => IF dq.sv#NIL AND NOT dq.sv.destroyed THEN ViewerOps.BlinkViewer[dq.sv];
            x: REF putf FCons => dq.stream.PutFL[x.format, x.list
                ! IO.Error => {
                    IF ec#StreamClosed THEN {
                        MessageWindow.Append[IO.PutFR["FeedbackImpl: IO Err at ts %g for fmt %g", [atom[script.typescriptName]], [rope[x.format]] ]];
                        MessageWindow.Blink[];
                        }
                    ELSE ClearStreamAndRequeue[script, stream, dq.fh];
                    CONTINUE;
                    }];
            x: REF putc FCons => dq.stream.PutChar[x.c
                ! IO.Error => {
                    IF ec#StreamClosed THEN {
                        MessageWindow.Append[IO.PutFR1["FeedbackImpl: IO Err at ts %g for PutChar", [atom[script.typescriptName]] ]];
                        MessageWindow.Blink[];
                        }
                    ELSE ClearStreamAndRequeue[script, stream, dq.fh];
                    CONTINUE;
                    }];
            ENDCASE => ERROR;
        RETURN};

    VClearHerald: PROC [mh: MsgHandler, msgClass: MsgClass] ~ {
        fd: FeedbackData Ź NARROW[FeedbackClasses.GetHandlerData[mh]];
        IF fd.lp.label=NIL AND fd.default#NIL THEN fd Ź fd.default;
        IF fd.lp.label=NIL OR fd.lp.label=noLabel THEN NULL
        ELSE IF fd.lp.label=messageWindow THEN MessageWindow.Clear[]
        ELSE Labels.Set[fd.lp.label, NIL];
        RETURN};

    VBlink: PROC [mh: MsgHandler, msgClass: MsgClass] ~ {
        fd: FeedbackData Ź NARROW[FeedbackClasses.GetHandlerData[mh]];
        IF fd.lp.label=NIL AND fd.default#NIL THEN fd Ź fd.default;
        IF fd.lp.label=NIL OR fd.lp.label=noLabel THEN {
            IF fd.tn#$None THEN {
                script: Script ~ FindScript[fd.tn];
                IF script#NIL THEN Enqueue[script, blinkF]
                }
            }
        ELSE IF fd.lp.label=messageWindow THEN MessageWindow.Blink[]
        ELSE BlinkLabel[fd.lp.label];
        RETURN};

    BlinkLabel: PROC [label: Viewer] = {
        Labels.SetDisplayStyle[label, $WhiteOnBlack];
        Process.Pause[Process.MsecToTicks[150]];
        Labels.SetDisplayStyle[label, $BlackOnWhite];
        Process.Pause[Process.MsecToTicks[150]];
        Labels.SetDisplayStyle[label, $WhiteOnBlack];
        Process.Pause[Process.MsecToTicks[150]];
        Labels.SetDisplayStyle[label, $BlackOnWhite];
        };

    END.