MODULE Args;

(***************************************************************************)
(*                      Copyright (C) Olivetti 1989                        *)
(*                          All Rights reserved                            *)
(*                                                                         *)
(* Use and copy of this software and preparation of derivative works based *)
(* upon this software are permitted to any person, provided this same      *)
(* copyright notice and the following Olivetti warranty disclaimer are     *) 
(* included in any copy of the software or any modification thereof or     *)
(* derivative work therefrom made by any person.                           *)
(*                                                                         *)
(* This software is made available AS IS and Olivetti disclaims all        *)
(* warranties with respect to this software, whether expressed or implied  *)
(* under any law, including all implied warranties of merchantibility and  *)
(* fitness for any purpose. In no event shall Olivetti be liable for any   *)
(* damages whatsoever resulting from loss of use, data or profits or       *)
(* otherwise arising out of or in connection with the use or performance   *)
(* of this software.                                                       *)
(***************************************************************************)

IMPORT Text, CharType, TextTo, Fmt, HashText, SList;
IMPORT TextExtras;


CONST
  KeywordPrefix = '-';
  KeywordPrefixText = "-";

  Spacer = ' ';
  AlternativeSep = '=';
  TypeSep = '/';
  EmptySList = SList.T{};


TYPE
  Key = OBJECT
    quota: CARDINAL := 1;
    exact := TRUE;
    required := FALSE;
    positional := FALSE;
    index: CARDINAL;
    names := EmptySList;
    cghack: REF INTEGER;
  END;

  Error = {None,
     RequiredArgMissing, TooFewArgs, TooManyArgs, KeyAppearsMoreThanOnce};


REVEAL
  Template = BRANDED OBJECT
    table: HashText.Table;
    count: CARDINAL := 0;
    keys: REF ARRAY OF Key := NIL;
  END;

  Handle = BRANDED OBJECT
    errors := 0;
    template: Template;
    values: REF ARRAY OF REF ARRAY OF TEXT;
    errorList: REF ARRAY OF Error := NIL;
    leftOver := EmptySList;
  END;


(* Utilities *)

<*INLINE*> PROCEDURE AddRear(VAR l: SList.T; t: Text.T) RAISES {}=
  BEGIN
    (* Append text to SList.T *)
    SList.AddRear(l, NEW(SList.TextElem, text := t));
  END AddRear;


<*INLINE*> PROCEDURE Copy(READONLY args: T): REF T RAISES {}=
  VAR
    new := NEW(REF ARRAY OF TEXT, NUMBER(args));
  BEGIN
    new^ := args;
    RETURN new;
  END Copy;


<*INLINE*> PROCEDURE Concatenate(READONLY args1, args2: T): REF T RAISES {}=
  VAR
    length1 := NUMBER(args1);
    length2 := NUMBER(args2);
    new := NEW(REF ARRAY OF TEXT, length1 + length2);
  BEGIN
    SUBARRAY(new^, 0, length1) := args1;
    SUBARRAY(new^, length1, length2) := args2;
    RETURN new;
  END Concatenate;


(* Parsing key strings and building a template *)

PROCEDURE EnterKeyName(
    table: HashText.Table;
    t: Text.T;
    k: Key)
    RAISES {BadTemplate}=
  VAR
    id: HashText.Id;
  BEGIN
    (* Add keyword to text hash table; no duplicates allowed *)
    IF HashText.Enter(table, t, id) THEN
      HashText.Associate(table, id, k);
    ELSE
      RAISE BadTemplate;
    END; (* if *)
  END EnterKeyName;


<*INLINE*> PROCEDURE EnterKeyNames(
    template: Template;
    key: Key)
    RAISES {BadTemplate}=
  BEGIN
    (* Make key accessible via hash table; its names are entered both with and
     without the special keyword prefix character *)
    VAR
      te: SList.TextElem := key.names.head;
    BEGIN
      WHILE te # NIL DO
        EnterKeyName(template.table, te.text, key);
        EnterKeyName(template.table, KeywordPrefixText & te.text, key);
        te := te.next;
      END;
    END;
  END EnterKeyNames;


<*INLINE*> PROCEDURE CheckKeyTypeValid(
    t, longForm: Text.T)
    RAISES {BadTemplate}=
  BEGIN
    IF Text.Length(t) > 1 AND NOT TextExtras.CIEqual(t, longForm) THEN
      RAISE BadTemplate;
    END; (* if *)
  END CheckKeyTypeValid;


PROCEDURE KeyType(
    key: Key;
    t: Text.T)
    RAISES {BadTemplate}=
  VAR
    ch := CharType.ToUpper(Text.GetChar(t, 0));
  BEGIN
    IF ch = 'R' THEN
      CheckKeyTypeValid(t, "required");
      key.required := TRUE;
    ELSIF ch = 'L' THEN
      CheckKeyTypeValid(t, "list");
      key.quota := LAST(CARDINAL);
      key.exact := FALSE;
    ELSIF ch = 'F' THEN
      CheckKeyTypeValid(t, "flag");
      key.quota := 0;
    ELSIF ch = 'P' THEN
      CheckKeyTypeValid(t, "positional");
      key.positional := TRUE;
    ELSIF ch IN CharType.Digit AND TextTo.Card(t, key.quota) THEN
      key.exact := (ch # '0');
    ELSE
      RAISE BadTemplate;
    END;
  END KeyType;


PROCEDURE GetItem(
    t: Text.T;
    terminators: SET OF CHAR;
    limit: CARDINAL;
    VAR pos: CARDINAL;
    VAR item: Text.T)
    : CHAR
    RAISES {BadTemplate}=
  VAR
    start := pos;
  BEGIN
    (* Extract next alphanumeric item and return terminating character or
     '\000' if we have reached 'limit'. The value of 'item' returned is
     always at least one character long and alphanumeric *)
    EVAL TextExtras.FindCharSet(t, CharType.All - CharType.AlphaNumeric, pos);
    IF pos = start THEN RAISE BadTemplate END;
    item := Text.Sub(t, start, pos - start);
    IF pos >= limit THEN
      RETURN '\000';
    ELSE
      WITH ch = Text.GetChar(t, pos) DO
        INC(pos);
        IF pos >= limit OR NOT ch IN terminators THEN RAISE BadTemplate END;
        RETURN ch;
      END;
    END;
  END GetItem;


PROCEDURE ParseKey(
    template: Template;
    t: Text.T;
    start, end: CARDINAL)
    RAISES {BadTemplate}=
  CONST
    BothSeps = SET OF CHAR {AlternativeSep, TypeSep};
    JustTypeSep = SET OF CHAR {TypeSep};
  VAR
    key := NEW(Key, index := template.count);
    pos := start;
    item: Text.T;
    ch: CHAR;
  BEGIN
    (* Build list of the alternative names of the key *)
    REPEAT
      ch := GetItem(t, BothSeps, end, pos, item);
      IF NOT Text.GetChar(item, 0) IN CharType.Alphabetic THEN
        RAISE BadTemplate;
      END;
      AddRear(key.names, item);
    UNTIL ch # AlternativeSep;

    (* Discover the type of the key *)
    WHILE ch = TypeSep DO
      ch := GetItem(t, JustTypeSep, end, pos, item);
      KeyType(key, item);
    END;
      
    (* Add the key names to the template *)
    EnterKeyNames(template, key);
  END ParseKey;


PROCEDURE NewTemplate(t: Text.T): Template RAISES {BadTemplate}=
  VAR
    template := NEW(Template, table := HashText.CINew(128));
  BEGIN
    (* Parse 't' and build up hash table containing all keys *)
    VAR
      start, pos: CARDINAL := 0;
    BEGIN
      WHILE TextExtras.FindCharSet(t, CharType.All - SET OF CHAR {Spacer}, pos) DO
        start := pos;
        WITH last = NOT TextExtras.FindChar(t, Spacer, pos) DO
          ParseKey(template, t, start, pos);
          INC(template.count);
          IF last THEN EXIT ELSE INC(pos) END;
        END;
      END;
    END;

    (* Build array so the keys can be accessed by index *)
    IF template.count > 0 THEN
      VAR
        i := HashText.NewIterator(template.table);
        key: Text.T;
        value: REFANY;
      BEGIN
        template.keys := NEW(REF ARRAY OF Key, template.count);
        WHILE HashText.Next(i, key, value) DO
          WITH key = NARROW(value, Key) DO
            template.keys[key.index] := key;
          END;
        END; <* UNEXPECTED HashText.Broken *>
      END;
    END;

    RETURN template;
  END NewTemplate;


(* Decoding arguments and building the argument handle *)

PROCEDURE LooksLikeKeyword(t: Text.T): BOOLEAN RAISES {}=
  BEGIN
    RETURN Text.Length(t) >= 2 AND Text.GetChar(t, 0) = KeywordPrefix AND
        Text.GetChar(t, 1) IN CharType.Alphabetic;
  END LooksLikeKeyword;


<*INLINE*> PROCEDURE IsKeyword(
    h: Handle;
    t: Text.T;
    VAR key: Key)
    : BOOLEAN
    RAISES {}=
  VAR
    id: HashText.Id;
  BEGIN
    IF HashText.Lookup(h.template.table, t, id) THEN
      key := HashText.Value(h.template.table, id);
      RETURN TRUE;
    ELSE
      RETURN FALSE;
    END;
  END IsKeyword;


PROCEDURE CheckedArgValue(t: Text.T): Text.T RAISES {}=
  VAR
    length := Text.Length(t);
  BEGIN
    IF length >= 2 AND Text.GetChar(t, 0) = KeywordPrefix AND
        Text.GetChar(t, 1) = KeywordPrefix THEN
      RETURN Text.Sub(t, 1, length - 1);
    ELSE
      RETURN t;
    END; (* if *)
  END CheckedArgValue;


PROCEDURE NewErrorList(number: CARDINAL): REF ARRAY OF Error RAISES {}=
  VAR
    new := NEW(REF ARRAY OF Error, number);
  BEGIN
    FOR i := 0 TO number - 1 DO new[i] := Error.None END;
    RETURN new;
  END NewErrorList;


<*INLINE*> PROCEDURE NoteError(h: Handle; key: Key; newError: Error) RAISES {}=
  BEGIN
    IF h.errorList = NIL THEN
      h.errorList := NewErrorList(h.template.count);
    END;
    WITH error =  h.errorList[key.index] DO
      IF error = Error.None THEN
        error := newError;
        INC(h.errors);
      END;
    END;
  END NoteError;


<*INLINE*> PROCEDURE MoveListOfArgs(
    VAR from: ARRAY OF TEXT)
    : REF ARRAY OF TEXT
    RAISES {}=
  VAR
    number := NUMBER(from);
    new := NEW(REF ARRAY OF TEXT, number);
  BEGIN
    FOR i := 0 TO number - 1 DO
      WITH f = from[i] DO
        new[i] := CheckedArgValue(f);
        f := NIL;
      END;
    END;
    RETURN new;
  END MoveListOfArgs;


VAR
  null_g := NEW(REF ARRAY OF TEXT, 0);


PROCEDURE BindValue(h: Handle; key: Key; VAR args: T) RAISES {}=
  VAR
    quota := key.quota;
    error := Error.None;
  BEGIN
    WITH value = h.values[key.index] DO

      IF value # NIL THEN
        error := Error.KeyAppearsMoreThanOnce;
      ELSIF NUMBER(args) > quota THEN
        error := Error.TooManyArgs;
      ELSIF key.exact AND NUMBER(args) < quota THEN
        error := Error.TooFewArgs;
      END;

      IF error = Error.None THEN
        value := MoveListOfArgs(args);
      ELSE
        IF value = NIL THEN value := null_g END;
        NoteError(h, key, error);
        FOR i := 0 TO LAST(args) DO args[i] := NIL END;
      END;

    END;
  END BindValue;


PROCEDURE FindNextKeyword(
    READONLY args: T;
    pos: CARDINAL;
    VAR argCount: CARDINAL)
    : CARDINAL
    RAISES {}=
  VAR
    countArgs := TRUE;
  BEGIN
    argCount := 0;
    LOOP
      IF pos >= NUMBER(args) THEN RETURN pos END;
      WITH arg = args[pos] DO
        IF arg = NIL THEN
          countArgs := FALSE;
        ELSIF LooksLikeKeyword(arg) THEN
          RETURN pos;
        ELSE
          IF countArgs THEN INC(argCount) END;
        END;
      END;
      INC(pos);
    END;
  END FindNextKeyword;


PROCEDURE KeywordArgs(h: Handle; VAR args: T) RAISES {}=
  VAR
    argCount: CARDINAL;
    i := FindNextKeyword(args, 0, argCount);
  BEGIN
    WHILE i <= LAST(args) DO
      WITH arg = args[i] DO
        INC(i);
        VAR
          key: Key;
          next := FindNextKeyword(args, i, argCount);
        BEGIN
          IF IsKeyword(h, arg, key) THEN
            arg := NIL;
            IF i + argCount > LAST(args) AND key.quota < argCount THEN
              argCount := key.quota;
            END;
            WITH argsForKey = SUBARRAY(args, i, argCount) DO
              BindValue(h, key, argsForKey);
            END;
          END;
          i := next;
        END;
      END;
    END;
  END KeywordArgs;


PROCEDURE FindTrailingArgs(
    READONLY args: T;
    VAR pos: CARDINAL)
    : BOOLEAN
    RAISES {}=
  VAR
    search := NUMBER(args);
  BEGIN
    LOOP
      IF search = 0 THEN
        EXIT;
      ELSE
        DEC(search);
      END;
      WITH arg = args[search] DO
        IF arg = NIL THEN
          INC(search); (* So 'search' points after the NIL *)
          EXIT;
        ELSIF LooksLikeKeyword(arg) THEN
          RETURN FALSE;
        ELSE
          (* loop *)
        END;
      END;
    END;
    (* Exit to here means we hit the start of the argument array or a NIL
     argument before hitting any keywords. If there are any arguments after
     this point we have found trailing arguments *)
    IF search < NUMBER(args) THEN
      pos := search;
      RETURN TRUE;
    ELSE
      RETURN FALSE;
    END;
  END FindTrailingArgs;


PROCEDURE PositionalArgs(h: Handle; VAR args: T) RAISES {}=
  VAR
    aPos: CARDINAL := 0;
    limit: CARDINAL;
  BEGIN
    (* First check that we have some arguments to bind; only arguments at the
     head and tail of the argument array can be bound positionally *)
    EVAL FindNextKeyword(args, 0, limit);
    IF limit = 0 THEN
      IF NOT FindTrailingArgs(args, aPos) THEN RETURN END;
      limit := NUMBER(args);
    END;

    (* Iterate the keys, looking for those which can be bound positionally *)
    WITH keys = h.template.keys^ DO
      FOR kPos := FIRST(keys) TO LAST(keys) DO
        WITH key = keys[kPos] DO

          (* Check if we can bind positionally to this keyword *)
          IF key.positional AND key.quota # 0 THEN

            (* If is already bound then we terminate processing of
             positional args *)
            IF h.values[key.index] # NIL THEN RETURN END;

            (* Check we have some values to bind *)
            IF aPos = limit THEN
              IF limit < NUMBER(args) AND FindTrailingArgs(args, aPos) THEN
                (* We found some more at the tail of the argument array *)
                limit := NUMBER(args);
              ELSE
                RETURN; (* We've run out *)
              END;
            END;

            (* Bind as many values as we can *)
            WITH argCount = MIN(limit - aPos, key.quota) DO
              BindValue(h, key, SUBARRAY(args, aPos, argCount));
              INC(aPos, argCount);
            END;

          END;

        END;
      END;
    END;
  END PositionalArgs;


<*INLINE*> PROCEDURE CheckRequiredArgsPresent(h: Handle) RAISES {}=
  BEGIN
    WITH keys = h.template.keys^ DO
      FOR i := FIRST(keys) TO LAST(keys) DO
        WITH key = keys[i] DO
          IF key.required AND h.values[i] = NIL THEN
            NoteError(h, key, Error.RequiredArgMissing);
          END;
        END;
      END;
    END;
  END CheckRequiredArgsPresent;


<*INLINE*> PROCEDURE CheckAllArgsDecoded(h: Handle; VAR args: T) RAISES {}=
  VAR
    afterKeyword := FALSE;
  BEGIN
    FOR i := FIRST(args) TO LAST(args) DO
      WITH arg = args[i] DO
        IF arg # NIL THEN
          WITH looksLikeKeyword = LooksLikeKeyword(arg) DO
            IF looksLikeKeyword OR NOT afterKeyword THEN
              AddRear(h.leftOver, arg);
              INC(h.errors);
            END;
            IF looksLikeKeyword THEN afterKeyword := TRUE END;
          END;
          arg := NIL;
        ELSE
          afterKeyword := FALSE;
        END;
      END;
    END;
  END CheckAllArgsDecoded;


PROCEDURE Decode(
    template: Template;
    VAR args: T;
    all := TRUE)
    : Handle
    RAISES {}=
  VAR
    h := NEW(Handle, template := template,
        values := NEW(REF ARRAY OF REF ARRAY OF TEXT, template.count));
  BEGIN
    FOR i := 0 TO h.template.count - 1 DO h.values[i] := NIL END;

    IF h.template.count > 0 THEN
      KeywordArgs(h, args);
      IF all THEN PositionalArgs(h, args) END;
      CheckRequiredArgsPresent(h);    
    END;

    IF all THEN CheckAllArgsDecoded(h, args) END;

    RETURN h;
  END Decode;


PROCEDURE Good(h: Handle): BOOLEAN RAISES {}=
  BEGIN
    RETURN h.errors = 0;
  END Good;


EXCEPTION
  Fatal;


<*INLINE*> PROCEDURE InternalValue(
    h: Handle;
    name: Text.T;
    VAR key: Key)
    : REF ARRAY OF TEXT
    RAISES {BadEnquiry}=
  BEGIN
    IF h.errors = 0 THEN
      IF IsKeyword(h, name, key) THEN
        RETURN h.values[key.index];
      ELSE
        RAISE BadEnquiry;
      END;
    ELSE
      RAISE Fatal; <* CRASH *>
    END;
  END InternalValue;


PROCEDURE Value(
    h: Handle;
    keyword: Text.T)
    : REF ARRAY OF TEXT
    RAISES {BadEnquiry}=
  VAR
    key: Key;
  BEGIN
    RETURN InternalValue(h, keyword, key);
  END Value;


PROCEDURE Flag(h: Handle; keyword: Text.T): BOOLEAN RAISES {BadEnquiry}=
  VAR
    key: Key;
    value := InternalValue(h, keyword, key);
  BEGIN
    IF key.quota # 0 THEN RAISE BadEnquiry END;
    RETURN value # NIL;
  END Flag;


PROCEDURE Single(h: Handle; keyword: Text.T): Text.T RAISES {BadEnquiry}=
  VAR
    key: Key;
    value := InternalValue(h, keyword, key);
  BEGIN
    IF key.quota # 1 OR NOT key.exact THEN RAISE BadEnquiry END;
    IF value = NIL THEN RETURN NIL ELSE RETURN value[0] END;
  END Single;


<*INLINE*> PROCEDURE KeyName(h: Handle; i: CARDINAL): Text.T RAISES {}=
  BEGIN
    RETURN NARROW(h.template.keys[i].names.head, SList.TextElem).text;
  END KeyName;


PROCEDURE Errors(h: Handle; indent: CARDINAL := 0): Text.T RAISES {}=
  BEGIN
    IF h.errors = 0 THEN
      RAISE Fatal; <* CRASH *>
    ELSE

      VAR
        texts := NEW(REF ARRAY OF TEXT, h.errors * 2);
            (* allocates space for all the error messages + padding *)
        pos: CARDINAL := 0;
        padding := Fmt.Pad("", indent);
        fmt: Text.T;

      <*INLINE*> PROCEDURE Add(t: Text.T) RAISES {}=
          BEGIN texts[pos] := t; INC(pos) END Add;
      <*INLINE*> PROCEDURE PaddedAdd(t: Text.T) RAISES {}=
          BEGIN Add(padding); Add(t) END PaddedAdd;

      BEGIN

        IF h.errorList # NIL THEN
          FOR i := 0 TO LAST(h.errorList^) DO
            VAR
              error := h.errorList[i];
            BEGIN
              IF error # Error.None THEN
                CASE error OF
                | Error.RequiredArgMissing =>
                    fmt := "Argument required for key \'%s\'\n";
                | Error.TooFewArgs =>
                    fmt := "Too few arguments for key \'%s\'\n";
                | Error.TooManyArgs =>
                    fmt := "Too many arguments for key \'%s\'\n";
                | Error.KeyAppearsMoreThanOnce =>
                    fmt := "More than one occurrence of key \'%s\'\n";
                END; (* case *)
                PaddedAdd(Fmt.F(fmt, KeyName(h, i)));
              END;
            END;
          END;
        END;

        VAR
          te: SList.TextElem := h.leftOver.head;
        BEGIN
          WHILE te # NIL DO
            IF LooksLikeKeyword(te.text) THEN
              fmt := "Unknown keyword \'%s\'\n";
            ELSE
              fmt := "Unexpected argument \'%s\'\n";
            END;
            PaddedAdd(Fmt.F(fmt, te.text));
            te := te.next;
          END;
        END;

        RETURN TextExtras.JoinN(texts^);
      END;
    END; (* if *)
  END Errors;


PROCEDURE Bind(
    h: Handle;
    keyword: Text.T;
    v: REF ARRAY OF TEXT;
    override := FALSE)
    RAISES {BadBinding}=
  VAR
    id: HashText.Id;
    key: Key;
  BEGIN
    IF h.errors # 0 THEN RAISE Fatal <* CRASH *> END;
    IF HashText.Lookup(h.template.table, keyword, id) THEN
      key := HashText.Value(h.template.table, id);
      WITH value = h.values[key.index] DO
        IF value # NIL AND NOT override THEN
          (* don't override existing value *)
          RETURN;
        ELSE
          VAR
            ok: BOOLEAN;
          BEGIN
            IF v = NIL THEN
              ok := NOT key.required;
            ELSIF key.exact THEN
              ok := NUMBER(v^) = key.quota;
            ELSE
              ok := NUMBER(v^) <= key.quota;
            END;
            IF ok THEN value := v; RETURN END;
          END;
        END;
      END;
    END;
    RAISE BadBinding;
  END Bind;


VAR
  standard_g := NewTemplate(StandardTemplateDescription);
      <* UNEXPECTED BadTemplate *>


PROCEDURE Standard(VAR args: T; VAR help, identify: BOOLEAN) RAISES {}=
  VAR
    h := Decode(standard_g, args, FALSE);
  BEGIN
    help := Flag(h, "help");
    identify := Flag(h, "identify");
  END Standard; <* UNEXPECTED BadEnquiry *>


BEGIN
END Args.