Pure IO in OCaml via the Free monad

gistfile1.ml

(* Purely functional I/O in Ocaml via the Free monad.
 * by Ricky Elrod <relrod@haskell.org>.
 *
 * This is free and unencumbered software released into the public domain.
 *
 * Anyone is free to copy, modify, publish, use, compile, sell, or
 * distribute this software, either in source code form or as a compiled
 * binary, for any purpose, commercial or non-commercial, and by any
 * means.
 *
 * In jurisdictions that recognize copyright laws, the author or authors
 * of this software dedicate any and all copyright interest in the
 * software to the public domain. We make this dedication for the benefit
 * of the public at large and to the detriment of our heirs and
 * successors. We intend this dedication to be an overt act of
 * relinquishment in perpetuity of all present and future rights to this
 * software under copyright law.
 *
 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
 * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
 * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
 * IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR
 * OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
 * ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
 * OTHER DEALINGS IN THE SOFTWARE.
 *)
module type Functor = sig
    type 'a t
    val fmap : ('a -> 'b) -> 'a t -> 'b t
end

module type Monad = sig
    type 'a t
    val unit : 'a -> 'a t
    val bind : 'a t -> ('a -> 'b t) -> 'b t
end

(* NB: lowercase "functor" below has nothing to do with category theoretic
   functors. *)
module Free = functor (F : Functor) -> struct
  type 'a t =
      Pure of 'a
    | Free of ('a t) F.t

  let unit a = Pure a

  let rec bind x f =
    match x with
    | Pure x' -> f x'
    | Free x' -> Free (F.fmap (fun y -> bind y f) x')

  let fmap f x = bind x (fun y -> unit (f y))
end

module ConsoleIO = struct
  type 'a t =
      PutStr of (string * 'a)
    | ReadLine of (string -> 'a)

  let fmap f x =
    match x with
    | PutStr (s, k) -> PutStr (s, f k)
    | ReadLine k    -> ReadLine (fun s -> f (k s))
end

module IO = Free(ConsoleIO)

(* Compatibility interpreter *)
module UnsafeIO = struct
  let rec runIO x =
    match x with
    | IO.Pure y -> y
    | IO.Free y ->
       match y with
       | ConsoleIO.PutStr (s, k) ->
          print_string s;
          runIO k
       | ConsoleIO.ReadLine k ->
          runIO (k (read_line ()))
end

(* Globally scoped syntactic sugar over our API *)
let (>>=) x y  = IO.bind x y
let (>>) x y   = IO.bind x (fun _ -> y)
let putStr x   = IO.Free(ConsoleIO.PutStr (x, IO.Pure ()))
let putStrLn x = IO.Free(ConsoleIO.PutStr (x ^ "\n", IO.Pure ()))
let readLine   = IO.Free(ConsoleIO.ReadLine (fun s -> IO.Pure s))

let pureMain =
  putStr "Hi! Say, what is your name?: " >>
  readLine >>=
  fun n -> putStr "Nice to meet you, " >>
  putStrLn n

let main = UnsafeIO.runIO pureMain