| 1 | (* Copyright (C) 2013 Matthew Fluet. |
| 2 | * Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh |
| 3 | * Jagannathan, and Stephen Weeks. |
| 4 | * |
| 5 | * MLton is released under a BSD-style license. |
| 6 | * See the file MLton-LICENSE for details. |
| 7 | *) |
| 8 | |
| 9 | signature STREAM_IO_EXTRA_ARG = |
| 10 | sig |
| 11 | structure Array: MONO_ARRAY |
| 12 | structure ArraySlice: MONO_ARRAY_SLICE |
| 13 | structure PrimIO: PRIM_IO |
| 14 | structure Vector: MONO_VECTOR |
| 15 | structure VectorSlice: MONO_VECTOR_SLICE |
| 16 | sharing type PrimIO.elem |
| 17 | = Vector.elem = VectorSlice.elem |
| 18 | = Array.elem = ArraySlice.elem |
| 19 | sharing type PrimIO.vector |
| 20 | = Vector.vector = VectorSlice.vector |
| 21 | = Array.vector = ArraySlice.vector |
| 22 | sharing type PrimIO.vector_slice |
| 23 | = VectorSlice.slice |
| 24 | = ArraySlice.vector_slice |
| 25 | sharing type PrimIO.array |
| 26 | = Array.array = ArraySlice.array |
| 27 | sharing type PrimIO.array_slice |
| 28 | = ArraySlice.slice |
| 29 | |
| 30 | val line: {isLine: PrimIO.elem -> bool, |
| 31 | lineElem: PrimIO.elem} option |
| 32 | val someElem: PrimIO.elem |
| 33 | val xlatePos : {toInt : PrimIO.pos -> Position.int, |
| 34 | fromInt : Position.int -> PrimIO.pos} option |
| 35 | end |
| 36 | |
| 37 | functor StreamIOExtra (S: STREAM_IO_EXTRA_ARG): STREAM_IO_EXTRA = |
| 38 | struct |
| 39 | open S |
| 40 | |
| 41 | structure PIO = PrimIO |
| 42 | structure A = Array |
| 43 | structure AS = ArraySlice |
| 44 | structure V = struct |
| 45 | open Vector |
| 46 | val extract : vector * int * int option -> vector |
| 47 | = VectorSlice.vector o VectorSlice.slice |
| 48 | end |
| 49 | structure VS = VectorSlice |
| 50 | |
| 51 | type elem = PIO.elem |
| 52 | type vector = PIO.vector |
| 53 | type vector_slice = PIO.vector_slice |
| 54 | type reader = PIO.reader |
| 55 | type writer = PIO.writer |
| 56 | type pos = PIO.pos |
| 57 | |
| 58 | fun liftExn name function cause = raise IO.Io {name = name, |
| 59 | function = function, |
| 60 | cause = cause} |
| 61 | |
| 62 | (*---------------*) |
| 63 | (* outstream *) |
| 64 | (*---------------*) |
| 65 | |
| 66 | datatype buf = Buf of {array: A.array, |
| 67 | size: int ref} |
| 68 | datatype bufferMode = NO_BUF |
| 69 | | LINE_BUF of buf |
| 70 | | BLOCK_BUF of buf |
| 71 | fun newLineBuf bufSize = |
| 72 | LINE_BUF (Buf {size = ref 0, |
| 73 | array = A.array (bufSize, someElem)}) |
| 74 | fun newBlockBuf bufSize = |
| 75 | BLOCK_BUF (Buf {size = ref 0, |
| 76 | array = A.array (bufSize, someElem)}) |
| 77 | |
| 78 | datatype state = Active | Terminated | Closed |
| 79 | fun active state = case state of Active => true | _ => false |
| 80 | fun terminated state = not (active state) |
| 81 | fun closed state = case state of Closed => true | _ => false |
| 82 | |
| 83 | datatype outstream = Out of {writer: writer, |
| 84 | augmented_writer: writer, |
| 85 | state: state ref, |
| 86 | bufferMode: bufferMode ref} |
| 87 | |
| 88 | fun equalsOut (Out {state = state1, ...}, Out {state = state2, ...}) = |
| 89 | state1 = state2 |
| 90 | |
| 91 | fun outstreamSel (Out v, sel) = sel v |
| 92 | fun outstreamWriter os = outstreamSel (os, #writer) |
| 93 | fun writerSel (PIO.WR v, sel) = sel v |
| 94 | fun outstreamName os = writerSel (outstreamWriter os, #name) |
| 95 | |
| 96 | local |
| 97 | fun flushGen (write: 'a -> int, |
| 98 | base: 'a -> ('b * int * int), |
| 99 | slice: ('b * int * int option) -> 'a, |
| 100 | a: 'a) = |
| 101 | let |
| 102 | val (b, i, sz) = base a |
| 103 | val max = i + sz |
| 104 | fun loop i = |
| 105 | if i = max |
| 106 | then () |
| 107 | else let |
| 108 | val j = write (slice (b, i, SOME (max - i))) |
| 109 | in |
| 110 | if j = 0 |
| 111 | then raise (Fail "partial write") |
| 112 | else loop (i + j) |
| 113 | end |
| 114 | in |
| 115 | loop i |
| 116 | end |
| 117 | in |
| 118 | fun flushVec (writer, x) = |
| 119 | case writerSel (writer, #writeVec) of |
| 120 | NONE => raise IO.BlockingNotSupported |
| 121 | | SOME writeVec => flushGen (writeVec, VS.base, VS.slice, x) |
| 122 | |
| 123 | fun flushArr (writer, x) = |
| 124 | case writerSel (writer, #writeArr) of |
| 125 | NONE => raise IO.BlockingNotSupported |
| 126 | | SOME writeArr => flushGen (writeArr, AS.base, AS.slice, x) |
| 127 | end |
| 128 | |
| 129 | fun flushBuf' (writer, size, array) = |
| 130 | let |
| 131 | val size' = !size |
| 132 | in |
| 133 | size := 0 |
| 134 | ; flushArr (writer, AS.slice (array, 0, SOME size')) |
| 135 | end |
| 136 | |
| 137 | fun flushBuf (writer, Buf {size, array}) = flushBuf' (writer, size, array) |
| 138 | |
| 139 | fun output (os as Out {augmented_writer, |
| 140 | state, |
| 141 | bufferMode, ...}, v) = |
| 142 | if terminated (!state) |
| 143 | then liftExn (outstreamName os) "output" IO.ClosedStream |
| 144 | else let |
| 145 | fun put () = flushVec (augmented_writer, VS.full v) |
| 146 | fun doit (buf as Buf {size, array}, maybe) = |
| 147 | let |
| 148 | val curSize = !size |
| 149 | val newSize = curSize + V.length v |
| 150 | in |
| 151 | if newSize >= A.length array orelse maybe () |
| 152 | then (flushBuf (augmented_writer, buf); put ()) |
| 153 | else (A.copyVec {src = v, dst = array, di = curSize}; |
| 154 | size := newSize) |
| 155 | end |
| 156 | in |
| 157 | case !bufferMode of |
| 158 | NO_BUF => put () |
| 159 | | LINE_BUF buf => doit (buf, fn () => (case line of |
| 160 | NONE => false |
| 161 | | SOME {isLine, lineElem} => V.exists isLine v)) |
| 162 | | BLOCK_BUF buf => doit (buf, fn () => false) |
| 163 | end |
| 164 | handle exn => liftExn (outstreamName os) "output" exn |
| 165 | |
| 166 | fun ensureActive (os as Out {state, ...}) = |
| 167 | if active (!state) |
| 168 | then () |
| 169 | else liftExn (outstreamName os) "output" IO.ClosedStream |
| 170 | |
| 171 | local |
| 172 | val buf1 = A.array (1, someElem) |
| 173 | fun flush (os, size, array) = |
| 174 | let |
| 175 | val Out {augmented_writer, ...} = os |
| 176 | in |
| 177 | flushBuf' (augmented_writer, size, array) |
| 178 | handle exn => liftExn (outstreamName os) "output1" exn |
| 179 | end |
| 180 | in |
| 181 | (* output1 is implemented very carefully to make it fast. Think hard |
| 182 | * before modifying it, and test after you do, to make sure that it |
| 183 | * hasn't been slowed down. |
| 184 | *) |
| 185 | fun output1 (os as Out {bufferMode, ...}, c): unit = |
| 186 | case !bufferMode of |
| 187 | BLOCK_BUF (Buf {array, size}) => |
| 188 | let |
| 189 | val n = !size |
| 190 | in |
| 191 | (* Use the bounds check for the update to make sure there |
| 192 | * is space to put the character in the array. |
| 193 | *) |
| 194 | (A.update (array, n, c) |
| 195 | ; size := 1 + n) |
| 196 | handle Subscript => |
| 197 | let |
| 198 | val _ = ensureActive os |
| 199 | val _ = flush (os, size, array) |
| 200 | val _ = A.update (array, 0, c) |
| 201 | val _ = size := 1 |
| 202 | in |
| 203 | () |
| 204 | end |
| 205 | end |
| 206 | | LINE_BUF (Buf {array, size}) => |
| 207 | let |
| 208 | val n = !size |
| 209 | val _ = |
| 210 | (* Use the bounds check for the update to make sure there |
| 211 | * is space to put the character in the array. |
| 212 | *) |
| 213 | (A.update (array, n, c) |
| 214 | ; size := 1 + n) |
| 215 | handle Subscript => |
| 216 | let |
| 217 | val _ = ensureActive os |
| 218 | val _ = flush (os, size, array) |
| 219 | val _ = A.update (array, 0, c) |
| 220 | val _ = size := 1 |
| 221 | in |
| 222 | () |
| 223 | end |
| 224 | in |
| 225 | case line of |
| 226 | NONE => () |
| 227 | | SOME {isLine, lineElem} => |
| 228 | if isLine c then flush (os, size, array) else () |
| 229 | end |
| 230 | | NO_BUF => |
| 231 | let |
| 232 | val _ = ensureActive os |
| 233 | val _ = A.update (buf1, 0, c) |
| 234 | val Out {augmented_writer, ...} = os |
| 235 | in |
| 236 | flushArr (augmented_writer, AS.slice (buf1, 0, SOME 1)) |
| 237 | end |
| 238 | end |
| 239 | |
| 240 | fun outputSlice (os as Out {augmented_writer, |
| 241 | state, |
| 242 | bufferMode, ...}, v) = |
| 243 | if terminated (!state) |
| 244 | then liftExn (outstreamName os) "output" IO.ClosedStream |
| 245 | else let |
| 246 | fun put () = flushVec (augmented_writer, v) |
| 247 | fun doit (buf as Buf {size, array}, maybe) = |
| 248 | let |
| 249 | val curSize = !size |
| 250 | val newSize = curSize + VS.length v |
| 251 | in |
| 252 | if newSize >= A.length array orelse maybe () |
| 253 | then (flushBuf (augmented_writer, buf); put ()) |
| 254 | else (AS.copyVec {src = v, dst = array, di = curSize}; |
| 255 | size := newSize) |
| 256 | end |
| 257 | in |
| 258 | case !bufferMode of |
| 259 | NO_BUF => put () |
| 260 | | LINE_BUF buf => doit (buf, fn () => (case line of |
| 261 | NONE => false |
| 262 | | SOME {isLine, lineElem} => VS.exists isLine v)) |
| 263 | | BLOCK_BUF buf => doit (buf, fn () => false) |
| 264 | end |
| 265 | handle exn => liftExn (outstreamName os) "output" exn |
| 266 | |
| 267 | fun flushOut (os as Out {augmented_writer, |
| 268 | state, |
| 269 | bufferMode, ...}) = |
| 270 | if terminated (!state) |
| 271 | then () |
| 272 | else case !bufferMode of |
| 273 | NO_BUF => () |
| 274 | | LINE_BUF buf => flushBuf (augmented_writer, buf) |
| 275 | | BLOCK_BUF buf => flushBuf (augmented_writer, buf) |
| 276 | handle exn => liftExn (outstreamName os) "flushOut" exn |
| 277 | |
| 278 | fun makeTerminated (Out {bufferMode, ...}) = |
| 279 | let |
| 280 | fun doit (Buf {array, size}) = size := A.length array |
| 281 | in |
| 282 | case !bufferMode of |
| 283 | BLOCK_BUF b => doit b |
| 284 | | LINE_BUF b => doit b |
| 285 | | NO_BUF => () |
| 286 | end |
| 287 | |
| 288 | fun closeOut (os as Out {state, ...}) = |
| 289 | if closed (!state) |
| 290 | then () |
| 291 | else (flushOut os; |
| 292 | if terminated (!state) |
| 293 | then () |
| 294 | else (writerSel (outstreamWriter os, #close)) (); |
| 295 | state := Closed |
| 296 | ; makeTerminated os) |
| 297 | handle exn => liftExn (outstreamName os) "closeOut" exn |
| 298 | |
| 299 | fun getBufferMode (Out {bufferMode, ...}) = |
| 300 | case !bufferMode of |
| 301 | NO_BUF => IO.NO_BUF |
| 302 | | LINE_BUF _ => IO.LINE_BUF |
| 303 | | BLOCK_BUF _ => IO.BLOCK_BUF |
| 304 | |
| 305 | fun setBufferMode (os as Out {bufferMode, ...}, mode) = |
| 306 | case mode of |
| 307 | IO.NO_BUF => (flushOut os; |
| 308 | bufferMode := NO_BUF) |
| 309 | | IO.LINE_BUF => let |
| 310 | fun doit () = |
| 311 | bufferMode := |
| 312 | newLineBuf (writerSel (outstreamWriter os, #chunkSize)) |
| 313 | in |
| 314 | case !bufferMode of |
| 315 | NO_BUF => doit () |
| 316 | | LINE_BUF _ => () |
| 317 | | BLOCK_BUF _ => doit () |
| 318 | end |
| 319 | | IO.BLOCK_BUF => let |
| 320 | fun doit () = |
| 321 | bufferMode := |
| 322 | newBlockBuf (writerSel (outstreamWriter os, #chunkSize)) |
| 323 | in |
| 324 | case !bufferMode of |
| 325 | NO_BUF => doit () |
| 326 | | LINE_BUF _ => doit () |
| 327 | | BLOCK_BUF _ => () |
| 328 | end |
| 329 | |
| 330 | fun mkOutstream' {writer, closed, bufferMode} = |
| 331 | let |
| 332 | val bufSize = writerSel (writer, #chunkSize) |
| 333 | in |
| 334 | Out {writer = writer, |
| 335 | augmented_writer = PIO.augmentWriter writer, |
| 336 | state = ref (if closed then Closed else Active), |
| 337 | bufferMode = ref (case bufferMode of |
| 338 | IO.NO_BUF => NO_BUF |
| 339 | | IO.LINE_BUF => newLineBuf bufSize |
| 340 | | IO.BLOCK_BUF => newBlockBuf bufSize)} |
| 341 | end |
| 342 | fun mkOutstream (writer, bufferMode) = |
| 343 | mkOutstream' {writer = writer, closed = false, bufferMode = bufferMode} |
| 344 | |
| 345 | fun getWriter (os as Out {writer, state, bufferMode, ...}) = |
| 346 | if closed (!state) |
| 347 | then liftExn (outstreamName os) "getWriter" IO.ClosedStream |
| 348 | else (flushOut os |
| 349 | ; state := Terminated |
| 350 | ; makeTerminated os |
| 351 | ; (writer, |
| 352 | case !bufferMode of |
| 353 | NO_BUF => IO.NO_BUF |
| 354 | | LINE_BUF _ => IO.LINE_BUF |
| 355 | | BLOCK_BUF _ => IO.BLOCK_BUF)) |
| 356 | |
| 357 | datatype out_pos = OutPos of {pos: pos, |
| 358 | outstream: outstream} |
| 359 | |
| 360 | fun getPosOut (os as Out {...}) = |
| 361 | (flushOut os; |
| 362 | case writerSel (outstreamSel (os, #writer), #getPos) of |
| 363 | NONE => liftExn (outstreamName os) "getPosOut" IO.RandomAccessNotSupported |
| 364 | | SOME getPos => OutPos {pos = getPos (), |
| 365 | outstream = os}) |
| 366 | |
| 367 | fun setPosOut (OutPos {pos, outstream = os}) = |
| 368 | (flushOut os; |
| 369 | case writerSel (outstreamSel (os, #writer), #setPos) of |
| 370 | NONE => liftExn (outstreamName os) "setPosOut" IO.RandomAccessNotSupported |
| 371 | | SOME setPos => setPos pos; |
| 372 | os) |
| 373 | |
| 374 | fun filePosOut (OutPos {pos, ...}) = pos |
| 375 | |
| 376 | (*---------------*) |
| 377 | (* instream *) |
| 378 | (*---------------*) |
| 379 | |
| 380 | datatype state = Link of {buf: buf} |
| 381 | | Eos of {buf: buf} (* V.length inp = 0 *) |
| 382 | | End |
| 383 | | Truncated |
| 384 | | Closed |
| 385 | and buf = Buf of {inp: V.vector, |
| 386 | base: pos option, |
| 387 | next: state ref} |
| 388 | |
| 389 | datatype instream = In of {common: {reader: reader, |
| 390 | augmented_reader: reader, |
| 391 | tail: state ref ref}, |
| 392 | pos: int, |
| 393 | buf: buf} |
| 394 | (* @ s = Eos, End, Truncated, Closed ==> |
| 395 | * pos = V.length inp, !next = s |
| 396 | *) |
| 397 | |
| 398 | fun equalsIn (In {common = {tail = tail1, ...}, ...}, |
| 399 | In {common = {tail = tail2, ...}, ...}) = |
| 400 | tail1 = tail2 |
| 401 | |
| 402 | fun update (In {common, ...}, pos, buf) = |
| 403 | In {common = common, |
| 404 | pos = pos, |
| 405 | buf = buf} |
| 406 | fun updatePos (is as In {buf, ...}, pos) = update (is, pos, buf) |
| 407 | fun updateBufBeg (is, buf) = update (is, 0, buf) |
| 408 | fun updateBufEnd (is, buf as Buf {inp, ...}) = update (is, V.length inp, buf) |
| 409 | |
| 410 | fun instreamSel (In v, sel) = sel v |
| 411 | fun instreamCommon is = instreamSel (is, #common) |
| 412 | fun instreamCommonSel (is, sel) = sel (instreamCommon is) |
| 413 | fun instreamReader is = instreamCommonSel (is, #reader) |
| 414 | fun instreamTail is = instreamCommonSel (is, #tail) |
| 415 | fun readerSel (PIO.RD v, sel) = sel v |
| 416 | fun instreamName is = readerSel (instreamReader is, #name) |
| 417 | |
| 418 | val empty = V.tabulate (0, fn _ => someElem) |
| 419 | |
| 420 | fun extend function |
| 421 | (is as In {common = {augmented_reader, tail, ...}, ...}) |
| 422 | blocking = |
| 423 | case !(!tail) of |
| 424 | End => |
| 425 | let |
| 426 | fun link (base, inp) = let |
| 427 | val next = ref End |
| 428 | val buf = Buf {inp = inp, |
| 429 | base = base, |
| 430 | next = next} |
| 431 | val this = if V.length inp = 0 |
| 432 | then Eos {buf = buf} |
| 433 | else Link {buf = buf} |
| 434 | val _ = !tail := this |
| 435 | val _ = tail := next |
| 436 | in |
| 437 | SOME this |
| 438 | end |
| 439 | fun doit readVec = |
| 440 | let |
| 441 | val base = |
| 442 | case readerSel (augmented_reader, #getPos) of |
| 443 | NONE => NONE |
| 444 | | SOME getPos => SOME (getPos ()) |
| 445 | val inp = readVec (readerSel (augmented_reader, #chunkSize)) |
| 446 | handle exn => |
| 447 | liftExn (instreamName is) function exn |
| 448 | in |
| 449 | case inp of |
| 450 | NONE => NONE |
| 451 | | SOME inp => link (base, inp) |
| 452 | end |
| 453 | in |
| 454 | if blocking |
| 455 | then case readerSel (augmented_reader, #readVec) of |
| 456 | NONE => liftExn (instreamName is) |
| 457 | function |
| 458 | IO.BlockingNotSupported |
| 459 | | SOME readVec => doit (SOME o readVec) |
| 460 | else case readerSel (augmented_reader, #readVecNB) of |
| 461 | NONE => liftExn (instreamName is) |
| 462 | function |
| 463 | IO.NonblockingNotSupported |
| 464 | | SOME readVecNB => doit readVecNB |
| 465 | end |
| 466 | | _ => liftExn (instreamName is) function Match |
| 467 | |
| 468 | fun extendB function is = valOf (extend function is true) |
| 469 | fun extendNB function is = extend function is false |
| 470 | |
| 471 | fun input (is as In {pos, buf as Buf {inp, next, ...}, ...}) = |
| 472 | if pos < V.length inp |
| 473 | then (V.extract(inp, pos, NONE), |
| 474 | updateBufEnd (is, buf)) |
| 475 | else let |
| 476 | fun doit next = |
| 477 | case next of |
| 478 | Link {buf as Buf {inp, ...}} => (inp, updateBufEnd (is, buf)) |
| 479 | | Eos {buf} => (empty, updateBufBeg (is, buf)) |
| 480 | | End => doit (extendB "input" is) |
| 481 | | _ => (empty, is) |
| 482 | in |
| 483 | doit (!next) |
| 484 | end |
| 485 | |
| 486 | fun inputN (is, n) = |
| 487 | if n < 0 orelse n > V.maxLen |
| 488 | then raise Size |
| 489 | else let |
| 490 | fun first (is as In {pos, buf as Buf {inp, ...}, ...}, n) = |
| 491 | if pos + n <= V.length inp |
| 492 | then let |
| 493 | val inp' = V.extract(inp, pos, SOME n) |
| 494 | in |
| 495 | (inp', updatePos (is, pos + n)) |
| 496 | end |
| 497 | else let |
| 498 | val inp' = VS.slice(inp, pos, NONE) |
| 499 | in |
| 500 | loop (buf, [inp'], n - (V.length inp - pos)) |
| 501 | end |
| 502 | and loop (buf' as Buf {next, ...}, inps, n) = |
| 503 | let |
| 504 | fun doit next = |
| 505 | case next of |
| 506 | Link {buf as Buf {inp, ...}} => |
| 507 | if n <= V.length inp |
| 508 | then let |
| 509 | val inp' = VS.slice(inp, 0, SOME n) |
| 510 | val inps = inp'::inps |
| 511 | in |
| 512 | finish (inps, update (is, n, buf)) |
| 513 | end |
| 514 | else loop (buf, (VS.full inp)::inps, n - V.length inp) |
| 515 | | Eos {buf} => |
| 516 | finish (inps, if n > 0 |
| 517 | then updateBufBeg (is, buf) |
| 518 | else updateBufEnd (is, buf')) |
| 519 | | End => doit (extendB "inputN" is) |
| 520 | | _ => finish (inps, updateBufEnd (is, buf')) |
| 521 | in |
| 522 | doit (!next) |
| 523 | end |
| 524 | and finish (inps, is) = |
| 525 | let val inp = VS.concat (List.rev inps) |
| 526 | in (inp, is) |
| 527 | end |
| 528 | in |
| 529 | first (is, n) |
| 530 | end |
| 531 | |
| 532 | (* input1' will move past a temporary end of stream *) |
| 533 | fun input1' (is as In {pos, buf = Buf {inp, next, ...}, ...}) = |
| 534 | case SOME (V.sub (inp, pos)) handle Subscript => NONE of |
| 535 | NONE => |
| 536 | let |
| 537 | fun doit next = |
| 538 | case next of |
| 539 | Link {buf} => input1' (updateBufBeg (is, buf)) |
| 540 | | Eos {buf} => (NONE, updateBufBeg (is, buf)) |
| 541 | | End => doit (extendB "input1" is) |
| 542 | | _ => (NONE, is) |
| 543 | in |
| 544 | doit (!next) |
| 545 | end |
| 546 | | SOME e => |
| 547 | let |
| 548 | val is' = updatePos (is, pos + 1) |
| 549 | in |
| 550 | (SOME e, is') |
| 551 | end |
| 552 | |
| 553 | (* input1 will never move past a temporary end of stream *) |
| 554 | fun input1 is = |
| 555 | case input1' is of |
| 556 | (SOME c, is') => SOME (c, is') |
| 557 | | _ => NONE |
| 558 | |
| 559 | fun inputAll is = |
| 560 | let |
| 561 | fun loop (is, ac) = |
| 562 | let val (inp, is') = input is |
| 563 | in |
| 564 | if V.length inp = 0 |
| 565 | then (V.concat (List.rev ac), is') |
| 566 | else loop (is', inp::ac) |
| 567 | end |
| 568 | in |
| 569 | loop (is, []) |
| 570 | end |
| 571 | |
| 572 | val inputLine = |
| 573 | case line of |
| 574 | NONE => (fn is => SOME (input is)) |
| 575 | | SOME {isLine, lineElem} => |
| 576 | let |
| 577 | val lineVecSl = VS.full (V.tabulate (1, fn _ => lineElem)) |
| 578 | in |
| 579 | fn is => |
| 580 | let |
| 581 | fun findLine (v, i) = |
| 582 | let |
| 583 | fun loop i = |
| 584 | case SOME (V.sub (v, i)) handle Subscript => NONE of |
| 585 | NONE => NONE |
| 586 | | SOME c => |
| 587 | if isLine c |
| 588 | then SOME (i + 1) |
| 589 | else loop (i + 1) |
| 590 | in |
| 591 | loop i |
| 592 | end |
| 593 | fun first (is as In {pos, buf as Buf {inp, next, ...}, ...}) = |
| 594 | (case findLine (inp, pos) of |
| 595 | SOME i => let |
| 596 | val inp' = V.extract(inp, pos, SOME (i - pos)) |
| 597 | in |
| 598 | SOME (inp', updatePos (is, i)) |
| 599 | end |
| 600 | | NONE => if pos < V.length inp |
| 601 | then let |
| 602 | val inp' = VS.slice(inp, pos, NONE) |
| 603 | in |
| 604 | loop (buf, [inp']) |
| 605 | end |
| 606 | else let |
| 607 | fun doit next = |
| 608 | case next of |
| 609 | Link {buf} => first (updateBufBeg (is, buf)) |
| 610 | | Eos _ => NONE |
| 611 | | End => doit (extendB "inputLine" is) |
| 612 | | _ => NONE |
| 613 | in |
| 614 | doit (!next) |
| 615 | end) |
| 616 | and loop (buf' as Buf {next, ...}, inps) = |
| 617 | (* List.length inps > 0 *) |
| 618 | let |
| 619 | fun doit next = |
| 620 | case next of |
| 621 | Link {buf as Buf {inp, ...}} => |
| 622 | (case findLine (inp, 0) of |
| 623 | SOME i => let |
| 624 | val inp' = VS.slice(inp, 0, SOME i) |
| 625 | val inps = inp'::inps |
| 626 | in |
| 627 | finish (inps, update (is, i, buf), false) |
| 628 | end |
| 629 | | NONE => loop (buf, (VS.full inp)::inps)) |
| 630 | | End => doit (extendB "inputLine" is) |
| 631 | | _ => finish (inps, updateBufEnd (is, buf'), true) |
| 632 | in |
| 633 | doit (!next) |
| 634 | end |
| 635 | and finish (inps, is, trail) = |
| 636 | let |
| 637 | val inps = if trail |
| 638 | then lineVecSl::inps |
| 639 | else inps |
| 640 | val inp = VS.concat (List.rev inps) |
| 641 | in |
| 642 | SOME (inp, is) |
| 643 | end |
| 644 | in |
| 645 | first is |
| 646 | end |
| 647 | end |
| 648 | |
| 649 | fun canInput (is as In {pos, buf = Buf {inp, next, ...}, ...}, n) = |
| 650 | if n < 0 orelse n > V.maxLen |
| 651 | then raise Size |
| 652 | else if n = 0 |
| 653 | then SOME 0 |
| 654 | else let |
| 655 | fun start inp = |
| 656 | add ([], inp, 0) |
| 657 | and add (inps, inp, k) = |
| 658 | let |
| 659 | val l = V.length inp |
| 660 | val inps = inp::inps |
| 661 | in |
| 662 | if k + l > n |
| 663 | then finish (inps, n) |
| 664 | else loop (inps, k + l) |
| 665 | end |
| 666 | and loop (inps, k) = |
| 667 | case extendNB "canInput" is of |
| 668 | NONE => finish (inps, k) |
| 669 | | SOME (Link {buf = Buf {inp, ...}}) => |
| 670 | add (inps, inp, k) |
| 671 | | SOME (Eos _) => finish (inps, k) |
| 672 | | _ => raise Fail "extendNB bug" |
| 673 | and finish (inps, k) = |
| 674 | let |
| 675 | val inp = V.concat (List.rev inps) |
| 676 | in |
| 677 | (inp, k) |
| 678 | end |
| 679 | in |
| 680 | if pos < V.length inp |
| 681 | then SOME (Int.min (V.length inp - pos, n)) |
| 682 | else case !next of |
| 683 | End => |
| 684 | (case extendNB "canInput" is of |
| 685 | NONE => NONE |
| 686 | | SOME (Link {buf = Buf {inp, base, ...}}) => |
| 687 | let |
| 688 | val (inp, k) = start inp |
| 689 | val buf = Buf {inp = inp, |
| 690 | base = base, |
| 691 | next = ref End} |
| 692 | in |
| 693 | next := Link {buf = buf}; |
| 694 | SOME k |
| 695 | end |
| 696 | | SOME (Eos _) => SOME 0 |
| 697 | | _ => raise Fail "extendNB bug") |
| 698 | | _ => SOME 0 |
| 699 | end |
| 700 | |
| 701 | structure Close = |
| 702 | struct |
| 703 | datatype t = T of {close: unit -> unit, |
| 704 | name: string, |
| 705 | tail: state ref ref} |
| 706 | |
| 707 | fun close (T {close, name, tail}) = |
| 708 | case !(!tail) of |
| 709 | End => |
| 710 | (!tail := Closed |
| 711 | ; close () handle exn => liftExn name "closeIn" exn) |
| 712 | | _ => () |
| 713 | |
| 714 | fun equalsInstream (T {tail, ...}, is) = tail = instreamTail is |
| 715 | |
| 716 | fun make (In {common = {reader = PIO.RD {close, name, ...}, |
| 717 | tail, ...}, |
| 718 | ...}): t = |
| 719 | T {close = close, name = name, tail = tail} |
| 720 | end |
| 721 | |
| 722 | val closeIn = Close.close o Close.make |
| 723 | |
| 724 | fun endOfStream is = |
| 725 | let val (inp, _) = input is |
| 726 | in V.length inp = 0 |
| 727 | end |
| 728 | |
| 729 | fun mkInstream' {bufferContents, closed, reader} = |
| 730 | let |
| 731 | val next = ref (if closed then Closed else End) |
| 732 | val base = |
| 733 | case readerSel (reader, #getPos) of |
| 734 | NONE => NONE |
| 735 | | SOME getPos => SOME (getPos ()) |
| 736 | val buf = |
| 737 | case bufferContents of |
| 738 | NONE => Buf {inp = empty, |
| 739 | base = base, |
| 740 | next = next} |
| 741 | | SOME (lastRead, v) => |
| 742 | if V.length v = 0 |
| 743 | then Buf {inp = empty, |
| 744 | base = base, |
| 745 | next = ref (Eos {buf = Buf {inp = empty, |
| 746 | base = base, |
| 747 | next = next}})} |
| 748 | else case (lastRead, base, xlatePos) of |
| 749 | (true, SOME b, SOME {fromInt, toInt}) => |
| 750 | let |
| 751 | val b = |
| 752 | fromInt (Position.- (toInt b, Position.fromInt (V.length v))) |
| 753 | in |
| 754 | Buf {inp = v, |
| 755 | base = SOME b, |
| 756 | next = next} |
| 757 | end |
| 758 | | _ => Buf {inp = v, |
| 759 | base = NONE, |
| 760 | next = next} |
| 761 | in |
| 762 | In {common = {reader = reader, |
| 763 | augmented_reader = PIO.augmentReader reader, |
| 764 | tail = ref next}, |
| 765 | pos = 0, |
| 766 | buf = buf} |
| 767 | end |
| 768 | |
| 769 | fun mkInstream (reader, bufferContents) = |
| 770 | mkInstream' {bufferContents = if 0 = V.length bufferContents |
| 771 | then NONE |
| 772 | else SOME (false, bufferContents), |
| 773 | closed = false, |
| 774 | reader = reader} |
| 775 | |
| 776 | fun getReader (is as In {common = {reader, tail, ...}, ...}) = |
| 777 | case !(!tail) of |
| 778 | End => (!tail := Truncated; |
| 779 | let val (inp, _) = inputAll is |
| 780 | in (reader, inp) |
| 781 | end) |
| 782 | | _ => liftExn (instreamName is) "getReader" IO.ClosedStream |
| 783 | |
| 784 | fun filePosIn (is as In {common = {augmented_reader, ...}, |
| 785 | pos, |
| 786 | buf = Buf {base, ...}, ...}) = |
| 787 | case base of |
| 788 | SOME b => (case xlatePos of |
| 789 | SOME {fromInt, toInt} => |
| 790 | (fromInt (Position.+ (Position.fromInt pos, toInt b))) |
| 791 | | NONE => (case (readerSel (augmented_reader, #readVec), |
| 792 | readerSel (augmented_reader, #getPos), |
| 793 | readerSel (augmented_reader, #setPos)) of |
| 794 | (SOME readVec, SOME getPos, SOME setPos) => |
| 795 | let |
| 796 | val curPos = getPos () |
| 797 | in |
| 798 | setPos b |
| 799 | ; ignore (readVec pos) |
| 800 | ; getPos () before setPos curPos |
| 801 | end |
| 802 | | _ => |
| 803 | liftExn (instreamName is) "filePosIn" IO.RandomAccessNotSupported)) |
| 804 | | NONE => liftExn (instreamName is) "filePosIn" IO.RandomAccessNotSupported |
| 805 | end |
| 806 | |
| 807 | signature STREAM_IO_ARG = |
| 808 | sig |
| 809 | structure Array: MONO_ARRAY |
| 810 | structure ArraySlice: MONO_ARRAY_SLICE |
| 811 | structure PrimIO: PRIM_IO |
| 812 | structure Vector: MONO_VECTOR |
| 813 | structure VectorSlice: MONO_VECTOR_SLICE |
| 814 | sharing type PrimIO.elem = Vector.elem = VectorSlice.elem = Array.elem |
| 815 | = ArraySlice.elem |
| 816 | sharing type PrimIO.vector = Vector.vector = VectorSlice.vector |
| 817 | = Array.vector = ArraySlice.vector |
| 818 | sharing type PrimIO.vector_slice = VectorSlice.slice |
| 819 | = ArraySlice.vector_slice |
| 820 | sharing type PrimIO.array = Array.array = ArraySlice.array |
| 821 | sharing type PrimIO.array_slice = ArraySlice.slice |
| 822 | |
| 823 | val someElem: PrimIO.elem |
| 824 | end |
| 825 | |
| 826 | functor StreamIO (S: STREAM_IO_ARG): STREAM_IO = |
| 827 | StreamIOExtra (open S |
| 828 | val line = NONE |
| 829 | val xlatePos = NONE) |
| 830 | |
| 831 | signature STREAM_IO_EXTRA_FILE_ARG = STREAM_IO_EXTRA_ARG |
| 832 | |
| 833 | functor StreamIOExtraFile (S: STREAM_IO_EXTRA_FILE_ARG): STREAM_IO_EXTRA_FILE = |
| 834 | struct |
| 835 | open S |
| 836 | |
| 837 | structure PIO = PrimIO |
| 838 | structure V = Vector |
| 839 | |
| 840 | structure StreamIO = StreamIOExtra (S) |
| 841 | open StreamIO |
| 842 | |
| 843 | fun liftExn name function cause = raise IO.Io {name = name, |
| 844 | function = function, |
| 845 | cause = cause} |
| 846 | |
| 847 | (*---------------*) |
| 848 | (* outstream *) |
| 849 | (*---------------*) |
| 850 | |
| 851 | fun writerSel (PIO.WR v, sel) = sel v |
| 852 | fun outstreamName os = writerSel (outstreamWriter os, #name) |
| 853 | |
| 854 | fun outFd os = |
| 855 | case writerSel (outstreamWriter os, #ioDesc) of |
| 856 | SOME ioDesc => valOf (Posix.FileSys.iodToFD ioDesc) |
| 857 | | NONE => liftExn (outstreamName os) "outFd" (Fail "<no ioDesc>") |
| 858 | |
| 859 | val openOutstreams : (outstream * {close: bool}) list ref = ref [] |
| 860 | |
| 861 | val mkOutstream'' = |
| 862 | let |
| 863 | val _ = Cleaner.addNew |
| 864 | (Cleaner.atExit, fn () => |
| 865 | List.app (fn (os, {close}) => |
| 866 | if close |
| 867 | then closeOut os |
| 868 | else flushOut os) (!openOutstreams)) |
| 869 | in |
| 870 | fn {bufferMode, closeAtExit, closed, writer} => |
| 871 | let |
| 872 | val os = mkOutstream' {bufferMode = bufferMode, |
| 873 | closed = closed, |
| 874 | writer = writer} |
| 875 | val _ = |
| 876 | if closed |
| 877 | then () |
| 878 | else openOutstreams := ((os, {close = closeAtExit}) |
| 879 | :: (!openOutstreams)) |
| 880 | in |
| 881 | os |
| 882 | end |
| 883 | end |
| 884 | |
| 885 | fun mkOutstream' {bufferMode, closed, writer} = |
| 886 | mkOutstream'' {bufferMode = bufferMode, |
| 887 | closeAtExit = true, |
| 888 | closed = closed, |
| 889 | writer = writer} |
| 890 | |
| 891 | fun mkOutstream (writer, bufferMode) = |
| 892 | mkOutstream' {bufferMode = bufferMode, |
| 893 | closed = false, |
| 894 | writer = writer} |
| 895 | |
| 896 | val closeOut = fn os => |
| 897 | let |
| 898 | val _ = openOutstreams := List.filter (fn (os', _) => |
| 899 | not (equalsOut (os, os'))) |
| 900 | (!openOutstreams) |
| 901 | in |
| 902 | closeOut os |
| 903 | end |
| 904 | |
| 905 | (*---------------*) |
| 906 | (* instream *) |
| 907 | (*---------------*) |
| 908 | |
| 909 | fun readerSel (PIO.RD v, sel) = sel v |
| 910 | |
| 911 | fun instreamName is = readerSel (instreamReader is, #name) |
| 912 | |
| 913 | fun inFd is = |
| 914 | case readerSel (instreamReader is, #ioDesc) of |
| 915 | SOME ioDesc => valOf (Posix.FileSys.iodToFD ioDesc) |
| 916 | | NONE => liftExn (instreamName is) "inFd" (Fail "<no ioDesc>") |
| 917 | |
| 918 | val closeAtExits: Close.t list ref = ref [] |
| 919 | |
| 920 | val mkInstream'' = |
| 921 | let |
| 922 | val _ = Cleaner.addNew (Cleaner.atExit, fn () => |
| 923 | List.app Close.close (!closeAtExits)) |
| 924 | in |
| 925 | fn {bufferContents, closeAtExit, closed, reader} => |
| 926 | let |
| 927 | val is = |
| 928 | mkInstream' {bufferContents = bufferContents, |
| 929 | closed = closed, |
| 930 | reader = reader} |
| 931 | val _ = |
| 932 | if closed orelse not closeAtExit |
| 933 | then () |
| 934 | else closeAtExits := Close.make is :: (!closeAtExits) |
| 935 | in |
| 936 | is |
| 937 | end |
| 938 | end |
| 939 | |
| 940 | fun mkInstream' {bufferContents, closed, reader} = |
| 941 | mkInstream'' {bufferContents = bufferContents, |
| 942 | closeAtExit = true, |
| 943 | closed = closed, |
| 944 | reader = reader} |
| 945 | |
| 946 | |
| 947 | fun mkInstream (reader, bufferContents) = |
| 948 | mkInstream' {bufferContents = (if V.length bufferContents = 0 then NONE |
| 949 | else SOME (false, bufferContents)), |
| 950 | closed = false, |
| 951 | reader = reader} |
| 952 | |
| 953 | val closeIn = fn is => |
| 954 | let |
| 955 | val _ = |
| 956 | closeAtExits := |
| 957 | List.filter (fn c => Close.equalsInstream (c, is)) (!closeAtExits) |
| 958 | in |
| 959 | closeIn is |
| 960 | end |
| 961 | end |