[hcoop/debian/mlton.git] / basis-library / io / prim-io.fun

(* Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 *
 * MLton is released under a BSD-style license.
 * See the file MLton-LICENSE for details.
 *)

signature PRIM_IO_ARG =
   sig
      structure Vector: MONO_VECTOR
      structure VectorSlice: MONO_VECTOR_SLICE
      structure Array: MONO_ARRAY
      structure ArraySlice: MONO_ARRAY_SLICE
      sharing type Vector.elem = VectorSlice.elem 
         = Array.elem = ArraySlice.elem 
      sharing type Vector.vector = VectorSlice.vector 
         = Array.vector = ArraySlice.vector 
      sharing type VectorSlice.slice = ArraySlice.vector_slice
      sharing type Array.array = ArraySlice.array

      val someElem: Vector.elem

      eqtype pos
      val compare: pos * pos -> order
   end

functor PrimIO (S: PRIM_IO_ARG): PRIM_IO =
   struct 
      open S

      structure V = Vector
      structure VS = VectorSlice
      structure A = Array
      structure AS = ArraySlice

      type elem = A.elem
      type vector = V.vector
      type vector_slice = VS.slice
      type array = A.array
      type array_slice = AS.slice
      type pos = pos
      val compare = compare

      datatype reader =
         RD of {avail: unit -> int option,
                block: (unit -> unit) option,
                canInput: (unit -> bool) option,
                chunkSize: int,
                close: unit -> unit,
                endPos: (unit -> pos) option,
                getPos: (unit -> pos) option,
                ioDesc: OS.IO.iodesc option,
                name: string,
                readArr: (array_slice -> int) option,
                readArrNB: (array_slice -> int option) option,
                readVec: (int -> vector) option,
                readVecNB: (int -> vector option) option,
                setPos: (pos -> unit) option,
                verifyPos: (unit -> pos) option}

      datatype writer =
         WR of {block: (unit -> unit) option,
                canOutput: (unit -> bool) option,
                chunkSize: int,
                close: unit -> unit,
                endPos: (unit -> pos) option,
                getPos: (unit -> pos) option,
                ioDesc: OS.IO.iodesc option,
                name: string,
                setPos: (pos -> unit) option,
                verifyPos: (unit -> pos) option,
                writeArr: (array_slice -> int) option,
                writeArrNB: (array_slice -> int option) option,
                writeVec: (vector_slice -> int) option,
                writeVecNB: (vector_slice -> int option) option}


      fun liftExn name function cause = raise IO.Io {name = name,
                                                     function = function,
                                                     cause = cause}

      fun openVector v =
         let
            val name = "openVector"
            val closed = ref false
            val pos = ref 0
            val eofPos = V.length v
            fun check f = if !closed
                             then liftExn name f IO.ClosedStream
                             else ()
            fun const f c = fn _ => (check f; c)
            fun readVec f i =
               let
                  val _ = check f
                  val n = Int.min (i, eofPos - !pos)
               in
                  VS.vector (VS.slice (v, !pos, SOME n)) before (pos := !pos + n)
               end
            fun readArr f sl =
               let
                  val _ = check f
                  val (buf, i, sz) = AS.base sl
                  val n = Int.min (sz, eofPos - !pos)
               in
                  AS.copyVec {src = VS.slice (v, !pos, SOME n),
                              dst = buf,
                              di = i};
                  pos := !pos + n;
                  n
               end
         in
            RD {avail = const "avail" NONE,
                block = SOME (const "block" ()),
                canInput = SOME (const "canInput" true),
                chunkSize = 32,
                close = fn () => (closed := true),
                endPos = NONE,
                getPos = NONE,
                ioDesc = NONE,
                name = name,
                readArr = SOME (readArr "readArr"),
                readArrNB = SOME (SOME o (readArr "readVecNB")),
                readVec = SOME (readVec "readVec"),
                readVecNB = SOME (SOME o (readVec "readVecNB")),
                setPos = NONE,
                verifyPos = NONE}
         end

      fun nullRd () =
         let
            val name = "nullRd"
            val closed = ref false
            fun check f = if !closed
                             then liftExn name f IO.ClosedStream
                             else ()
            fun const f c = fn _ => (check f; c)
            val empty = V.fromList []
         in
            RD {avail = const "avail" NONE,
                block = SOME (const "block" ()),
                canInput = SOME (const "canInput" true),
                chunkSize = 1,
                close = fn () => (closed := true),
                endPos = NONE,
                getPos = NONE,
                ioDesc = NONE,
                name = name,
                readArr = SOME (const "readArr" 0),
                readArrNB = SOME (const "readArrNB" (SOME 0)),
                readVec = SOME (const "readVec" empty),
                readVecNB = SOME (const "readVecNB" (SOME empty)),
                setPos = NONE,
                verifyPos = NONE}
         end

      fun nullWr () =
         let
            val name = "nullWr"
            val closed = ref false
            fun check f = if !closed
                             then liftExn name f IO.ClosedStream
                             else ()
            fun const f c = fn _ => (check f; c)
            fun function f g = fn x => (check f; g x)
         in
            WR {block = SOME (const "block" ()),
                canOutput = SOME (const "canOutput" true),
                chunkSize = 1,
                close = fn () => (closed := true),
                endPos = NONE,
                getPos = NONE,
                ioDesc = NONE,
                name = name,
                setPos = NONE,
                verifyPos = NONE,
                writeArr = SOME (function "writeArr" AS.length),
                writeArrNB = SOME (function "writeArrNB" (SOME o AS.length)),
                writeVec = SOME (function "writeVec" VS.length),
                writeVecNB = SOME (function "writeVecNB" (SOME o VS.length))}
         end

      fun doBlock (f, block: unit -> unit) x = (block (); valOf (f x))
      fun doCanInput (f, canInput) x = if canInput ()
                                          then SOME (f x)
                                          else NONE

      fun augmentReader (RD {name, chunkSize,
                             readVec, readArr, readVecNB, readArrNB,
                             block, canInput, avail,
                             getPos, setPos, endPos, verifyPos,
                             close, ioDesc}) =
         let
            fun augmentRead (readVec, readArr) =
               case (readVec, readArr) of
                  (SOME readVec, SOME readArr) => (SOME readVec, SOME readArr)
                | (NONE, SOME readArr) =>
                     (SOME (fn i =>
                            let
                               val buf = A.array (i, someElem)
                               fun first j = AS.slice (buf, 0, SOME j)
                            in
                               (AS.vector o first) (readArr (first i))
                            end),
                      SOME readArr)
                | (SOME readVec, NONE) =>
                     (SOME readVec,
                      SOME (fn sl =>
                            let
                               val (buf, i, sz) = AS.base sl
                               val v = readVec sz
                               val _ = A.copyVec {src = v, dst = buf, di = i}
                            in
                               V.length v
                            end))
                | (NONE, NONE) => (NONE, NONE)
            fun augmentReadNB (readVecNB, readArrNB) =
               case (readVecNB, readArrNB) of
                  (SOME readVecNB, SOME readArrNB) => (SOME readVecNB, SOME readArrNB)
                | (NONE, SOME readArrNB) => 
                     (SOME (fn i =>
                            let
                               val buf = A.array (i, someElem)
                               fun first j = AS.slice (buf, 0, SOME j)
                            in
                               Option.map (AS.vector o first) (readArrNB (first i))
                            end),
                      SOME readArrNB)
                | (SOME readVecNB, NONE) =>
                     (SOME readVecNB,
                      SOME (fn sl =>
                            let
                               val (buf, i, sz) = AS.base sl
                            in
                               case readVecNB sz of
                                  NONE => NONE
                                | SOME v => (A.copyVec {src = v, dst = buf, di = i}
                                             ; SOME (V.length v))
                            end))
                | (NONE, NONE) => (NONE, NONE)
            fun augmentSeq (readSeq, readSeqNB) =
               case (readSeq, readSeqNB) of
                  (SOME readSeq, SOME readSeqNB) => (SOME readSeq, SOME readSeqNB)
                | (NONE, SOME readSeqNB) =>
                     (case block of
                         NONE => NONE
                       | SOME block => SOME (doBlock (readSeqNB, block)),
                            SOME readSeqNB)
                | (SOME readSeq, NONE) =>
                         (SOME readSeq,
                          case canInput of
                             NONE => NONE
                           | SOME canInput => SOME (doCanInput (readSeq, canInput)))
                | (NONE, NONE) => (NONE, NONE)

            val ((readVec,readArr),(readVecNB,readArrNB)) =
               (augmentRead (readVec, readArr),
                augmentReadNB (readVecNB, readArrNB))
            val ((readVec,readVecNB),(readArr,readArrNB)) =
               (augmentSeq (readVec, readVecNB),
                augmentSeq (readArr, readArrNB))
         in
            RD {name = name, chunkSize = chunkSize,
                readVec = readVec, readArr = readArr, 
                readVecNB = readVecNB, readArrNB = readArrNB,
                block = block, canInput = canInput, avail = avail,
                getPos = getPos, setPos = setPos, 
                endPos = endPos, verifyPos = verifyPos,
                close = close, ioDesc = ioDesc}
         end

      fun augmentWriter (WR {name, chunkSize,
                             writeVec, writeArr, writeVecNB, writeArrNB,
                             block, canOutput,
                             getPos, setPos, endPos, verifyPos,
                             close, ioDesc}) =
         let
            fun augmentWrite (writeVec, writeArr) =
               case (writeVec, writeArr) of
                  (SOME writeVec, SOME writeArr) => (SOME writeVec, SOME writeArr)
                | (NONE, SOME writeArr) =>
                     (SOME (fn sl => 
                            writeArr
                            (AS.full
                             (A.tabulate (VS.length sl, fn i => VS.sub (sl, i))))),
                      SOME writeArr)
                | (SOME writeVec, NONE) =>
                     (SOME writeVec,
                      SOME (fn sl => writeVec (VS.full (AS.vector sl))))
                | (NONE, NONE) => (NONE, NONE)
            fun augmentSeq (writeSeq, writeSeqNB) =
               case (writeSeq, writeSeqNB) of
                  (SOME writeSeq, SOME writeSeqNB) => (SOME writeSeq, SOME writeSeqNB)
                | (NONE, SOME writeSeqNB) =>
                     (case block of
                         NONE => NONE
                       | SOME block => SOME (fn x => (block ();
                                                      valOf (writeSeqNB x))),
                            SOME writeSeqNB)
                | (SOME writeSeq, NONE) =>
                         (SOME writeSeq,
                          case canOutput of
                             NONE => NONE
                           | SOME canOutput => SOME (fn x => (if canOutput ()
                                                                 then SOME (writeSeq x)
                                                                 else NONE)))
                | (NONE, NONE) => (NONE, NONE)

            val ((writeVec,writeArr),(writeVecNB,writeArrNB)) =
               (augmentWrite (writeVec, writeArr),
                augmentWrite (writeVecNB, writeArrNB))
            val ((writeVec,writeVecNB),(writeArr,writeArrNB)) =
               (augmentSeq (writeVec, writeVecNB),
                augmentSeq (writeArr, writeArrNB))
         in
            WR {name = name, chunkSize = chunkSize,
                writeVec = writeVec, writeArr = writeArr, 
                writeVecNB = writeVecNB, writeArrNB = writeArrNB,
                block = block, canOutput = canOutput,
                getPos = getPos, setPos = setPos, 
                endPos = endPos, verifyPos = verifyPos,
                close = close, ioDesc = ioDesc}
         end
   end
Commit	Line	Data
7f918cf1 CE	1	(* Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh
	2	* Jagannathan, and Stephen Weeks.
	3	*
	4	* MLton is released under a BSD-style license.
	5	* See the file MLton-LICENSE for details.
	6	*)
	7
	8	signature PRIM_IO_ARG =
	9	sig
	10	structure Vector: MONO_VECTOR
	11	structure VectorSlice: MONO_VECTOR_SLICE
	12	structure Array: MONO_ARRAY
	13	structure ArraySlice: MONO_ARRAY_SLICE
	14	sharing type Vector.elem = VectorSlice.elem
	15	= Array.elem = ArraySlice.elem
	16	sharing type Vector.vector = VectorSlice.vector
	17	= Array.vector = ArraySlice.vector
	18	sharing type VectorSlice.slice = ArraySlice.vector_slice
	19	sharing type Array.array = ArraySlice.array
	20
	21	val someElem: Vector.elem
	22
	23	eqtype pos
	24	val compare: pos * pos -> order
	25	end
	26
	27	functor PrimIO (S: PRIM_IO_ARG): PRIM_IO =
	28	struct
	29	open S
	30
	31	structure V = Vector
	32	structure VS = VectorSlice
	33	structure A = Array
	34	structure AS = ArraySlice
	35
	36	type elem = A.elem
	37	type vector = V.vector
	38	type vector_slice = VS.slice
	39	type array = A.array
	40	type array_slice = AS.slice
	41	type pos = pos
	42	val compare = compare
	43
	44	datatype reader =
	45	RD of {avail: unit -> int option,
	46	block: (unit -> unit) option,
	47	canInput: (unit -> bool) option,
	48	chunkSize: int,
	49	close: unit -> unit,
	50	endPos: (unit -> pos) option,
	51	getPos: (unit -> pos) option,
	52	ioDesc: OS.IO.iodesc option,
	53	name: string,
	54	readArr: (array_slice -> int) option,
	55	readArrNB: (array_slice -> int option) option,
	56	readVec: (int -> vector) option,
	57	readVecNB: (int -> vector option) option,
	58	setPos: (pos -> unit) option,
	59	verifyPos: (unit -> pos) option}
	60
	61	datatype writer =
	62	WR of {block: (unit -> unit) option,
	63	canOutput: (unit -> bool) option,
	64	chunkSize: int,
65	close: unit -> unit,
66	endPos: (unit -> pos) option,
67	getPos: (unit -> pos) option,
68	ioDesc: OS.IO.iodesc option,
69	name: string,
70	setPos: (pos -> unit) option,
71	verifyPos: (unit -> pos) option,
72	writeArr: (array_slice -> int) option,
73	writeArrNB: (array_slice -> int option) option,
74	writeVec: (vector_slice -> int) option,
75	writeVecNB: (vector_slice -> int option) option}
76
77
78	fun liftExn name function cause = raise IO.Io {name = name,
79	function = function,
80	cause = cause}
81
82	fun openVector v =
83	let
84	val name = "openVector"
85	val closed = ref false
86	val pos = ref 0
87	val eofPos = V.length v
88	fun check f = if !closed
89	then liftExn name f IO.ClosedStream
90	else ()
91	fun const f c = fn _ => (check f; c)
92	fun readVec f i =
93	let
94	val _ = check f
95	val n = Int.min (i, eofPos - !pos)
96	in
97	VS.vector (VS.slice (v, !pos, SOME n)) before (pos := !pos + n)
98	end
99	fun readArr f sl =
100	let
101	val _ = check f
102	val (buf, i, sz) = AS.base sl
103	val n = Int.min (sz, eofPos - !pos)
104	in
105	AS.copyVec {src = VS.slice (v, !pos, SOME n),
106	dst = buf,
107	di = i};
108	pos := !pos + n;
109	n
110	end
111	in
112	RD {avail = const "avail" NONE,
113	block = SOME (const "block" ()),
114	canInput = SOME (const "canInput" true),
115	chunkSize = 32,
116	close = fn () => (closed := true),
117	endPos = NONE,
118	getPos = NONE,
119	ioDesc = NONE,
120	name = name,
121	readArr = SOME (readArr "readArr"),
122	readArrNB = SOME (SOME o (readArr "readVecNB")),
123	readVec = SOME (readVec "readVec"),
124	readVecNB = SOME (SOME o (readVec "readVecNB")),
125	setPos = NONE,
126	verifyPos = NONE}
127	end
128
129	fun nullRd () =
130	let
131	val name = "nullRd"
132	val closed = ref false
133	fun check f = if !closed
134	then liftExn name f IO.ClosedStream
135	else ()
136	fun const f c = fn _ => (check f; c)
137	val empty = V.fromList []
138	in
139	RD {avail = const "avail" NONE,
140	block = SOME (const "block" ()),
141	canInput = SOME (const "canInput" true),
142	chunkSize = 1,
143	close = fn () => (closed := true),
144	endPos = NONE,
145	getPos = NONE,
146	ioDesc = NONE,
147	name = name,
148	readArr = SOME (const "readArr" 0),
149	readArrNB = SOME (const "readArrNB" (SOME 0)),
150	readVec = SOME (const "readVec" empty),
151	readVecNB = SOME (const "readVecNB" (SOME empty)),
152	setPos = NONE,
153	verifyPos = NONE}
154	end
155
156	fun nullWr () =
157	let
158	val name = "nullWr"
159	val closed = ref false
160	fun check f = if !closed
161	then liftExn name f IO.ClosedStream
162	else ()
163	fun const f c = fn _ => (check f; c)
164	fun function f g = fn x => (check f; g x)
165	in
166	WR {block = SOME (const "block" ()),
167	canOutput = SOME (const "canOutput" true),
168	chunkSize = 1,
169	close = fn () => (closed := true),
170	endPos = NONE,
171	getPos = NONE,
172	ioDesc = NONE,
173	name = name,
174	setPos = NONE,
175	verifyPos = NONE,
176	writeArr = SOME (function "writeArr" AS.length),
177	writeArrNB = SOME (function "writeArrNB" (SOME o AS.length)),
178	writeVec = SOME (function "writeVec" VS.length),
179	writeVecNB = SOME (function "writeVecNB" (SOME o VS.length))}
180	end
181
182	fun doBlock (f, block: unit -> unit) x = (block (); valOf (f x))
183	fun doCanInput (f, canInput) x = if canInput ()
184	then SOME (f x)
185	else NONE
186
187	fun augmentReader (RD {name, chunkSize,
188	readVec, readArr, readVecNB, readArrNB,
189	block, canInput, avail,
190	getPos, setPos, endPos, verifyPos,
191	close, ioDesc}) =
192	let
193	fun augmentRead (readVec, readArr) =
194	case (readVec, readArr) of
195	(SOME readVec, SOME readArr) => (SOME readVec, SOME readArr)
196	\| (NONE, SOME readArr) =>
197	(SOME (fn i =>
198	let
199	val buf = A.array (i, someElem)
200	fun first j = AS.slice (buf, 0, SOME j)
201	in
202	(AS.vector o first) (readArr (first i))
203	end),
204	SOME readArr)
205	\| (SOME readVec, NONE) =>
206	(SOME readVec,
207	SOME (fn sl =>
208	let
209	val (buf, i, sz) = AS.base sl
210	val v = readVec sz
211	val _ = A.copyVec {src = v, dst = buf, di = i}
212	in
213	V.length v
214	end))
215	\| (NONE, NONE) => (NONE, NONE)
216	fun augmentReadNB (readVecNB, readArrNB) =
217	case (readVecNB, readArrNB) of
218	(SOME readVecNB, SOME readArrNB) => (SOME readVecNB, SOME readArrNB)
219	\| (NONE, SOME readArrNB) =>
220	(SOME (fn i =>
221	let
222	val buf = A.array (i, someElem)
223	fun first j = AS.slice (buf, 0, SOME j)
224	in
225	Option.map (AS.vector o first) (readArrNB (first i))
226	end),
227	SOME readArrNB)
228	\| (SOME readVecNB, NONE) =>
229	(SOME readVecNB,
230	SOME (fn sl =>
231	let
232	val (buf, i, sz) = AS.base sl
233	in
234	case readVecNB sz of
235	NONE => NONE
236	\| SOME v => (A.copyVec {src = v, dst = buf, di = i}
237	; SOME (V.length v))
238	end))
239	\| (NONE, NONE) => (NONE, NONE)
240	fun augmentSeq (readSeq, readSeqNB) =
241	case (readSeq, readSeqNB) of
242	(SOME readSeq, SOME readSeqNB) => (SOME readSeq, SOME readSeqNB)
243	\| (NONE, SOME readSeqNB) =>
244	(case block of
245	NONE => NONE
246	\| SOME block => SOME (doBlock (readSeqNB, block)),
247	SOME readSeqNB)
248	\| (SOME readSeq, NONE) =>
249	(SOME readSeq,
250	case canInput of
251	NONE => NONE
252	\| SOME canInput => SOME (doCanInput (readSeq, canInput)))
253	\| (NONE, NONE) => (NONE, NONE)
254
255	val ((readVec,readArr),(readVecNB,readArrNB)) =
256	(augmentRead (readVec, readArr),
257	augmentReadNB (readVecNB, readArrNB))
258	val ((readVec,readVecNB),(readArr,readArrNB)) =
259	(augmentSeq (readVec, readVecNB),
260	augmentSeq (readArr, readArrNB))
261	in
262	RD {name = name, chunkSize = chunkSize,
263	readVec = readVec, readArr = readArr,
264	readVecNB = readVecNB, readArrNB = readArrNB,
265	block = block, canInput = canInput, avail = avail,
266	getPos = getPos, setPos = setPos,
267	endPos = endPos, verifyPos = verifyPos,
268	close = close, ioDesc = ioDesc}
269	end
270
271	fun augmentWriter (WR {name, chunkSize,
272	writeVec, writeArr, writeVecNB, writeArrNB,
273	block, canOutput,
274	getPos, setPos, endPos, verifyPos,
275	close, ioDesc}) =
276	let
277	fun augmentWrite (writeVec, writeArr) =
278	case (writeVec, writeArr) of
279	(SOME writeVec, SOME writeArr) => (SOME writeVec, SOME writeArr)
280	\| (NONE, SOME writeArr) =>
281	(SOME (fn sl =>
282	writeArr
283	(AS.full
284	(A.tabulate (VS.length sl, fn i => VS.sub (sl, i))))),
285	SOME writeArr)
286	\| (SOME writeVec, NONE) =>
287	(SOME writeVec,
288	SOME (fn sl => writeVec (VS.full (AS.vector sl))))
289	\| (NONE, NONE) => (NONE, NONE)
290	fun augmentSeq (writeSeq, writeSeqNB) =
291	case (writeSeq, writeSeqNB) of
292	(SOME writeSeq, SOME writeSeqNB) => (SOME writeSeq, SOME writeSeqNB)
293	\| (NONE, SOME writeSeqNB) =>
294	(case block of
295	NONE => NONE
296	\| SOME block => SOME (fn x => (block ();
297	valOf (writeSeqNB x))),
298	SOME writeSeqNB)
299	\| (SOME writeSeq, NONE) =>
300	(SOME writeSeq,
301	case canOutput of
302	NONE => NONE
303	\| SOME canOutput => SOME (fn x => (if canOutput ()
304	then SOME (writeSeq x)
305	else NONE)))
306	\| (NONE, NONE) => (NONE, NONE)
307
308	val ((writeVec,writeArr),(writeVecNB,writeArrNB)) =
309	(augmentWrite (writeVec, writeArr),
310	augmentWrite (writeVecNB, writeArrNB))
311	val ((writeVec,writeVecNB),(writeArr,writeArrNB)) =
312	(augmentSeq (writeVec, writeVecNB),
313	augmentSeq (writeArr, writeArrNB))
314	in
315	WR {name = name, chunkSize = chunkSize,
316	writeVec = writeVec, writeArr = writeArr,
317	writeVecNB = writeVecNB, writeArrNB = writeArrNB,
318	block = block, canOutput = canOutput,
319	getPos = getPos, setPos = setPos,
320	endPos = endPos, verifyPos = verifyPos,
321	close = close, ioDesc = ioDesc}
322	end
323	end