for review: Declarative debugger front end

[Mark Anthony BROWN]

Hi,

This is the latest installment on the declarative debugger.  It still
has some bugs (in particular it apparently does not cope with the recent
changes to RTTI), has a fairly shoddy user interface, and is incomplete
but enough of the framework is there to make this a good time to review.

Cheers,
Mark.


Estimated hours taken: 80

Add a front end to the declarative debugger, written in Mercury.  Modify
the back end to call this whenever an EDT is built.  Also, various
bug fixes and improvements.

browser/declarative_debugger:
	New module.  This is a first implementation of the front end of
	the declarative debugger.  It uses a simple top-down algorithm
	to search the EDT for a buggy node.  The results are printed
	in a simple format to the output stream.  It is called from the
	back end, in trace/mercury_trace_declarative.

browser/browser_library.m:
	Import the new module.

trace/mercury_trace_declarative.c:
	- Various fixes/improvements of comments.
	- Fix bugs where `int' is used instead of `Unsigned'.
	- Pass the event_info structure to MR_trace_decl_update_path,
	  rather than passing various components of it.
	- Use the copy of MR_trace_event_number in the event_info structure
	  rather than referring to the global variable directly.
	- Remove the EDT printing functions, as they have been superseded by
	  the new front end.  Call the new front end instead of these old
	  functions.
	- Provide an interface to the EDT nodes that is imported by the
	  front end.
	- Ensure that, after diagnosis, we end up at the same event we
	  started at.
	- Fix a bug where it was assumed all procedures had at least one
	  argument.
	- Ensure that the user is notified if the dd_wrong operation cannot
	  be started due to MR_trace_retry failing.

trace/mercury_trace_declarative.h:
	- Move a #include to the correct place.
	- Declare the interface to the EDT nodes.

trace/mercury_trace_internal.c:
	- Fix a bug introduced earlier.

Index: browser/browser_library.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/browser_library.m,v
retrieving revision 1.3
diff -u -r1.3 browser_library.m
--- browser_library.m	1999/03/05 12:52:10	1.3
+++ browser_library.m	1999/04/09 03:02:42
@@ -12,9 +12,8 @@
 
 :- implementation.
 
-:- import_module help.
-:- import_module debugger_interface.
-:- import_module browse, frame, parse, util.
+:- import_module browse, frame, help, parse, util.
+:- import_module debugger_interface, declarative_debugger.
 :- import_module interactive_query, dl, name_mangle.
 
 % See library/library.m for why we implement this predicate this way.
Index: trace/mercury_trace_declarative.c
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_declarative.c,v
retrieving revision 1.2
diff -u -r1.2 mercury_trace_declarative.c
--- mercury_trace_declarative.c	1999/02/20 06:08:12	1.2
+++ mercury_trace_declarative.c	1999/04/09 03:03:14
@@ -11,21 +11,22 @@
 ** back end is an extension to the internal debugger which collects
 ** related trace events and builds them into an Evaluation Dependency
 ** Tree (EDT).  Once built, the EDT is passed to the front end where it can
-** be analysed to find bugs.
-**
-** In this incarnation, the front end just dumps the EDT to stdout where
-** the user can do manual analysis.
+** be analysed to find bugs.  The front end is implemented in
+** browse/declarative_debugger.m.
 */
 
 #include "mercury_imp.h"
 
 #ifdef MR_USE_DECLARATIVE_DEBUGGER
 
-#include "mercury_dummy.h"
 #include "mercury_trace.h"
+#include "mercury_trace_browse.h"
 #include "mercury_trace_internal.h"
 #include "mercury_trace_declarative.h"
+#include "mercury_trace_tables.h"
+#include "mercury_trace_util.h"
 #include "mercury_layout_util.h"
+#include "declarative_debugger.h"
 #include <stdio.h>
 
 /*
@@ -46,9 +47,9 @@
 ** back into interactive mode.
 */
 
-static	int		MR_edt_min_depth;
-static	int		MR_edt_max_depth;
-static	int		MR_edt_last_event;
+static	Unsigned	MR_edt_min_depth;
+static	Unsigned	MR_edt_max_depth;
+static	Unsigned	MR_edt_last_event;
 
 /*
 ** MR_edt_parent points to the the parent edt_node of a procedure
@@ -77,23 +78,25 @@
 		MR_Event_Info *event_info, int decl_slot);
 
 static void
-MR_trace_decl_update_path(const MR_Stack_Layout_Label *layout, 
-		Word *saved_regs, const char *path, int decl_slot);
+MR_trace_decl_update_path(MR_Event_Info *event_info, int decl_slot);
 
 static void
 MR_trace_decl_save_args(const MR_Stack_Layout_Label *layout, Word *saved_regs,
 		MR_Edt_Node *edt_node);
 
-static 	void
-MR_edt_print(MR_Edt_Node *root, int level);
-
-static 	void
-MR_edt_print_node(MR_Edt_Node *node, int level);
+static	void
+MR_analyse_edt(MR_Edt_Node *root);
 
 static	MR_Edt_Node *
 MR_edt_node_construct(const MR_Stack_Layout_Label *layout,
 		MR_Edt_Node_Type node_tag, int start_event);
 
+static	ConstString
+MR_edt_root_node_name(const MR_Stack_Layout_Entry *entry);
+
+static	Word
+MR_edt_root_node_args(const MR_Edt_Node *edt);
+
 Code *
 MR_trace_decl_wrong_answer(MR_Trace_Cmd_Info *cmd, 
 		MR_Event_Info *event_info)
@@ -106,7 +109,9 @@
 	entry = event_info->MR_event_sll->MR_sll_entry;
 	depth = event_info->MR_call_depth;
 
-	if (MR_trace_event_number > MR_edt_last_event) {
+	if (event_info->MR_event_number > MR_edt_last_event) {
+		/* This shouldn't ever be reached. */
+		fprintf(MR_mdb_err, "Warning: missed final event.\n");
 		MR_trace_decl_mode = MR_TRACE_INTERACTIVE;
 		return MR_trace_event_internal(cmd, TRUE, event_info);
 	}
@@ -120,10 +125,13 @@
 		depth < MR_edt_min_depth ||
 		entry->MR_sle_maybe_decl_debug < 1 ) {
 		/*
-		** We can just ignore any event with a depth outside the
-		** range given by MR_edt_{min,max}_depth, or which
-		** does not have slots reserved for declarative
-		** debugging.
+		** We ignore any event for a procedure that does not have
+		** slots reserved for declarative debugging.  Such
+		** procedures are assumed to be correct.  We also filter
+		** out events with a depth outside the range given by
+		** MR_edt_{min,max}_depth.  These events are either
+		** irrelevant, or else implicitly represented in the
+		** structure being built.
 		*/
 		return NULL;
 	}
@@ -152,9 +160,7 @@
 		case MR_PORT_ELSE:
 		case MR_PORT_DISJ:
 		case MR_PORT_SWITCH:
-			MR_trace_decl_update_path(event_info->MR_event_sll,
-					event_info->MR_saved_regs, 
-					event_info->MR_event_path, decl_slot);
+			MR_trace_decl_update_path(event_info, decl_slot);
 		case MR_PORT_PRAGMA_FIRST:
 		case MR_PORT_PRAGMA_LATER:
 			break;
@@ -164,9 +170,10 @@
 	
 	if (MR_trace_event_number == MR_edt_last_event) {
 		/* Call the front end */
-		MR_edt_print(MR_edt_parent->MR_edt_node_children, 0);
+		MR_analyse_edt(MR_edt_parent->MR_edt_node_children);
 
 		MR_trace_decl_mode = MR_TRACE_INTERACTIVE;
+		return MR_trace_event_internal(cmd, TRUE, event_info);
 	}
 
 	MR_trace_enabled = TRUE;
@@ -197,7 +204,7 @@
 	}
 
 	edt_node = MR_edt_node_construct(event_info->MR_event_sll, node_tag,
-			MR_trace_event_number);
+			event_info->MR_event_number);
 
 	if (MR_DETISM_DET_STACK(entry->MR_sle_detism)) {
 		MR_based_stackvar(MR_saved_sp(saved_regs), decl_slot) =
@@ -242,7 +249,7 @@
 	}
 
 	edt_node->MR_edt_node_layout = layout;
-	edt_node->MR_edt_node_end_event = MR_trace_event_number;
+	edt_node->MR_edt_node_end_event = event_info->MR_event_number;
 	edt_node->MR_edt_node_seqno = event_info->MR_call_seqno;
 
 	MR_trace_decl_save_args(layout, saved_regs, edt_node);
@@ -323,17 +330,21 @@
 
 /*
 ** MR_trace_decl_update_path adds to the record of the execution path
-** taken for the current edt_node.
+** taken for the current EDT parent node.
 **
-** XXX It currently just overwrites all but the last path seen.  If
-** the goal is a conjunction of two disjunctions, only the path 
-** through the second disjunction is remembered.
+** XXX It currently doesn't do anything useful.  When implemented properly
+** it will add a new type of node to the current parent to indicate the
+** path taken.
 */
 static void
-MR_trace_decl_update_path(const MR_Stack_Layout_Label *layout, 
-		Word *saved_regs, const char *path, int decl_slot)
+MR_trace_decl_update_path(MR_Event_Info *event_info, int decl_slot)
 {
-	MR_Edt_Node	*edt_node;
+	MR_Edt_Node			*edt_node;
+	const MR_Stack_Layout_Label	*layout;
+	Word				*saved_regs;
+
+	layout = event_info->MR_event_sll;
+	saved_regs = event_info->MR_saved_regs;
 
 	if (MR_DETISM_DET_STACK(layout->MR_sll_entry->MR_sle_detism)) {
 		edt_node = (MR_Edt_Node *) MR_based_stackvar(
@@ -342,7 +353,7 @@
 		edt_node = (MR_Edt_Node *) MR_based_framevar(
 				MR_saved_curfr(saved_regs), decl_slot);
 	}
-	edt_node->MR_edt_node_path = path;
+	edt_node->MR_edt_node_path = event_info->MR_event_path;
 }
 
 static void
@@ -365,7 +376,10 @@
 
 	arg_count = layout->MR_sll_var_count;
 	if (arg_count < 0) {
-		printf("mdb: no info about live variables.\n");
+		fprintf(MR_mdb_err, "mdb: no info about live variables.\n");
+	}
+
+	if (arg_count <= 0) {
 		edt_node->MR_edt_node_arg_values = NULL;
 		edt_node->MR_edt_node_arg_types = NULL;
 		return;
@@ -384,15 +398,15 @@
 				&arg_values[i]);
 		locn = var->MR_slv_locn;
 
-#ifdef 0
-		printf("var %d: lval type = %d, "
+#ifdef DEBUG_DD_BACK_END
+		fprintf(MR_mdb_out, "var %d: lval type = %d, "
 				"lval number = %d, value = ",
 				i,
 				MR_LIVE_LVAL_TYPE(locn),
 				MR_LIVE_LVAL_NUMBER(locn)
 		);
-		MR_write_variable(arg_types[i], arg_values[i]);
-		printf("\n");
+		MR_trace_print(arg_types[i], arg_values[i]);
+		fprintf(MR_mdb_out, "\n");
 #endif
 	}
 
@@ -406,6 +420,7 @@
 {
 	MR_Stack_Layout_Entry 	*entry;
 	int			decl_slot;
+	const char		*message;
 
 	entry = event_info->MR_event_sll->MR_sll_entry;
 
@@ -426,7 +441,11 @@
 	MR_edt_min_depth = event_info->MR_call_depth;
 	MR_edt_max_depth = event_info->MR_call_depth + MR_EDT_DEPTH_STEP_SIZE;
 
-	MR_trace_retry(event_info, event_details, jumpaddr);
+	message = MR_trace_retry(event_info, event_details, jumpaddr);
+
+	if (message != NULL) {
+		return FALSE;
+	}
 
 	cmd->MR_trace_cmd = MR_CMD_GOTO;
 	cmd->MR_trace_stop_event = MR_trace_event_number + 1;
@@ -453,58 +472,86 @@
 	return edt_node;
 }
 
-/*
-** The following functions do a fairly unpretty print of the EDT.  They
-** currently form the front end of the declarative debugger.  In the
-** future the front end will be in a separate module to the back, and
-** will be much more detailed.  These functions will probably disappear.
-*/
-
 static void
-MR_edt_print(MR_Edt_Node *root, int level)
+MR_analyse_edt(MR_Edt_Node *root)
 {
-	int i;
+	MercuryFile	mdb_in, mdb_out;
 
-	if (root->MR_edt_node_sibling != NULL) {
-		MR_edt_print(root->MR_edt_node_sibling, level);
-	}
+	mdb_in.file = MR_mdb_in;
+	mdb_in.line_number = 1;
+	mdb_out.file = MR_mdb_out;
+	mdb_out.line_number = 1;
+
+	MR_TRACE_CALL_MERCURY(
+		ML_DD_analyse_edt((Word) root,
+				(Word) &mdb_in,
+				(Word) &mdb_out
+			);
+	);
+}
 
-	MR_edt_print_node(root, level);
+extern void
+MR_edt_root_node(Word EDT, Word *Node)
+{
+	MR_Edt_Node		*edt;
+	MR_Stack_Layout_Entry	*entry;
+	ConstString		name;
+	Word			args;
 
-	if (root->MR_edt_node_tag == MR_EDT_WRONG_ANSWER_IMPLICIT) {
-		for (i = 0; i < level + 1; i++) {
-			printf("    ");
-		}
-		printf("/* implicit */\n");
+	edt = (MR_Edt_Node *) EDT;
+	entry = edt->MR_edt_node_layout->MR_sll_entry;
+	
+	switch (edt->MR_edt_node_tag) {
+		case MR_EDT_WRONG_ANSWER_EXPLICIT:
+		case MR_EDT_WRONG_ANSWER_IMPLICIT:
+			name = MR_edt_root_node_name(entry);
+			args = MR_edt_root_node_args(edt);
+			incr_hp(*Node, 2);
+			field(mktag(0), *Node, 0) = (Word) name;
+			field(mktag(0), *Node, 1) = args;
+			break;
+		default:
+			fatal_error("MR_edt_root_node: unknown tag");
 	}
+}
 
-	if (root->MR_edt_node_children != NULL) {
-		MR_edt_print(root->MR_edt_node_children, level + 1);
+static ConstString
+MR_edt_root_node_name(const MR_Stack_Layout_Entry *entry)
+{
+	if (MR_ENTRY_LAYOUT_HAS_PROC_ID(entry)) {
+		if (MR_ENTRY_LAYOUT_COMPILER_GENERATED(entry)) {
+			return (ConstString) "(internal)";
+		} else {
+			return entry->MR_sle_proc_id.MR_proc_user.MR_user_name;
+		}
+	} else {
+		return (ConstString) "(unknown)";
 	}
 }
 
-static void
-MR_edt_print_node(MR_Edt_Node *node, int level)
+static Word
+MR_edt_root_node_args(const MR_Edt_Node *edt)
 {
-	int i;
-
-	for (i = 0; i < level; i++) {
-		printf("    ");
-	}
-	printf("(");
-	MR_write_variable(node->MR_edt_node_arg_types[0],
-			node->MR_edt_node_arg_values[0]);
-	for (i = 1; i < node->MR_edt_node_layout->MR_sll_var_count; i++) {
-		printf(", ");
-		MR_write_variable(node->MR_edt_node_arg_types[i],
-				node->MR_edt_node_arg_values[i]);
+	int			i;
+	int			argc;
+	Word			arglist;
+	Word			tail;
+	Word			head;
+
+	argc = edt->MR_edt_node_layout->MR_sll_var_count;
+
+	arglist = list_empty();
+	for (i = argc - 1; i >= 0; i--) {
+		tail = arglist;
+		incr_hp(head, 2);
+		field(mktag(0), head, UNIV_OFFSET_FOR_TYPEINFO) =
+			edt->MR_edt_node_arg_types[i];
+		field(mktag(0), head, UNIV_OFFSET_FOR_DATA) =
+			edt->MR_edt_node_arg_values[i];
+		arglist = list_cons(head, tail);
 	}
-	printf(") ");
-	if (node->MR_edt_node_path != NULL) {
-		printf("%s ", node->MR_edt_node_path);
-	}
-	MR_print_proc_id_for_debugger(stdout, 
-			node->MR_edt_node_layout->MR_sll_entry);
+
+	return arglist;
 }
 
 #endif	/* MR_USE_DECLARATIVE_DEBUGGER */
Index: trace/mercury_trace_declarative.h
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_declarative.h,v
retrieving revision 1.2
diff -u -r1.2 mercury_trace_declarative.h
--- mercury_trace_declarative.h	1999/02/20 06:08:12	1.2
+++ mercury_trace_declarative.h	1999/04/09 03:03:16
@@ -4,8 +4,6 @@
 ** Public License - see the file COPYING.LIB in the Mercury distribution.
 */
 
-#include "mercury_imp.h"
-
 #ifndef MERCURY_TRACE_DECLARATIVE_H
 #define MERCURY_TRACE_DECLARATIVE_H
 
@@ -16,6 +14,9 @@
 ** declarative debugger from the internal debugger.
 */
 
+#include "mercury_imp.h"
+#include "mercury_trace.h"
+
 /*
 ** Each node in an EDT has a tag to denote its type.  At the moment
 ** the only type of analysis is wrong answer analysis, so the tag
@@ -80,6 +81,13 @@
 		*/
 	MR_Edt_Node			*MR_edt_node_sibling;
 };
+
+/*
+** The following function is part of an interface to the EDT that can be
+** used by a front end written in Mercury (see browser/declarative_debugger.m).
+*/
+
+extern	void	MR_edt_root_node(Word EDT, Word *Node);
 
 /*
 ** When in declarative debugging mode, the internal debugger calls
Index: trace/mercury_trace_internal.c
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_internal.c,v
retrieving revision 1.37
diff -u -r1.37 mercury_trace_internal.c
--- mercury_trace_internal.c	1999/04/08 16:04:27	1.37
+++ mercury_trace_internal.c	1999/04/09 03:03:41
@@ -1365,7 +1365,7 @@
 			fflush(MR_mdb_out);
 			fprintf(MR_mdb_err,
 				"mdb: dd_wrong requires no arguments.\n");
-		} else if (port != MR_PORT_EXIT) {
+		} else if (event_info->MR_trace_port != MR_PORT_EXIT) {
 			fflush(MR_mdb_out);
 			fprintf(MR_mdb_err,
 				"mdb: wrong answer analysis is only "

%-----------------------------------------------------------------------------%
% Copyright (C) 1999 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
%-----------------------------------------------------------------------------%
% File: declarative_debugger.m
% Author: Mark Brown
% Purpose:
%	This module is the front end of a Mercury declarative debugger.
% It is called by the back end, in trace/mercury_trace_declarative.c, and
% is passed an evaluation dependency tree (EDT).  It then analyses this to
% diagnose a bug.
%
% The implementation is in three sections:
%	- Mercury interface to the main data structure.
%	- Implementation of the analysis algorithm.
%	- Interface to an oracle.
%

:- module declarative_debugger.
:- interface.
:- import_module io.

:- type evaluation_tree.

	%
	% This procedure is exported to C to be called from the back
	% end of the declarative debugger.
	%
:- pred analyse_edt(evaluation_tree, io__input_stream, io__output_stream,
		io__state, io__state).
:- mode analyse_edt(in, in, in, di, uo) is det.


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

:- implementation.
:- import_module bool, require, int, char, list, string, std_util.

	%
	% This section contains the Mercury interface to the EDTs that
	% are built by the back end.
	%

:- type evaluation_tree == c_pointer.

:- type edt_node
	--->	wrong_answer(string, list(univ)).

:- pred edt_children(evaluation_tree, list(evaluation_tree)).
:- mode edt_children(in, out) is det.

edt_children(EDT, Children) :-
	(
		edt_first_child(EDT, FirstChild)
	->
		edt_children_1(FirstChild, Children0),
		Children = [FirstChild | Children0]
	;
		Children = []
	).


:- pred edt_children_1(evaluation_tree, list(evaluation_tree)).
:- mode edt_children_1(in, out) is det.

edt_children_1(Child, Siblings) :-
	(
		edt_sibling(Child, Sibling)
	->
		edt_children_1(Sibling, Siblings0),
		Siblings = [Sibling | Siblings0]
	;
		Siblings = []
	).

:- pragma c_header_code("
	#include ""mercury_trace_declarative.h""
	#include ""mercury_type_info.h""
").

:- pred edt_first_child(evaluation_tree, evaluation_tree).
:- mode edt_first_child(in, out) is semidet.

:- pragma c_code(edt_first_child(Parent::in, Child::out),
	[will_not_call_mercury],
	"
		MR_Edt_Node	*parent;
		MR_Edt_Node	*child;

		parent = (MR_Edt_Node *) Parent;
		child = parent->MR_edt_node_children;
		if (child != NULL) {
			Child = (Word) child;
			SUCCESS_INDICATOR = TRUE;
		} else {
			SUCCESS_INDICATOR = FALSE;
		}
	"
).

:- pred edt_sibling(evaluation_tree, evaluation_tree).
:- mode edt_sibling(in, out) is semidet.

:- pragma c_code(edt_sibling(Child::in, Sibling::out),
	[will_not_call_mercury],
	"
		MR_Edt_Node	*child;
		MR_Edt_Node	*sibling;

		child = (MR_Edt_Node *) Child;
		sibling = child->MR_edt_node_sibling;
		if (sibling != NULL) {
			Sibling = (Word) sibling;
			SUCCESS_INDICATOR = TRUE;
		} else {
			SUCCESS_INDICATOR = FALSE;
		}
	"
).

:- pred edt_root(evaluation_tree, edt_node).
:- mode edt_root(in, out) is det.

:- pragma import(edt_root(in, out),
	[will_not_call_mercury],
	"MR_edt_root_node"
).

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

	%
	% This section implements the front end.  It exports the function
	% ML_DD_analyse_edt to C to be called from
	% trace/mercury_trace_declarative.c, and is passed an EDT.
	% This structure is then analysed to find a cause of the bug,
	% which is then presented to the user.
	%
	% The current implementation uses a simple top-down strategy to
	% analyse the EDT.
	%

	%
	% This is what the analysis can currently find.
	%

:- type declarative_bug
	--->	unknown
	;	wrong(evaluation_tree).


:- pragma export(declarative_debugger__analyse_edt(in, in, in, di, uo),
		"ML_DD_analyse_edt").

analyse_edt(EDT, MdbIn, MdbOut) -->
	io__set_input_stream(MdbIn, OldIn),
	io__set_output_stream(MdbOut, OldOut),
	{ edt_root(EDT, RootNode) },
	query_oracle(RootNode, Valid),
	(
		{ Valid = yes },
		{ Bug = unknown }
	;
		{ Valid = no },
		analyse_edt_1(EDT, Bug)
	),
	report_bug(Bug),
	io__set_input_stream(OldIn, _),
	io__set_output_stream(OldOut, _).


	%
	% Assumes the root note is not valid.
	%
:- pred analyse_edt_1(evaluation_tree, declarative_bug, io__state, io__state).
:- mode analyse_edt_1(in, out, di, uo) is det.

analyse_edt_1(EDT, Bug) -->
	{ edt_children(EDT, Children) },
	analyse_children(Children, wrong(EDT), Bug).


:- pred analyse_children(list(evaluation_tree), declarative_bug,
		declarative_bug, io__state, io__state).
:- mode analyse_children(in, in, out, di, uo) is det.

analyse_children([], Bug, Bug) -->
	[].
analyse_children([Child | Children], Bug0, Bug) -->
	{ edt_root(Child, ChildNode) },
	query_oracle(ChildNode, Valid),
	(
		{ Valid = yes },
		analyse_children(Children, Bug0, Bug)
	;
		{ Valid = no },
		analyse_edt_1(Child, Bug)
	).


:- pred report_bug(declarative_bug, io__state, io__state).
:- mode report_bug(in, di, uo) is det.

report_bug(unknown) -->
	io__write_string("Bug not found.\n").
report_bug(wrong(EDT)) -->
	io__write_string("Incorrect instance found:\n\n"),
	write_root_atom(EDT),
	{ edt_children(EDT, Children0) },
	(
		{ Children0 = [Child | Children1] }
	->
		io__write_string(" :-\n"),
		{ list__reverse(Children1, Children) },
		write_children(Children),
		io__write_char('\t'),
		write_root_atom(Child)
	;
		[]
	),
	io__write_string(".\n\n").


:- pred write_children(list(evaluation_tree), io__state, io__state).
:- mode write_children(in, di, uo) is det.

write_children([]) -->
	[].
write_children([Child | Children]) -->
	io__write_char('\t'),
	write_root_atom(Child),
	io__write_string(",\n"),
	write_children(Children).


:- pred write_root_atom(evaluation_tree, io__state, io__state).
:- mode write_root_atom(in, di, uo) is det.

write_root_atom(EDT) -->
	{ edt_root(EDT, RootNode) },
	{
		RootNode = wrong_answer(Name0, Args0),
		Name = Name0,
		Args = Args0
	},
	write_atom(Name, Args).


:- pred write_atom(string, list(univ), io__state, io__state).
:- mode write_atom(in, in, di, uo) is det.

write_atom(Name, Args) -->
	io__write_string(Name),
	(
		{ Args = [Arg1 | Args0] }
	->
		io__write_char('('),
		io__print(Arg1),
		write_args_rest(Args0),
		io__write_char(')')
	;
		[]
	).


:- pred write_args_rest(list(univ), io__state, io__state).
:- mode write_args_rest(in, di, uo) is det.

write_args_rest([]) -->
	[].
write_args_rest([Arg | Args]) -->
	io__write_string(", "),
	io__print(Arg),
	write_args_rest(Args).


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

	%
	% This section implements the "oracle", which really just asks
	% the user directly and returns their response.
	%

:- type debugger_command
	--->	yes
	;	no
	;	browse
	;	tree
	;	help
	;	unknown.


:- pred query_oracle(edt_node, bool, io__state, io__state).
:- mode query_oracle(in, out, di, uo) is det.

query_oracle(Node, Valid) -->
	write_node(Node),
	io__flush_output,
	get_command(Answer),
	(
		{ Answer = yes },
		{ Valid = yes }
	;
		{ Answer = no },
		{ Valid = no }
	;
		{ Answer = browse },
		io__write_string("Sorry, not implemented.\n"),
		query_oracle(Node, Valid)
	;
		{ Answer = tree },
		io__write_string("Sorry, not implemented.\n"),
		query_oracle(Node, Valid)
	;
		{ Answer = help },
		io__write_strings([
			"According to the intended interpretation",
			" of the program, answer one of:\n",
			"\ty\tyes\n",
			"\tn\tno\n",
%			"\tb\tbrowse the atom arguments (not yet)\n",
%			"\tt\tprint the evaluation tree (not yet)\n",
			"\th, ?\tthis help message\n"
		]),
		query_oracle(Node, Valid)
	;
		{ Answer = unknown },
		io__write_string("Unknown command, 'h' for help.\n"),
		query_oracle(Node, Valid)
	).


:- pred write_node(edt_node, io__state, io__state).
:- mode write_node(in, di, uo) is det.

write_node(wrong_answer(Name, Args)) -->
	write_atom(Name, Args),
	io__nl,
	io__write_string("Valid? ").


:- pred get_command(debugger_command, io__state, io__state).
:- mode get_command(out, di, uo) is det.

get_command(Command) -->
	io__read_line(Res),
	{ 
		Res = ok(Line)
	->
		(
			command_chars(Line, Command0)
		->
			Command = Command0
		;
			Command = unknown
		)
	;
		% XXX this should definitely be handled better.
		error("I/O error or EOF.\n")
	}.


:- pred command_chars(list(char), debugger_command).
:- mode command_chars(in, out) is semidet.

command_chars(['y' | _], yes).
command_chars(['n' | _], no).
command_chars(['b' | _], browse).
command_chars(['t' | _], tree).
command_chars(['h' | _], help).
command_chars(['?' | _], help).
	
-- 
Mark Brown  (dougl at cs.mu.oz.au)       )O+   |  For Microsoft to win,
MEngSc student,                             |  the customer must lose
Dept of Computer Science, Melbourne Uni     |          -- Eric S. Raymond