[m-dev.] Stream2000

[Peter Ross]

The only issue I have with this version is that it makes heavy use of
existential types.  It seems once you start using them you just have to
keep using them.

I have also attached a new implementation of stdio, for perusal.  The
problem I forsee with this design is that it is possible to create more
then one stdin stream, which may lead to problems with putback and so
on.

Pete
-------------- next part --------------
%-----------------------------------------------------------------------------%*
% Copyright (C) 2000 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
%-----------------------------------------------------------------------------%
%
% File: stream.m.
% Main author: petdr
% Stability: exceptionally low.
%
% This file provides a typeclass for defining streams in Mercury.
% It is completely pure and you are encouraged to use it to write
% streams in Mercury.  If however you are a library implementor then you
% may want to look at the impure interface described in stream.impure.m
%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%

:- module stream.

:- interface.

:- import_module char, io, list.

	% The state of one stream of type S.
:- type stream(S).

	% The type of exceptions thrown by this module.
:- type stream_error ---> stream_error(string).

:- type stream__result(T)
	--->	ok(T)
	;	eof
	;	error(string)
	.

:- type stream__result
	--->	ok
	;	eof
	;	error(string)
	.

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

	%
	% The pure interface to streams.
	%
:- typeclass stream(S) where [
	func stream__name(S) = string
].

:- typeclass stream__input(S) <= stream(S) where [
		% Read one character from the stream S.
	pred stream__read_char(S::in, stream__result(char)::out,
			io__state::di, io__state::uo) is det
].

:- typeclass stream__output(S) <= stream(S) where [
		% Write one character to the stream S.
	pred stream__write_char(S::in, char::in,
			io__state::di, io__state::uo) is det
].

:- typeclass stream__duplex(S)
		<= (stream__input(S), stream__output(S)) where [].

:- typeclass stream__putback(S) <= stream__input(S) where [
	pred stream__putback_char(S::in, char::in,
			io__state::di, io__state::uo) is det
].

:- typeclass stream__line(S) <= stream__input(S) where [
	func stream__line_number(S) = int
].

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

	%
	% Create a stream with infinite putback from an input stream.
	%
:- some [T] (func putback_stream(S) = T
		=> stream__putback(T)) <= stream__input(S).

	%
	% Create a stream which records which line of the input stream
	% we are up to.
	%
:- some [T] (func linenumber_stream(S) = T
		=> stream__line(T)) <= stream__input(S).

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

% XXX When default type class implementations are introduced these
% the following predicates should probably become members of the
% relevant type classes.

% Predicates which require an input stream.

	% Reads one line of input from the current input stream.
:- pred stream__read_line(S::in, stream__result(list(char))::out,
		io__state::di, io__state::uo) is det <= stream__input(S).

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

% Predicates which require an input stream with putback.

	% Reads a whitespace delimited word from the current input stream.
:- pred stream__read_word(S::in, stream__result(list(char))::out,
		io__state::di, io__state::uo) is det <= stream__putback(S).

	% Discards all the whitespace from the input stream.
:- pred stream__ignore_whitespace(S::in, stream__result::out,
		io__state::di, io__state::uo) is det <= stream__putback(S).

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

% Predicates which require an output stream.
% On failure these predicates will throw an stream_error exception.

	% Write the string to the output stream.
:- pred stream__write_string(S::in, string::in,
		io__state::di, io__state::uo) is det <= stream__output(S).

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

:- implementation.

:- import_module int, string.

:- type putback(S)
	--->	pb(
			S,
			mutvar(list(char))
		).

:- instance stream(putback(S)) <= stream(S) where [
	(stream__name(pb(S, _)) = stream__name(S))
].

:- instance stream__input(putback(S)) <= stream__input(S) where [
	pred(stream__read_char/4) is putback_read_char
].

:- instance stream__putback(putback(S)) <= stream__input(S) where [
	pred(stream__putback_char/4) is putback_putback_char
].

:- pragma promise_pure(putback_stream/1).
putback_stream(Stream) = pb(Stream, MPutbackChars) :-
	impure new_mutvar([], MPutbackChars).

:- pred putback_read_char(putback(S)::in, stream__result(char)::out,
		io__state::di, io__state::uo) is det <= stream__input(S).

:- pragma promise_pure(putback_read_char/4).
putback_read_char(pb(Stream, MPutbackChars), Result) -->
	{ impure get_mutvar(MPutbackChars, PutbackChars) },
	(
		{ PutbackChars = [] },
		stream__read_char(Stream, Result)
	;
		{ PutbackChars = [Char | NewPutbackChars] },
		{ Result = ok(Char) },
		{ impure set_mutvar(MPutbackChars, NewPutbackChars) }
	).

:- pred putback_putback_char(putback(S)::in, char::in,
		io__state::di, io__state::uo) is det <= stream__input(S).

:- pragma promise_pure(putback_putback_char/4).
putback_putback_char(pb(_Stream, MPutbackChars), Char) -->
	{ impure get_mutvar(MPutbackChars, PutbackChars) },
	{ impure set_mutvar(MPutbackChars, [Char | PutbackChars] ) }.

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

:- type linenumber(S)
	--->	line(
			S,		% stream
			mutvar(int)	% line number
		).

:- instance stream(linenumber(S)) <= stream(S) where [
	(stream__name(line(S, _)) = stream__name(S))
].

:- instance stream__input(linenumber(S)) <= stream__input(S) where [
	pred(stream__read_char/4) is linenumber_read_char
].

:- instance stream__putback(linenumber(S)) <= stream__putback(S) where [
	pred(stream__putback_char/4) is linenumber_putback_char
].

:- instance stream__line(linenumber(S)) <= stream__input(S) where [
	func(stream__line_number/1) is linenumber
].

:- pragma promise_pure(linenumber_stream/1).
linenumber_stream(S) = line(S, MLine) :-
	impure new_mutvar(0, MLine).

/*
:- some [T] (func linenumber_putback_stream(S) = T
		=> (stream__putback(T), stream__line(T))) <= stream__input(S).

linenumber_putback_stream(Stream)
	= putback_stream(linenumber_stream(Stream)).
*/

:- pred linenumber_read_char(linenumber(S)::in, stream__result(char)::out,
		io__state::di, io__state::uo) is det <= stream__input(S).

:- pragma promise_pure(linenumber_read_char/4).
linenumber_read_char(line(Stream, MLine), Result) -->
	stream__read_char(Stream, Result),
	{ Result = ok('\n') ->
		impure get_mutvar(MLine, Line),
		impure set_mutvar(MLine, Line + 1)
	;
		true
	}.

:- pred linenumber_putback_char(linenumber(S)::in, char::in,
		io__state::di, io__state::uo) is det <= stream__putback(S).

:- pragma promise_pure(linenumber_putback_char/4).
linenumber_putback_char(line(Stream, MLine), Char) -->
	stream__putback_char(Stream, Char),
	{ Char = '\n' ->
		impure get_mutvar(MLine, Line),
		impure set_mutvar(MLine, Line - 1)
	;
		true
	}.

:- func linenumber(linenumber(S)) = int.

:- pragma promise_pure(linenumber/1).
linenumber(line(_, MLine)) = Line :-
	impure get_mutvar(MLine, Line).


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

read_line(Stream, Result) -->
	stream__read_char(Stream, CharResult),
	(
		{ CharResult = error(Error) },
		{ Result = error(Error) }
	;
		{ CharResult = eof },
		{ Result = eof }
	;
		{ CharResult = ok(Char) },
		( { Char = '\n' } ->
			{ Result = ok([Char]) }
		;
			read_line(Stream, Result0),
			(
				{ Result0 = ok(Chars) },
				{ Result = ok([Char | Chars]) }
			;
				{ Result0 = error(_) },
				{ Result = Result0 }
			;
				{ Result0 = eof },
				{ Result = ok([Char]) }
			)
		)	
	).

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

stream__read_word(Stream, Result) -->
	stream__ignore_whitespace(Stream, WSResult),
	(
		{ WSResult = error(Error) },
		{ Result = error(Error) }
	;
		{ WSResult = eof },
		{ Result = eof }
	;
		{ WSResult = ok },
		stream__read_word_2(Stream, Result)
	).

:- pred read_word_2(S::in, stream__result(list(char))::out,
		io__state::di, io__state::uo) is det <= stream__putback(S).

read_word_2(Stream, Result) -->
	stream__read_char(Stream, CharResult),
	(
		{ CharResult = error(Error) },
		{ Result = error(Error) }
	;
		{ CharResult = eof },
		{ Result = eof }
	;
		{ CharResult = ok(Char) },
		( { char__is_whitespace(Char) } ->
			stream__putback_char(Stream, Char),
			{ Result = ok([]) }
		;
			read_word_2(Stream, Result0),
			(
				{ Result0 = ok(Chars) },
				{ Result = ok([Char | Chars]) }
			;
				{ Result0 = error(_) },
				{ Result = Result0 }
			;
				{ Result0 = eof },
				{ Result = ok([Char]) }
			)
		)	
	).

stream__ignore_whitespace(Stream, Result) -->
	stream__read_char(Stream, CharResult),
	(
		{ CharResult = error(Error) },
		{ Result = error(Error) }
	;
		{ CharResult = eof },
		{ Result = eof }
	;
		{ CharResult = ok(Char) },
		( { char__is_whitespace(Char) } ->
			stream__ignore_whitespace(Stream, Result)
		;
			stream__putback_char(Stream, Char),
			{ Result = ok }
		)	
	).

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

stream__write_string(Stream, String) -->
	string__foldl(stream__write_char(Stream), String).
	
%-----------------------------------------------------------------------------%

%%% :- module mutvar.
%%% :- interface.

%  A non-backtrackably destructively modifiable reference type
:- type mutvar(T).

%  Create a new mutvar given a term for it to reference.
:- impure pred new_mutvar(T, mutvar(T)).
:-        mode new_mutvar(in, out) is det.
:-        mode new_mutvar(di, uo) is det.

%  Get the value currently referred to by a reference.
:- impure pred get_mutvar(mutvar(T), T) is det.
:-        mode get_mutvar(in, uo) is det.	% XXX this is a work-around
/*
XXX `ui' modes don't work yet
:-        mode get_mutvar(in, uo) is det.
:-        mode get_mutvar(ui, uo) is det.	% unsafe, but we use it safely
*/

%  destructively modify a reference to refer to a new object.
:- impure pred set_mutvar(mutvar(T), T) is det.
:-        mode set_mutvar(in, in) is det.
/*
XXX `ui' modes don't work yet
:-        pred set_mutvar(ui, di) is det.
*/

%%% :- implementation.

%  This type is implemented in C.
:- type mutvar(T) ---> mutvar(c_pointer).

:- pragma inline(new_mutvar/2).
:- pragma c_code(new_mutvar(X::in, Ref::out), will_not_call_mercury,
"
	incr_hp_msg(Ref, 1, MR_PROC_LABEL, ""std_util:mutvar/1"");
	*(MR_Word *) Ref = X;
").
:- pragma c_code(new_mutvar(X::di, Ref::uo), will_not_call_mercury,
"
	incr_hp_msg(Ref, 1, MR_PROC_LABEL, ""std_util:mutvar/1"");
	*(MR_Word *) Ref = X;
").

:- pragma inline(get_mutvar/2).
:- pragma c_code(get_mutvar(Ref::in, X::uo), will_not_call_mercury,
"
	X = *(MR_Word *) Ref;
").

:- pragma inline(set_mutvar/2).
:- pragma c_code(set_mutvar(Ref::in, X::in), will_not_call_mercury, "
	*(MR_Word *) Ref = X;
").

%%% end_module mutvar.

%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
-------------- next part --------------
%-----------------------------------------------------------------------------%
% Copyright (C) 2000 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
%-----------------------------------------------------------------------------%
%
% File: impure.m.
% Main author: petdr
% Stability: exceptionally low.
%
% An impure interface for describing streams.
%
% This file provides a typeclass for people who want to map streams
% to a foreign language binding while doing the minimum amount of work.  In
% particular you need to write much less foreign language code, since
% you only need to implement a few impure predicates with a well defined
% interface.
%
% This file provides throwing exceptions, grabbing error messages,
% results packaged into ok/error/eof, and turning C style handle based
% IO into Mercury di/uo.  That's all it does, but it's something you'll
% have to do and get right every time you implement a stream, so we have
% done it for you.
%
% Note that current design isn't thread safe, it is up to the
% implementor to ensure thread safety.
%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%

:- module (impure).

:- interface.

:- import_module stream.
:- import_module char.

	% A handle on the impure stream.
:- type impure(S) ---> impure(S).

:- typeclass impure(S) where [
		% Did an error occur processing the stream?
		% This predicate must also clear the error status of a
		% stream after reporting the error.
	impure pred impure__get_error(S::in, string::out) is semidet
].

:- typeclass impure__input(S) <= impure(S) where [
		% Read one character from the stream described by S.
		% Fail if we reach eof or some error condition.
	impure pred impure__read_char(S::in, char::out) is semidet,

		% Have we reached the eof for S?
	semipure pred impure__is_eof(S::in) is semidet
].

:- typeclass impure__output(S) <= impure(S) where [
		% Read one character from the current stream.
	impure pred impure__write_char(S::in, char::in) is semidet
].

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

	% Read one character of input.  This read character
	% implementation can be used in instance declarations for the
	% stream__input type class.

:- pred pure_read_char(impure(S), stream__result(char),
		io__state, io__state) <= impure__input(S).
:- mode pure_read_char(in, out, di, uo) is det.

	% Write one character of output.  This write character
	% implementation can be used in instance declarations for the
	% stream__output type class.

:- pred pure_write_char(impure(S), char,
		io__state, io__state) <= impure__output(S).
:- mode pure_write_char(in, in, di, uo) is det.

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

:- implementation.
:- import_module exception.

:- pragma promise_pure(pure_read_char/4).
pure_read_char(impure(Stream), Result, IO, IO) :-
	( impure impure__read_char(Stream, Chr) ->
		Result = ok(Chr)
	;
		( impure impure__get_error(Stream, Error) ->
			Result = error(Error)
		; semipure impure__is_eof(Stream) ->
			Result = eof
		;
			Error = "read char failed for an unknown reason",
			Result = error(Error)
		)
	).

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

:- pragma promise_pure(pure_write_char/4).
pure_write_char(impure(Stream), Chr, IO, IO) :-
	( impure impure__write_char(Stream, Chr) ->
		true
	;
		( impure impure__get_error(Stream, Err0) ->
			Err = Err0
		;
			Err = "write char failed but there is no error message"
		),
		throw(stream_error(Err))
	).

%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
-------------- next part --------------
%-----------------------------------------------------------------------------%
% Copyright (C) 2000 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
%-----------------------------------------------------------------------------%
%
% File: stdio.m
% Main author: petdr
% Stability: exceptionally low.
%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%

:- module stdio.

:- interface.

:- import_module stream.

:- type file.

:- instance stream(file).
:- instance stream__input(file).
:- instance stream__output(file).

:- some [T] (func stdin = T => stream__input(T)).
:- some [T] (func stdout = T => stream__output(T)).
:- some [T] (func stderr = T => stream__output(T)).

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

:- implementation.

:- import_module (impure).
:- import_module char.

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

:- type file
	--->	file(
			name	:: string,
			handle	:: impure(file_handle)
		).

:- instance stream(file) where [
	(stream__name(file(Name, _)) = Name)
].

:- instance stream__input(file) where [
	(stream__read_char(S, R) --> pure_read_char(S ^ handle, R))
].

:- instance stream__output(file) where [
	(stream__write_char(S, R) --> pure_write_char(S ^ handle, R))
].

stdin  = file("stdin", impure(stdin_file_handle)).
stdout = file("stdout", impure(stdout_file_handle)).
stderr = file("stderr", impure(stderr_file_handle)).

%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
	
	%
	% The low level impure interface.
	%

:- type file_handle
	--->	file(c_pointer).

:- instance impure(file_handle) where [
	pred(impure__get_error/2) is stdio__get_error
].

:- instance impure__input(file_handle) where [
	pred(impure__read_char/2) is stdio__read_char,
	pred(impure__is_eof/1) is stdio__is_eof
].

:- instance impure__output(file_handle) where [
	pred(impure__write_char/2) is stdio__write_char
].

:- func stdin_file_handle = file_handle.

:- pragma c_code(stdin_file_handle = (File::out),
		[will_not_call_mercury, thread_safe], "{
	File = (MR_Word) stdin;
}").

:- func stderr_file_handle = file_handle.

:- pragma c_code(stderr_file_handle = (File::out),
		[will_not_call_mercury, thread_safe], "{
	File = (MR_Word) stderr;
}").

:- func stdout_file_handle = file_handle.

:- pragma c_code(stdout_file_handle = (File::out),
		[will_not_call_mercury, thread_safe], "{
	File = (MR_Word) stdout;
}").

:- impure pred stdio__read_char(file_handle::in, char::out) is semidet.
:- pragma c_code(stdio__read_char(File::in, Chr::out),
		[will_not_call_mercury, thread_safe], "{
	int chr;
	FILE *file = (FILE *) File;

	chr = fgetc(file);
	if (chr == EOF) {
		SUCCESS_INDICATOR = FALSE;
	} else {
		SUCCESS_INDICATOR = TRUE;
		Chr = chr;
	}
}").

:- impure pred stdio__write_char(file_handle::in, char::in) is semidet.
:- pragma c_code(stdio__write_char(File::in, Chr::in),
		[will_not_call_mercury, thread_safe], "{
	FILE *file = (FILE *) File;

	if (fputc(Chr, file) == EOF) {
		SUCCESS_INDICATOR = FALSE;
	} else {
		SUCCESS_INDICATOR = TRUE;
	}
}").

:- pragma c_header_code("#include <errno.h>").

:- impure pred stdio__get_error(file_handle::in, string::out) is semidet.
:- pragma c_code(stdio__get_error(File::in, Msg::out),
		[will_not_call_mercury, thread_safe], "{
	FILE *file = (FILE *) File;

	if (ferror(file)) {
		SUCCESS_INDICATOR = TRUE;
		clearerr(file);
		save_transient_hp();
		MR_make_aligned_string_copy(Msg, strerror(errno));
		restore_transient_hp();
	} else {
		SUCCESS_INDICATOR = FALSE;
	}
}").

:- semipure pred stdio__is_eof(file_handle::in) is semidet.
:- pragma c_code(stdio__is_eof(File::in),
		[will_not_call_mercury, thread_safe], "{
	FILE *file = (FILE *) File;

	if (feof(file)) {
		SUCCESS_INDICATOR = TRUE;
	} else {
		SUCCESS_INDICATOR = FALSE;
	}
}").

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