Commits

camlspotter committed bbef01e

tried pbasetpl, but no difference...

  • Participants
  • Parent commits 6b19dd8

Comments (0)

Files changed (4)

    pbase
    pbaseexn
    pbaseref
+   pbasetpl
    pchar
    pbuffer
    pmemo
 open Planck
 
 let rec parse_and_print stream = 
-  match (Input.Parser.eos_as_none Lex.ocaml_token) stream with
+  match Input.Parser.run (Input.Parser.eos_as_none Lex.ocaml_token) stream with
   | Result.Ok (None, _) -> () (* EOS *)
   | Result.Ok (Some (v, pos), stream') ->
       let show t = Sexplib.Sexp.to_string_hum (Token.sexp_of_t t) in
   let error s : 'a t = fun st -> Profile.incr (); Error (Str.position st, s)
   let throw err = fun _st -> Profile.incr (); Error err
 
-  let critical_error pos s = Profile.incr (); raise (Critical_error (pos, s))
-
-  let throw e : 'a t = fun _st -> Profile.incr (); Error e
+  let critical_error pos s = raise (Critical_error (pos, s))
 
   let stream : Str.t t = fun st -> Profile.incr (); Ok (st, st)
 
       wasted := !all_wasted
   end
 
+  type 'a monad = 
+    | Return of (Str.t -> ('a * Str.t, error) Result.t)
+    | Bind of Obj.t monad * (Obj.t -> 'a monad) (* nasty hack *)
+  
   include Monad.Make(struct 
 
-    type 'a t = 
-      | Return of Str.t -> ('a * Str.t, error) Result.t
-      | Bind of Obj.t t * Obj.t -> 'a t (* nasty hack *)
-  
+    type 'a t = 'a monad
+
     let return v = Return (fun st -> Ok (v, st))
   
     let bind (t : 'a t) (f : 'a -> 'b t) = Bind (Obj.magic t, Obj.magic f)
 
   open Open
 
-  let take : Str.elem t = fun s -> 
+  let rec run : 'a t -> Str.t -> ('a * Str.t, error) Result.t = fun t st ->
+    match t with
+    | Return f -> f st
+    | Bind (m, f) ->
+        match run (Obj.magic m) st with
+        | Ok (o, st') -> run ((Obj.magic f) o) st'
+        | Error err -> Error err
+
+  let result : 'a t -> ('a, error) Result.t t = fun c -> Return (fun st ->
+    Profile.incr ();
+    match run c st with
+    | Ok (res, st) -> Ok (Ok res, st)
+    | Error e -> Ok (Error e, st))
+
+  let take : Str.elem t = Return (fun s -> 
     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, _pos, s') -> Ok (elem, s'))
 
-  let take_ : unit t = fun s -> 
+  let take_ : unit t = Return (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)
+  let position : Str.Pos.t t = Return (fun st -> Profile.incr (); Ok (Str.position st, st))
 
-  let error s : 'a t = fun st -> Profile.incr (); Error (Str.position st, s)
-  let throw err = fun _st -> Profile.incr (); Error err
+  let error s : 'a t = Return (fun st -> Profile.incr (); Error (Str.position st, s))
+  let throw err = Return (fun _st -> Profile.incr (); Error err)
 
-  let critical_error pos s = Profile.incr (); raise (Critical_error (pos, s))
+  let critical_error pos s = raise (Critical_error (pos, s))
 
-  let throw e : 'a t = fun _st -> Profile.incr (); Error e
+  let stream : Str.t t = Return (fun st -> Profile.incr (); Ok (st, st))
 
-  let stream : Str.t t = fun st -> Profile.incr (); Ok (st, st)
-
-  let eos : unit t = fun s -> 
+  let eos : unit t = Return (fun s -> 
     Profile.incr ();
     match Str.peek s with
     | Some _ -> Error (Str.position s, "end of stream expected")
-    | None -> Ok ((), s)
+    | None -> Ok ((), s))
 
-  let (<?>) : 'a t -> string -> 'a t = fun c mes st ->
-    Profile.incr ();
-    let res = c st in
-    match res with
-    | Ok _ -> res
-    | Error (pos, _) -> Error (pos, "expected " ^ mes)
+  let (<?>) : 'a t -> string -> 'a t = fun c mes -> 
+    result c >>= function
+      | Ok v -> return v
+      | Error (pos, _) -> throw (pos, "expected " ^ mes)
 
-  let (<?!>) : 'a t -> string -> 'a t = fun c mes st ->
-    Profile.incr ();
-    let res = c st in
-    match res with
-    | Ok _ -> res
-    | Error (pos, _) -> Error (pos, mes)
+  let (<?!>) : 'a t -> string -> 'a t = fun c mes -> 
+    result c >>= function
+      | Ok v -> return v
+      | Error (pos, _) -> throw (pos, mes)
 
-  let (<?@>) : 'a t -> Str.Pos.t -> 'a t = fun c pos st ->
-    Profile.incr ();
-    let res = c st in
-    match res with
-    | Ok _ -> res
-    | Error (_, mes) -> Error (pos, mes)
+  let (<?@>) : 'a t -> Str.Pos.t -> 'a t = fun c pos -> 
+    result c >>= function
+      | Ok v -> return v
+      | Error (_, mes) -> throw (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]. *)
     <?> Printf.sprintf "expected one of %s"
          (String.concat " " (List.map Str.show_elem tkns))
 
-  let tokens : Str.elem list -> unit t = fun elems str ->
-    Profile.incr ();
-    let rec aux str = function
-      | [] -> return () str
-      | x::xs -> 
-          match Str.peek str with
-          | Some (c,_,str') when Str.equal_elem c x -> aux str' xs
-          | _ -> error (Printf.sprintf "expected %s" (Str.show_elem x)) str
+  let tokens : Str.elem list -> unit t = fun elems -> 
+    let rec aux = function
+      | [] -> return ()
+      | x::xs ->
+          take >>= fun y ->
+          if Str.equal_elem x y then aux xs
+          else error (Printf.sprintf "expected %s" (Str.show_elem x))
     in
-    aux str elems
+    aux elems
   
-  let option : 'a t -> 'a option t = fun com s ->
-    Profile.incr ();
-    match com s with
-    | Error _ -> return None s
-    | Ok (v, s') -> return (Some v) s'
+  let option : 'a t -> 'a option t = fun com -> 
+    result com >>= function
+      | Error _ -> return None
+      | Ok v -> return (Some v)
 
-  let option_ : unit t -> unit t = fun com s ->
-    Profile.incr ();
-    match com s with
-    | Error _ -> return () s
-    | Ok ((), s') -> return () s'
-
-  let result : 'a t -> ('a, error) Result.t t = fun c st ->
-    Profile.incr ();
-    match c st with
-    | Ok (res, st) -> Ok (Ok res, st)
-    | Error e -> Ok (Error e, st)
+  let option_ : unit t -> unit t = fun com -> ignore (result com)
 
   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 -> Error err
+    | Error err -> throw err
 
   let ( ?** ) : 'a t -> 'a list t = fun com ->
-    let rec aux st = fun s ->
-      Profile.incr ();
-      match com s with
-      | Error _ -> return (List.rev st) s
-      | Ok (v, s') -> aux (v :: st) s'
+    let rec aux st = 
+      result com >>= function
+        | Error _ -> return (List.rev st)
+        | Ok v -> aux (v :: st)
     in
     aux []
   
   let ( ?* ) : 'a t -> unit t = fun com ->
-    let rec aux = fun s ->
-      Profile.incr ();
-      match com s with
-      | Error _ -> return () s
-      | Ok (_v, s') -> aux  s'
+    let rec aux () = 
+      result com >>= function
+        | Error _ -> return ()
+        | Ok _ -> aux ()
     in
-    aux
+    aux ()
   
   let (?++) : 'a t -> 'a list t = fun com ->
     com >>= fun v -> 
     right >>= fun _ ->
     return res
   
-  let critical : 'a t -> 'a t = fun t st ->
-    Profile.incr ();
-    match t st with
-    | (Ok _ as res) -> res
-    | Error (pos, s) -> raise (Critical_error (pos, s))
+  let critical : 'a t -> 'a t = fun t -> 
+    result t >>= function
+      | Ok v -> return v
+      | Error (pos, s) -> raise (Critical_error (pos, s))
 
-  let (<|>) : 'a t -> 'a t -> 'a t = fun c1 c2 st -> 
+  let (<|>) : 'a t -> 'a t -> 'a t = fun c1 c2 -> 
+    position >>= fun pos0 ->
+    result c1 >>= function
+      | Ok v -> return v
+      | Error (pos, _ as err) -> if pos = pos0 then c2 else throw err
+
+  let (<!>) : 'a t -> 'a t -> 'a t = fun c1 c2 -> 
+    position >>= fun pos ->
+    Profile.start ();
+    result c1 >>= function
+      | Ok v ->
+          Profile.add (Profile.stop ());
+          return v
+      | Error (pos', _) -> 
+          if pos = pos' then Profile.add (Profile.stop ())
+          else begin
+            Profile.wasted := !Profile.wasted + Profile.stop ();
+          end;
+          c2
+
+  (* CR jfuruse: _ is used in a different meaning than option_ *)
+  let try_ : 'a t -> 'a t = fun c -> Return (fun st ->
     Profile.incr ();
     let pos0 = Str.position st in
-    let res = c1 st in
+    let res = run c st in
     match res with
     | Ok _ -> res
-    | Error (pos, _) -> if pos = pos0 then c2 st else res
+    | Error (_, err) -> Error (pos0, err))
 
-  (* CR jfuruse: _ is used in a different meaning than option_ *)
-  let try_ : 'a t -> 'a t = fun c st ->
-    Profile.incr ();
-    let pos0 = Str.position st in
-    let res = c st in
-    match res with
-    | Ok _ -> res
-    | Error (_, err) -> Error (pos0, err)
-
-  let (<!>) : 'a t -> 'a t -> 'a t = fun c1 c2 st -> 
-    Profile.incr ();
-    Profile.start ();
-    let pos = Str.position st in
-    match c1 st with
-    | (Ok _ as res) -> 
-        Profile.add (Profile.stop ());
-        res
-    | Error (pos', _) -> 
-        if pos = pos' then Profile.add (Profile.stop ())
-        else begin
-          Profile.wasted := !Profile.wasted + Profile.stop ();
-        end;
-        c2 st
-
-  let (<<>) : 'a t -> 'a t -> 'a t = fun c1 c2 st ->
+  let (<<>) : 'a t -> 'a t -> 'a t = fun c1 c2 -> Return (fun st ->
     Profile.incr ();
     let pos = Str.position st in
-    let res1 = c1 st in
+    let res1 = run c1 st in
     match res1 with
     | Ok _ -> 
         Profile.add (Profile.stop ());
     | Error (pos', _) ->
         let binds_in_c1 = Profile.stop () in
         Profile.start (); 
-        let res2 = c2 st in
+        let res2 = run c2 st in
         match res2 with
         | Ok _ -> 
             if pos = pos' then Profile.add binds_in_c1
         | Error (pos'', _) -> 
             if pos' = pos'' then Profile.add (Profile.stop ())
             else Profile.wasted := !Profile.wasted + Profile.stop ();
-            res1
+            res1)
 
   let eos_as_none : 'a t -> 'a option t = fun t ->
     (eos >>= fun _ -> return None)
 
   (* Used for push back *)          
   let (<&>) : 'a t -> ('a -> 'b t) -> 'b t = fun c1 c2 -> 
-    fun st ->
+    Return (fun st ->
       Profile.incr ();
-      match c1 st with
-      | Ok (v, _) -> c2 v st
-      | (Error _ as res) -> res
+      match run c1 st with
+      | Ok (v, _) -> run (c2 v) st
+      | (Error _ as res) -> res)
 
 
   let rec (/**/) : 'a list t -> 'a list t -> 'a list t = fun c1 c2 ->
       | None -> return None
       | Some _ -> c2 >>= fun v -> return (Some v)
 
-  let set_stream new_st _st = Profile.incr (); Ok ((), new_st)
+  let set_stream new_st = Return (fun _st -> Profile.incr (); Ok ((), new_st))
 
-  let run : 'a t -> Str.t -> ('a * Str.t, error) Result.t = fun t st ->
-    t st
 end