mercury/browser/listing.m

%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 2005-2007, 2010-2011 The University of Melbourne.
% Copyright (C) 2015, 2017-2018, 2020, 2022, 2025 The Mercury team.
% This file is distributed under the terms specified in COPYING.LIB.
%---------------------------------------------------------------------------%
%
% File: listing.m.
% Author: Ralph Becket <rafe@cs.mu.oz.au>
%
% Support for providing file listing functionality in the debugger.
%
% Unfortunately, scanning large files such as library/io.m byte-by-byte
% in a debugging grade is likely to exhaust the stack, because debugging
% grades do not support tail recursion. Instead we have to handle this
% aspect using a bit of C code.
%
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%

:- module mdb.listing.
:- interface.

:- import_module io.
:- import_module list.

%---------------------------------------------------------------------------%

:- type search_path.
:- type line_no    == int.
:- type path_name  == string.
:- type file_name  == string.
:- type c_file_ptr.                     % For passing `FILE *' arguments.

    % Construct an empty search_path structure.
    %
:- func new_list_path = search_path.

    % Get/set/clear the stack of directories searched for FileName matches by
    %   list_file/7.
    %
:- func get_list_path(search_path::in) = (list(path_name)::out) is det.
:- pred set_list_path(list(path_name)::in,
    search_path::in, search_path::out) is det.
:- pred clear_list_path(search_path::in, search_path::out) is det.

    % push_list_path(Dir, !Path):
    %
    % Push Dir on to the stack of directories searched for FileName
    % matches by list_file/7.
    %
:- pred push_list_path(path_name::in, search_path::in, search_path::out)
    is det.

    % pop_list_path(!Path):
    %
    % Pop the last Dir pushed on to the stack of directories.
    % Does nothing if the search path stack is empty.
    %
:- pred pop_list_path(search_path::in, search_path::out) is det.

    % list_file(OutStreamC, ErrorStreamC, FileName, FirstLine, LastLine,
    %   MarkLine, Path, !IO):
    %
    % Print, on OutStreamC, the lines from FileName with numbers in the range
    % FirstLine..LastLine (the first line is numbered 1). We mark the line
    % numbered MarkLine with a chevron; we indent all other lines
    % appropriately.
    %
    % We search for the file matching FileName by first looking in the current
    % working directory or, failing that, by prepending each Dir on the
    % search path stack in turn until a match is found. If no match is found,
    % we print an error message.
    %
    % We report any errors on ErrorStreamC.
    %
:- pred list_file(c_file_ptr::in, c_file_ptr::in, file_name::in, line_no::in,
    line_no::in, line_no::in, search_path::in, io::di, io::uo) is det.

    % As above, but implemented without foreign code. This is used by the
    % source-to-source debugger, which does not enable debugging in the
    % standard library, so does not suffer the problem of excessive
    % stack usage.
    %
    % XXX Stack usage should not be a problem if we implemented this predicate
    % using either read_named_file_as_line, or read_file_as_string and
    % split_into_lines.
    %
:- pred list_file_portable(io.text_output_stream::in,
    io.text_output_stream::in, file_name::in,
    line_no::in, line_no::in, line_no::in, search_path::in,
    io::di, io::uo) is det.

    % list_file_with_command(OutStreamC, ErrorStreamC, FileName,
    %   FirstLine, LastLine, MarkLine, Path, !IO):
    %
    % Like list_file, but invokes an external command to print the source
    % listing. The command is passed the four arguments:
    %
    %   FileName, FirstLine, LastLine, MarkLine
    %
    % The command should print all the lines from the first to the last,
    % both inclusive, with the current line marked (or highlighted) in
    % some fashion to standard output, and report any errors to standard error.
    %
:- pred list_file_with_command(c_file_ptr::in, c_file_ptr::in, string::in,
    file_name::in, line_no::in, line_no::in, line_no::in, search_path::in,
    io::di, io::uo) is det.

%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%

:- implementation.

:- import_module bool.
:- import_module dir.
:- import_module int.
:- import_module io.call_system.
:- import_module io.file.
:- import_module maybe.
:- import_module string.
:- import_module type_desc.

%---------------------------------------------------------------------------%

:- type search_path  == list(path_name).

:- pragma foreign_type("C", c_file_ptr, "FILE *", [can_pass_as_mercury_type]).
    % stub.
:- pragma foreign_type("C#", c_file_ptr, "object").
:- pragma foreign_type("Java", c_file_ptr, "java.lang.Object").

    % These predicates are called from trace/mercury_trace_internal.c.
    %
:- pragma foreign_export("C", new_list_path = out,
    "ML_LISTING_new_list_path").
:- pragma foreign_export("C", get_list_path(in) = out,
    "ML_LISTING_get_list_path").
:- pragma foreign_export("C", set_list_path(in, in, out),
    "ML_LISTING_set_list_path").
:- pragma foreign_export("C", clear_list_path(in, out),
    "ML_LISTING_clear_list_path").
:- pragma foreign_export("C", push_list_path(in, in, out),
    "ML_LISTING_push_list_path").
:- pragma foreign_export("C", pop_list_path(in, out),
    "ML_LISTING_pop_list_path").
:- pragma foreign_export("C", list_file(in, in, in, in, in, in, in, di, uo),
    "ML_LISTING_list_file").
:- pragma foreign_export("C", list_file_with_command(in, in, in, in, in, in,
    in, in, di, uo), "ML_LISTING_list_file_with_command").

:- func listing_type = type_desc.
:- pragma foreign_export("C", listing_type = out, "ML_LISTING_listing_type").

listing_type = type_of(Path) :-
    clear_list_path(Path @ [], _).

%---------------------------------------------------------------------------%

new_list_path = [].

%---------------------------------------------------------------------------%

get_list_path(Path) = Path.

set_list_path(Dirs, _, Dirs).

clear_list_path(_, []).

%---------------------------------------------------------------------------%

push_list_path(Dir, Path, [Dir | Path]).

%---------------------------------------------------------------------------%

pop_list_path([],         []).
pop_list_path([_ | Path], Path).

%---------------------------------------------------------------------------%

list_file(OutStreamC, ErrorStreamC, FileName, FirstLine, LastLine, MarkLine,
        Path, !IO) :-
    ( if dir.path_name_is_absolute(FileName) then
        io.open_input(FileName, Result0, !IO),
        (
            Result0 = ok(InStream),
            InStreamC = mercury_stream_to_c_file_ptr(InStream),
            print_lines_in_range_c(InStreamC, OutStreamC,
                1, FirstLine, LastLine, MarkLine, !IO),
            io.close_input(InStream, !IO)
        ;
            Result0 = error(Error),
            ErrorMsg = io.error_message(Error),
            write_to_c_file(ErrorStreamC,
                string.format("mdb: cannot open file %s: %s\n",
                    [s(FileName), s(ErrorMsg)]), !IO)
        )
    else
        find_and_open_file([dir.this_directory | Path], FileName, Result, !IO),
        (
            Result = yes(InStream),
            InStreamC = mercury_stream_to_c_file_ptr(InStream),
            print_lines_in_range_c(InStreamC, OutStreamC,
                1, FirstLine, LastLine, MarkLine, !IO),
            io.close_input(InStream, !IO)
        ;
            Result = no,
            string.format("mdb: cannot find file %s\n", [s(FileName)], Msg),
            write_to_c_file(ErrorStreamC, Msg, !IO)
        )
    ).

%---------------------%

:- func mercury_stream_to_c_file_ptr(io.text_input_stream) = c_file_ptr.
:- pragma no_determinism_warning(func(mercury_stream_to_c_file_ptr/1)).

:- pragma foreign_proc("C",
    mercury_stream_to_c_file_ptr(InStream::in) = (InStreamC::out),
    [promise_pure, thread_safe, will_not_call_mercury],
"
    InStreamC = MR_file(*(MR_unwrap_input_stream(InStream)));
").

mercury_stream_to_c_file_ptr(_) = _ :-
    private_builtin.sorry($pred).

%---------------------%

:- pred write_to_c_file(c_file_ptr::in, string::in, io::di, io::uo) is det.
:- pragma no_determinism_warning(pred(write_to_c_file/4)).

:- pragma foreign_proc("C",
    write_to_c_file(ErrorStreamC::in, Str::in, _IO0::di, _IO::uo),
    [promise_pure, thread_safe, will_not_call_mercury],
"
    fputs(Str, (FILE *) ErrorStreamC);
").

write_to_c_file(_, _, _, _) :-
    private_builtin.sorry($pred).

%---------------------------------------------------------------------------%

list_file_portable(OutStream, ErrorStream, FileName, FirstLine, LastLine,
        MarkLine, Path, !IO) :-
    ( if dir.path_name_is_absolute(FileName) then
        io.open_input(FileName, Result0, !IO),
        (
            Result0 = ok(InStream),
            print_lines_in_range_m(InStream, OutStream,
                1, FirstLine, LastLine, MarkLine, !IO),
            io.close_input(InStream, !IO)
        ;
            Result0 = error(Error),
            ErrorMsg = io.error_message(Error),
            io.format(ErrorStream, "mdb: cannot open file %s: %s\n",
                [s(FileName), s(ErrorMsg)], !IO)
        )
    else
        find_and_open_file([dir.this_directory | Path], FileName, Result, !IO),
        (
            Result = yes(InStream),
            print_lines_in_range_m(InStream, OutStream,
                1, FirstLine, LastLine, MarkLine, !IO),
            io.close_input(InStream, !IO)
        ;
            Result = no,
            io.format(ErrorStream, "mdb: cannot find file %s\n",
                [s(FileName)], !IO)
        )
    ).

%---------------------------------------------------------------------------%

list_file_with_command(OutStream, ErrorStream, Command, FileName, FirstLine,
        LastLine, MarkLine, Path, !IO) :-
    LineArgs = [string.from_int(FirstLine), string.from_int(LastLine),
        string.from_int(MarkLine)],
    ( if dir.path_name_is_absolute(FileName) then
        FindResult = yes(FileName)
    else
        find_file([dir.this_directory | Path], FileName, FindResult, !IO)
    ),
    (
        FindResult = yes(FoundFileName),
        execute_command_with_redirects(Command, [FoundFileName | LineArgs],
            OutStream, ErrorStream, CallResult, !IO),
        (
            CallResult = ok
        ;
            CallResult = error(Error),
            write_to_c_file(ErrorStream,
                string.format("mdb: %s: %s\n", [s(Command), s(Error)]), !IO)
        )
    ;
        FindResult = no,
        write_to_c_file(ErrorStream,
            string.format("mdb: cannot find file %s\n", [s(FileName)]), !IO)
    ).

%---------------------------------------------------------------------------%

    % Search for the first file with the given name on the search path
    % that we can open for reading and return the complete file name
    % (including the path component) and input stream handle.
    %
:- pred find_and_open_file(search_path::in, file_name::in,
    maybe(io.text_input_stream)::out, io::di, io::uo) is det.

find_and_open_file([], _, no, !IO).
find_and_open_file([Dir | Path], FileName, Result, !IO) :-
    io.open_input(Dir / FileName, Result0, !IO),
    (
        Result0 = ok(InStream),
        Result  = yes(InStream)
    ;
        Result0 = error(_),
        find_and_open_file(Path, FileName, Result, !IO)
    ).

:- pred find_file(search_path::in, file_name::in, maybe(file_name)::out,
    io::di, io::uo) is det.

find_file([], _, no, !IO).
find_file([Dir | Path], FileName0, Result, !IO) :-
    FileName = Dir / FileName0,
    FollowSymLinks = yes,
    io.file.file_type(FollowSymLinks, FileName, FileTypeRes, !IO),
    (
        FileTypeRes = ok(FileType),
        (
            ( FileType = regular_file
            ; FileType = symbolic_link
            ; FileType = named_pipe
            ; FileType = socket
            ; FileType = character_device
            ; FileType = block_device
            ; FileType = message_queue
            ; FileType = semaphore
            ; FileType = shared_memory
            ; FileType = unknown
            ),
            Result = yes(FileName)
        ;
            FileType = directory,
            % It is debatable whether we should continue searching.
            find_file(Path, FileName0, Result, !IO)
        )
    ;
        FileTypeRes = error(_),
        find_file(Path, FileName0, Result, !IO)
    ).

%---------------------------------------------------------------------------%

    % print_lines_in_range(InStreamC, OutStreamC,
    %   ThisLine, FirstLine, LastLine, MarkLine, !IO):
    %
    % Print the lines numbered FirstLine to LastLine from InStreamC
    % on OutStreamC (the current line number is taken as ThisLine).
    % Each line is printed indented with "  ", except for the line
    % numbered MarkLine, if it occurs in the range FirstLine .. LastLine,
    % which is indented with "> ".
    %
:- pred print_lines_in_range_c(c_file_ptr::in, c_file_ptr::in,
    line_no::in, line_no::in, line_no::in, line_no::in, io::di, io::uo) is det.
:- pragma no_determinism_warning(pred(print_lines_in_range_c/8)).

:- pragma foreign_proc("C",
    print_lines_in_range_c(InStreamC::in, OutStreamC::in, ThisLine::in,
        FirstLine::in, LastLine::in, MarkLine::in, _IO0::di, _IO::uo),
    [promise_pure, thread_safe, will_not_call_mercury],
"
    if (FirstLine <= ThisLine && ThisLine <= LastLine) {
        const char *s = (ThisLine == MarkLine) ? \"> \" : \"  \";
        fputs(s, (FILE *) OutStreamC);
    }
    while (ThisLine <= LastLine) {
        int c = fgetc((FILE *) InStreamC);
        if (c == EOF) {
            fputc('\\n', (FILE *) OutStreamC);
            break;
        }
        if (FirstLine <= ThisLine) {
            fputc(c, (FILE *) OutStreamC);
        }
        if (c == '\\n') {
            ThisLine++;
            if (FirstLine <= ThisLine && ThisLine <= LastLine)  {
                const char *s = (ThisLine == MarkLine) ? \"> \" : \"  \";
                fputs(s, (FILE *) OutStreamC);
            }
        }
    }
").

print_lines_in_range_c(_, _, _, _, _, _, _, _) :-
    private_builtin.sorry($pred).

%---------------------------------------------------------------------------%

:- pred print_lines_in_range_m(io.text_input_stream::in,
    io.text_output_stream::in,
    line_no::in, line_no::in, line_no::in, line_no::in, io::di, io::uo) is det.

print_lines_in_range_m(InStream, OutStream, ThisLine, FirstLine, LastLine,
        MarkLine, !IO) :-
    io.read_line_as_string(InStream, Res, !IO),
    (
        Res = ok(Line),
        ( if FirstLine =< ThisLine, ThisLine =< LastLine then
            ( if ThisLine = MarkLine then
                io.write_string(OutStream, "> ", !IO)
            else
                io.write_string(OutStream, "  ", !IO)
            ),
            io.write_string(OutStream, Line, !IO)
        else
            true
        ),
        print_lines_in_range_m(InStream, OutStream, ThisLine + 1, FirstLine,
            LastLine, MarkLine, !IO)
    ;
        Res = eof
    ;
        Res = error(Error),
        io.format(OutStream, "Error: %s\n", [s(io.error_message(Error))], !IO)
    ).

%---------------------------------------------------------------------------%

:- pred execute_command_with_redirects(string::in, list(string)::in,
    c_file_ptr::in, c_file_ptr::in, maybe_error::out, io::di, io::uo) is det.

execute_command_with_redirects(Prog, Args, OutStreamC, ErrorStreamC,
        Result, !IO) :-
    do_posix_spawnp(Prog, length(Args), Args, OutStreamC, ErrorStreamC, Status,
        Error0, !IO),
    ( if Status = -1 then
        io.make_io_error_from_system_error(Error0,
            "error invoking system command: ", IOError, !IO),
        Result = error(io.error_message(IOError))
    else if Status = -2 then
        Result = error("posix_spawn not supported on this platform")
    else
        Result0 = io.call_system.decode_system_command_exit_code(Status),
        (
            Result0 = ok(exited(ExitStatus)),
            ( if ExitStatus = 0 then
                Result = ok
            else
                Result = error("exit status " ++ string.from_int(ExitStatus))
            )
        ;
            Result0 = ok(signalled(Signal)),
            Result = error("received signal " ++ string.from_int(Signal))
        ;
            Result0 = error(Error),
            Result = error(io.error_message(Error))
        )
    ).

%---------------------%

:- pred do_posix_spawnp(string::in, int::in, list(string)::in,
    c_file_ptr::in, c_file_ptr::in, int::out, io.system_error::out,
    io::di, io::uo) is det.
:- pragma no_determinism_warning(pred(do_posix_spawnp/9)).

:- pragma foreign_proc("C",
    do_posix_spawnp(Prog::in, NumArgs::in, Args::in,
        OutStreamC::in, ErrorStreamC::in, Status::out, Error::out,
        _IO0::di, _IO::uo),
    [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io,
        may_not_duplicate],
"
    int error;

    Status = do_posix_spawnp(Prog, NumArgs, Args,
        fileno(OutStreamC), fileno(ErrorStreamC), &error);
    if (Status == -1) {
        Error = error;
    } else {
        Error = 0;
    }
").

do_posix_spawnp(_, _, _, _, _, _, _, _, _) :-
    private_builtin.sorry($pred).

%---------------------------------------------------------------------------%

:- pragma foreign_decl("C", local, "
// See library/io.m regarding declaration of the environ global variable.
#if defined(MR_HAVE_SPAWN_H) && defined(MR_HAVE_ENVIRON)
    #include <spawn.h>

    #if defined(MR_MAC_OSX)
        #include <crt_externs.h>
    #else
        extern char **environ;
    #endif
#endif

static int do_posix_spawnp(MR_String prog, int num_args, MR_Word args,
    const int outfd, const int errfd, int *ret_errno);
").

:- pragma foreign_code("C", "
static int
do_posix_spawnp(MR_String prog, int num_args, MR_Word args,
    const int outfd, const int errfd, int *ret_errno)
{
#if defined(MR_HAVE_POSIX_SPAWN) && defined(MR_HAVE_ENVIRON)

    pid_t   pid;
    char    **argv;
    posix_spawn_file_actions_t file_actions;
    posix_spawnattr_t attr;
    int     rc;
    int     status;
    int     i;

    argv = MR_GC_NEW_ARRAY(char *, 1 + num_args + 1);
    argv[0] = prog;
    for (i = 1; i <= num_args; i++) {
        argv[i] = (MR_String) MR_list_head(args);
        args = MR_list_tail(args);
    }
    argv[i] = NULL;

    rc = posix_spawnattr_init(&attr);
    if (rc == -1) {
        *ret_errno = errno;
        return -1;
    }

    rc = posix_spawn_file_actions_init(&file_actions);
    if (rc == -1) {
        *ret_errno = errno;
        goto error_cleanup_attr;
    }

    if (outfd != STDOUT_FILENO) {
        // Redirect standard output in child process.
        rc = posix_spawn_file_actions_adddup2(&file_actions,
            outfd, STDOUT_FILENO);
        if (rc == -1) {
            *ret_errno = errno;
            goto error_cleanup_fa_attr;
        }
        // Close outfd in child process.
        rc = posix_spawn_file_actions_addclose(&file_actions, outfd);
        if (rc == -1) {
            *ret_errno = errno;
            goto error_cleanup_fa_attr;
        }
    }

    if (errfd != STDERR_FILENO) {
        // Redirect standard error in child process.
        rc = posix_spawn_file_actions_adddup2(&file_actions,
            errfd, STDERR_FILENO);
        if (rc == -1) {
            *ret_errno = errno;
            goto error_cleanup_fa_attr;
        }
        // Close errfd in child process.
        rc = posix_spawn_file_actions_addclose(&file_actions, errfd);
        if (rc == -1) {
            *ret_errno = errno;
            goto error_cleanup_fa_attr;
        }
    }

    #ifdef MR_MAC_OSX
        rc = posix_spawnp(&pid, prog, &file_actions, &attr, argv,
            *_NSGetEnviron());
    #else
        rc = posix_spawnp(&pid, prog, &file_actions, &attr, argv,
            environ);
    #endif

    if (rc == -1) {
        // Spawn failed.
        *ret_errno = errno;
        goto error_cleanup_fa_attr;
    }

    posix_spawnattr_destroy(&attr);
    posix_spawn_file_actions_destroy(&file_actions);

    // Wait for the spawned process to exit.
    do {
        rc = waitpid(pid, &status, 0);
    } while (rc == -1 && MR_is_eintr(errno));
    if (rc == -1) {
        *ret_errno = errno;
        return -1;
    }
    *ret_errno = 0;
    return status;

error_cleanup_fa_attr:
    posix_spawn_file_actions_destroy(&file_actions);
error_cleanup_attr:
    posix_spawnattr_destroy(&attr);
    return -1;

#else   // not (defined(MR_HAVE_POSIX_SPAWN) && defined(MR_HAVE_ENVIRON))

    *ret_errno = ENOEXEC;
    return -2;

#endif  // not (defined(MR_HAVE_POSIX_SPAWN) && defined(MR_HAVE_ENVIRON))
}
").

%---------------------------------------------------------------------------%
:- end_module mdb.listing.
%---------------------------------------------------------------------------%