Commits

camlspotter committed 27e3f1b

reimplementation of the base stream. ongoing

Comments (0)

Files changed (18)

   | Null
 
 let null = lazy_from_val Null
-let null_desc = Null
-let cons_desc v t = Cons (v, t)
 
 let desc = force
 let peek = function
 
 (** Constructor functions *)
 val null : 'a zlist
-val null_desc : 'a desc
-val cons_desc : 'a -> 'a zlist -> 'a desc
 
 (** Destructors *)
 val desc : 'a zlist -> 'a desc
     Profile.incr ();
     match Str.peek s with
     | None -> Error (Str.position s, "unexpected end of stream")
-    | Some (elem, _pos, s') -> Ok (elem, s')
+    | Some (elem, s') -> Ok (elem, s')
 
   let take_ : unit t = fun s -> 
     Profile.incr ();
     match Str.peek s with
     | None -> Error (Str.position s, "unexpected end of stream")
-    | Some (_, _, s') -> Ok ((),s')
+    | Some (_, s') -> Ok ((),s')
 
   let position : Str.Pos.t t = fun st -> Profile.incr (); Ok (Str.position st, st)
 
       | [] -> return () str
       | x::xs -> 
           match Str.peek str with
-          | Some (c,_,str') when Str.Elem.equal c x -> aux str' xs
+          | Some (c, str') when Str.Elem.equal c x -> aux str' xs
           | _ -> error (Printf.sprintf "expected %s" (Str.Elem.show x)) str
     in
     aux str elems
 
   let take : Str.Elem.t t = fun s -> match Str.peek s with
     | None -> throw (Str.position s, "unexpected end of stream")
-    | Some (elem, _pos, s') -> ok (elem, s')
+    | Some (elem, s') -> ok (elem, s')
 
   let take_ : unit t = fun s -> match Str.peek s with
     | None -> throw (Str.position s, "unexpected end of stream")
-    | Some (_, _, s') -> ok ((),s')
+    | Some (_, s') -> ok ((),s')
 
   let position : Str.Pos.t t = fun st -> ok (Str.position st, st)
 
       | [] -> return () str
       | x::xs -> 
           match Str.peek str with
-          | Some (c,_,str') when c = x -> aux str' xs
+          | Some (c, str') when c = x -> aux str' xs
           | _ -> error (Printf.sprintf "expected %s" (Str.Elem.show x)) str
     in
     aux str elems
 
   let take : Str.Elem.t t =  fun () -> match Str.peek !global_stream with
     | None -> throw (Str.position !global_stream, "unexpected end of stream")
-    | Some (elem, _pos, s') -> 
+    | Some (elem, s') -> 
         set s';
         ok elem
 
   let take_ : unit t = fun () -> match Str.peek !global_stream with
     | None -> throw (Str.position !global_stream, "unexpected end of stream")
-    | Some (_, _, s') -> 
+    | Some (_, s') -> 
         set s';
         ok ()
 
       | [] -> return ()
       | x::xs -> 
           match Str.peek !global_stream with
-          | Some (c,_,str') when c = x -> 
+          | Some (c, str') when c = x -> 
               set str';
               aux xs
           | _ -> error (Printf.sprintf "expected %s" (Str.Elem.show x))
   val takeWhile : (char -> bool) -> t -> string * t
   val bytes : t -> int
 end)(Base : Planck_intf.S
-     with type Str.Elem.t = Sbuffer.Elem.t
-     and  type Str.Attr.t = Sbuffer.Attr.t
-     and  type Str.Pos.t  = Sbuffer.Pos.t
+     with type Str.Elem.t = char
+     and  type Str.Pos.t  = Position.File.t
+     and  type Str.desc = Sbuffer.desc
     ) = struct
 
   open Base
   val takeWhile : (char -> bool) -> t -> string * t
   val bytes : t -> int
 end)(Base : Planck_intf.S 
-     with type Str.Elem.t = Sbuffer.Elem.t
-     and  type Str.Attr.t = Sbuffer.Attr.t
-     and  type Str.Pos.t  = Sbuffer.Pos.t) : sig
+     with type Str.Elem.t = char
+     and  type Str.Pos.t  = Position.File.t
+     and  type Str.desc   = Sbuffer.desc) : sig
 
   (* CR jfuruse: we cannot write Base : Planck_intf.S with module Str = Sbuffer ! *)
 
 (* Interface for generic char stream. Not optimized. *)
 module Extend(Str : Stream_intf.S with type Elem.t = char) (Base : Planck_intf.S 
       with type Str.Elem.t = Str.Elem.t
-      and  type Str.Attr.t = Str.Attr.t
       and  type Str.Pos.t = Str.Pos.t)  = struct
 
   open Base
 module Extend(Str : Stream_intf.S with type Elem.t = char)
              (Base : Planck_intf.S 
               with type Str.Elem.t = Str.Elem.t
-              and  type Str.Attr.t = Str.Attr.t
               and  type Str.Pos.t  = Str.Pos.t) :
 sig
   val string : string -> unit Base.t
   val memoize : key -> (t -> 'a) -> t -> 'a
 end )(Base : Planck_intf.S 
       with type Str.Elem.t = Str.Elem.t
-      and  type Str.Attr.t = Str.Attr.t
       and  type Str.Pos.t  = Str.Pos.t) = struct
 
   let memoize = Str.memoize
   val memoize : key -> (t -> 'a) -> t -> 'a
 end )(Base : Planck_intf.S 
       with type Str.Elem.t = Str.Elem.t
-      and  type Str.Attr.t = Str.Attr.t
       and  type Str.Pos.t  = Str.Pos.t) : sig 
   val memoize : Str.key -> (Str.t -> 'a) -> Str.t -> 'a 
 end
   let take_ : unit t = fun s stat -> 
     match Str.peek s with
     | None -> Error (Str.position s, "unexpected end of stream")
-    | Some (_, _, s') -> Ok ((), s', stat)
+    | Some (_, s') -> Ok ((), s', stat)
 
   let position : Str.Pos.t t = fun st stat -> Ok (Str.position st, st, stat)
 
       | [] -> return () str
       | x::xs -> 
           match Str.peek str with
-          | Some (c,_,str') when Str.Elem.equal c x -> aux str' xs
+          | Some (c, str') when Str.Elem.equal c x -> aux str' xs
           | _ -> error (Printf.sprintf "expected %s" (Str.Elem.show x)) str
     in
     aux str elems
 
 module Extend(Base : sig
   include S
-  with type Elem.t = char * Position.File.t
+  with type Elem.t = char
   and  type Pos.t  = Position.File.t
   val buf : t -> buf
+  val create_attr : buf -> Attr.t
 end) = struct
 
   open Base
 
   let rec create : buf -> t = fun i ->
     match Sstring.peek i.base with
-    | None -> null
+    | None -> null (create_attr i)
     | Some (elem, buf') ->
         if i.rel_pos >= String.length elem then begin
           (* If the position is out of the head *)
     let rec substr stream stream_pos (* abs position of head of buf *) pos len =
       match Sstring.peek stream with
       | None -> failwith "Sbuffer.substr: end of stream"
-      | Some (string, _, stream') ->
+      | Some (string, stream') ->
           (*
           Format.eprintf "substr.substr %d %d %d %s@." stream_pos pos len 
             (try String.sub string 0 40 with _ -> string);
       in
       match Sstring.peek stream with
       | None -> finish rel_pos
-      | Some (string, _, stream') ->
+      | Some (string, stream') ->
           let len_string = String.length string in
           let rec iter_internal = function
             | n when len_string = n -> 
 
 module Extend(Base : sig
   include S
-  with type Elem.t = (char * Position.File.t)
+  with type Elem.t = char
   and  type Pos.t  = Position.File.t
   (** Sbuffer is based on a stream whose element is [char].
       [attr] is implementation dependent.
 
 include Stream.Make(struct
   module Pos = Position.None
+  module Attr = struct
+    type t = Pos.t
+    let pos x = x
+    let default = Pos.none
+  end
   module Elem = struct
     type t = string
     let show = Printf.sprintf "%S"
   end
 end)
 
-let from_string str = Lazy.lazy_from_val (cons_desc str null)
+let default_null_desc = null_desc Attr.default
+let default_null = null Attr.default
+
+let from_string str = Lazy.lazy_from_val (cons_desc str Attr.default default_null)
 
 let from_chan ic =
   let len = 1024 in
   let rec read () = lazy begin
     let buf = String.create len in
     let read_bytes = input ic buf 0 len in
-    if read_bytes = 0 then null_desc
+    if read_bytes = 0 then default_null_desc
     else
       let str = String.sub buf 0 read_bytes in
-      cons_desc str (read ())
+      cons_desc str Attr.default (read ())
   end
   in
   read ()
   with type Elem.t = string
   and  type Pos.t  = unit
 
+val default_null : t
+
 val from_string : string -> t
 
 val from_chan : in_channel -> t
   open Lazylist
   include P
 
-  type desc = (Elem.t option * Pos.t)
-  type t = desc zlist (* None means EOS *)
+  type desc = (Elem.t option * Attr.t) Lazylist.desc
+  type t = (Elem.t option * Attr.t) zlist (* None means EOS *)
 
-  let null_desc pos = cons_desc (None, pos) Lazylist.null
-  let null pos = Lazy.lazy_from_val (null_desc pos)
-  let cons_desc e pos = cons_desc (Some e,pos)
+  let cons_desc e attr v = Lazylist.Cons ((Some e,attr), v)
+  let null_desc attr = Lazylist.Cons ((None, attr), Lazylist.null)
+  let null attr = Lazy.lazy_from_val (null_desc attr)
+
+  let default_null = null Attr.default
 
   let desc = desc
   let peek = function
 
   let is_null = is_null
     
-  let to_list = to_list
+  let to_list t = 
+    let rec to_list st = function
+      | lazy Cons ((Some elem, _), t) -> to_list (elem :: st) t
+      | _ -> List.rev st
+    in
+    to_list [] t
 
-  let iter = iter
-  let fold_right = fold_right
-  let map = map
+  let rec iter f = function
+    | lazy Cons ((Some elem, _), t) -> f elem; iter f t
+    | _ -> ()
 
-  let rev_between = rev_between
-  let between = between
+  let rec fold_right f lst st = match lst with
+    | lazy Cons ((Some v, _), lst') -> f v (fold_right f lst' st)
+    | _ -> st
 
-  let position = function
-    | lazy Cons ((_, pos), _) -> pos
+  let rec map f lst = lazy (match lst with
+    | lazy Cons ((Some v, _pos), lst') -> Cons (f v, map f lst')
+    | _ -> Null)
+
+  (* [t2] must be a postfix of [t1] otherwise, it loops forever *)
+  let rev_between t1 t2 =
+    let rec loop st t =
+      if t == t2 then st (* CR jfuruse: we cannot always use pointer eq *)
+      else 
+        match t with
+        | lazy Cons ((Some elem, _), t') -> loop (elem::st) t'
+        | _ -> st
+    in
+    loop [] t1
+
+  let between t1 t2 = List.rev (rev_between t1 t2)
+
+  let attr = function
+    | lazy Cons ((_, attr), _) -> attr
     | _ -> assert false
 
+  let position s = Attr.pos (attr s)
+
 end

lib/stream_intf.ml

 module type Base = sig
 
   module Pos : Position.S
+
+  module Attr : sig
+    type t
+    val default : t
+    val pos : t -> Pos.t
+  end 
   (** Module for stream positions *)
 
   module Elem : sig
   include Base
 
   type desc
-  type t = desc zlist
+  type t = desc Lazy.t
 
-  val null : Pos.t -> t
+  val null : Attr.t -> t
   (** Create a null stream *)
 
-  val null_desc : Pos.t -> desc
-  val cons_desc : Elem.t -> Pos.t -> t -> desc
+  val default_null : t
+  (** The default null with the default position. The position may be just a meaningless value. *)
+
+  val null_desc : Attr.t -> desc
+  val cons_desc : Elem.t -> Attr.t -> t -> desc
   (** Create a null/cons cell desc. *)
 
   (** Destructors *)
   val is_null : t -> bool
   (** Null check *)
 
+  val attr : t -> Attr.t
   val position : t -> Pos.t
   (** Position of the head element/null *)