IO Monad implemented in SML using Structures

io.sml

signature MONAD = sig
    type 'a m;
    val return : 'a -> 'a m;
    val bind : 'a m -> ('a -> 'b m) -> 'b m;
end;

signature IO_MONAD = sig
    include MONAD;
    val exec : 'a m -> 'a;
    val getStr : int -> TextIO.vector m;
    val putStr : string -> unit m;
end;

(* Mock approximations of "State# RealWorld". *)
type 'a State' = unit;
type RealWorld = unit;

structure IO :> IO_MONAD = struct
    datatype 'a m    = IO of RealWorld State' -> RealWorld State' * 'a;

    (* exec : 'a IO.m -> 'a *)
    fun exec (IO f)  = let val (_, a) = f () in a end;

    (* return : 'a -> 'a IO.m *)
    fun return x     = IO (fn s => (s, x))
                        
    (* (>>=) : 'a IO.m * ('a -> 'b IO.m) -> 'b IO.m *)
    local fun unIO (IO a) = a
    in fun bind (IO m : 'a m) (k : 'a -> 'b m)
           = IO (fn s => case m s of
                             (new_s, a) => (unIO (k a)) new_s)
    end
    
    (* getStr : int -> TextIO.vector IO.m *)
    fun getStr n     = IO (fn s => (s, TextIO.inputN(TextIO.stdIn, n)))

    (* putStr : string -> unit IO.m *)
    fun putStr str   = IO (fn s => (s, print str))
end;

infix 1 >>=
fun a >>= b = IO.bind a b;

infix 1 >>
fun a >> b = IO.bind a (fn _ => b);

fun gettingLine s : string IO.m =
    (IO.getStr 1) >>= (fn c => if c = "\n"
                                then IO.return s
                                else gettingLine (s^c));

(* getLine : string IO.m *)
val getLine = gettingLine "";

val main : unit IO.m
  = IO.putStr "First name: " >> getLine >>= (fn first =>
    IO.putStr "Second name: " >> getLine >>= (fn second =>
    IO.putStr ("Hello "^first^" "^second^"\n")));

(* IO.exec main; *)