(*
    Title:      Standard Basis Library: PrimIO functor
    Copyright   David C.J. Matthews 2000, 2005

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License as published by the Free Software Foundation; either
    version 2.1 of the License, or (at your option) any later version.
    
    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.
    
    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

(* G&R 2004 status: Done *)

functor PrimIO (
    structure Vector : MONO_VECTOR
    structure VectorSlice: MONO_VECTOR_SLICE
    structure Array : MONO_ARRAY
    structure ArraySlice : MONO_ARRAY_SLICE
    sharing type Array.elem = Vector.elem = VectorSlice.elem = ArraySlice.elem
    sharing type Array.vector = Vector.vector = VectorSlice.vector = ArraySlice.vector
    sharing type VectorSlice.slice = ArraySlice.vector_slice
    sharing type Array.array = ArraySlice.array
    val someElem : Array.elem
    eqtype pos (* Note: this was shown as just a type in the functor arg. *)
    val compare : pos * pos -> order
    ): PRIM_IO =
struct
    type array = Array.array 
    and  vector = Vector.vector
    and  elem = Array.elem
    and  vector_slice = VectorSlice.slice
    and  array_slice = ArraySlice.slice

    type pos = pos

    val compare = compare

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

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

    (* Define readVec, readArr, readVecNB, readArrNB if they are not
       provided using the functions which are. *)
    fun augmentReader ( 
        RD {
            name : string,
            chunkSize : int,
            readVec : (int -> vector) Option.option,
            readArr : (array_slice -> int) Option.option,
            readVecNB : (int -> vector Option.option) Option.option,
            readArrNB : (array_slice -> int Option.option) Option.option,
            block : (unit -> unit) option,
            canInput : (unit -> bool) option,
            avail : unit -> int option,
            getPos : (unit -> pos) option,
            setPos : (pos -> unit) option,
            endPos : (unit -> pos) option,
            verifyPos : (unit -> pos) option,
            close : unit -> unit,
            ioDesc : OS.IO.iodesc option
    }) : reader =
    let
        (* First try defining readVec in terms of readArr. *)
        val readVec' =
            case (readVec, readArr) of
                (s as SOME _, _) => s (* If readVec exists use it. *)
            |   (NONE, SOME ra) =>
                (* if readVec doesn't exists but readArr does *)
                    SOME(
                    fn (l: int) =>
                        let
                            (* Create an array initialised to zeros.
                               We have to be careful here.  Suppose
                               the caller was using "readVec maxInt" to mean
                               "give me the rest of the file" knowing that it
                               was only small. To avoid problems we
                               only read the smaller of the size requested or
                               the block size. *)
                            val v = Array.array(Int.min(l, chunkSize), someElem)
                            (* Read as much as we can. *)
                            val n = ra(ArraySlice.full v)
                        in
                            (* Return the section read. *)
                            ArraySlice.vector(ArraySlice.slice(v, 0, SOME n))
                        end
                    )
            |   (NONE, NONE) => NONE

        (* And vice-versa *)
        val readArr' =
            case (readArr, readVec) of
                (s as SOME _, _) => s(* If readArr exists use it. *)
            |   (NONE, SOME rv) =>
                (* if readArr doesn't exists but readVec does *)
                    SOME(
                    fn slice =>
                        let
                            val (buff, i, len) = ArraySlice.base slice
                            (* Read a vector and try and put that into
                               the array. *)
                            val r = rv len
                        in
                            (* Copy the vector into the array. *)
                            Array.copyVec{src=r, dst = buff, di=i};
                            (* Return the number of characters read. *)
                            Vector.length r
                        end
                    )
            |   (NONE, NONE) => NONE

        (* We now have the blocking versions of readVec and readArr if either
           of them existed. Now defining the non-blocking versions using these
           blocking versions if we have to. *)

        val readVecNB' =
            case (readVecNB, readArrNB) of
                (s as SOME _, _) => s (* If readVecNB exists use it. *)
            |   (NONE, SOME ra) => 
                (* If readVecNB does not exist but readArrNB does*)
                    SOME(
                    fn (l: int) =>
                        let
                            val v = Array.array(Int.min(l, chunkSize), someElem)
                        in
                            case ra(ArraySlice.full v) of
                                NONE => NONE
                            |   SOME n => (* Return the section read. *)
                                    SOME (ArraySlice.vector(ArraySlice.slice(v, 0, SOME n)))
                        end
                    )
            |   (NONE, NONE) => 
                (* Try using the blocking readVec' with canInput.
                   We use the readVec' we defined above so that this will
                   also try using readArr. *)
                case (canInput, readVec') of
                    (SOME canIn, SOME rv) =>
                        SOME(
                        fn (l: int) =>
                            if canIn()
                            then SOME(rv l)
                            else NONE
                        )
                |   _ => NONE (* Can't do it. *)

        val readArrNB' =
            case (readArrNB, readVecNB) of
                (s as SOME _, _) => s(* If readArrNB exists use it. *)
            |   (NONE, SOME rv) =>
                (* if readArrNB doesn't exists but readVecNB does *)
                    SOME(
                    fn slice =>
                        let
                            val (buff, i, len) = ArraySlice.base slice
                        in
                            (* Try reading a vector of this size. *)
                            case rv len of
                                NONE => NONE
                            |   SOME r =>
                                (
                                (* Copy the vector into the array. *)
                                Array.copyVec{src=r, dst = buff, di=i};
                                (* Return the number of characters read. *)
                                SOME(Vector.length r)
                            )
                        end
                    )
            |   (NONE, NONE) =>
                (* Try using the blocking readArr' with canInput.
                   We use the readArr' we defined above so that this will
                   also try using readVec. *)
                case (canInput, readArr') of
                    (SOME canIn, SOME ra) =>
                        SOME(
                        fn slice =>
                            if canIn()
                            then SOME(ra slice)
                            else NONE
                        )
                |   _ => NONE (* Can't do it. *)

        (* Finally define the blocking functions in terms of the non-blocking
           if we have to. *)
        val readVec'' =
            case readVec' of
                (* If readVec' exists use it. i.e. if readVec or readArr were
                   defined. *)
                (s as SOME _) => s
            |   NONE =>
                (* No blocking version exists - try using block and the
                   synthesised non-blocking version. *)
                case (block, readVecNB') of
                    (SOME blk, SOME rv) =>
                        SOME(
                        fn (l: int) =>
                            (
                            blk();
                            case rv l of
                                NONE => (* Should not occur. *)
                                    raise IO.Io{
                                        name=name,
                                        function="readVec",
                                        cause = IO.BlockingNotSupported }
                            |   SOME v => v
                            )
                        )
                |   _ => NONE (* Can't do it. *)

        val readArr'' =
            case readArr' of
                (* If readArr' exists use it. *)
                (s as SOME _) => s
            |   NONE =>
                (* Try using block and the synthesised readArrNB'. *)
                case (block, readArrNB') of
                    (SOME blk, SOME ra) =>
                        SOME(
                            fn slice =>
                                (
                                blk();
                                case ra slice of
                                    NONE => 
                                        raise IO.Io{
                                            name=name,
                                            function="readArr",
                                            cause = IO.BlockingNotSupported }
                                |   SOME l => l
                                )
                        )
                    |   _ => NONE (* Can't do it. *)
    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 : string,
        chunkSize : int,
        writeVec : (vector_slice -> int) Option.option,
        writeArr : (array_slice -> int) Option.option,
        writeVecNB : (vector_slice -> int Option.option) Option.option,
        writeArrNB : (array_slice -> int Option.option) Option.option,
        block : (unit -> unit) option,
        canOutput : (unit -> bool) option,
        getPos : (unit -> pos) option,
        setPos : (pos -> unit) option,
        endPos : (unit -> pos) option,
        verifyPos : (unit -> pos) option,
        close : unit -> unit,
        ioDesc : OS.IO.iodesc option
    }) : writer =
    let
        (* First try defining writeVec in terms of writeArr. *)
        val writeVec' =
            case (writeVec, writeArr) of
                (s as SOME _, _) => s (* If writeVec exists use it. *)
            |   (NONE, SOME ra) =>
                (* if writeVec doesn't exists but writeArr does *)
                    SOME(
                    fn slice =>
                        let
                            (* Create an array to hold this slice. *)
                            val a = Array.array(VectorSlice.length slice, someElem)
                        in
                            (* Copy in the vector. *)
                            ArraySlice.copyVec{src=slice, dst=a, di=0};
                            (* write as much as we can. *)
                            ra(ArraySlice.full a)
                        end
                    )
            |   (NONE, NONE) => NONE

        (* And vice-versa *)
        val writeArr' =
            case (writeArr, writeVec) of
                (s as SOME _, _) => s (* If writeArr exists use it. *)
            |   (NONE, SOME wv) =>
                (* if writeArr doesn't exists but writeVec does *)
                    SOME(
                    fn slice =>
                        let
                            (* Construct a vector from this slice. *)
                            val v = ArraySlice.vector slice;
                        in
                            (* Try writing this vector. *)
                            wv(VectorSlice.full v)
                        end
                    )
            |   (NONE, NONE) => NONE

        (* We now have the blocking versions of writeVec and writeArr if either
           of them existed. Now defining the non-blocking versions using these
           blocking versions if we have to. *)

        val writeVecNB' =
            case (writeVecNB, writeArrNB) of
                (s as SOME _, _) => s (* If writeVecNB exists use it. *)
            |   (NONE, SOME wa) => 
                (* If writeVecNB does not exist but writeArrNB does*)
                    SOME(
                    fn slice =>
                        let
                            val len = VectorSlice.length slice
                            (* Create an array to hold this slice. *)
                            val a = Array.array(len, someElem)
                        in
                            (* Copy in the vector. *)
                            ArraySlice.copyVec{src=slice, dst=a, di=0};
                            (* Try writing it and see what happened. *)
                            wa(ArraySlice.full a)
                        end
                    )
            |   (NONE, NONE) => 
                (* Try using the blocking writeVec' with canOutput.
                   We use the writeVec' we defined above so that this will
                   also try using writeArr. *)
                case (canOutput, writeVec') of
                    (SOME canOut, SOME wv) =>
                        SOME(
                        fn slice =>
                            if canOut() then SOME(wv slice) else NONE
                        )
                |   _ => NONE (* Can't do it. *)

        val writeArrNB' =
            case (writeArrNB, writeVecNB) of
                (s as SOME _, _) => s (* If writeArrNB exists use it. *)
            |   (NONE, SOME wv) =>
                (* if writeArrNB doesn't exists but writeVecNB does *)
                    SOME(
                    fn slice =>
                        let
                            (* Construct a vector from this slice. *)
                            val v = ArraySlice.vector slice;
                        in
                            (* Try writing the vector. *)
                            wv(VectorSlice.full v)
                        end
                    )
            |   (NONE, NONE) =>
                (* Try using the blocking writeArr' with canOutput.
                   We use the writeArr' we defined above so that this will
                   also try using writeVec. *)
                case (canOutput, writeArr') of
                    (SOME canOut, SOME wa) =>
                        SOME(
                        fn slice =>
                            if canOut() then SOME(wa slice) else NONE
                        )
                |   _ => NONE (* Can't do it. *)

        (* Finally define the blocking functions in terms of the non-blocking
           if we have to. *)
        val writeVec'' =
            case writeVec' of
                (* If writeVec' exists use it. i.e. if writeVec or writeArr were
                   defined. *)
                (s as SOME _) => s
            |   NONE =>
                (* No blocking version exists - try using block and the
                   synthesised non-blocking version. *)
                case (block, writeVecNB') of
                    (SOME blk, SOME wv) =>
                        SOME(
                        fn slice =>
                            (
                                blk();
                                case wv slice of
                                    NONE => (* Should not occur. *)
                                        raise IO.Io{
                                            name=name,
                                            function="writeVec",
                                            cause = IO.BlockingNotSupported }
                                |   SOME l => l
                            )
                        )
                |   _ => NONE (* Can't do it. *)

        val writeArr'' =
            case writeArr' of
                (* If writeArr' exists use it. *)
                (s as SOME _) => s
            |   NONE =>
                (* Try using block and the synthesised writeArrNB'. *)
                case (block, writeArrNB') of
                    (SOME blk, SOME wa) =>
                        SOME(
                            fn slice =>
                            (
                                blk();
                                case wa slice of
                                    NONE => 
                                        raise IO.Io{
                                            name=name,
                                            function="writeArr",
                                            cause = IO.BlockingNotSupported }
                                |   SOME l => l
                            )
                        )
                    |   _ => NONE (* Can't do it. *)
    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
    
    (* Null reader - always returns end-of-file except when closed when it raises IO.ClosedStream. *)
    fun nullRd () =
    let
        val isOpen = ref true
    in
        RD {
        name = "nullRd",
        chunkSize = 1,
        readVec = SOME(fn n => if n < 0 then raise Size else if !isOpen then Vector.fromList [] else raise IO.ClosedStream),
        readArr = SOME(fn _ => if !isOpen then 0 else raise IO.ClosedStream),
        readVecNB = SOME(fn n => if n < 0 then raise Size else if !isOpen then SOME(Vector.fromList []) else raise IO.ClosedStream),
        readArrNB = SOME(fn _ => if !isOpen then SOME 0 else raise IO.ClosedStream),
        block = SOME(fn () => if !isOpen then () else raise IO.ClosedStream),
        canInput = SOME(fn () => if !isOpen then true else raise IO.ClosedStream),
        avail = fn () => if !isOpen then NONE else raise IO.ClosedStream,
        getPos = NONE,
        setPos = NONE,
        endPos = NONE,
        verifyPos = NONE,
        close = fn () => isOpen := false,
        ioDesc = NONE
        }
    end

    (* Null writer - always swallows input except when closed when it raises IO.ClosedStream. *)
    fun nullWr () =
    let
        val isOpen = ref true
    in
        WR {
        name = "nullWr",
        chunkSize = 1,
        writeVec = SOME(fn slice => if !isOpen then VectorSlice.length slice else raise IO.ClosedStream),
        writeArr = SOME(fn slice => if !isOpen then ArraySlice.length slice else raise IO.ClosedStream),
        writeVecNB = SOME(fn slice => if !isOpen then SOME(VectorSlice.length slice) else raise IO.ClosedStream),
        writeArrNB = SOME(fn slice => if !isOpen then SOME(ArraySlice.length slice) else raise IO.ClosedStream),
        block = SOME(fn () => if !isOpen then () else raise IO.ClosedStream),
        canOutput = SOME(fn () => if !isOpen then true else raise IO.ClosedStream),
        getPos = NONE,
        setPos = NONE,
        endPos = NONE,
        verifyPos = NONE,
        close = fn () => isOpen := false,
        ioDesc = NONE
        }
    end
    
    fun openVector v =
    let
        val isOpen = ref true
        val len = Vector.length v
        val p = ref 0 (* Pointer to current element. *)

        (* Return a slice of the vector from the current position for either the rest of
           the vector or the size requested if that's smaller. *)
        fun getSlice n =
            if not (! isOpen) then raise IO.ClosedStream
            else
            let
                val toRead = Int.min(n, len - !p) (* Return the smaller of the size requested or the size left. *)
                val resSlice = VectorSlice.slice(v, !p, SOME toRead)
            in
                p := !p + toRead;
                resSlice
            end

        (* Return a slice of the vector. *)
        fun readVec n = if n < 0 then raise Size else VectorSlice.vector(getSlice n)

        (* Copy a portion of the vector into the array.  We can probably copy directly
           from the original vector whereas if we synthesised this function it would
           require an extra copy. *)
        fun readArr slice = 
            let
                val (base, di, len) = ArraySlice.base slice
                val resSlice = getSlice len
            in
                ArraySlice.copyVec{src=resSlice, dst=base, di=di};
                VectorSlice.length resSlice
            end
    in
        RD {
        name = "openVector",
        chunkSize = 1, (* Or the size of the vector? *)
        readVec = SOME readVec,
        readArr = SOME readArr,
        readVecNB = NONE,
        readArrNB = NONE,
        block = SOME(fn () => if !isOpen then () else raise IO.ClosedStream),
        canInput = SOME(fn () => if !isOpen then true else raise IO.ClosedStream),
        (* avail returns the number of bytes and since we don't know the size of "elem" we return NONE here *)
        avail = fn () => if !isOpen then NONE else raise IO.ClosedStream,
        getPos = NONE,
        setPos = NONE,
        endPos = NONE,
        verifyPos = NONE,
        close = fn () => isOpen := false,
        ioDesc = NONE
        }
    end

end;