[m-rev.] diff: move remaining concurrency example into samples
Julien Fischer
juliensf at csse.unimelb.edu.au
Sat Nov 27 01:46:50 AEDT 2010
Branches: main
Shift the remaining concurrency example out of extras distribution and into the
samples directory.
samples/concurrency/midimon/concurrent_stream.m:
samples/concurrency/midimon/midi.m:
samples/concurrency/midimon/midimon.m:
samples/concurrency/midimon/midi_data:
Shift the midi monitor example from the extras distribution
into the samples directory.
samples/README:
Add a description of the concurrency directory.
samples/concurrency/dining_philosophers/README:
samples/concurrency/midimon/README:
Move the descriptions of the concurrency examples
to these files.
extras/concurrency/Mercury.options:
extras/concurrency/Mmakefile:
extras/concurrency/midi.m:
extras/concurrency/midi_data:
extras/concurrency/midimon.m:
Delete the midi monitor example from the extras
distribution.
extras/README:
Delete the description of the concurrency directory.
Julien.
Index: extras/README
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/extras/README,v
retrieving revision 1.25
diff -u -r1.25 README
--- extras/README 23 Apr 2007 04:00:52 -0000 1.25
+++ extras/README 9 Nov 2010 02:33:22 -0000
@@ -14,10 +14,6 @@
A Mercury library package containing support for
complex and imaginary numbers.
-concurrency Support for coroutining and concurrent execution of
- deterministic (or cc_multi) goals, and some data structures
- for communicating between different concurrent threads.
-
curs A Mercury library providing a somewhat more complete
and more faithful binding to the curses and panel
libraries (the latter is used to provide elementary
Index: extras/concurrency/Mercury.options
===================================================================
RCS file: extras/concurrency/Mercury.options
diff -N extras/concurrency/Mercury.options
Index: extras/concurrency/Mmakefile
===================================================================
RCS file: extras/concurrency/Mmakefile
diff -N extras/concurrency/Mmakefile
--- extras/concurrency/Mmakefile 8 Nov 2010 08:19:10 -0000 1.9
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,25 +0,0 @@
-#-----------------------------------------------------------------------------#
-# Copyright (C) 2000-2003, 2006, 2010 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.
-#-----------------------------------------------------------------------------#
-
-INSTALL_PREFIX := $(INSTALL_PREFIX)/extras
-
-TESTS = midimon
-
--include ../Mmake.params
-include Mercury.options
-
-default_target: all
-
-depend: $(TESTS:%=%.depend)
-all: tests
-install:
-clean: $(TESTS:%=%.clean)
-realclean: $(TESTS:%=%.realclean)
-tests: $(TESTS)
-
-.PHONY: check
-check: all
- true
Index: extras/concurrency/concurrent_stream.m
===================================================================
RCS file: extras/concurrency/concurrent_stream.m
diff -N extras/concurrency/concurrent_stream.m
--- extras/concurrency/concurrent_stream.m 9 Nov 2010 02:31:41 -0000 1.1
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,133 +0,0 @@
-%-----------------------------------------------------------------------------%
-% vim: ft=mercury ts=4 sw=4 et
-%-----------------------------------------------------------------------------%
-% Copyright (C) 2000, 2006, 2010 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: concurrent_stream.m.
-% Main author: conway.
-% Stability: medium.
-%
-% This module implements a simple concurrent data-stream.
-%
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-
-:- module concurrent_stream.
-:- interface.
-
-:- import_module io.
-
-%-----------------------------------------------------------------------------%
-
-:- type concurrent_stream(T).
-
-:- type concurrent_stream.result(T)
- ---> end
- ; error(string)
- ; ok(T).
-
- % new(Stream, !IO) creates a new data concurrent_stream `Stream'.
- %
-:- pred new(concurrent_stream(T)::out, io::di, io::uo) is det.
-
- % get(Stream, Result, !IO) blocks until a message appears
- % on the data stream `Stream'. When a message arrives, `Result' is
- % bound to the value of the message.
- %
-:- pred get(concurrent_stream(T)::in, concurrent_stream.result(T)::out,
- io::di, io::uo) is det.
-
- % put(Stream, Thing, !IO) adds `Thing' to the end of the stream
- % `Stream', waking a call to get/4 if necessary.
- %
-:- pred put(concurrent_stream(T)::in, T::in, io::di, io::uo) is det.
-
- % end(Stream, !IO) puts an end-of-stream marker on the stream
- % `Stream', waking a call to get/4 if necessary.
- %
-:- pred end(concurrent_stream(T)::in, io::di, io::uo) is det.
-
- % error(Stream, !IO) puts an error message on the stream
- % `Stream', waking a call to get/4 if necessary.
- %
-:- pred error(concurrent_stream(T)::in, string::in, io::di, io::uo) is det.
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-
-:- implementation.
-
-:- pragma require_feature_set([concurrency]).
-
-:- import_module thread.
-:- import_module thread.semaphore.
-
-:- import_module queue.
-:- import_module require.
-:- import_module store.
-
-%-----------------------------------------------------------------------------%
-
-:- type concurrent_stream(T)
- ---> concurrent_stream(
- semaphore,
- io_mutvar(concurrent_stream0(T)),
- semaphore
- ).
-
-:- type concurrent_stream0(T) == queue(concurrent_stream.result(T)).
-
-new(Stream, !IO) :-
- queue.init(Queue),
- store.new_mutvar(Queue, QueueRef, !IO),
- semaphore.new(Lock, !IO),
- semaphore.signal(Lock, !IO),
- semaphore.new(Semaphore, !IO),
- Stream = concurrent_stream(Lock, QueueRef, Semaphore).
-
-put(Stream, Thing, !IO) :-
- Stream = concurrent_stream(Lock, QueueRef, Semaphore),
- wait(Lock, !IO),
- store.get_mutvar(QueueRef, Queue0, !IO),
- queue.put(Queue0, ok(Thing), Queue),
- store.set_mutvar(QueueRef, Queue, !IO),
- signal(Lock, !IO),
- signal(Semaphore, !IO).
-
-end(Stream, !IO) :-
- Stream = concurrent_stream(Lock, QueueRef, Semaphore),
- semaphore.wait(Lock, !IO),
- store.get_mutvar(QueueRef, Queue0, !IO),
- queue.put(Queue0, end, Queue),
- store.set_mutvar(QueueRef, Queue, !IO),
- semaphore.signal(Lock, !IO),
- semaphore.signal(Semaphore, !IO).
-
-error(Stream, Msg, !IO) :-
- Stream = concurrent_stream(Lock, QueueRef, Semaphore),
- semaphore.wait(Lock, !IO),
- store.get_mutvar(QueueRef, Queue0, !IO),
- queue.put(Queue0, error(Msg), Queue),
- store.set_mutvar(QueueRef, Queue, !IO),
- semaphore.signal(Lock, !IO),
- semaphore.signal(Semaphore, !IO).
-
-get(Stream, Thing, !IO) :-
- Stream = concurrent_stream(Lock, QueueRef, Semaphore),
- semaphore.wait(Semaphore, !IO),
- semaphore.wait(Lock, !IO),
- store.get_mutvar(QueueRef, Queue0, !IO),
- ( queue.get(Queue0, Thing0, Queue) ->
- Thing = Thing0,
- store.set_mutvar(QueueRef, Queue, !IO)
- ;
- error("concurrent_stream.get/4: queue and semaphore out of sync")
- ),
- semaphore.signal(Lock, !IO).
-
-%-----------------------------------------------------------------------------%
-:- end_module concurrent_stream.
-%-----------------------------------------------------------------------------%
Index: extras/concurrency/midi.m
===================================================================
RCS file: extras/concurrency/midi.m
diff -N extras/concurrency/midi.m
--- extras/concurrency/midi.m 9 Nov 2010 02:31:41 -0000 1.3
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,859 +0,0 @@
-%-----------------------------------------------------------------------------%
-% vim: ft=mercury ts=4 sw=4 et
-%-----------------------------------------------------------------------------%
-% Copyright (C) 2000, 2006, 2010 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: midi.m.
-% Main author: conway.
-%
-% This module provides routines for concurrently reading and writing MIDI
-% streams. MIDI stands for "Musical Instrument Digital Interface" and is a
-% hardware and software protocol for electronic instruments to talk to each
-% other.
-%
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-
-:- module midi.
-:- interface.
-
-:- import_module concurrent_stream.
-
-:- import_module io.
-:- import_module list.
-
-%-----------------------------------------------------------------------------%
-
- % For information about the meaning
- %
-:- type message
- ---> off(channel, note, velocity) % note off
- ; on(channel, note, velocity) % note on
- ; kp(channel, note, pressure) % polyphonic aftertouch
- ; cc(channel, parameter, value) % controller change
- ; pc(channel, program) % program change
- ; cp(channel, pressure) % monophonic aftertouch
- ; pw(channel, pitch_value) % pitch wheel change
- ; mm(channel, modes) % mode message
- ; sys(system) % system message
- ; rt(realtime). % realtime message
-
-:- type channel == int. % 0 - 15.
-:- type note == int. % 0 - 127
-:- type velocity == int. % 0 - 127
-:- type pressure == int. % 0 - 127
-:- type parameter == int. % 0 - 127
-:- type value == int. % 0 - 127
-:- type program == int. % 0 - 127
-:- type pitch_value == int. % 0 - (1 << 14 - 1) biased from 0x2000
-
-:- type modes
- ---> local(onoff)
- ; ano
- ; omni(onoff)
- ; mono(byte)
- ; poly.
-
-:- type onoff
- ---> off
- ; on.
-
-:- type system
- ---> sysex(list(byte))
- ; pos(int)
- ; sel(byte)
- ; tune.
-
-:- type realtime
- ---> clk
- ; start
- ; cont
- ; stop
- ; sense
- ; reset.
-
-:- type byte == int.
-
- % Reads from a concurrent stream of bytes and puts its outputs
- % on to a concurrent stream of midi messages.
- %
-:- pred read_midi(concurrent_stream(byte)::in, concurrent_stream(message)::in,
- io::di, io::uo) is det.
-
- % Reads from a concurrent stream of messages, and puts the messages
- % on to a concurrent stream of bytes.
- %
-:- pred write_midi(concurrent_stream(message)::in, concurrent_stream(byte)::in,
- io::di, io::uo) is det.
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-
-:- implementation.
-
-:- import_module bool.
-:- import_module int.
-:- import_module require.
-
-%-----------------------------------------------------------------------------%
-
-:- type hex
- ---> x0
- ; x1
- ; x2
- ; x3
- ; x4
- ; x5
- ; x6
- ; x7
- ; x8
- ; x9
- ; xA
- ; xB
- ; xC
- ; xD
- ; xE
- ; xF.
-
- % This type is used for storing the "running status" used by
- % most MIDI devices, where if the status-byte of two consecutive
- % messages (ignoring any intervening realtime messages) is the
- % same, then it may be omitted in the second message.
- %
-:- type status
- ---> none
- ; status(kind, channel).
-
-:- type kind
- ---> one(onebyte)
- ; two(twobyte).
-
-:- type onebyte
- ---> pc
- ; cp.
-
-:- type twobyte
- ---> off
- ; on
- ; kp
- ; cc
- ; pw.
-
-%-----------------------------------------------------------------------------%
-
- % The midi protocol has two classes of message. The majority of
- % messages including note and controller events fall in the first
- % class. A small number of events - the "realtime" events - can
- % occur in the middle of a normal event. In a sense, they are
- % like out-of-band data.
- %
- % To handle this, the MIDI parser is encoded as a state machine,
- % which remembers any message that is might be half way through
- % parsing when it receives a realtime event.
- %
- % For more info on the MIDI protocol, see a site like
- % <ftp://ftp.ucsd.edu/midi/doc/midi-intro.Z>
-
-read_midi(Ins, Outs, !IO) :-
- byte0(none, Ins, Outs, !IO).
-
-:- pred byte0(status::in, concurrent_stream(byte)::in,
- concurrent_stream(message)::in, io::di, io::uo) is det.
-
-byte0(Status, Ins, Outs, !IO) :-
- get(Ins, Res0, !IO),
- (
- Res0 = end,
- end(Outs, !IO)
- ;
- Res0 = error(Err),
- error(Outs, Err, !IO)
- ;
- Res0 = ok(Byte),
- byte2hex(Byte, MSN, LSN),
- byte0a(MSN, LSN, Status, Ins, Outs, !IO)
- ).
-
-:- pred byte0a(hex::in, hex::in, status::in,
- concurrent_stream(byte)::in, concurrent_stream(message)::in,
- io::di, io::uo) is det.
-
-byte0a(x0, LSN, Status, Ins, Outs, !IO) :-
- hex2byte(x0, LSN, Byte),
- byte1b(Status, Byte, Ins, Outs, !IO).
-byte0a(x1, LSN, Status, Ins, Outs, !IO) :-
- hex2byte(x1, LSN, Byte),
- byte1b(Status, Byte, Ins, Outs, !IO).
-byte0a(x2, LSN, Status, Ins, Outs, !IO) :-
- hex2byte(x2, LSN, Byte),
- byte1b(Status, Byte, Ins, Outs, !IO).
-byte0a(x3, LSN, Status, Ins, Outs, !IO) :-
- hex2byte(x3, LSN, Byte),
- byte1b(Status, Byte, Ins, Outs, !IO).
-byte0a(x4, LSN, Status, Ins, Outs, !IO) :-
- hex2byte(x4, LSN, Byte),
- byte1b(Status, Byte, Ins, Outs, !IO).
-byte0a(x5, LSN, Status, Ins, Outs, !IO) :-
- hex2byte(x5, LSN, Byte),
- byte1b(Status, Byte, Ins, Outs, !IO).
-byte0a(x6, LSN, Status, Ins, Outs, !IO) :-
- hex2byte(x6, LSN, Byte),
- byte1b(Status, Byte, Ins, Outs, !IO).
-byte0a(x7, LSN, Status, Ins, Outs, !IO) :-
- hex2byte(x7, LSN, Byte),
- byte1b(Status, Byte, Ins, Outs, !IO).
-byte0a(x8, LSN, _Status, Ins, Outs, !IO) :-
- nibble2hex(Chan, LSN),
- Status = status(two(off), Chan),
- byte1(Status, Ins, Outs, !IO).
-byte0a(x9, LSN, _Status, Ins, Outs, !IO) :-
- nibble2hex(Chan, LSN),
- Status = status(two(on), Chan),
- byte1(Status, Ins, Outs, !IO).
-byte0a(xA, LSN, _Status, Ins, Outs, !IO) :-
- nibble2hex(Chan, LSN),
- Status = status(two(kp), Chan),
- byte1(Status, Ins, Outs, !IO).
-byte0a(xB, LSN, _Status, Ins, Outs, !IO) :-
- nibble2hex(Chan, LSN),
- Status = status(two(cc), Chan),
- byte1(Status, Ins, Outs, !IO).
-byte0a(xC, LSN, _Status, Ins, Outs, !IO) :-
- nibble2hex(Chan, LSN),
- Status = status(one(pc), Chan),
- byte1(Status, Ins, Outs, !IO).
-byte0a(xD, LSN, _Status, Ins, Outs, !IO) :-
- nibble2hex(Chan, LSN),
- Status = status(one(cp), Chan),
- byte1(Status, Ins, Outs, !IO).
-byte0a(xE, LSN, _Status, Ins, Outs, !IO) :-
- nibble2hex(Chan, LSN),
- Status = status(two(pw), Chan),
- byte1(Status, Ins, Outs, !IO).
-byte0a(xF, x0, Status, Ins, Outs, !IO) :-
- sysex0(Status, Ins, Outs, !IO).
-byte0a(xF, x1, _Status, _Ins, Outs, !IO) :-
- error(Outs, "undefined system byte", !IO).
-byte0a(xF, x2, Status, Ins, Outs, !IO) :-
- pos0(Status, Ins, Outs, !IO).
-byte0a(xF, x3, Status, Ins, Outs, !IO) :-
- sel0(Status, Ins, Outs, !IO).
-byte0a(xF, x4, _Status, _Ins, Outs, !IO) :-
- error(Outs, "undefined system byte", !IO).
-byte0a(xF, x5, _Status, _Ins, Outs, !IO) :-
- error(Outs, "undefined system byte", !IO).
-byte0a(xF, x6, Status, Ins, Outs, !IO) :-
- put(Outs, sys(tune), !IO),
- byte0(Status, Ins, Outs, !IO).
-byte0a(xF, x7, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected system byte (byte0)", !IO).
-byte0a(xF, x8, Status, Ins, Outs, !IO) :-
- put(Outs, rt(clk), !IO),
- byte0(Status, Ins, Outs, !IO).
-byte0a(xF, x9, _Status, _Ins, Outs, !IO) :-
- error(Outs, "undefined system byte", !IO).
-byte0a(xF, xA, Status, Ins, Outs, !IO) :-
- put(Outs, rt(start), !IO),
- byte0(Status, Ins, Outs, !IO).
-byte0a(xF, xB, Status, Ins, Outs, !IO) :-
- put(Outs, rt(cont), !IO),
- byte0(Status, Ins, Outs, !IO).
-byte0a(xF, xC, Status, Ins, Outs, !IO) :-
- put(Outs, rt(stop), !IO),
- byte0(Status, Ins, Outs, !IO).
-byte0a(xF, xD, _Status, _Ins, Outs, !IO) :-
- error(Outs, "undefined system byte", !IO).
-byte0a(xF, xE, Status, Ins, Outs, !IO) :-
- put(Outs, rt(sense), !IO),
- byte0(Status, Ins, Outs, !IO).
-byte0a(xF, xF, Status, Ins, Outs, !IO) :-
- put(Outs, rt(reset), !IO),
- byte0(Status, Ins, Outs, !IO).
-
-:- pred byte1(status::in, concurrent_stream(byte)::in,
- concurrent_stream(message)::in, io::di, io::uo) is det.
-
-byte1(Status, Ins, Outs, !IO) :-
- get(Ins, Res0, !IO),
- (
- Res0 = end,
- error(Outs, "unexpected end of input", !IO)
- ;
- Res0 = error(Err),
- error(Outs, Err, !IO)
- ;
- Res0 = ok(Byte),
- byte2hex(Byte, MSN, LSN),
- byte1a(MSN, LSN, Status, Ins, Outs, !IO)
- ).
-
-:- pred byte1a(hex::in, hex::in, status::in,
- concurrent_stream(byte)::in, concurrent_stream(message)::in,
- io::di, io::uo) is det.
-
-byte1a(x0, LSN, Status, Ins, Outs, !IO) :-
- hex2byte(x0, LSN, Byte),
- byte1b(Status, Byte, Ins, Outs, !IO).
-byte1a(x1, LSN, Status, Ins, Outs, !IO) :-
- hex2byte(x1, LSN, Byte),
- byte1b(Status, Byte, Ins, Outs, !IO).
-byte1a(x2, LSN, Status, Ins, Outs, !IO) :-
- hex2byte(x2, LSN, Byte),
- byte1b(Status, Byte, Ins, Outs, !IO).
-byte1a(x3, LSN, Status, Ins, Outs, !IO) :-
- hex2byte(x3, LSN, Byte),
- byte1b(Status, Byte, Ins, Outs, !IO).
-byte1a(x4, LSN, Status, Ins, Outs, !IO) :-
- hex2byte(x4, LSN, Byte),
- byte1b(Status, Byte, Ins, Outs, !IO).
-byte1a(x5, LSN, Status, Ins, Outs, !IO) :-
- hex2byte(x5, LSN, Byte),
- byte1b(Status, Byte, Ins, Outs, !IO).
-byte1a(x6, LSN, Status, Ins, Outs, !IO) :-
- hex2byte(x6, LSN, Byte),
- byte1b(Status, Byte, Ins, Outs, !IO).
-byte1a(x7, LSN, Status, Ins, Outs, !IO) :-
- hex2byte(x7, LSN, Byte),
- byte1b(Status, Byte, Ins, Outs, !IO).
-byte1a(x8, _LSN, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected status byte", !IO).
-byte1a(x9, _LSN, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected status byte", !IO).
-byte1a(xA, _LSN, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected status byte", !IO).
-byte1a(xB, _LSN, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected status byte", !IO).
-byte1a(xC, _LSN, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected status byte", !IO).
-byte1a(xD, _LSN, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected status byte", !IO).
-byte1a(xE, _LSN, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected status byte", !IO).
-byte1a(xF, x0, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected system byte", !IO).
-byte1a(xF, x1, _Status, _Ins, Outs, !IO) :-
- error(Outs, "undefined system byte", !IO).
-byte1a(xF, x2, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected system byte", !IO).
-byte1a(xF, x3, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected system byte", !IO).
-byte1a(xF, x4, _Status, _Ins, Outs, !IO) :-
- error(Outs, "undefined system byte", !IO).
-byte1a(xF, x5, _Status, _Ins, Outs, !IO) :-
- error(Outs, "undefined system byte", !IO).
-byte1a(xF, x6, Status, Ins, Outs, !IO) :-
- put(Outs, sys(tune), !IO),
- byte1(Status, Ins, Outs, !IO).
-byte1a(xF, x7, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected system byte", !IO).
-byte1a(xF, x8, Status, Ins, Outs, !IO) :-
- put(Outs, rt(clk), !IO),
- byte1(Status, Ins, Outs, !IO).
-byte1a(xF, x9, _Status, _Ins, Outs, !IO) :-
- error(Outs, "undefined system byte", !IO).
-byte1a(xF, xA, Status, Ins, Outs, !IO) :-
- put(Outs, rt(start), !IO),
- byte1(Status, Ins, Outs, !IO).
-byte1a(xF, xB, Status, Ins, Outs, !IO) :-
- put(Outs, rt(cont), !IO),
- byte1(Status, Ins, Outs, !IO).
-byte1a(xF, xC, Status, Ins, Outs, !IO) :-
- put(Outs, rt(stop), !IO),
- byte1(Status, Ins, Outs, !IO).
-byte1a(xF, xD, _Status, _Ins, Outs, !IO) :-
- error(Outs, "undefined system byte", !IO).
-byte1a(xF, xE, Status, Ins, Outs, !IO) :-
- put(Outs, rt(sense), !IO),
- byte1(Status, Ins, Outs, !IO).
-byte1a(xF, xF, Status, Ins, Outs, !IO) :-
- put(Outs, rt(reset), !IO),
- byte1(Status, Ins, Outs, !IO).
-
-:- pred byte1b(status::in, byte::in, concurrent_stream(byte)::in,
- concurrent_stream(message)::in, io::di, io::uo) is det.
-
-byte1b(none, _Byte, Ins, Outs, !IO) :-
- byte0(none, Ins, Outs, !IO).
-byte1b(status(one(Kind), Chan), Byte, Ins, Outs, !IO) :-
- (
- Kind = pc,
- Msg = pc(Chan, Byte)
- ;
- Kind = cp,
- Msg = cp(Chan, Byte)
- ),
- put(Outs, Msg, !IO),
- byte0(status(one(Kind), Chan), Ins, Outs, !IO).
-byte1b(status(two(Kind), Chan), Byte1, Ins, Outs, !IO) :-
- byte2(status(two(Kind), Chan), Byte1, Ins, Outs, !IO).
-
-:- pred byte2(status::in, byte::in, concurrent_stream(byte)::in,
- concurrent_stream(message)::in, io::di, io::uo) is det.
-
-byte2(Status, Byte1, Ins, Outs, !IO) :-
- get(Ins, Res0, !IO),
- (
- Res0 = end,
- error(Outs, "unexpected end of input", !IO)
- ;
- Res0 = error(Err),
- error(Outs, Err, !IO)
- ;
- Res0 = ok(Byte2),
- byte2hex(Byte2, MSN2, LSN2),
- byte2a(MSN2, LSN2, Byte1, Status, Ins, Outs, !IO)
- ).
-
-:- pred byte2a(hex::in, hex::in, byte::in, status::in,
- concurrent_stream(byte)::in, concurrent_stream(message)::in,
- io::di, io::uo) is det.
-
-byte2a(x0, LSN, Byte1, Status, Ins, Outs, !IO) :-
- hex2byte(x0, LSN, Byte2),
- byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
-byte2a(x1, LSN, Byte1, Status, Ins, Outs, !IO) :-
- hex2byte(x1, LSN, Byte2),
- byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
-byte2a(x2, LSN, Byte1, Status, Ins, Outs, !IO) :-
- hex2byte(x2, LSN, Byte2),
- byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
-byte2a(x3, LSN, Byte1, Status, Ins, Outs, !IO) :-
- hex2byte(x3, LSN, Byte2),
- byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
-byte2a(x4, LSN, Byte1, Status, Ins, Outs, !IO) :-
- hex2byte(x4, LSN, Byte2),
- byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
-byte2a(x5, LSN, Byte1, Status, Ins, Outs, !IO) :-
- hex2byte(x5, LSN, Byte2),
- byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
-byte2a(x6, LSN, Byte1, Status, Ins, Outs, !IO) :-
- hex2byte(x6, LSN, Byte2),
- byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
-byte2a(x7, LSN, Byte1, Status, Ins, Outs, !IO) :-
- hex2byte(x7, LSN, Byte2),
- byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
-byte2a(x8, _LSN, _Byte1, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected status byte", !IO).
-byte2a(x9, _LSN, _Byte1, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected status byte", !IO).
-byte2a(xA, _LSN, _Byte1, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected status byte", !IO).
-byte2a(xB, _LSN, _Byte1, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected status byte", !IO).
-byte2a(xC, _LSN, _Byte1, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected status byte", !IO).
-byte2a(xD, _LSN, _Byte1, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected status byte", !IO).
-byte2a(xE, _LSN, _Byte1, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected status byte", !IO).
-byte2a(xF, x0, _Byte1, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected system byte", !IO).
-byte2a(xF, x1, _Byte1, _Status, _Ins, Outs, !IO) :-
- error(Outs, "undefined system byte", !IO).
-byte2a(xF, x2, _Byte1, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected system byte", !IO).
-byte2a(xF, x3, _Byte1, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected system byte", !IO).
-byte2a(xF, x4, _Byte1, _Status, _Ins, Outs, !IO) :-
- error(Outs, "undefined system byte", !IO).
-byte2a(xF, x5, _Byte1, _Status, _Ins, Outs, !IO) :-
- error(Outs, "undefined system byte", !IO).
-byte2a(xF, x6, Byte1, Status, Ins, Outs, !IO) :-
- put(Outs, sys(tune), !IO),
- byte2(Status, Byte1, Ins, Outs, !IO).
-byte2a(xF, x7, _Byte1, _Status, _Ins, Outs, !IO) :-
- error(Outs, "unexpected system byte", !IO).
-byte2a(xF, x8, Byte1, Status, Ins, Outs, !IO) :-
- put(Outs, rt(clk), !IO),
- byte2(Status, Byte1, Ins, Outs, !IO).
-byte2a(xF, x9, _Byte1, _Status, _Ins, Outs, !IO) :-
- error(Outs, "undefined system byte", !IO).
-byte2a(xF, xA, Byte1, Status, Ins, Outs, !IO) :-
- put(Outs, rt(start), !IO),
- byte2(Status, Byte1, Ins, Outs, !IO).
-byte2a(xF, xB, Byte1, Status, Ins, Outs, !IO) :-
- put(Outs, rt(cont), !IO),
- byte2(Status, Byte1, Ins, Outs, !IO).
-byte2a(xF, xC, Byte1, Status, Ins, Outs, !IO) :-
- put(Outs, rt(stop), !IO),
- byte2(Status, Byte1, Ins, Outs, !IO).
-byte2a(xF, xD, _Byte1, _Status, _Ins, Outs, !IO) :-
- error(Outs, "undefined system byte", !IO).
-byte2a(xF, xE, Byte1, Status, Ins, Outs, !IO) :-
- put(Outs, rt(sense), !IO),
- byte2(Status, Byte1, Ins, Outs, !IO).
-byte2a(xF, xF, Byte1, Status, Ins, Outs, !IO) :-
- put(Outs, rt(reset), !IO),
- byte2(Status, Byte1, Ins, Outs, !IO).
-
-:- pred byte2b(status::in, byte::in, byte::in,
- concurrent_stream(byte)::in, concurrent_stream(message)::in,
- io::di, io::uo) is det.
-
-byte2b(none, _Byte1, _Byte2, Ins, Outs, !IO) :-
- byte0(none, Ins, Outs, !IO).
-byte2b(status(one(_), _Chan), _Byte1, _Byte2, _Ins, Outs, !IO) :-
- error(Outs, "internal error", !IO).
-byte2b(status(two(Kind), Chan), Byte1, Byte2, Ins, Outs, !IO) :-
- (
- Kind = off,
- Msg = off(Chan, Byte1, Byte2)
- ;
- Kind = on,
- Msg = on(Chan, Byte1, Byte2)
- ;
- Kind = kp,
- Msg = kp(Chan, Byte1, Byte2)
- ;
- Kind = cc,
- (
- (
- Byte1 = 122,
- OnOrOff = ( Byte2 = 0 -> off ; on ),
- Msg0 = mm(Chan, local(OnOrOff))
- ;
- Byte1 = 123,
- Msg0 = mm(Chan, ano)
- ;
- Byte1 = 124,
- Msg0 = mm(Chan, omni(off))
- ;
- Byte1 = 125,
- Msg0 = mm(Chan, omni(on))
- ;
- Byte1 = 126,
- Msg0 = mm(Chan, mono(Byte2))
- ;
- Byte1 = 127,
- Msg0 = mm(Chan, poly)
- )
- ->
- Msg = Msg0
- ;
- Msg = cc(Chan, Byte1, Byte2)
- )
- ;
- Kind = pw,
- Val = (Byte1 /\ 0x7F) \/ ((Byte2 /\ 0x7F) << 7),
- Msg = pw(Chan, Val)
- ),
- put(Outs, Msg, !IO),
- byte0(status(two(Kind), Chan), Ins, Outs, !IO).
-
-:- pred sysex0(status::in, concurrent_stream(byte)::in,
- concurrent_stream(message)::in, io::di, io::uo) is det.
-
-sysex0(Status, Ins, Outs, !IO) :-
- sysex1([], Status, Ins, Outs, !IO).
-
-:- pred sysex1(list(byte)::in, status::in, concurrent_stream(byte)::in,
- concurrent_stream(message)::in, io::di, io::uo) is det.
-
-sysex1(Bytes0, Status, Ins, Outs, !IO) :-
- get(Ins, Res0, !IO),
- (
- Res0 = end,
- error(Outs, "unexpected end of input", !IO)
- ;
- Res0 = error(Err),
- error(Outs, Err, !IO)
- ;
- Res0 = ok(Byte),
- ( Byte >= 0, Byte =< 127 ->
- sysex1([Byte|Bytes0], Status, Ins, Outs, !IO)
- ;
- list.reverse(Bytes0, Bytes),
- put(Outs, sys(sysex(Bytes)), !IO),
- ( Byte = 0xF7 ->
- byte0(Status, Ins, Outs, !IO)
- ;
- byte2hex(Byte, MSN, LSN),
- byte0a(MSN, LSN, Status, Ins, Outs, !IO)
- )
- )
- ).
-
-:- pred pos0(status::in, concurrent_stream(byte)::in,
- concurrent_stream(message)::in, io::di, io::uo) is det.
-
-pos0(Status, Ins, Outs, !IO) :-
- get(Ins, Res0, !IO),
- (
- Res0 = end,
- error(Outs, "unexpected end of input", !IO)
- ;
- Res0 = error(Err),
- error(Outs, Err, !IO)
- ;
- Res0 = ok(Byte),
- pos1(Byte, Status, Ins, Outs, !IO)
- ).
-
-:- pred pos1(byte::in, status::in, concurrent_stream(byte)::in,
- concurrent_stream(message)::in, io::di, io::uo) is det.
-
-pos1(Byte1, Status, Ins, Outs, !IO) :-
- get(Ins, Res0, !IO),
- (
- Res0 = end,
- error(Outs, "unexpected end of input", !IO)
- ;
- Res0 = error(Err),
- error(Outs, Err, !IO)
- ;
- Res0 = ok(Byte2),
- Val = (Byte1 /\ 0x7F) \/ ((Byte2 /\ 0x7F) << 7),
- put(Outs, sys(pos(Val)), !IO),
- byte0(Status, Ins, Outs, !IO)
- ).
-
-:- pred sel0(status::in, concurrent_stream(byte)::in,
- concurrent_stream(message)::in, io::di, io::uo) is det.
-
-sel0(Status, Ins, Outs, !IO) :-
- get(Ins, Res0, !IO),
- (
- Res0 = end,
- error(Outs, "unexpected end of input", !IO)
- ;
- Res0 = error(Err),
- error(Outs, Err, !IO)
- ;
- Res0 = ok(Byte),
- put(Outs, sys(sel(Byte)), !IO),
- byte0(Status, Ins, Outs, !IO)
- ).
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-
-write_midi(Ins, Outs, !IO) :-
- write_midi(none, Ins, Outs, !IO).
-
-:- pred write_midi(status::in, concurrent_stream(message)::in,
- concurrent_stream(byte)::in, io::di, io::uo) is det.
-
-write_midi(Status, Ins, Outs, !IO) :-
- get(Ins, Res0, !IO),
- (
- Res0 = end,
- end(Outs, !IO)
- ;
- Res0 = error(Msg),
- error(Outs, Msg, !IO)
- ;
- Res0 = ok(Msg),
- write_midi(Msg, Status, Ins, Outs, !IO)
- ).
-
-:- pred write_midi(message::in, status::in, concurrent_stream(message)::in,
- concurrent_stream(byte)::in, io::di, io::uo) is det.
-
-write_midi(off(Chan, Note, Vel), Status0, Ins, Outs, !IO) :-
- Status1 = status(two(off), Chan),
- write_two(Status0, Status1, Note, Vel, Ins, Outs, !IO).
-write_midi(on(Chan, Note, Vel), Status0, Ins, Outs, !IO) :-
- Status1 = status(two(on), Chan),
- write_two(Status0, Status1, Note, Vel, Ins, Outs, !IO).
-write_midi(kp(Chan, Note, Press), Status0, Ins, Outs, !IO) :-
- Status1 = status(two(kp), Chan),
- write_two(Status0, Status1, Note, Press, Ins, Outs, !IO).
-write_midi(cc(Chan, Ctrl, Val), Status0, Ins, Outs, !IO) :-
- Status1 = status(two(cc), Chan),
- write_two(Status0, Status1, Ctrl, Val, Ins, Outs, !IO).
-write_midi(pc(Chan, Prog), Status0, Ins, Outs, !IO) :-
- Status1 = status(one(pc), Chan),
- write_one(Status0, Status1, Prog, Ins, Outs, !IO).
-write_midi(cp(Chan, Press), Status0, Ins, Outs, !IO) :-
- Status1 = status(one(cp), Chan),
- write_one(Status0, Status1, Press, Ins, Outs, !IO).
-write_midi(pw(Chan, Val), Status0, Ins, Outs, !IO) :-
- Status1 = status(two(pw), Chan),
- Byte1 = Val /\ 0x7F,
- Byte2 = (Val >> 7) /\ 0x7F,
- write_two(Status0, Status1, Byte1, Byte2, Ins, Outs, !IO).
-write_midi(mm(Chan, Mode), Status0, Ins, Outs, !IO) :-
- Status1 = status(two(cc), Chan),
- (
- Mode = local(off),
- Byte1 = 122, Byte2 = 0
- ;
- Mode = local(on),
- Byte1 = 122, Byte2 = 127
- ;
- Mode = ano,
- Byte1 = 123, Byte2 = 0
- ;
- Mode = omni(off),
- Byte1 = 124, Byte2 = 0
- ;
- Mode = omni(on),
- Byte1 = 125, Byte2 = 0
- ;
- Mode = mono(N),
- Byte1 = 126, Byte2 = N /\ 0x7F
- ;
- Mode = poly,
- Byte1 = 127, Byte2 = 0
- ),
- write_two(Status0, Status1, Byte1, Byte2, Ins, Outs, !IO).
-write_midi(sys(sysex(Bytes)), Status, Ins, Outs, !IO) :-
- put(Outs, 0xF0, !IO),
- PutByte = (pred(Byte::in, !.IO::di, !:IO::uo) is det :-
- ( Byte >= 0, Byte =< 127 ->
- put(Outs, Byte, !IO)
- ;
- error(Outs, "sysex data byte out of range", !IO)
- )
- ),
- list.foldl(PutByte, Bytes, !IO),
- put(Outs, 0xF7, !IO),
- write_midi(Status, Ins, Outs, !IO).
-write_midi(sys(pos(Pos)), Status, Ins, Outs, !IO) :-
- put(Outs, 0xF2, !IO),
- Byte1 = Pos /\ 0x7F,
- Byte2 = (Pos >> 7) /\ 0x7F,
- put(Outs, Byte1, !IO),
- put(Outs, Byte2, !IO),
- write_midi(Status, Ins, Outs, !IO).
-write_midi(sys(sel(Sel)), Status, Ins, Outs, !IO) :-
- put(Outs, 0xF3, !IO),
- put(Outs, Sel, !IO),
- write_midi(Status, Ins, Outs, !IO).
-write_midi(sys(tune), Status, Ins, Outs, !IO) :-
- put(Outs, 0xF6, !IO),
- write_midi(Status, Ins, Outs, !IO).
-write_midi(rt(clk), Status, Ins, Outs, !IO) :-
- put(Outs, 0xF8, !IO),
- write_midi(Status, Ins, Outs, !IO).
-write_midi(rt(start), Status, Ins, Outs, !IO) :-
- put(Outs, 0xFA, !IO),
- write_midi(Status, Ins, Outs, !IO).
-write_midi(rt(cont), Status, Ins, Outs, !IO) :-
- put(Outs, 0xFB, !IO),
- write_midi(Status, Ins, Outs, !IO).
-write_midi(rt(stop), Status, Ins, Outs, !IO) :-
- put(Outs, 0xFC, !IO),
- write_midi(Status, Ins, Outs, !IO).
-write_midi(rt(sense), Status, Ins, Outs, !IO) :-
- put(Outs, 0xFE, !IO),
- write_midi(Status, Ins, Outs, !IO).
-write_midi(rt(reset), Status, Ins, Outs, !IO) :-
- put(Outs, 0xFF, !IO),
- write_midi(Status, Ins, Outs, !IO).
-
-:- pred write_one(status::in, status::in, byte::in,
- concurrent_stream(message)::in, concurrent_stream(byte)::in,
- io::di, io::uo) is det.
-
-write_one(Status0, Status1, Byte1, Ins, Outs, !IO) :-
- ( Status0 = Status1 ->
- Status = Status0
- ;
- Status = Status1,
- ( status(Status, Byte) ->
- put(Outs, Byte, !IO)
- ;
- error(Outs, "invalid channel", !IO)
- )
- ),
- ( Byte1 >= 0, Byte1 =< 127 ->
- put(Outs, Byte1, !IO)
- ;
- error(Outs, "invalid data byte", !IO)
- ),
- write_midi(Status, Ins, Outs, !IO).
-
-:- pred write_two(status::in, status::in, byte::in, byte::in,
- concurrent_stream(message)::in,
- concurrent_stream(byte)::in, io::di, io::uo) is det.
-
-write_two(Status0, Status1, Byte1, Byte2, Ins, Outs, !IO) :-
- ( Status0 = Status1 ->
- Status = Status0
- ;
- Status = Status1,
- ( status(Status, Byte) ->
- put(Outs, Byte, !IO)
- ;
- error(Outs, "invalid channel", !IO)
- )
- ),
- ( Byte1 >= 0, Byte1 =< 127 ->
- put(Outs, Byte1, !IO)
- ;
- error(Outs, "invalid data byte", !IO)
- ),
- ( Byte2 >= 0, Byte2 =< 127 ->
- put(Outs, Byte2, !IO)
- ;
- error(Outs, "invalid data byte", !IO)
- ),
- write_midi(Status, Ins, Outs, !IO).
-
-:- pred status(status::in, byte::out) is semidet.
-
-status(none, _) :-
- error("status: no status").
-status(status(Kind, Chan), Byte) :-
- Chan >= 0, Chan =< 15,
- ( Kind = two(off), Nib = 0x80
- ; Kind = two(on), Nib = 0x90
- ; Kind = two(kp), Nib = 0xA0
- ; Kind = two(cc), Nib = 0xB0
- ; Kind = one(pc), Nib = 0xC0
- ; Kind = one(cp), Nib = 0xD0
- ; Kind = two(pw), Nib = 0xE0
- ),
- Byte = Nib \/ Chan.
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-
-:- pred byte2hex(int::in, hex::out, hex::out) is det.
-
-byte2hex(Byte, MSN, LSN) :-
- (
- nibble2hex(Byte /\ 0xF, LSN0),
- nibble2hex((Byte >> 4) /\ 0xF, MSN0)
- ->
- LSN = LSN0,
- MSN = MSN0
- ;
- error("byte2hex: conversion failed!")
- ).
-
-:- pred hex2byte(hex::in, hex::in, int::out) is det.
-
-hex2byte(MSN, LSN, Byte) :-
- nibble2hex(A, MSN),
- nibble2hex(B, LSN),
- Byte = B \/ (A << 4).
-
-:- pred nibble2hex(int, hex).
-:- mode nibble2hex(in, out) is semidet.
-:- mode nibble2hex(out, in) is det.
-
-nibble2hex(0x0, x0).
-nibble2hex(0x1, x1).
-nibble2hex(0x2, x2).
-nibble2hex(0x3, x3).
-nibble2hex(0x4, x4).
-nibble2hex(0x5, x5).
-nibble2hex(0x6, x6).
-nibble2hex(0x7, x7).
-nibble2hex(0x8, x8).
-nibble2hex(0x9, x9).
-nibble2hex(0xA, xA).
-nibble2hex(0xB, xB).
-nibble2hex(0xC, xC).
-nibble2hex(0xD, xD).
-nibble2hex(0xE, xE).
-nibble2hex(0xF, xF).
-
-%-----------------------------------------------------------------------------%
-:- end_module midi.
-%-----------------------------------------------------------------------------%
Index: extras/concurrency/midi_data
===================================================================
RCS file: extras/concurrency/midi_data
diff -N extras/concurrency/midi_data
Binary files /tmp/cvsu67LH2 and /dev/null differ
Index: extras/concurrency/midimon.m
===================================================================
RCS file: extras/concurrency/midimon.m
diff -N extras/concurrency/midimon.m
--- extras/concurrency/midimon.m 9 Nov 2010 02:31:41 -0000 1.4
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,178 +0,0 @@
-%----------------------------------------------------------------------------%
-% vim: ft=mercury ts=4 sw=4 et
-%-----------------------------------------------------------------------------%
-
-:- module midimon.
-
-:- interface.
-:- import_module io.
-
-:- pred main(io::di, io::uo) is cc_multi.
-
-%----------------------------------------------------------------------------%
-%----------------------------------------------------------------------------%
-
-:- implementation.
-
-:- pragma require_feature_set([concurrency]).
-
-:- import_module concurrent_stream.
-:- import_module midi.
-
-:- import_module bool.
-:- import_module char.
-:- import_module getopt.
-:- import_module int.
-:- import_module list.
-:- import_module maybe.
-:- import_module require.
-:- import_module string.
-:- import_module thread.
-
-%----------------------------------------------------------------------------%
-
-main(!IO) :-
- io.command_line_arguments(Args0, !IO),
- process_options(
- option_ops_multi(short_option, long_option, option_defaults),
- Args0, _Args, MOpts),
- (
- MOpts = ok(Opts),
- lookup_bool_option(Opts, help, Help),
- (
- Help = yes,
- help(!IO)
- ;
- Help = no,
- lookup_maybe_string_option(Opts, input, MInfile),
- open_input(MInfile, InFileOpened, !IO),
- (
- InFileOpened = yes,
- new(Bytes0, !IO),
- new(Messages, !IO),
- spawn((pred(!.IO::di, !:IO::uo) is cc_multi :-
- read_midi(Bytes0, Messages, !IO)
- ), !IO),
- spawn((pred(!.IO::di, !:IO::uo) is cc_multi :-
- print_messages(Messages, !IO)
- ), !IO),
- read_input(Bytes0, !IO)
- ;
- InFileOpened = no
- )
- )
- ;
- MOpts = error(Msg),
- io.stderr_stream(StdErr, !IO),
- io.format(StdErr, "%s\n", [s(Msg)], !IO),
- io.set_exit_status(1, !IO)
- ).
-
-:- pred open_input(maybe(string)::in, bool::out, io::di, io::uo) is det.
-
-open_input(no, Opened, !IO) :-
- io.see_binary("/dev/midi", Res, !IO),
- (
- Res = ok,
- Opened = yes
- ;
- Res = error(Err),
- io.error_message(Err, Msg),
- io.stderr_stream(StdErr, !IO),
- io.format(StdErr, "error opening `/dev/midi': %s\n", [s(Msg)], !IO),
- Opened = no
- ).
-open_input(yes(FileName), Opened, !IO) :-
- ( FileName = "-" ->
- % use stdin
- Opened = yes
- ;
- io.see_binary(FileName, Res, !IO),
- (
- Res = ok,
- Opened = yes
- ;
- Res = error(Err),
- io.error_message(Err, Msg),
- io.stderr_stream(StdErr, !IO),
- io.format(StdErr, "error opening `%s': %s\n",
- [s(FileName), s(Msg)], !IO),
- Opened = no
- )
- ).
-
-:- pred read_input(concurrent_stream(byte)::in,
- io::di, io::uo) is det.
-
-read_input(Stream, !IO) :-
- io.read_byte(Res0, !IO),
- (
- Res0 = eof,
- end(Stream, !IO)
- ;
- Res0 = error(Err),
- io.error_message(Err, Msg),
- error(Stream, Msg, !IO)
- ;
- Res0 = ok(Byte),
- put(Stream, Byte, !IO),
- read_input(Stream, !IO)
- ).
-
-:- pred print_messages(concurrent_stream(message)::in,
- io::di, io::uo) is det.
-
-print_messages(Stream, !IO) :-
- get(Stream, Res0, !IO),
- (
- Res0 = ok(Msg),
- io.write(Msg, !IO),
- io.write_string(".\n", !IO),
- print_messages(Stream, !IO)
- ;
- Res0 = end
- ;
- Res0 = error(Msg),
- io.write_string(Msg, !IO),
- io.nl(!IO)
- ).
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-
-:- type option_table == option_table(option).
-:- type maybe_option_table == maybe_option_table(option).
-
- % The master list of options.
- %
-:- type option
- ---> help
- ; input.
-
-:- pred long_option(string::in, option::out) is semidet.
-
-long_option("help", help).
-long_option("input-file", input).
-
-:- pred short_option(char::in, option::out) is semidet.
-
-short_option('h', help).
-short_option('i', input).
-
-:- pred option_defaults(option::out, option_data::out) is multi.
-
-option_defaults(help, bool(no)).
-option_defaults(input, maybe_string(no)).
-
-:- pred help(io::di, io::uo) is det.
-
-help(!IO) :-
- io.write_strings([
-"usage: midimon [--help|-h] [--input-file|-i <filename>]\n",
-" --help|-h print this help message.\n",
-" --input-file|-i <file> read from <file> (default is /dev/midi).\n"
- ], !IO).
-
-%-----------------------------------------------------------------------------%
-:- end_module midimon.
-%-----------------------------------------------------------------------------%
Index: samples/README
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/samples/README,v
retrieving revision 1.10
diff -u -r1.10 README
--- samples/README 7 Jul 2010 07:43:32 -0000 1.10
+++ samples/README 9 Nov 2010 07:31:18 -0000
@@ -47,6 +47,9 @@
- some solutions (determined by a user-specified criteria)
for a query which has more than one logically correct answer.
+The `concurrency' sub-directory contains examples of how to use Mercury's
+concurrency interface, i.e. using threads in Mercury programs.
+
There are also some sub-directories which contain examples of multi-module
Mercury programs:
Index: samples/concurrency/dining_philosophers/README
===================================================================
RCS file: samples/concurrency/dining_philosophers/README
diff -N samples/concurrency/dining_philosophers/README
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ samples/concurrency/dining_philosophers/README 9 Nov 2010 07:35:03 -0000
@@ -0,0 +1,7 @@
+This directory contains several variants on the dining philosophers example.
+
+ philo - uses a single semaphore for synchronization.
+
+ philo2 - uses a single mvar.
+
+ philo3 - uses one semaphore per thread.
Index: samples/concurrency/midimon/README
===================================================================
RCS file: samples/concurrency/midimon/README
diff -N samples/concurrency/midimon/README
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ samples/concurrency/midimon/README 9 Nov 2010 07:37:48 -0000
@@ -0,0 +1,6 @@
+This directory contains a MIDI data monitor that concurrently reads the
+bytestream, parses the MIDI messages, and writes out the results.
+A file `midi_data' has been included which contains some MIDI data that
+you can test the program with. MIDI (Musical Instrument Digital Interface)
+is a hardware and software protocol for electronic musical instruments (e.g.
+synthesizers) to talk to each other.
Index: samples/concurrency/midimon/concurrent_stream.m
===================================================================
RCS file: samples/concurrency/midimon/concurrent_stream.m
diff -N samples/concurrency/midimon/concurrent_stream.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ samples/concurrency/midimon/concurrent_stream.m 9 Nov 2010 02:32:37 -0000
@@ -0,0 +1,133 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2000, 2006, 2010 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: concurrent_stream.m.
+% Main author: conway.
+% Stability: medium.
+%
+% This module implements a simple concurrent data-stream.
+%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- module concurrent_stream.
+:- interface.
+
+:- import_module io.
+
+%-----------------------------------------------------------------------------%
+
+:- type concurrent_stream(T).
+
+:- type concurrent_stream.result(T)
+ ---> end
+ ; error(string)
+ ; ok(T).
+
+ % new(Stream, !IO) creates a new data concurrent_stream `Stream'.
+ %
+:- pred new(concurrent_stream(T)::out, io::di, io::uo) is det.
+
+ % get(Stream, Result, !IO) blocks until a message appears
+ % on the data stream `Stream'. When a message arrives, `Result' is
+ % bound to the value of the message.
+ %
+:- pred get(concurrent_stream(T)::in, concurrent_stream.result(T)::out,
+ io::di, io::uo) is det.
+
+ % put(Stream, Thing, !IO) adds `Thing' to the end of the stream
+ % `Stream', waking a call to get/4 if necessary.
+ %
+:- pred put(concurrent_stream(T)::in, T::in, io::di, io::uo) is det.
+
+ % end(Stream, !IO) puts an end-of-stream marker on the stream
+ % `Stream', waking a call to get/4 if necessary.
+ %
+:- pred end(concurrent_stream(T)::in, io::di, io::uo) is det.
+
+ % error(Stream, !IO) puts an error message on the stream
+ % `Stream', waking a call to get/4 if necessary.
+ %
+:- pred error(concurrent_stream(T)::in, string::in, io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- pragma require_feature_set([concurrency]).
+
+:- import_module thread.
+:- import_module thread.semaphore.
+
+:- import_module queue.
+:- import_module require.
+:- import_module store.
+
+%-----------------------------------------------------------------------------%
+
+:- type concurrent_stream(T)
+ ---> concurrent_stream(
+ semaphore,
+ io_mutvar(concurrent_stream0(T)),
+ semaphore
+ ).
+
+:- type concurrent_stream0(T) == queue(concurrent_stream.result(T)).
+
+new(Stream, !IO) :-
+ queue.init(Queue),
+ store.new_mutvar(Queue, QueueRef, !IO),
+ semaphore.new(Lock, !IO),
+ semaphore.signal(Lock, !IO),
+ semaphore.new(Semaphore, !IO),
+ Stream = concurrent_stream(Lock, QueueRef, Semaphore).
+
+put(Stream, Thing, !IO) :-
+ Stream = concurrent_stream(Lock, QueueRef, Semaphore),
+ wait(Lock, !IO),
+ store.get_mutvar(QueueRef, Queue0, !IO),
+ queue.put(Queue0, ok(Thing), Queue),
+ store.set_mutvar(QueueRef, Queue, !IO),
+ signal(Lock, !IO),
+ signal(Semaphore, !IO).
+
+end(Stream, !IO) :-
+ Stream = concurrent_stream(Lock, QueueRef, Semaphore),
+ semaphore.wait(Lock, !IO),
+ store.get_mutvar(QueueRef, Queue0, !IO),
+ queue.put(Queue0, end, Queue),
+ store.set_mutvar(QueueRef, Queue, !IO),
+ semaphore.signal(Lock, !IO),
+ semaphore.signal(Semaphore, !IO).
+
+error(Stream, Msg, !IO) :-
+ Stream = concurrent_stream(Lock, QueueRef, Semaphore),
+ semaphore.wait(Lock, !IO),
+ store.get_mutvar(QueueRef, Queue0, !IO),
+ queue.put(Queue0, error(Msg), Queue),
+ store.set_mutvar(QueueRef, Queue, !IO),
+ semaphore.signal(Lock, !IO),
+ semaphore.signal(Semaphore, !IO).
+
+get(Stream, Thing, !IO) :-
+ Stream = concurrent_stream(Lock, QueueRef, Semaphore),
+ semaphore.wait(Semaphore, !IO),
+ semaphore.wait(Lock, !IO),
+ store.get_mutvar(QueueRef, Queue0, !IO),
+ ( queue.get(Queue0, Thing0, Queue) ->
+ Thing = Thing0,
+ store.set_mutvar(QueueRef, Queue, !IO)
+ ;
+ error("concurrent_stream.get/4: queue and semaphore out of sync")
+ ),
+ semaphore.signal(Lock, !IO).
+
+%-----------------------------------------------------------------------------%
+:- end_module concurrent_stream.
+%-----------------------------------------------------------------------------%
Index: samples/concurrency/midimon/midi.m
===================================================================
RCS file: samples/concurrency/midimon/midi.m
diff -N samples/concurrency/midimon/midi.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ samples/concurrency/midimon/midi.m 9 Nov 2010 02:32:37 -0000
@@ -0,0 +1,859 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2000, 2006, 2010 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: midi.m.
+% Main author: conway.
+%
+% This module provides routines for concurrently reading and writing MIDI
+% streams. MIDI stands for "Musical Instrument Digital Interface" and is a
+% hardware and software protocol for electronic instruments to talk to each
+% other.
+%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- module midi.
+:- interface.
+
+:- import_module concurrent_stream.
+
+:- import_module io.
+:- import_module list.
+
+%-----------------------------------------------------------------------------%
+
+ % For information about the meaning
+ %
+:- type message
+ ---> off(channel, note, velocity) % note off
+ ; on(channel, note, velocity) % note on
+ ; kp(channel, note, pressure) % polyphonic aftertouch
+ ; cc(channel, parameter, value) % controller change
+ ; pc(channel, program) % program change
+ ; cp(channel, pressure) % monophonic aftertouch
+ ; pw(channel, pitch_value) % pitch wheel change
+ ; mm(channel, modes) % mode message
+ ; sys(system) % system message
+ ; rt(realtime). % realtime message
+
+:- type channel == int. % 0 - 15.
+:- type note == int. % 0 - 127
+:- type velocity == int. % 0 - 127
+:- type pressure == int. % 0 - 127
+:- type parameter == int. % 0 - 127
+:- type value == int. % 0 - 127
+:- type program == int. % 0 - 127
+:- type pitch_value == int. % 0 - (1 << 14 - 1) biased from 0x2000
+
+:- type modes
+ ---> local(onoff)
+ ; ano
+ ; omni(onoff)
+ ; mono(byte)
+ ; poly.
+
+:- type onoff
+ ---> off
+ ; on.
+
+:- type system
+ ---> sysex(list(byte))
+ ; pos(int)
+ ; sel(byte)
+ ; tune.
+
+:- type realtime
+ ---> clk
+ ; start
+ ; cont
+ ; stop
+ ; sense
+ ; reset.
+
+:- type byte == int.
+
+ % Reads from a concurrent stream of bytes and puts its outputs
+ % on to a concurrent stream of midi messages.
+ %
+:- pred read_midi(concurrent_stream(byte)::in, concurrent_stream(message)::in,
+ io::di, io::uo) is det.
+
+ % Reads from a concurrent stream of messages, and puts the messages
+ % on to a concurrent stream of bytes.
+ %
+:- pred write_midi(concurrent_stream(message)::in, concurrent_stream(byte)::in,
+ io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module bool.
+:- import_module int.
+:- import_module require.
+
+%-----------------------------------------------------------------------------%
+
+:- type hex
+ ---> x0
+ ; x1
+ ; x2
+ ; x3
+ ; x4
+ ; x5
+ ; x6
+ ; x7
+ ; x8
+ ; x9
+ ; xA
+ ; xB
+ ; xC
+ ; xD
+ ; xE
+ ; xF.
+
+ % This type is used for storing the "running status" used by
+ % most MIDI devices, where if the status-byte of two consecutive
+ % messages (ignoring any intervening realtime messages) is the
+ % same, then it may be omitted in the second message.
+ %
+:- type status
+ ---> none
+ ; status(kind, channel).
+
+:- type kind
+ ---> one(onebyte)
+ ; two(twobyte).
+
+:- type onebyte
+ ---> pc
+ ; cp.
+
+:- type twobyte
+ ---> off
+ ; on
+ ; kp
+ ; cc
+ ; pw.
+
+%-----------------------------------------------------------------------------%
+
+ % The midi protocol has two classes of message. The majority of
+ % messages including note and controller events fall in the first
+ % class. A small number of events - the "realtime" events - can
+ % occur in the middle of a normal event. In a sense, they are
+ % like out-of-band data.
+ %
+ % To handle this, the MIDI parser is encoded as a state machine,
+ % which remembers any message that is might be half way through
+ % parsing when it receives a realtime event.
+ %
+ % For more info on the MIDI protocol, see a site like
+ % <ftp://ftp.ucsd.edu/midi/doc/midi-intro.Z>
+
+read_midi(Ins, Outs, !IO) :-
+ byte0(none, Ins, Outs, !IO).
+
+:- pred byte0(status::in, concurrent_stream(byte)::in,
+ concurrent_stream(message)::in, io::di, io::uo) is det.
+
+byte0(Status, Ins, Outs, !IO) :-
+ get(Ins, Res0, !IO),
+ (
+ Res0 = end,
+ end(Outs, !IO)
+ ;
+ Res0 = error(Err),
+ error(Outs, Err, !IO)
+ ;
+ Res0 = ok(Byte),
+ byte2hex(Byte, MSN, LSN),
+ byte0a(MSN, LSN, Status, Ins, Outs, !IO)
+ ).
+
+:- pred byte0a(hex::in, hex::in, status::in,
+ concurrent_stream(byte)::in, concurrent_stream(message)::in,
+ io::di, io::uo) is det.
+
+byte0a(x0, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x0, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte0a(x1, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x1, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte0a(x2, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x2, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte0a(x3, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x3, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte0a(x4, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x4, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte0a(x5, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x5, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte0a(x6, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x6, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte0a(x7, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x7, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte0a(x8, LSN, _Status, Ins, Outs, !IO) :-
+ nibble2hex(Chan, LSN),
+ Status = status(two(off), Chan),
+ byte1(Status, Ins, Outs, !IO).
+byte0a(x9, LSN, _Status, Ins, Outs, !IO) :-
+ nibble2hex(Chan, LSN),
+ Status = status(two(on), Chan),
+ byte1(Status, Ins, Outs, !IO).
+byte0a(xA, LSN, _Status, Ins, Outs, !IO) :-
+ nibble2hex(Chan, LSN),
+ Status = status(two(kp), Chan),
+ byte1(Status, Ins, Outs, !IO).
+byte0a(xB, LSN, _Status, Ins, Outs, !IO) :-
+ nibble2hex(Chan, LSN),
+ Status = status(two(cc), Chan),
+ byte1(Status, Ins, Outs, !IO).
+byte0a(xC, LSN, _Status, Ins, Outs, !IO) :-
+ nibble2hex(Chan, LSN),
+ Status = status(one(pc), Chan),
+ byte1(Status, Ins, Outs, !IO).
+byte0a(xD, LSN, _Status, Ins, Outs, !IO) :-
+ nibble2hex(Chan, LSN),
+ Status = status(one(cp), Chan),
+ byte1(Status, Ins, Outs, !IO).
+byte0a(xE, LSN, _Status, Ins, Outs, !IO) :-
+ nibble2hex(Chan, LSN),
+ Status = status(two(pw), Chan),
+ byte1(Status, Ins, Outs, !IO).
+byte0a(xF, x0, Status, Ins, Outs, !IO) :-
+ sysex0(Status, Ins, Outs, !IO).
+byte0a(xF, x1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte0a(xF, x2, Status, Ins, Outs, !IO) :-
+ pos0(Status, Ins, Outs, !IO).
+byte0a(xF, x3, Status, Ins, Outs, !IO) :-
+ sel0(Status, Ins, Outs, !IO).
+byte0a(xF, x4, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte0a(xF, x5, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte0a(xF, x6, Status, Ins, Outs, !IO) :-
+ put(Outs, sys(tune), !IO),
+ byte0(Status, Ins, Outs, !IO).
+byte0a(xF, x7, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected system byte (byte0)", !IO).
+byte0a(xF, x8, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(clk), !IO),
+ byte0(Status, Ins, Outs, !IO).
+byte0a(xF, x9, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte0a(xF, xA, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(start), !IO),
+ byte0(Status, Ins, Outs, !IO).
+byte0a(xF, xB, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(cont), !IO),
+ byte0(Status, Ins, Outs, !IO).
+byte0a(xF, xC, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(stop), !IO),
+ byte0(Status, Ins, Outs, !IO).
+byte0a(xF, xD, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte0a(xF, xE, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(sense), !IO),
+ byte0(Status, Ins, Outs, !IO).
+byte0a(xF, xF, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(reset), !IO),
+ byte0(Status, Ins, Outs, !IO).
+
+:- pred byte1(status::in, concurrent_stream(byte)::in,
+ concurrent_stream(message)::in, io::di, io::uo) is det.
+
+byte1(Status, Ins, Outs, !IO) :-
+ get(Ins, Res0, !IO),
+ (
+ Res0 = end,
+ error(Outs, "unexpected end of input", !IO)
+ ;
+ Res0 = error(Err),
+ error(Outs, Err, !IO)
+ ;
+ Res0 = ok(Byte),
+ byte2hex(Byte, MSN, LSN),
+ byte1a(MSN, LSN, Status, Ins, Outs, !IO)
+ ).
+
+:- pred byte1a(hex::in, hex::in, status::in,
+ concurrent_stream(byte)::in, concurrent_stream(message)::in,
+ io::di, io::uo) is det.
+
+byte1a(x0, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x0, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte1a(x1, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x1, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte1a(x2, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x2, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte1a(x3, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x3, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte1a(x4, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x4, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte1a(x5, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x5, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte1a(x6, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x6, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte1a(x7, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x7, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte1a(x8, _LSN, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte1a(x9, _LSN, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte1a(xA, _LSN, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte1a(xB, _LSN, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte1a(xC, _LSN, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte1a(xD, _LSN, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte1a(xE, _LSN, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte1a(xF, x0, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected system byte", !IO).
+byte1a(xF, x1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte1a(xF, x2, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected system byte", !IO).
+byte1a(xF, x3, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected system byte", !IO).
+byte1a(xF, x4, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte1a(xF, x5, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte1a(xF, x6, Status, Ins, Outs, !IO) :-
+ put(Outs, sys(tune), !IO),
+ byte1(Status, Ins, Outs, !IO).
+byte1a(xF, x7, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected system byte", !IO).
+byte1a(xF, x8, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(clk), !IO),
+ byte1(Status, Ins, Outs, !IO).
+byte1a(xF, x9, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte1a(xF, xA, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(start), !IO),
+ byte1(Status, Ins, Outs, !IO).
+byte1a(xF, xB, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(cont), !IO),
+ byte1(Status, Ins, Outs, !IO).
+byte1a(xF, xC, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(stop), !IO),
+ byte1(Status, Ins, Outs, !IO).
+byte1a(xF, xD, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte1a(xF, xE, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(sense), !IO),
+ byte1(Status, Ins, Outs, !IO).
+byte1a(xF, xF, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(reset), !IO),
+ byte1(Status, Ins, Outs, !IO).
+
+:- pred byte1b(status::in, byte::in, concurrent_stream(byte)::in,
+ concurrent_stream(message)::in, io::di, io::uo) is det.
+
+byte1b(none, _Byte, Ins, Outs, !IO) :-
+ byte0(none, Ins, Outs, !IO).
+byte1b(status(one(Kind), Chan), Byte, Ins, Outs, !IO) :-
+ (
+ Kind = pc,
+ Msg = pc(Chan, Byte)
+ ;
+ Kind = cp,
+ Msg = cp(Chan, Byte)
+ ),
+ put(Outs, Msg, !IO),
+ byte0(status(one(Kind), Chan), Ins, Outs, !IO).
+byte1b(status(two(Kind), Chan), Byte1, Ins, Outs, !IO) :-
+ byte2(status(two(Kind), Chan), Byte1, Ins, Outs, !IO).
+
+:- pred byte2(status::in, byte::in, concurrent_stream(byte)::in,
+ concurrent_stream(message)::in, io::di, io::uo) is det.
+
+byte2(Status, Byte1, Ins, Outs, !IO) :-
+ get(Ins, Res0, !IO),
+ (
+ Res0 = end,
+ error(Outs, "unexpected end of input", !IO)
+ ;
+ Res0 = error(Err),
+ error(Outs, Err, !IO)
+ ;
+ Res0 = ok(Byte2),
+ byte2hex(Byte2, MSN2, LSN2),
+ byte2a(MSN2, LSN2, Byte1, Status, Ins, Outs, !IO)
+ ).
+
+:- pred byte2a(hex::in, hex::in, byte::in, status::in,
+ concurrent_stream(byte)::in, concurrent_stream(message)::in,
+ io::di, io::uo) is det.
+
+byte2a(x0, LSN, Byte1, Status, Ins, Outs, !IO) :-
+ hex2byte(x0, LSN, Byte2),
+ byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
+byte2a(x1, LSN, Byte1, Status, Ins, Outs, !IO) :-
+ hex2byte(x1, LSN, Byte2),
+ byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
+byte2a(x2, LSN, Byte1, Status, Ins, Outs, !IO) :-
+ hex2byte(x2, LSN, Byte2),
+ byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
+byte2a(x3, LSN, Byte1, Status, Ins, Outs, !IO) :-
+ hex2byte(x3, LSN, Byte2),
+ byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
+byte2a(x4, LSN, Byte1, Status, Ins, Outs, !IO) :-
+ hex2byte(x4, LSN, Byte2),
+ byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
+byte2a(x5, LSN, Byte1, Status, Ins, Outs, !IO) :-
+ hex2byte(x5, LSN, Byte2),
+ byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
+byte2a(x6, LSN, Byte1, Status, Ins, Outs, !IO) :-
+ hex2byte(x6, LSN, Byte2),
+ byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
+byte2a(x7, LSN, Byte1, Status, Ins, Outs, !IO) :-
+ hex2byte(x7, LSN, Byte2),
+ byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
+byte2a(x8, _LSN, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte2a(x9, _LSN, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte2a(xA, _LSN, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte2a(xB, _LSN, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte2a(xC, _LSN, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte2a(xD, _LSN, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte2a(xE, _LSN, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte2a(xF, x0, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected system byte", !IO).
+byte2a(xF, x1, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte2a(xF, x2, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected system byte", !IO).
+byte2a(xF, x3, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected system byte", !IO).
+byte2a(xF, x4, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte2a(xF, x5, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte2a(xF, x6, Byte1, Status, Ins, Outs, !IO) :-
+ put(Outs, sys(tune), !IO),
+ byte2(Status, Byte1, Ins, Outs, !IO).
+byte2a(xF, x7, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected system byte", !IO).
+byte2a(xF, x8, Byte1, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(clk), !IO),
+ byte2(Status, Byte1, Ins, Outs, !IO).
+byte2a(xF, x9, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte2a(xF, xA, Byte1, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(start), !IO),
+ byte2(Status, Byte1, Ins, Outs, !IO).
+byte2a(xF, xB, Byte1, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(cont), !IO),
+ byte2(Status, Byte1, Ins, Outs, !IO).
+byte2a(xF, xC, Byte1, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(stop), !IO),
+ byte2(Status, Byte1, Ins, Outs, !IO).
+byte2a(xF, xD, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte2a(xF, xE, Byte1, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(sense), !IO),
+ byte2(Status, Byte1, Ins, Outs, !IO).
+byte2a(xF, xF, Byte1, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(reset), !IO),
+ byte2(Status, Byte1, Ins, Outs, !IO).
+
+:- pred byte2b(status::in, byte::in, byte::in,
+ concurrent_stream(byte)::in, concurrent_stream(message)::in,
+ io::di, io::uo) is det.
+
+byte2b(none, _Byte1, _Byte2, Ins, Outs, !IO) :-
+ byte0(none, Ins, Outs, !IO).
+byte2b(status(one(_), _Chan), _Byte1, _Byte2, _Ins, Outs, !IO) :-
+ error(Outs, "internal error", !IO).
+byte2b(status(two(Kind), Chan), Byte1, Byte2, Ins, Outs, !IO) :-
+ (
+ Kind = off,
+ Msg = off(Chan, Byte1, Byte2)
+ ;
+ Kind = on,
+ Msg = on(Chan, Byte1, Byte2)
+ ;
+ Kind = kp,
+ Msg = kp(Chan, Byte1, Byte2)
+ ;
+ Kind = cc,
+ (
+ (
+ Byte1 = 122,
+ OnOrOff = ( Byte2 = 0 -> off ; on ),
+ Msg0 = mm(Chan, local(OnOrOff))
+ ;
+ Byte1 = 123,
+ Msg0 = mm(Chan, ano)
+ ;
+ Byte1 = 124,
+ Msg0 = mm(Chan, omni(off))
+ ;
+ Byte1 = 125,
+ Msg0 = mm(Chan, omni(on))
+ ;
+ Byte1 = 126,
+ Msg0 = mm(Chan, mono(Byte2))
+ ;
+ Byte1 = 127,
+ Msg0 = mm(Chan, poly)
+ )
+ ->
+ Msg = Msg0
+ ;
+ Msg = cc(Chan, Byte1, Byte2)
+ )
+ ;
+ Kind = pw,
+ Val = (Byte1 /\ 0x7F) \/ ((Byte2 /\ 0x7F) << 7),
+ Msg = pw(Chan, Val)
+ ),
+ put(Outs, Msg, !IO),
+ byte0(status(two(Kind), Chan), Ins, Outs, !IO).
+
+:- pred sysex0(status::in, concurrent_stream(byte)::in,
+ concurrent_stream(message)::in, io::di, io::uo) is det.
+
+sysex0(Status, Ins, Outs, !IO) :-
+ sysex1([], Status, Ins, Outs, !IO).
+
+:- pred sysex1(list(byte)::in, status::in, concurrent_stream(byte)::in,
+ concurrent_stream(message)::in, io::di, io::uo) is det.
+
+sysex1(Bytes0, Status, Ins, Outs, !IO) :-
+ get(Ins, Res0, !IO),
+ (
+ Res0 = end,
+ error(Outs, "unexpected end of input", !IO)
+ ;
+ Res0 = error(Err),
+ error(Outs, Err, !IO)
+ ;
+ Res0 = ok(Byte),
+ ( Byte >= 0, Byte =< 127 ->
+ sysex1([Byte|Bytes0], Status, Ins, Outs, !IO)
+ ;
+ list.reverse(Bytes0, Bytes),
+ put(Outs, sys(sysex(Bytes)), !IO),
+ ( Byte = 0xF7 ->
+ byte0(Status, Ins, Outs, !IO)
+ ;
+ byte2hex(Byte, MSN, LSN),
+ byte0a(MSN, LSN, Status, Ins, Outs, !IO)
+ )
+ )
+ ).
+
+:- pred pos0(status::in, concurrent_stream(byte)::in,
+ concurrent_stream(message)::in, io::di, io::uo) is det.
+
+pos0(Status, Ins, Outs, !IO) :-
+ get(Ins, Res0, !IO),
+ (
+ Res0 = end,
+ error(Outs, "unexpected end of input", !IO)
+ ;
+ Res0 = error(Err),
+ error(Outs, Err, !IO)
+ ;
+ Res0 = ok(Byte),
+ pos1(Byte, Status, Ins, Outs, !IO)
+ ).
+
+:- pred pos1(byte::in, status::in, concurrent_stream(byte)::in,
+ concurrent_stream(message)::in, io::di, io::uo) is det.
+
+pos1(Byte1, Status, Ins, Outs, !IO) :-
+ get(Ins, Res0, !IO),
+ (
+ Res0 = end,
+ error(Outs, "unexpected end of input", !IO)
+ ;
+ Res0 = error(Err),
+ error(Outs, Err, !IO)
+ ;
+ Res0 = ok(Byte2),
+ Val = (Byte1 /\ 0x7F) \/ ((Byte2 /\ 0x7F) << 7),
+ put(Outs, sys(pos(Val)), !IO),
+ byte0(Status, Ins, Outs, !IO)
+ ).
+
+:- pred sel0(status::in, concurrent_stream(byte)::in,
+ concurrent_stream(message)::in, io::di, io::uo) is det.
+
+sel0(Status, Ins, Outs, !IO) :-
+ get(Ins, Res0, !IO),
+ (
+ Res0 = end,
+ error(Outs, "unexpected end of input", !IO)
+ ;
+ Res0 = error(Err),
+ error(Outs, Err, !IO)
+ ;
+ Res0 = ok(Byte),
+ put(Outs, sys(sel(Byte)), !IO),
+ byte0(Status, Ins, Outs, !IO)
+ ).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+write_midi(Ins, Outs, !IO) :-
+ write_midi(none, Ins, Outs, !IO).
+
+:- pred write_midi(status::in, concurrent_stream(message)::in,
+ concurrent_stream(byte)::in, io::di, io::uo) is det.
+
+write_midi(Status, Ins, Outs, !IO) :-
+ get(Ins, Res0, !IO),
+ (
+ Res0 = end,
+ end(Outs, !IO)
+ ;
+ Res0 = error(Msg),
+ error(Outs, Msg, !IO)
+ ;
+ Res0 = ok(Msg),
+ write_midi(Msg, Status, Ins, Outs, !IO)
+ ).
+
+:- pred write_midi(message::in, status::in, concurrent_stream(message)::in,
+ concurrent_stream(byte)::in, io::di, io::uo) is det.
+
+write_midi(off(Chan, Note, Vel), Status0, Ins, Outs, !IO) :-
+ Status1 = status(two(off), Chan),
+ write_two(Status0, Status1, Note, Vel, Ins, Outs, !IO).
+write_midi(on(Chan, Note, Vel), Status0, Ins, Outs, !IO) :-
+ Status1 = status(two(on), Chan),
+ write_two(Status0, Status1, Note, Vel, Ins, Outs, !IO).
+write_midi(kp(Chan, Note, Press), Status0, Ins, Outs, !IO) :-
+ Status1 = status(two(kp), Chan),
+ write_two(Status0, Status1, Note, Press, Ins, Outs, !IO).
+write_midi(cc(Chan, Ctrl, Val), Status0, Ins, Outs, !IO) :-
+ Status1 = status(two(cc), Chan),
+ write_two(Status0, Status1, Ctrl, Val, Ins, Outs, !IO).
+write_midi(pc(Chan, Prog), Status0, Ins, Outs, !IO) :-
+ Status1 = status(one(pc), Chan),
+ write_one(Status0, Status1, Prog, Ins, Outs, !IO).
+write_midi(cp(Chan, Press), Status0, Ins, Outs, !IO) :-
+ Status1 = status(one(cp), Chan),
+ write_one(Status0, Status1, Press, Ins, Outs, !IO).
+write_midi(pw(Chan, Val), Status0, Ins, Outs, !IO) :-
+ Status1 = status(two(pw), Chan),
+ Byte1 = Val /\ 0x7F,
+ Byte2 = (Val >> 7) /\ 0x7F,
+ write_two(Status0, Status1, Byte1, Byte2, Ins, Outs, !IO).
+write_midi(mm(Chan, Mode), Status0, Ins, Outs, !IO) :-
+ Status1 = status(two(cc), Chan),
+ (
+ Mode = local(off),
+ Byte1 = 122, Byte2 = 0
+ ;
+ Mode = local(on),
+ Byte1 = 122, Byte2 = 127
+ ;
+ Mode = ano,
+ Byte1 = 123, Byte2 = 0
+ ;
+ Mode = omni(off),
+ Byte1 = 124, Byte2 = 0
+ ;
+ Mode = omni(on),
+ Byte1 = 125, Byte2 = 0
+ ;
+ Mode = mono(N),
+ Byte1 = 126, Byte2 = N /\ 0x7F
+ ;
+ Mode = poly,
+ Byte1 = 127, Byte2 = 0
+ ),
+ write_two(Status0, Status1, Byte1, Byte2, Ins, Outs, !IO).
+write_midi(sys(sysex(Bytes)), Status, Ins, Outs, !IO) :-
+ put(Outs, 0xF0, !IO),
+ PutByte = (pred(Byte::in, !.IO::di, !:IO::uo) is det :-
+ ( Byte >= 0, Byte =< 127 ->
+ put(Outs, Byte, !IO)
+ ;
+ error(Outs, "sysex data byte out of range", !IO)
+ )
+ ),
+ list.foldl(PutByte, Bytes, !IO),
+ put(Outs, 0xF7, !IO),
+ write_midi(Status, Ins, Outs, !IO).
+write_midi(sys(pos(Pos)), Status, Ins, Outs, !IO) :-
+ put(Outs, 0xF2, !IO),
+ Byte1 = Pos /\ 0x7F,
+ Byte2 = (Pos >> 7) /\ 0x7F,
+ put(Outs, Byte1, !IO),
+ put(Outs, Byte2, !IO),
+ write_midi(Status, Ins, Outs, !IO).
+write_midi(sys(sel(Sel)), Status, Ins, Outs, !IO) :-
+ put(Outs, 0xF3, !IO),
+ put(Outs, Sel, !IO),
+ write_midi(Status, Ins, Outs, !IO).
+write_midi(sys(tune), Status, Ins, Outs, !IO) :-
+ put(Outs, 0xF6, !IO),
+ write_midi(Status, Ins, Outs, !IO).
+write_midi(rt(clk), Status, Ins, Outs, !IO) :-
+ put(Outs, 0xF8, !IO),
+ write_midi(Status, Ins, Outs, !IO).
+write_midi(rt(start), Status, Ins, Outs, !IO) :-
+ put(Outs, 0xFA, !IO),
+ write_midi(Status, Ins, Outs, !IO).
+write_midi(rt(cont), Status, Ins, Outs, !IO) :-
+ put(Outs, 0xFB, !IO),
+ write_midi(Status, Ins, Outs, !IO).
+write_midi(rt(stop), Status, Ins, Outs, !IO) :-
+ put(Outs, 0xFC, !IO),
+ write_midi(Status, Ins, Outs, !IO).
+write_midi(rt(sense), Status, Ins, Outs, !IO) :-
+ put(Outs, 0xFE, !IO),
+ write_midi(Status, Ins, Outs, !IO).
+write_midi(rt(reset), Status, Ins, Outs, !IO) :-
+ put(Outs, 0xFF, !IO),
+ write_midi(Status, Ins, Outs, !IO).
+
+:- pred write_one(status::in, status::in, byte::in,
+ concurrent_stream(message)::in, concurrent_stream(byte)::in,
+ io::di, io::uo) is det.
+
+write_one(Status0, Status1, Byte1, Ins, Outs, !IO) :-
+ ( Status0 = Status1 ->
+ Status = Status0
+ ;
+ Status = Status1,
+ ( status(Status, Byte) ->
+ put(Outs, Byte, !IO)
+ ;
+ error(Outs, "invalid channel", !IO)
+ )
+ ),
+ ( Byte1 >= 0, Byte1 =< 127 ->
+ put(Outs, Byte1, !IO)
+ ;
+ error(Outs, "invalid data byte", !IO)
+ ),
+ write_midi(Status, Ins, Outs, !IO).
+
+:- pred write_two(status::in, status::in, byte::in, byte::in,
+ concurrent_stream(message)::in,
+ concurrent_stream(byte)::in, io::di, io::uo) is det.
+
+write_two(Status0, Status1, Byte1, Byte2, Ins, Outs, !IO) :-
+ ( Status0 = Status1 ->
+ Status = Status0
+ ;
+ Status = Status1,
+ ( status(Status, Byte) ->
+ put(Outs, Byte, !IO)
+ ;
+ error(Outs, "invalid channel", !IO)
+ )
+ ),
+ ( Byte1 >= 0, Byte1 =< 127 ->
+ put(Outs, Byte1, !IO)
+ ;
+ error(Outs, "invalid data byte", !IO)
+ ),
+ ( Byte2 >= 0, Byte2 =< 127 ->
+ put(Outs, Byte2, !IO)
+ ;
+ error(Outs, "invalid data byte", !IO)
+ ),
+ write_midi(Status, Ins, Outs, !IO).
+
+:- pred status(status::in, byte::out) is semidet.
+
+status(none, _) :-
+ error("status: no status").
+status(status(Kind, Chan), Byte) :-
+ Chan >= 0, Chan =< 15,
+ ( Kind = two(off), Nib = 0x80
+ ; Kind = two(on), Nib = 0x90
+ ; Kind = two(kp), Nib = 0xA0
+ ; Kind = two(cc), Nib = 0xB0
+ ; Kind = one(pc), Nib = 0xC0
+ ; Kind = one(cp), Nib = 0xD0
+ ; Kind = two(pw), Nib = 0xE0
+ ),
+ Byte = Nib \/ Chan.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- pred byte2hex(int::in, hex::out, hex::out) is det.
+
+byte2hex(Byte, MSN, LSN) :-
+ (
+ nibble2hex(Byte /\ 0xF, LSN0),
+ nibble2hex((Byte >> 4) /\ 0xF, MSN0)
+ ->
+ LSN = LSN0,
+ MSN = MSN0
+ ;
+ error("byte2hex: conversion failed!")
+ ).
+
+:- pred hex2byte(hex::in, hex::in, int::out) is det.
+
+hex2byte(MSN, LSN, Byte) :-
+ nibble2hex(A, MSN),
+ nibble2hex(B, LSN),
+ Byte = B \/ (A << 4).
+
+:- pred nibble2hex(int, hex).
+:- mode nibble2hex(in, out) is semidet.
+:- mode nibble2hex(out, in) is det.
+
+nibble2hex(0x0, x0).
+nibble2hex(0x1, x1).
+nibble2hex(0x2, x2).
+nibble2hex(0x3, x3).
+nibble2hex(0x4, x4).
+nibble2hex(0x5, x5).
+nibble2hex(0x6, x6).
+nibble2hex(0x7, x7).
+nibble2hex(0x8, x8).
+nibble2hex(0x9, x9).
+nibble2hex(0xA, xA).
+nibble2hex(0xB, xB).
+nibble2hex(0xC, xC).
+nibble2hex(0xD, xD).
+nibble2hex(0xE, xE).
+nibble2hex(0xF, xF).
+
+%-----------------------------------------------------------------------------%
+:- end_module midi.
+%-----------------------------------------------------------------------------%
Index: samples/concurrency/midimon/midi_data
===================================================================
RCS file: samples/concurrency/midimon/midi_data
diff -N samples/concurrency/midimon/midi_data
Binary files /dev/null and midi_data differ
Index: samples/concurrency/midimon/midimon.m
===================================================================
RCS file: samples/concurrency/midimon/midimon.m
diff -N samples/concurrency/midimon/midimon.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ samples/concurrency/midimon/midimon.m 9 Nov 2010 02:32:37 -0000
@@ -0,0 +1,178 @@
+%----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+
+:- module midimon.
+
+:- interface.
+:- import_module io.
+
+:- pred main(io::di, io::uo) is cc_multi.
+
+%----------------------------------------------------------------------------%
+%----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- pragma require_feature_set([concurrency]).
+
+:- import_module concurrent_stream.
+:- import_module midi.
+
+:- import_module bool.
+:- import_module char.
+:- import_module getopt.
+:- import_module int.
+:- import_module list.
+:- import_module maybe.
+:- import_module require.
+:- import_module string.
+:- import_module thread.
+
+%----------------------------------------------------------------------------%
+
+main(!IO) :-
+ io.command_line_arguments(Args0, !IO),
+ process_options(
+ option_ops_multi(short_option, long_option, option_defaults),
+ Args0, _Args, MOpts),
+ (
+ MOpts = ok(Opts),
+ lookup_bool_option(Opts, help, Help),
+ (
+ Help = yes,
+ help(!IO)
+ ;
+ Help = no,
+ lookup_maybe_string_option(Opts, input, MInfile),
+ open_input(MInfile, InFileOpened, !IO),
+ (
+ InFileOpened = yes,
+ new(Bytes0, !IO),
+ new(Messages, !IO),
+ spawn((pred(!.IO::di, !:IO::uo) is cc_multi :-
+ read_midi(Bytes0, Messages, !IO)
+ ), !IO),
+ spawn((pred(!.IO::di, !:IO::uo) is cc_multi :-
+ print_messages(Messages, !IO)
+ ), !IO),
+ read_input(Bytes0, !IO)
+ ;
+ InFileOpened = no
+ )
+ )
+ ;
+ MOpts = error(Msg),
+ io.stderr_stream(StdErr, !IO),
+ io.format(StdErr, "%s\n", [s(Msg)], !IO),
+ io.set_exit_status(1, !IO)
+ ).
+
+:- pred open_input(maybe(string)::in, bool::out, io::di, io::uo) is det.
+
+open_input(no, Opened, !IO) :-
+ io.see_binary("/dev/midi", Res, !IO),
+ (
+ Res = ok,
+ Opened = yes
+ ;
+ Res = error(Err),
+ io.error_message(Err, Msg),
+ io.stderr_stream(StdErr, !IO),
+ io.format(StdErr, "error opening `/dev/midi': %s\n", [s(Msg)], !IO),
+ Opened = no
+ ).
+open_input(yes(FileName), Opened, !IO) :-
+ ( FileName = "-" ->
+ % use stdin
+ Opened = yes
+ ;
+ io.see_binary(FileName, Res, !IO),
+ (
+ Res = ok,
+ Opened = yes
+ ;
+ Res = error(Err),
+ io.error_message(Err, Msg),
+ io.stderr_stream(StdErr, !IO),
+ io.format(StdErr, "error opening `%s': %s\n",
+ [s(FileName), s(Msg)], !IO),
+ Opened = no
+ )
+ ).
+
+:- pred read_input(concurrent_stream(byte)::in,
+ io::di, io::uo) is det.
+
+read_input(Stream, !IO) :-
+ io.read_byte(Res0, !IO),
+ (
+ Res0 = eof,
+ end(Stream, !IO)
+ ;
+ Res0 = error(Err),
+ io.error_message(Err, Msg),
+ error(Stream, Msg, !IO)
+ ;
+ Res0 = ok(Byte),
+ put(Stream, Byte, !IO),
+ read_input(Stream, !IO)
+ ).
+
+:- pred print_messages(concurrent_stream(message)::in,
+ io::di, io::uo) is det.
+
+print_messages(Stream, !IO) :-
+ get(Stream, Res0, !IO),
+ (
+ Res0 = ok(Msg),
+ io.write(Msg, !IO),
+ io.write_string(".\n", !IO),
+ print_messages(Stream, !IO)
+ ;
+ Res0 = end
+ ;
+ Res0 = error(Msg),
+ io.write_string(Msg, !IO),
+ io.nl(!IO)
+ ).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- type option_table == option_table(option).
+:- type maybe_option_table == maybe_option_table(option).
+
+ % The master list of options.
+ %
+:- type option
+ ---> help
+ ; input.
+
+:- pred long_option(string::in, option::out) is semidet.
+
+long_option("help", help).
+long_option("input-file", input).
+
+:- pred short_option(char::in, option::out) is semidet.
+
+short_option('h', help).
+short_option('i', input).
+
+:- pred option_defaults(option::out, option_data::out) is multi.
+
+option_defaults(help, bool(no)).
+option_defaults(input, maybe_string(no)).
+
+:- pred help(io::di, io::uo) is det.
+
+help(!IO) :-
+ io.write_strings([
+"usage: midimon [--help|-h] [--input-file|-i <filename>]\n",
+" --help|-h print this help message.\n",
+" --input-file|-i <file> read from <file> (default is /dev/midi).\n"
+ ], !IO).
+
+%-----------------------------------------------------------------------------%
+:- end_module midimon.
+%-----------------------------------------------------------------------------%
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list