Make Ocs_port use the type system better

ocs-1.0.3/src/ocs_port.ml

@@ -2,62 +2,58 @@
 
 open Ocs_error
 
-type port_impl =
+type port =
-  | Input_channel of in_channel
+  | Input_channel of in_channel * char option ref
   | Output_channel of out_channel
-  | Input_string of string * int ref
+  | Input_string of (string * int ref) * char option ref
   | Output_string of Buffer.t
 
-type port = {
-  ungot : char option ref;
-  impl : port_impl;
-}
-
 let is_input p =
-  match p.impl with
+  match p with
     | Input_string _
     | Input_channel _ -> true
     | _ -> false
 
 let is_output p =
-  match p.impl with
+  match p with
     | Output_string _
     | Output_channel _ -> true
     | _ -> false
 
 let getc p =
-  match (!(p.ungot), p.impl) with
+  match p with
-    | (Some c, _) ->
+    | Input_channel (_, ({contents = Some c} as ungot))
-        p.ungot := None;
+    | Input_string (_, ({contents = Some c} as ungot)) ->
+        ungot := None;
         Some c
-    | (None, Input_string (str, pos)) ->
+    | Input_channel (chan, {contents = None}) ->
-        if !pos >= (String.length str) then
-          None
-        else
-          let c = str.[!pos] in
-            pos := !pos + 1;
-            Some c
-    | (None, Input_channel chan) ->
         begin
           try
             Some (input_char chan)
           with End_of_file ->
             None
         end
+    | Input_string ((str, pos), {contents = None}) ->
+        if !pos >= (String.length str) then
+          None
+        else
+          let c = str.[!pos] in
+            pos := !pos + 1;
+            Some c
     | _ ->
         None
 
 let flush p =
-  match p.impl with
+  match p with
     | Output_channel chan ->
         Pervasives.flush chan
     | _ ->
         ()
 
 let close p =
-  p.ungot := None;
+  match p with
-  match p.impl with
+    | Input_channel (chan, ungot) ->
-    | Input_channel chan ->
+        ungot := None;
         close_in chan
     | Output_channel chan ->
         close_out chan
@@ -65,16 +61,21 @@ let close p =
         ()
 
 let ungetc p c =
-  p.ungot := Some c
+  match p with
+    | Input_channel (_, ungot)
+    | Input_string (_, ungot) ->
+        ungot := Some c
+    | _ ->
+        ()
 
 let char_ready p =
-  match (!(p.ungot), p.impl) with
+  match p with
-    | (Some _, Input_string _)
+    | Input_string (_, {contents = Some _})
-    | (Some _, Input_channel _) ->
+    | Input_channel (_, {contents = Some _}) ->
         true
-    | (None, Input_string (str, pos)) ->
+    | Input_string ((str, pos), {contents = None}) ->
         !pos < (String.length str)
-    | (None, Input_channel chan) ->
+    | Input_channel (chan, {contents = None}) ->
         let fd = Unix.descr_of_in_channel chan in
         let (r, _, _) = Unix.select [fd] [] [] 0.0 in
           List.length r > 0
@@ -82,7 +83,7 @@ let char_ready p =
         false
 
 let putc p c =
-  match p.impl with
+  match p with
     | Output_string buf ->
         Buffer.add_char buf c
     | Output_channel chan ->
@@ -91,7 +92,7 @@ let putc p c =
         ()
 
 let puts p s =
-  match p.impl with
+  match p with
     | Output_string buf ->
         Buffer.add_string buf s
     | Output_channel chan ->
@@ -99,11 +100,9 @@ let puts p s =
     | _ ->
         ()
 
-let input_port ch =
+let input_port ch = Input_channel (ch, ref None)
-  { ungot = ref None; impl = Input_channel ch }
 
-let output_port ch =
+let output_port ch = Output_channel ch
-  { ungot = ref None; impl = Output_channel ch }
 
 let open_input_port name =
   try
@@ -117,14 +116,12 @@ let open_output_port name =
   with Sys_error err ->
     raise (Error ("unable to open '" ^ name ^ "' for output: " ^ err))
 
-let open_input_string s =
+let open_input_string s = Input_string ((s, ref 0), ref None)
-  { ungot = ref None; impl = Input_string (s, ref 0) }
 
-let open_output_string () =
+let open_output_string () =Output_string (Buffer.create 256)
-  { ungot = ref None; impl = Output_string (Buffer.create 256) }
 
 let get_output_string p =
-  match p.impl with
+  match p with
     | Output_string buf ->
         Buffer.contents buf
     | _ ->