Commits

camlspotter committed 6d91a15

independent profile + a new planck with state

  • Participants
  • Parent commits 06faf02

Comments (0)

Files changed (8)

    smemo
    sbuffer
    planck_intf
+   profile
    pbase
    pbaseexn
    pbaseref
+   pstate
    pchar
    pbuffer
    pmemo
+   pstate
    op_prec
 
 LIB = planck
   type error = Str.Pos.t * string
   exception Critical_error of error
 
-  module Profile = struct
-    let all_total = ref 0
-    let all_wasted = ref 0
-    let total = ref 0
-    let wasted = ref 0
-    let top_ref = ref (ref 0)
-    let stack = ref [!top_ref]
-    let start () = 
-      top_ref := ref 0;
-      stack := !top_ref :: !stack
-    let stop () = 
-      match !stack with
-      | r::r'::rs -> 
-          top_ref := r';
-          stack := (r'::rs); 
-          !r
-      | _ -> assert false
-    let incr () =
-      incr total;
-      incr !top_ref
-
-    let add n =
-      !top_ref := !(!top_ref) + n
-
-    let format ppf = 
-      Format.fprintf ppf "Bind total %d, wasted %d, ratio %f"
-        !total !wasted (float !wasted /. float !total)
-
-    let reset () =
-      all_total := !all_total + !total;
-      all_wasted := !all_wasted + !wasted;
-      top_ref := ref 0;
-      total := 0;
-      wasted := 0;
-      stack := [!top_ref]
-
-    let recover_all () =
-      reset ();
-      total := !all_total;
-      wasted := !all_wasted
-  end
-
-  type 'a t = Str.t -> ('a * Str.t, Str.Pos.t * string) Result.t
+  type 'a t = Str.t -> ('a * Str.t, error) Result.t
+  type 'a _t = 'a t
 
   include Monad.Make(struct 
 
-    type 'a t = Str.t -> ('a * Str.t, error) Result.t
+    type 'a t = 'a _t
   
     let return v = fun st -> Ok (v, st)
   
   exception Critical_error of error
   exception Exn of error
 
-  module Profile = struct
-    let all_total = ref 0
-    let all_wasted = ref 0
-    let total = ref 0
-    let wasted = ref 0
-    let top_ref = ref (ref 0)
-    let stack = ref [!top_ref]
-    let start () = 
-      top_ref := ref 0;
-      stack := !top_ref :: !stack
-    let stop () = 
-      match !stack with
-      | r::r'::rs -> 
-          top_ref := r';
-          stack := (r'::rs); 
-          !r
-      | _ -> assert false
-        
-    let incr () =
-      incr total;
-      incr !top_ref
-
-    let add n =
-      !top_ref := !(!top_ref) + n
-
-    let format ppf = 
-      Format.fprintf ppf "Bind total %d, wasted %d, ratio %f"
-        !total !wasted (float !wasted /. float !total)
-
-    let reset () =
-      all_total := !all_total + !total;
-      all_wasted := !all_wasted + !wasted;
-      top_ref := ref 0;
-      total := 0;
-      wasted := 0;
-      stack := [!top_ref]
-
-    let recover_all () =
-      reset ();
-      total := !all_total;
-      wasted := !all_wasted
-  end
-
   include Monad.Make(struct 
 
     type 'a t = Str.t -> 'a * Str.t
   exception Critical_error of error
   exception Exn of error
 
-  module Profile = struct
-    let all_total = ref 0
-    let all_wasted = ref 0
-    let total = ref 0
-    let wasted = ref 0
-    let top_ref = ref (ref 0)
-    let stack = ref [!top_ref]
-    let start () = 
-      top_ref := ref 0;
-      stack := !top_ref :: !stack
-    let stop () = 
-      match !stack with
-      | r::r'::rs -> 
-          top_ref := r';
-          stack := (r'::rs); 
-          !r
-      | _ -> assert false
-        
-    let incr () =
-      incr total;
-      incr !top_ref
-
-    let add n =
-      !top_ref := !(!top_ref) + n
-
-    let format ppf = 
-      Format.fprintf ppf "Bind total %d, wasted %d, ratio %f"
-        !total !wasted (float !wasted /. float !total)
-
-    let reset () =
-      all_total := !all_total + !total;
-      all_wasted := !all_wasted + !wasted;
-      top_ref := ref 0;
-      total := 0;
-      wasted := 0;
-      stack := [!top_ref]
-
-    let recover_all () =
-      reset ();
-      total := !all_total;
-      wasted := !all_wasted
-  end
-
   include Monad.Make(struct 
 
     type 'a t = unit -> 'a

lib/planck_intf.ml

 
 open Spotlib.Spot
 
+(** Profiling purpose to count closure constructions. *)
+module type Profile = sig
+  val incr : unit -> unit
+  val format : Format.t -> unit
+  val reset : unit -> unit
+  val recover_all : unit -> unit (* format will print the over all result *)
+end
+
 module type S = sig
   module Str : Stream_intf.S
   (** Underlied stream *)
   exception Critical_error of error
   (** Exception of critical error. Used for non recoverable errors. *)
 
-  (** Profiling purpose to count closure constructions. *)
-  module Profile : sig
-    val incr : unit -> unit
-    val format : Format.t -> unit
-    val reset : unit -> unit
-    val recover_all : unit -> unit (* format will print the over all result *)
-  end
-
   include Monad_intf.T
   (** Inherit monadic interface. ['a t] is a function, so \eta expandable *)
 
 
   val run : 'a t -> Str.t -> ('a * Str.t, error) Result.t
   (** Run the monad over the stream *)
-
+  (* CR jfuruse: run should be out of S ? *)
 end
+let all_total = ref 0
+let all_wasted = ref 0
+let total = ref 0
+let wasted = ref 0
+let top_ref = ref (ref 0)
+let stack = ref [!top_ref]
+let start () = 
+  top_ref := ref 0;
+  stack := !top_ref :: !stack
+let stop () = 
+  match !stack with
+  | r::r'::rs -> 
+      top_ref := r';
+      stack := (r'::rs); 
+      !r
+  | _ -> assert false
+let incr () =
+  incr total;
+  incr !top_ref
+
+let add n =
+  !top_ref := !(!top_ref) + n
+
+let format ppf = 
+  Format.fprintf ppf "Bind total %d, wasted %d, ratio %f"
+    !total !wasted (float !wasted /. float !total)
+
+let reset () =
+  all_total := !all_total + !total;
+  all_wasted := !all_wasted + !wasted;
+  top_ref := ref 0;
+  total := 0;
+  wasted := 0;
+  stack := [!top_ref]
+
+let recover_all () =
+  reset ();
+  total := !all_total;
+  wasted := !all_wasted
+
+
+val incr : unit -> unit
+val format : Format.t -> unit
+val reset : unit -> unit
+val recover_all : unit -> unit (* format will print the over all result *)
+open Spotlib.Spot
+open Result
+
+module Make(Str : Stream_intf.S)(State : sig type t end) : sig
+  include Planck_intf.S
+  val get : State.t t
+  val put : State.t -> unit t
+  (** do not use [run]. *)
+  val run_with_state : 'a t -> Str.t -> State.t -> ('a * Str.t * State.t, Str.Pos.t * string) Result.t
+end = struct
+  module Str = Str
+  module State = State
+
+  type error = Str.Pos.t * string
+  exception Critical_error of error
+
+  type 'a t = Str.t -> State.t -> ('a * Str.t * State.t, Str.Pos.t * string) Result.t
+  type 'a _t = 'a t
+
+  include Monad.Make(struct 
+
+    type 'a t = 'a _t
+  
+    let return v = fun st stat -> Ok (v, st, stat)
+  
+    let bind t f = fun st stat ->
+      match t st stat with
+      | Ok (r, st', stat') -> f r st' stat'
+      | Error s -> Error s
+  end)
+
+  open Open
+
+  let take : Str.Elem.t t = fun s stat -> 
+    match Str.peek s with
+    | None -> Error (Str.position s, "unexpected end of stream")
+    | Some (elem, _pos, s') -> Ok (elem, s', stat)
+
+  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)
+
+  let position : Str.Pos.t t = fun st stat -> Ok (Str.position st, st, stat)
+
+  let error s : 'a t = fun st _stat -> Error (Str.position st, s)
+  let throw err = fun _st _stat -> Error err
+
+  let critical_error pos s = raise (Critical_error (pos, s))
+
+  let stream : Str.t t = fun st stat -> Ok (st, st, stat)
+
+  let eos : unit t = fun s stat -> 
+    match Str.peek s with
+    | Some _ -> Error (Str.position s, "end of stream expected")
+    | None -> Ok ((), s, stat)
+
+  let (<?>) : 'a t -> string -> 'a t = fun c mes st stat ->
+    let res = c st stat in
+    match res with
+    | Ok _ -> res
+    | Error (pos, _) -> Error (pos, "expected " ^ mes)
+
+  let (<?!>) : 'a t -> string -> 'a t = fun c mes st stat ->
+    let res = c st stat in
+    match res with
+    | Ok _ -> res
+    | Error (pos, _) -> Error (pos, mes)
+
+  let (<?@>) : 'a t -> Str.Pos.t -> 'a t = fun c pos st stat ->
+    let res = c st stat in
+    match res with
+    | Ok _ -> res
+    | Error (_, mes) -> Error (pos, mes)
+
+  (* [take] advances the stream. If we use [take] and some predicate to check the result,
+     the error position must be fixed as the one at the use of [take]. *)
+
+  let tokenp : (Str.Elem.t -> bool) -> Str.Elem.t t = fun p ->
+    position >>= fun pos ->
+    take >>= fun elem -> if p elem then return elem else error "tokenp" <?@> pos
+
+  let token_option : (Str.Elem.t -> 'a option) -> 'a t = fun p ->
+    position >>= fun pos ->
+    take >>= fun elem -> 
+    match p elem with
+    | Some v -> return v
+    | None -> error "tokenop" <?@> pos
+
+  let token_result : (Str.Elem.t -> ('a, string) Result.t) -> 'a t = fun p ->
+    position >>= fun pos ->
+    take >>= fun elem ->
+    match p elem with
+    | Ok v -> return v
+    | Error err -> error err <?@> pos
+
+  let token : Str.Elem.t -> unit t = fun tkn ->
+    void (tokenp (fun x -> Str.Elem.equal tkn x)) <?>  Str.Elem.show tkn
+
+  (* CR jfuruss: optimization oppotunity for char *)     
+  let one_of : Str.Elem.t list -> Str.Elem.t t = fun tkns ->
+    tokenp (fun x -> List.exists (Str.Elem.equal x) tkns)
+    <?> Printf.sprintf "expected one of %s"
+         (String.concat " " (List.map Str.Elem.show tkns))
+
+  let tokens : Str.Elem.t list -> unit t = fun elems str ->
+    let rec aux str = function
+      | [] -> return () str
+      | x::xs -> 
+          match Str.peek str with
+          | 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 option : 'a t -> 'a option t = fun com s stat ->
+    match com s stat with
+    | Error _ -> Ok (None, s, stat)
+    | Ok (v, s', stat') -> Ok (Some v, s', stat')
+
+  let option_ : unit t -> unit t = fun com s stat ->
+    match com s stat with
+    | Error _ -> Ok ((), s, stat)
+    | (Ok _ as v) -> v
+
+  let result : 'a t -> ('a, error) Result.t t = fun c st stat ->
+    match c st stat with
+    | Ok (res, st, stat) -> Ok (Ok res, st, stat)
+    | Error e -> Ok (Error e, st, stat)
+
+  let try_finally : 'a t -> (('a, error) Result.t -> unit) -> 'a t = fun c f -> 
+    result c >>= fun res ->
+    f res;
+    match res with
+    | Ok v -> return v
+    | Error err -> fun _st _stat -> Error err
+
+  let ( ?** ) : 'a t -> 'a list t = fun com ->
+    let rec aux st = fun s stat ->
+      match com s stat with
+      | Error _ -> Ok (List.rev st, s, stat)
+      | Ok (v, s', stat') -> aux (v :: st) s' stat'
+    in
+    aux []
+  
+  let ( ?* ) : 'a t -> unit t = fun com ->
+    let rec aux = fun s stat ->
+      match com s stat with
+      | Error _ -> Ok ((), s, stat)
+      | Ok (_v, s', stat') -> aux  s' stat'
+    in
+    aux
+  
+  let (?++) : 'a t -> 'a list t = fun com ->
+    com >>= fun v -> 
+    ?** com >>= fun vs -> 
+    return (v :: vs)
+  
+  let (?+) : 'a t -> unit t = fun com ->
+    com >>= fun _v -> 
+    ?* com >>= fun () -> 
+    return ()
+
+  let list_with_sep ?(optional_head=false) ~sep t = 
+    (if optional_head then option_ sep else return ()) >>= fun () ->
+    t >>= fun v -> 
+    ?** (sep >>= fun () -> t) >>= fun vs ->
+    return (v :: vs)
+
+  let surrounded left right content =
+    left >>= fun _ ->
+    content >>= fun res ->
+    right >>= fun _ ->
+    return res
+  
+  let critical : 'a t -> 'a t = fun t st stat ->
+    match t st stat with
+    | (Ok _ as res) -> res
+    | Error (pos, s) -> raise (Critical_error (pos, s))
+
+  let (<|>) : 'a t -> 'a t -> 'a t = fun c1 c2 st stat -> 
+    let pos0 = Str.position st in
+    let res = c1 st stat in
+    match res with
+    | Ok _ -> res
+    | Error (pos, _) -> if pos = pos0 then c2 st stat else res
+
+  (* CR jfuruse: _ is used in a different meaning than option_ *)
+  let try_ : 'a t -> 'a t = fun c st stat ->
+    let pos0 = Str.position st in
+    let res = c st stat in
+    match res with
+    | Ok _ -> res
+    | Error (_, err) -> Error (pos0, err)
+
+  let (<!>) : 'a t -> 'a t -> 'a t = fun c1 c2 st stat -> 
+    match c1 st stat with
+    | (Ok _ as res) -> 
+        res
+    | Error (_pos', _) -> 
+        c2 st stat
+
+  let (<!<) : 'a t -> 'a t -> 'a t = fun c1 c2 st stat ->
+    let res1 = c1 st stat in
+    match res1 with
+    | Ok _ -> 
+        res1
+    | Error (_pos', _) ->
+        let res2 = c2 st stat in
+        match res2 with
+        | Ok _ -> 
+            res2
+        | Error (_pos'', _) -> 
+            res1
+
+  let eos_as_none : 'a t -> 'a option t = fun t ->
+    (eos >>= fun _ -> return None)
+    <|> (t >>= fun x -> return (Some x))
+
+  (* Used for push back *)          
+  let (<&>) : 'a t -> ('a -> 'b t) -> 'b t = fun c1 c2 -> 
+    fun st stat ->
+      match c1 st stat with
+      | Ok (v, _, stat') -> c2 v st stat'
+      | (Error _ as res) -> res
+
+
+  let rec (/**/) : 'a list t -> 'a list t -> 'a list t = fun c1 c2 ->
+    (c1 >>= fun x -> (/**/) c1 c2 >>= fun y -> return (x @ y)) <!> c2
+        
+  let rec ( /*/ ) : unit t -> unit t -> unit t = fun c1 c2 ->
+    (c1 >>= fun () -> (/*/) c1 c2) <!> c2
+        
+  let (/++/) : 'a list t -> 'a list t -> 'a list t = fun c1 c2 ->
+    c1 >>= fun x -> (/**/) c1  c2 >>= fun y -> return (x @ y)
+
+  let (/+/) : unit t -> unit t -> unit t = fun c1 c2 ->
+    c1 >>= fun () -> (/*/) c1  c2 
+
+  let (/?/) : 'a list t -> 'a list t -> 'a list t = fun c1 c2 ->
+    (c1 >>= fun x -> c2 >>= fun y -> return (x @ y)) <!> c2
+
+  let begin_with c1 c2 =
+    option c1 >>= function
+      | None -> return None
+      | Some _ -> c2 >>= fun v -> return (Some v)
+
+  let set_stream new_st = fun _st state -> Ok ((), new_st, state)
+
+  let run _t = failwith "use run_with_state"
+  let run_with_state : 'a t -> Str.t -> State.t -> ('a * Str.t * State.t, error) Result.t = 
+    fun t st stat -> t st stat
+
+  (** state manipulation *)
+
+  let get : State.t t = fun t st -> Ok (st, t, st)
+  let put : State.t -> unit t = fun st -> fun t _ -> Ok ((), t, st)
+end