MODULE M3Error EXPORTS M3Error, M3ErrorStream;

IMPORT TextExtras, Fmt, Wr, Stdio, Thread, RefList, TextRefTbl, Atom;
IMPORT AST, M3AST_LX, M3AST_AS;
IMPORT M3AST_FE_priv;

IMPORT M3AST_LX_F, (*M3AST_AS_F,*) M3AST_SM_F, M3AST_TM_F, M3AST_FE_priv_F;

IMPORT M3CSrcPos, M3CId, M3CUnit, M3ASTWalk;
IMPORT M3Assert;

VAR
  messages_g := NEW(TextRefTbl.Default).init();
  cu_g: M3AST_AS.Compilation_Unit := NIL;
  stream_g: Wr.T := Stdio.stderr;
  warn_g := TRUE;

REVEAL Notification = Notification_public BRANDED OBJECT END;

TYPE NotificationElem = REF RECORD e: Notification END;

<* FATAL Thread.Alerted, Wr.Failure *>

VAR notifications_g: RefList.T := NIL;
    notificationsMutex_g := NEW(MUTEX);

PROCEDURE AddNotification(e: Notification) RAISES {}=
  BEGIN
    LOCK notificationsMutex_g DO
      notifications_g := RefList.AppendD(notifications_g,
                             RefList.List1(NEW(NotificationElem, e := e)));
    END; (* lock *)
  END AddNotification;

PROCEDURE RemoveNotification(e: Notification) RAISES {}=
  VAR l: RefList.T := notifications_g; prev: RefList.T := NIL;
  BEGIN
    LOCK notificationsMutex_g DO
      WHILE l # NIL DO
        IF NARROW(l.head, NotificationElem).e = e THEN
          IF prev = NIL THEN notifications_g := l.tail
          ELSE prev.tail := l.tail;
          END;
          RETURN
        END;
        prev := l; l := l.tail;
      END;
    END; (* lock *)
  END RemoveNotification;

PROCEDURE Notify(cu: M3AST_AS.Compilation_Unit; warn: BOOLEAN)=
  BEGIN
    LOCK notificationsMutex_g DO
      VAR list: RefList.T := notifications_g;
      BEGIN
        WHILE list # NIL DO
          NARROW(list.head, NotificationElem).e.notify(cu, warn);
          list := list.tail;
        END;
      END;
    END;
  END Notify;

TYPE
  NodeElem = REF RECORD
    node: ERROR_NODE;
    errors: RefList.T (* of ErrorElem *);
  END;
  ErrorElem = REF RECORD
    messageKey: Atom.T;
    a1, a2, a3, a4: M3AST_LX.Symbol_rep
  END;

REVEAL
  M3AST_FE_priv.Unit_errors = BRANDED REF RefList.T;

PROCEDURE SetCu(cu: M3AST_AS.Compilation_Unit) RAISES {} =
  BEGIN
    cu_g := cu;
    IF cu # NIL AND cu.fe_priv_errors = NIL THEN
      cu.fe_priv_errors := NEW(M3AST_FE_priv.Unit_errors);
    END;
  END SetCu;

PROCEDURE ReportAtPos(pos: M3CSrcPos.T; message: TEXT) RAISES {} =
  BEGIN
    M3Assert.Check(cu_g # NIL);
    PutError(M3CUnit.TextName(cu_g.fe_uid), pos, message);
  END ReportAtPos;

PROCEDURE Report(n: ERROR_NODE; message: TEXT) RAISES {}=
  BEGIN
    RecordError(n, message, TRUE);
  END Report;

PROCEDURE ReportWithId(n: ERROR_NODE; message: TEXT;
    id1, id2, id3, id4: M3AST_LX.Symbol_rep := NIL) RAISES {} =
  BEGIN
    RecordError(n, message, TRUE, id1, id2, id3, id4);
  END ReportWithId;

PROCEDURE Warn(pos: ERROR_NODE; message: TEXT) RAISES {} =
  BEGIN
    IF warn_g THEN RecordError(pos, "warning: " & message, FALSE); END;
  END Warn;

PROCEDURE WarnWithId(pos: ERROR_NODE; message: TEXT;
    id1, id2, id3, id4: M3AST_LX.Symbol_rep := NIL) RAISES {} =
  BEGIN
    IF warn_g THEN
      RecordError(pos, "warning: " & message, FALSE, id1, id2, id3, id4);
    END;
  END WarnWithId;

PROCEDURE SuppressWarnings(b := TRUE) RAISES {}=
  BEGIN
    warn_g := b;
  END SuppressWarnings;

PROCEDURE RecordError(
    pos: ERROR_NODE;
    message: TEXT;
    serious: BOOLEAN;
    arg1, arg2, arg3, arg4: M3AST_LX.Symbol_rep := NIL)
    RAISES {} =
  VAR
    errors: RefList.T;
    error: ErrorElem;
    cu: M3AST_AS.Compilation_Unit;
    key: Atom.T;
    nodeElem: NodeElem;
  BEGIN
    (* Redeclaration errors may be in units other than current *)
    TYPECASE pos OF
    | M3AST_AS.DEF_ID(def_id) =>
        WITH unitId = def_id.tmp_unit_id DO
          IF unitId = NIL THEN
            (* We are at an early stage of processing; the 'tmp_unit_id' has
             not been set up yet. This implies 'def_id' is declared in the
             current unit as imported units are fully semantically analysed
             (and hence have their 'tmp_unit_id' fields set up) before the
             current unit is analysed *)
            cu := cu_g;
          ELSE
            cu := unitId.sm_spec.sm_comp_unit;
          END;
        END;
    ELSE
      cu := cu_g;
    END;

    key := Atom.FromText(message);
    EVAL messages_g.put(message, key);
    IF CarefulNodeLookup(cu, pos, nodeElem) THEN
      (* not the first on this node *)
    ELSE
      nodeElem := NEW(NodeElem, node := pos, errors := NIL);
      cu.fe_priv_errors^ := RefList.AppendD(cu.fe_priv_errors^,
                                            RefList.List1(nodeElem));
    END; (* if *)
    errors := nodeElem.errors;
    WHILE errors # NIL DO
      error := NARROW(errors.head, ErrorElem);
      IF (error.messageKey = key) AND (error.a1 = arg1) AND
         (error.a2 = arg2) AND (error.a3 = arg3) AND (error.a4 = arg4) THEN
        RETURN  (* duplicate *)
      END;
      errors := errors.tail;
    END; (* while *)

    error := NEW(ErrorElem, a1 := arg1, a2 := arg2, a3 := arg3, a4 := arg4,
        messageKey := key);
    nodeElem.errors := RefList.AppendD(nodeElem.errors, RefList.List1(error));
    Notify(cu, serious);
  END RecordError;

PROCEDURE CarefulNodeLookup(
    cu: M3AST_AS.Compilation_Unit;
    n: ERROR_NODE;
    VAR (*out*) nodeElem: NodeElem)
    : BOOLEAN
    RAISES {}=
  BEGIN
    IF cu.fe_priv_errors = NIL THEN
      cu.fe_priv_errors := NEW(M3AST_FE_priv.Unit_errors);
    END;
    RETURN NodeLookup(cu.fe_priv_errors^, n, nodeElem);
  END CarefulNodeLookup;

PROCEDURE NodeLookup(
    nodes: RefList.T;
    n: ERROR_NODE;
    VAR (*out*) nodeElem: NodeElem)
    : BOOLEAN
    RAISES {}=
  BEGIN
    WHILE nodes # NIL DO
      IF NARROW(nodes.head, NodeElem).node = n THEN
        nodeElem := nodes.head;
        RETURN TRUE
      ELSE
        nodes := nodes.tail;
      END;
    END; (* while *)
    RETURN FALSE;
  END NodeLookup;

PROCEDURE Show(n: ERROR_NODE; forget := TRUE) RAISES {} =
  VAR
    nodeElem: NodeElem;
    errors: RefList.T;
    error: ErrorElem;
  BEGIN
    IF NodeLookup(cu_g.fe_priv_errors^, n, nodeElem) THEN
      errors := nodeElem.errors;
      WHILE errors # NIL DO
        error := NARROW(errors.head, ErrorElem);
        PutError(M3CUnit.TextName(cu_g.fe_uid),
                 n.lx_srcpos,
                 Atom.ToText(error.messageKey),
                 error.a1, error.a2, error.a3, error.a4);
        errors := errors.tail;
      END; (* while *)
      IF forget THEN
        cu_g.fe_priv_errors^ := RefList_DeleteD(cu_g.fe_priv_errors^, nodeElem);
      END;
    END; (* if *)

    VAR
      usedId: M3AST_AS.USED_ID;
    BEGIN
      IF n.IsA_USED_ID(usedId) AND usedId # n THEN
        Show(usedId)
      END;
    END;
  END Show;

TYPE Closure = M3ASTWalk.Closure OBJECT forget: BOOLEAN END;

PROCEDURE ShowAll(n: ERROR_NODE; forget := TRUE) RAISES {}=
  BEGIN
    (* nothing to do if cu.fe_priv_errors empty *)
    IF cu_g.fe_priv_errors^ # NIL THEN
      <* FATAL ANY *>
      BEGIN
        M3ASTWalk.VisitNodes(n,
            NEW(Closure, forget := forget, callback := DoShow));
      END;
    END; (* if *)
  END ShowAll;

PROCEDURE DoShow(cl: Closure; n: AST.NODE;
    <*UNUSED*> vm: M3ASTWalk.VisitMode) RAISES {}=
  BEGIN
    Show(n, cl.forget);
  END DoShow;

PROCEDURE PutError(name: TEXT; pos: M3CSrcPos.T;
    message: TEXT; id1, id2, id3, id4: M3AST_LX.Symbol_rep := NIL;
    ) RAISES {} =
  VAR
    line, linePos: CARDINAL;
    t, messageWithIds: TEXT;
  BEGIN
    t := Fmt.F("\"%s\"", name);
    IF pos # M3CSrcPos.Null THEN
      line := M3CSrcPos.Unpack(pos, linePos);
      t := Fmt.F("%s, line %s,%s", t, Fmt.Int(line), Fmt.Int(linePos));
    END; (* if *)
    IF id1 = NIL THEN
      (* This is not just an optimisation it is important. Some syntax errors
       may have an embedded %s in 'message' but do not want it substituted by
       an id (such messages must never contain a %s which does need
       substitution or chaos will ensue) *)
      messageWithIds := message;
    ELSE
      messageWithIds := Fmt.F(message,
                          SafeIdToText(id1),
                          SafeIdToText(id2),
                          SafeIdToText(id3),
                          SafeIdToText(id4));
    END;
    t := TextExtras.Join(t, ": ", messageWithIds);
    WITH err = stream_g DO
      Wr.PutText(err, t); Wr.PutChar(err, '\n');
    END;
  END PutError;

PROCEDURE SafeIdToText(id: M3AST_LX.Symbol_rep): TEXT RAISES {}=
  BEGIN
    IF id # NIL THEN RETURN id.toText() ELSE RETURN NIL; END;
  END SafeIdToText;

PROCEDURE Set(s: Wr.T): Wr.T RAISES {}=
  VAR
    old: Wr.T;
  BEGIN
    old := stream_g; stream_g := s; RETURN old;
  END Set;

PROCEDURE RefList_DeleteD(list: RefList.T;
                                 x: REFANY): RefList.T=
  VAR result, t: RefList.T;
  BEGIN
    IF list.head = x THEN result := list.tail
    ELSE
      result := list; t := list; list := list.tail;
      WHILE list # NIL DO
        IF list.head = x THEN t.tail := list.tail; EXIT
        ELSE t := list; list := list.tail;
        END;
      END;
    END;
    RETURN result;
  END RefList_DeleteD;

BEGIN

END M3Error.