Commits

camlspotter committed 47e2815

added buffered char stream pbufchar

Comments (0)

Files changed (7)

    elem
    stream_intf
    stream
+   schar
    sstring
    smemo
    sbuffer
    pbaseref
    pstate
    pchar
+   pbufchar
    pbuffer
    pmemo
    pstate
 open Sexplib.Conv
 
+module Operator = struct
+  type t = { 
+    prec : float; (* just a joke :-) *)
+    kind : [ `Infix of [ `Left | `Right | `Noassoc ] | `Prefix | `Postfix ]
+  } with sexp
+    
+  let prec_app = 1000.0
+  let app = { prec = prec_app; kind = `Infix `Left }
+
+  let show t = 
+    let kind = match t.kind with
+      | `Infix `Left -> "infix left"
+      | `Infix `Right -> "infix right"
+      | `Infix `Noassoc -> "infix noassoc"
+      | `Prefix -> "prefix"
+      | `Postfix -> "postfix"
+    in
+    Printf.sprintf "%s %f" kind t.prec
+end
+
+module O = Operator
+
 module Make(A : sig
   type t
   type op
+  val show_op : op -> string
   val app : t -> t -> t
   val binop : op -> t -> t -> t
   val unop : op -> t -> t
 end) = struct
-  type op = { 
-    prec : float; (* just a joke :-) *)
-    kind : [ `Infix of [ `Left | `Right | `Noassoc ] | `Prefix | `Postfix ]
-  } with sexp
-  
-  let prec_app = 1000.0
-  let op_app = { prec = prec_app; kind = `Infix `Left }
-  
-(*
-  let tbl : (A.op, op) Hashtbl.t = Hashtbl.create 107
-*)
-  
+
   (* List like e1, e2, ..., en is implemented as infix with special builder *)
   type t = 
-    | Infix of op * A.op option * t * t (* None means application *)
-    | Postfix of op * A.op * t
-    | Prefix of op * A.op * t
+    | Infix of O.t * A.op option * t * t (* None means application *)
+    | Postfix of O.t * A.op * t
+    | Prefix of O.t * A.op * t
     | Terminal of A.t
 
+  type error = 
+    | Ambiguous of O.t * A.op option * O.t * A.op option
+    | Empty
+    | NoRightArg of O.t * A.op
+    | NoLeftArg of O.t * A.op
+
+  let format_op ppf (o, aop) =
+    let show_aop_opt = function
+      | None -> "application"
+      | Some aop -> A.show_op aop
+    in
+    Format.fprintf ppf "%s (%s)" (show_aop_opt aop) (Operator.show o)
+    
+  let format_error ppf = 
+    function
+      | Ambiguous (lo, laop, ro, raop) ->
+          Format.fprintf ppf "@[<v2>Ambiguous operator uses:@ %a@ %a@]"
+            format_op (lo, laop)
+            format_op (ro, raop)
+      | Empty -> Format.fprintf ppf "Empty input"
+      | NoRightArg (o, aop) ->
+          Format.fprintf ppf "No right argument for %a" format_op (o, Some aop)
+      | NoLeftArg (o, aop) ->
+          Format.fprintf ppf "No left argument for %a" format_op (o, Some aop)
+
+  exception Error of error
+
+  let ambiguous o aop o' aop' = raise (Error (Ambiguous (o, aop, o', aop')))
+
   let rec build = function
     | Terminal a -> a
     | Infix (_, None, t1, t2) -> A.app (build t1) (build t2)
     | Postfix (_, op, t) | Prefix (_, op, t) -> A.unop op (build t)
 
   let compare x y =
+    let open O in
     match compare x.prec y.prec with
     | 1 -> `Strong
     | -1 -> `Weak
             infix lop la e1 (infix op a e2 e3) 
         | `Weak | `Left -> (* 0 * 1 + 2 => <0 * 1> + 2 *)
             infix_check_right op a e12 e3 
-        | `Error -> assert false  (* ERROR *)
+        | `Error -> ambiguous lop la op a 
         end
   
   and infix_check_right op a e1 e23 =
             infix rop ra (infix op a e1 e2) e3
         | `Weak | `Right -> (* 0 + 1 * 2 => 0 + <1 * 2> *)
             Infix (op, a, e1, e23)
-        | `Error -> assert false (* ERROR *)
+        | `Error -> ambiguous op a rop ra
   
   and prefix op a e =
     match e with
         begin match compare op op' with
         | `Strong -> (* <- e> ! *) postfix op' a' (prefix op a e')
         | `Weak -> (* - <e !> *) Prefix (op, a, e)
-        | `Error -> assert false (* ERROR *)
+        | `Error -> ambiguous op (Some a) op' (Some a')
         | _ -> assert false (* impossible *)
         end
     | Infix (rop, ra, e1, e2) ->
         begin match compare op op' with
         | `Strong -> (* flip!: - e ! => - <e !> *) prefix op' a' (postfix op a e')
         | `Weak -> (* flip!: - e ! => <- e> ! *) Postfix (op, a, e)
-        | `Error -> assert false (* ERROR *)
+        | `Error -> ambiguous op' (Some a') op (Some a)
         | _ -> assert false (* impossible *)
         end
     | Infix (rop, ra, e1, e2) ->
         | _ -> (* flip!: 1 * 2 $ => 1 * <2 $> *) 
             infix rop ra e1 (postfix op a e2)
     
-  (*
-  let list op f = function
-    | [] -> []
-    | [e] -> [e]
-    | e1::e2::es ->
-  *)      
-        
-  (*
-  let infix op f left right = 
-    Format.eprintf "INFIX: %a (%a) (%a)@."
-      Sexplib.Sexp.pp_hum (sexp_of_op op)
-      pp left
-      pp right;
-    let res = infix op f left right in
-    Format.eprintf "INFIX DONE@.";
-    res
-  
-  let prefix op f e = 
-    Format.eprintf "PREFIX: %a (%a)@."
-      Sexplib.Sexp.pp_hum (sexp_of_op op)
-      pp e;
-    let res = prefix op f e in
-    Format.eprintf "PREFIX DONE@.";
-    res
-  
-  let postfix op f e = 
-    Format.eprintf "POSTFIX: %a (%a)@."
-      Sexplib.Sexp.pp_hum (sexp_of_op op)
-      pp e;
-    let res = postfix op f e in
-    Format.eprintf "POSTFIX DONE@.";
-    res
-  *)
-  
-  let app = infix op_app None
+  let app = infix O.app None
 
-  let rec parse treeopt str = 
+  let rec parse treeopt contextopt str = 
     match treeopt with
     | None ->
         begin match str with
-        | [] -> failwith "empty"
-        | `Term t :: str -> parse (Some (terminal t)) str
+        | [] -> 
+            begin match contextopt with
+            | Some (op, a) -> raise (Error (NoRightArg (op, a)))
+            | None -> raise (Error Empty)
+            end
+        | `Term t :: str -> parse (Some (terminal t)) None str
         | `Op (op, a) :: str ->
-            begin match op.kind with
-            | `Prefix -> prefix op a (parse None str)
-            | `Postfix -> failwith "postfix"
-            | `Infix _ -> failwith "infix"
+            begin match op.O.kind with
+            | `Prefix -> prefix op a (parse None (Some (op, a)) str)
+            | `Postfix | `Infix _ -> raise (Error (NoLeftArg (op, a)))
             end
         end
     | Some tree ->
         begin match str with
         | [] -> tree
-        | `Term t :: str -> parse (Some (app tree (terminal t))) str
+        | `Term t :: str -> parse (Some (app tree (terminal t))) None str
         | `Op (op, a) :: str ->
-            begin match op.kind with
-            | `Prefix -> app tree (prefix op a (parse None str))
-            | `Postfix -> parse (Some (postfix op a tree)) str
-            | `Infix _ -> infix op (Some a) tree (parse None str)
+            begin match op.O.kind with
+            | `Prefix -> app tree (prefix op a (parse None (Some (op, a)) str))
+            | `Postfix -> parse (Some (postfix op a tree)) None str
+            | `Infix _ -> infix op (Some a) tree (parse None (Some (op, a)) str)
             end
         end
 
-  let parse xs = build (parse None xs)
+  let parse xs = build (parse None None xs)
 
 (*
   let list op = function
 (** Tools for operator precedences and associativities *)
 
+module Operator : sig
+  type t = {
+    prec : float; (** Operator precedence. Bigger is stronger. *)
+    kind : [ `Infix of [ `Left | `Right | `Noassoc ]
+           | `Postfix 
+           | `Prefix
+           ];
+  }
+    
+  val prec_app : float
+  (** Operator precedence of function application. = 1000.0 *)
+  
+  val show : t -> string
+end
+
 module Make(A : sig
   type t
   type op
+  val show_op : op -> string
   val app : t -> t -> t
   val binop : op -> t -> t -> t
   val unop : op -> t -> t
 end) : sig
 
-  type op = {
-    prec : float; (** Operator precedence. Bigger is stronger. *)
-    kind : [ `Infix of [ `Left | `Right | `Noassoc ] (** Infix, left or right associative *)
-           | `Postfix 
-           | `Prefix
-           ];
-  }
-  
-  val prec_app : float
-  (** Operator precedence of function application. = 1000.0 *)
-  
-(*
-  val tbl : (A.op, op) Hashtbl.t
-  (** Operator table. The resolution functions below uses this table to query operators
-      and its precedence information *)
-  
-  val find : (A.op -> op) ref
-  (** By default [!find] is used to query operators from [tbl]. 
-      If your set of operators cannot use table based precedence + associativity query,
-      you can override this behavior by modifying the reference. 
-  *)
-*)
-  
-  (** Resolution *)
+  type error = 
+    | Ambiguous of Operator.t * A.op option * Operator.t * A.op option
+    | Empty
+    | NoRightArg of Operator.t * A.op
+    | NoLeftArg of Operator.t * A.op
 
-  val parse : [ `Op of op * A.op | `Term of A.t ] list -> A.t
+  exception Error of error
+
+  val format_error : Format.formatter -> error -> unit
+
+  val parse : [ `Op of Operator.t * A.op | `Term of A.t ] list -> A.t
+
 end
+(** Parser for Schar *)
+
+module Base = Pbase.Make(Schar) (* Base parser *)
+include Base
+include Pbuffer.Extend(Schar)(Base) (* Extend Base with parser operators for buffered streams *)
+include Pbase.S with type Str.desc  = Schar.desc
+                and  type Str.Pos.t = Position.File.t
+include Pbuffer.X with type 'a t := 'a t
+(** Stream of chars with buffering and memoization *)
+
 module type S = sig
   include Stream_intf.S with type Elem.t = char
                         and  type Pos.t = Position.File.t
 open Planck
 
 (* Stream of chars with buffering and memoization *)
-module Stream = struct
-
-  (* The configuration of the stream *)    
-  module Base = struct
-
-    (* Stream elements *)
-    module Elem = struct
-      type t = char (* It is a char stream *)
-      let show = Printf.sprintf "%C" (* How to pretty print the element *)
-      let format ppf = Format.fprintf ppf "%C" (* How to pretty print the element *)
-      let equal (x : char) y = x = y
-      let compare (x : char) y = compare x y
-    end
-
-    (* Stream positions *)
-    module Pos = Position.File (* Type of the element position *)
-
-    module Attr = struct
-      (* Stream attributes *)
-      type t = Sbuffer.buf (* Stream elements carry internal buffers *)
-      let default = Sbuffer.default_buf
-      let position attr = Sbuffer.position_of_buf attr (* How to obtain the position from attr *)
-    end
-
-  end
-
-  module Str = Stream.Make(Base) (* Build the stream *)
-  include Str
-
-  (* Extend Str with buffering *)
-  include Sbuffer.Extend(struct
-    include Str
-    let create_attr buf = buf (* How to create an attribute from a buffer *)
-    let buf st = attr st (* How to obtain the buffer of a stream *)
-  end)
-
-end
+module Stream = Schar
 
 module Parser = struct
 
   module Base = Pbase.Make(Stream) (* Base parser *)
   include Base
-
   include Pbuffer.Extend(Stream)(Base) (* Extend Base with parser operators for buffered streams *)
 end    
 
     | Unop (char, t1) -> "(" ^ String.make 1 char ^ " " ^ show t1  ^ ")"
 end
 
-module Op_prec = Op_prec.Make(struct
+module Op = Op_prec.Make(struct
   type t = Tree.t
   type op = char
+  let show_op = Printf.sprintf "(%c)"
   let app _f _a = assert false
   let binop op a1 a2 = Tree.Binop(op, a1, a2)
   let unop op a1 = Tree.Unop(op, a1)
 end)
 
-open Op_prec (* open Op_prec, functions for operator precedences *)
+open Op (* open Op_prec, functions for operator precedences *)
 
-let tbl = Hashtbl.of_list 11 [
+let tbl = 
+  let open Op_prec.Operator in
+  Hashtbl.of_list 11 [
     '+',  { prec = 2.0; kind = `Infix `Left };
     '-',  { prec = 2.0; kind = `Infix `Left };
     '*',  { prec = 3.0; kind = `Infix `Left };
   option (token '-') >>= fun unary_minus ->
   ?++ simple_expr >>= fun es -> 
   match unary_minus with
-  | Some () -> return (Op_prec.parse (`Op (Hashtbl.find tbl '~', '~') :: es))
-  | None -> return (Op_prec.parse es)
+  | Some () -> return (Op.parse (`Op (Hashtbl.find tbl '~', '~') :: es))
+  | None -> return (Op.parse es)
 end st
 
 (* For test *)