#
# File: io.k3
# Basic IO module.
#
# Copyright 2005, Radboud University of Nijmegen.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU Library General Public License for more details.
#
# You should have received a copy of the GNU Library General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
#
# CVS ID = "$Id: io.k3,v 1.25 2005/10/26 13:36:55 marcs Exp $"
#

MODULE io = ERROR_COUNT
            LOG_FILE CODE_FILE ERROR_FILE PROF_FILE
            LOG_TEXT LOG_LEN LOG_INDENT LIF_FILE INDENT_TEXT.

DEFINES ACTION open output files,
        ACTION close output files,
        ACTION open code file,
        ACTION close code file,

        ACTION set error to standard output,

	ACTION open lexicon interface file,
	ACTION close lexicon interface file,
	ACTION write to lif (>TEXT),
        ACTION write separator to lif,

        FUNCTION convert >INT to TEXT>,
        TEST convert >TEXT to INT>,
        FUNCTION binhex (>INT, TEXT>),
        FUNCTION hexbin (>TEXT, INT>),

        FUNCTION convert control codes (>TEXT>),
        FUNCTION strip quotes (>TEXT>),
        FUNCTION strip square brackets (>TEXT>),
        FUNCTION strip leading space (>TEXT>),
        FUNCTION strip trailing space (>TEXT>),

	POS,
        FUNCTION convert >POS to TEXT>,
        FUNCTION convert >POS to short TEXT>,

        ACTION error (>TEXT),
        ACTION error (>TEXT, >POS),
	ACTION write error (>TEXT),
        ACTION warning (>TEXT),
        ACTION very verbose warning (>TEXT),
        ACTION warning (>TEXT, >POS),
        ACTION strong warning (>TEXT, >POS),
        ACTION interface error (>TEXT),
        ACTION interface error (>TEXT, >POS),
        ACTION system error (>TEXT),
        FUNCTION abort (>TEXT),

        ACTION message (>TEXT),
        FUNCTION[ACTION] debug (>TEXT),
        FUNCTION[ACTION] dump (>TEXT),

        ACTION log (>TEXT),
        ACTION log no nl (>TEXT),
        ACTION set log indent (>INT),
        ACTION flush log,
        ACTION put log (>TEXT),

        ACTION log position (>TEXT),

        ACTION output code (>TEXT),

        FUNCTION abort if errors found,
        ACTION display time (>TEXT),
        FUNCTION stop nicely.

USES globals.

ERROR_COUNT =  INT.

LOG_FILE, ERROR_FILE, CODE_FILE, LIF_FILE, PROF_FILE = FILE.

PRELUDE init io:
  [ 0 -> ERROR_COUNT ],
    set error to standard output,
    watch (INT).

# ACTION open error file:
#   open standard error (ERROR_FILE);
#   write ("agfl: stopping: cannot open standard error file"),
#     ?.

ACTION set error to standard output:
  open standard output (ERROR_FILE);
  write ("agfl: stopping: cannot open standard output!"),
    ?.

ACTION open output files:
  open log file,
    open prof file,
    init logging.

ACTION close output files:
  close prof file,
  close log file.

ACTION open code file:
  get code file(TEXT),
    (open output file(TEXT, CODE_FILE);
     abort ("cannot create code file '" + TEXT + "'"),
       !).

ACTION close code file:
  close (CODE_FILE).

ACTION open log file:
  get log file (TEXT),
    (open output file (TEXT, LOG_FILE);
     abort ("cannot create log file '" + TEXT + "'"),
       !).

ACTION close log file:
  close (LOG_FILE).

ACTION open prof file:
  if profile option,
    get prof file (TEXT),
    (open output file (TEXT, PROF_FILE);
     abort ("cannot create profiling file '" + TEXT + "'"),
       !);
  +.

ACTION close prof file:
  if profile option, 
    close (PROF_FILE);
  +.

ACTION log position (>TEXT):
  if profile option, 
    write (PROF_FILE, TEXT),
    write (PROF_FILE, "\n");
  +.

ACTION open lexicon interface file:
  get lexicon interface file name (TEXT),
    (open output file (TEXT, LIF_FILE);
     abort ("cannot open lexicon interface file '"+TEXT+"'"),
       !).
    
ACTION close lexicon interface file:
  close (LIF_FILE).

ACTION write separator to lif:
  write to lif ("*****\n").

ACTION write to lif (>TEXT):
  write (LIF_FILE, TEXT).

TEST convert >TEXT to INT>:
  decbin (TEXT,INT).

FUNCTION convert >INT to TEXT>:
  bindec (INT, TEXT).

FUNCTION binhex (>INT, TEXT>):
  binhex (8, INT, TEXT).

FUNCTION binhex (>INT1, >INT, TEXT>):
  [INT1 -> 0],
    ["" -> TEXT];
  hexdigit (INT & 15, TEXT1),
    binhex (INT1 - 1, INT >> 4, TEXT2),
    [TEXT2 + TEXT1 -> TEXT].

FUNCTION hexdigit (>INT, TEXT>):
  less (INT, 10), bindec (INT, TEXT);
  [ INT -> 10 ], [ "A" -> TEXT ];
  [ INT -> 11 ], [ "B" -> TEXT ];
  [ INT -> 12 ], [ "C" -> TEXT ];
  [ INT -> 13 ], [ "D" -> TEXT ];
  [ INT -> 14 ], [ "E" -> TEXT ];
  [ INT -> 15 ], [ "F" -> TEXT ];
  ?.

FUNCTION hexbin (>TEXT, INT>):
  hexbin (8, TEXT, INT).

FUNCTION hexbin (>INT, >TEXT, INT1>):
  [ INT -> 0 ], [ 0 -> INT1 ];
  extract (TEXT, 0, 1, TEXT1),
    extract (TEXT, 1, INT, TEXT2),
    hexdigit (TEXT1, INT3),
    [ (1 << ((INT - 1) * 4)) * INT3 -> INT2 ],
    hexbin (INT - 1, TEXT2, INT1),
    [ INT1 + INT2 -> INT1 ].

FUNCTION hexdigit (>TEXT, INT>):
  between (TEXT, 0, "0", "9"),
    ( decbin (TEXT, INT);
      ?
    );
  [ TEXT -> "A" ], [ 10 -> INT ];
  [ TEXT -> "B" ], [ 11 -> INT ];
  [ TEXT -> "C" ], [ 12 -> INT ];
  [ TEXT -> "D" ], [ 13 -> INT ];
  [ TEXT -> "E" ], [ 14 -> INT ];
  [ TEXT -> "F" ], [ 15 -> INT ];
  ?.

FUNCTION convert control codes (>TEXT>, >INT):
  [INT + 1 -> INT1],
    extract(TEXT, INT, INT1, TEXT2),
      ([TEXT2 -> ""];
       [TEXT2 -> "\\"],
         prefix (TEXT, INT, TEXT3, TEXT5),
         prefix (TEXT5, 2, TEXT4, TEXT5),
           ([TEXT4 -> "\\\""],
              convert control codes (TEXT5, 0),
              [TEXT3 + "\"" + TEXT5 -> TEXT];
            [TEXT4 -> "\\r"],
              convert control codes (TEXT5, 0),
              [TEXT3 + "\r" + TEXT5 -> TEXT];
            [TEXT4 -> "\\n"],
              convert control codes (TEXT5, 0),
              [TEXT3 + "\n" + TEXT5 -> TEXT];
            [TEXT4 -> "\\t"],
              convert control codes (TEXT5, 0),
              [TEXT3 + "\t" + TEXT5 -> TEXT];
            convert control codes (TEXT, INT + 2));
       convert control codes (TEXT, INT1)).   
     
FUNCTION convert control codes (>TEXT>):
  convert control codes (TEXT, 0).

FUNCTION strip quotes (>TEXT>):
  length (TEXT, INT),
    extract (TEXT, 0, 1, TEXT1),
    [TEXT1 -> "\""],
    extract (TEXT, INT - 1, INT, TEXT2),
    [TEXT2 -> "\""],
    extract (TEXT, 1, INT - 1, TEXT);
  +.

FUNCTION strip square brackets (>TEXT>):
  length (TEXT, INT),
    extract (TEXT, 0, 1, TEXT1),
    [TEXT1 -> "["],
    extract (TEXT, INT - 1, INT, TEXT2),
    [TEXT2 -> "]"],
    extract (TEXT, 1, INT - 1, TEXT);
  +.

FUNCTION strip leading space (>TEXT>):
  length (TEXT, INT),
    extract (TEXT, 0, 1, TEXT1),
    [TEXT1 -> " "],
    extract (TEXT, 1, INT - 1, TEXT);
  +.

FUNCTION strip trailing space (>TEXT>):
  length (TEXT, INT),
    extract (TEXT, INT - 1, INT, TEXT2),
    [TEXT2 -> " "],
    extract (TEXT, 1, INT - 1, TEXT);
  +.

#
# Many error reports use a position
#
POS :: module TEXT extension TEXT line INT at INT;
       internal;
       unknown.

FUNCTION convert >POS to TEXT>:
   [ POS -> module TEXT1 extension TEXT2 line INT3 at INT4],
      bindec (INT3, TEXT3), bindec (INT4, TEXT4),
      [ "Module " + TEXT1 + TEXT2 + ": line " + TEXT3 + ", column " + TEXT4 -> TEXT ];
   [ POS -> internal ], [ "Internal position" -> TEXT ];
   [ POS -> unknown ], [ "Unknown position" -> TEXT ];
   ?.

FUNCTION convert >POS to short TEXT>:
   [ POS -> module TEXT1 extension TEXT2 line INT3 at INT4 ],
      bindec (INT3, TEXT3), bindec (INT4, TEXT4),
      [ TEXT1 + TEXT2 + ":" + TEXT3 + ":" + TEXT4 -> TEXT ];
   [ POS -> internal ], [ "Internal" -> TEXT ];
   [ POS -> unknown ], [ "Unknown" -> TEXT ];
   ?.

#
# Various error handling
#
FUNCTION abort (>TEXT):
# do not use 'write error', maybe we don't have an open log file
  write (ERROR_FILE, "stopping: " + TEXT + "\n"),
    !.

FUNCTION abort if errors found:
  no errors found;
  stop nicely.

TEST no errors found:
  [ ERROR_COUNT -> 0 ].

ACTION increment error count:
  [ ERROR_COUNT + 1 -> ERROR_COUNT ].

ACTION error (>TEXT):
  increment error count,
    write with prefix ("error:", TEXT).

ACTION error (>TEXT, >POS):
  increment error count,
    convert POS to TEXT1,
    write with prefix (TEXT1 + ": error:", TEXT).

ACTION system error (>TEXT):
  write error ("system error: " +  TEXT),
    abort ("please contact agfl@cs.ru.nl").

ACTION warning (>TEXT):
  if warnings option,
    write with prefix ("warning:", TEXT);
  +.

ACTION warning (>TEXT, >POS):
  if warnings option,
    convert POS to TEXT1,
    write with prefix (TEXT1 + ":", TEXT);
  +.

ACTION strong warning (>TEXT, >POS):
  convert POS to TEXT1,
  write with prefix (TEXT1 + ":", TEXT).

ACTION very verbose warning (>TEXT):
  if warnings option,
    if very verbose option,
      write with prefix ("warning:", TEXT);
  +.

ACTION message (>TEXT):
  if verbose option,
    write (ERROR_FILE, TEXT + "\n");
  +.

FUNCTION[ACTION] debug (>TEXT):
  write error (TEXT).

FUNCTION[ACTION] dump (>TEXT):
  write (TEXT).

# TODO: nice layout for long error messages.

ACTION write with prefix (>TEXT1, >TEXT2):
  write error (TEXT1 + " " + TEXT2).

ACTION display time (>TEXT):
  if time option,
    watch (INT),
    convert (INT % 10) to TEXT1,
    convert (INT %% 10) to TEXT2,
    message ("At" + TEXT1 + "." + TEXT2 + " (" + TEXT + ")");
  +.

ACTION write error (>TEXT):
  write (ERROR_FILE, TEXT + "\n"),
    write (LOG_FILE, TEXT + "\n").

ACTION log (>TEXT):
  write (LOG_FILE, TEXT),
    write (LOG_FILE, "\n").

ACTION log no nl (>TEXT):
  write (LOG_FILE, TEXT).

ACTION output code (>TEXT):
  write (CODE_FILE, TEXT).

FUNCTION stop nicely:
  write stop message,
    !.

ACTION write stop message:
  [ERROR_COUNT -> 1],
    write error ("stopping: 1 error found...");
  bindec (ERROR_COUNT, TEXT),
    write error ("stopping: " + TEXT + " errors found...").

ACTION interface error (>TEXT):
  increment error count,
    write with prefix ("interface error:", TEXT).

ACTION interface error (>TEXT, >POS):
  increment error count,
    convert POS to TEXT2,
    write with prefix ("interface error (" + TEXT2 + "):", TEXT).

####################
#                  #
#   Neat logging   #
#                  #
####################

LOG_TEXT    = TEXT.
LOG_LEN     = INT.
LOG_INDENT  = INT.
INDENT_TEXT = TEXT.

ACTION init logging:
  ["" -> LOG_TEXT],
    [0 -> LOG_LEN],
    [0 -> LOG_INDENT].

ACTION set log indent (>INT):
  [INT -> LOG_INDENT],
    extract ("                                                                               ", 0, LOG_INDENT, INDENT_TEXT). 

FUNCTION get log indent (TEXT>):
  [INDENT_TEXT -> TEXT].
  
ACTION flush log:
  log (LOG_TEXT),
    ["" -> LOG_TEXT],
    [0 -> LOG_LEN].

ACTION put log (>TEXT):
  [LOG_LEN -> 0],
    get log indent (TEXT1),
    [TEXT1 + TEXT -> LOG_TEXT],
    length (TEXT, INT),
    [LOG_INDENT + INT  -> LOG_LEN];
  length (TEXT, INT),
    [LOG_LEN + INT -> INT1],
      (less (INT1, 79),
         [LOG_TEXT + TEXT -> LOG_TEXT],
         [INT1 -> LOG_LEN];
       flush log,
         get log indent (TEXT1),
         [TEXT1 + TEXT -> LOG_TEXT],
         [LOG_INDENT + INT -> LOG_LEN]).

### Externals

EXTERNAL FUNCTION watch(INT>):216
