Commits

Anonymous committed 95af527

Added monadic IO stub.

  • Participants
  • Parent commits 000babd

Comments (0)

Files changed (1)

 
 open Types
 
+
+module Funlist : sig
+
+(* The funlist datatype *)
+type ('a, 'b) t
+
+(* Constructors *)
+val nil : ('a, 'a) t
+val cons : ('a -> 'b) -> ('b, 'c) t -> ('a, 'c) t
+
+(* Applying a value to a composition *)
+val apply : ('a, 'b) t -> 'a -> 'b
+
+val append : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t
+
+end = struct
+(* List of composable functions.
+
+    The intended type expressed by the four types below is :
+    type ('a, 'b) t = Nil of ('a -> 'b)
+                    | Cons of exists 'c. ('a -> 'c) * ('c, 'b) t
+*)
+type ('a, 'b) t =
+    | Nil of ('a -> 'b)
+    | Cons of ('a, 'b) packed_list
+
+and ('a, 'b, 'z) list_scope =
+    { bind_list : 'c. ('a -> 'c) * ('c, 'b) t -> 'z}
+
+and ('a, 'b) packed_list =
+    { open_list : 'z. ('a, 'b, 'z) list_scope -> 'z }
+
+(* Packing and unpacking lists *)
+let pack_list h t = { open_list = fun scope -> scope.bind_list (h,t) }
+let with_packed_list p e = p.open_list e
+
+(* Constructors *)
+let nil = Nil(fun x -> x)
+let cons h t = Cons(pack_list h t)
+
+(* Type to handle the polymorphic recursion of the apply function *)
+type poly_rec = { apply : 'a 'b. poly_rec -> ('a, 'b) t -> 'a -> 'b }
+let apply' r l x = match l with
+| Nil id -> id x
+| Cons l ->
+     with_packed_list l { bind_list = function h,t -> r.apply r t (h x) }
+
+let poly_rec = { apply = apply' }
+let apply l x = apply' poly_rec l x
+
+let rec append x y =
+    match x with
+    | Nil id -> invalid_arg "append"
+    | Cons l -> invalid_arg "append"
+
+end
+
+
 module NetworkIO : sig
     type t
     val new_from    : Unix.file_descr -> t
     val read_line   : t -> string
     val send_string : t -> string -> unit
+
+    type 'a io
+    val m_put_string : string -> unit io
+    val m_read_line : string io
+
+    val bind : 'a io -> ('a -> 'b io) -> 'b io
+    val return : 'a -> 'a io
+
+    val io_exec : 'a io -> 'a
 end = struct
     type t = Unix.file_descr
 
 
     let send_string fd s =
         ignore (Unix.send fd s 0 (String.length s) [])
+
+    (** Monadic interface *)
+
+    type 'a io = unit
+
+    let return _ = ()
+    let bind _ _ = ()
+    let io_exec _ = invalid_arg "io_exec"
+
+    let m_put_string _ = ()
+    let m_read_line = ()
+
 end
 
-
 type options =
     { user_control         : bool
     ; complete_information : bool