Source

ocaml-lib / ipp / ipp.ml


type ('cursor, 'ctx) result = Printed of 'cursor * 'ctx | Failed

class type ['cursor, 'ctx] p =
  object
    method next : ('cursor, 'ctx) result
  end

type ('a, 'cursor, 'ctx) print = 'a -> 'cursor -> 'ctx -> ('cursor,'ctx) p

class ['a,'b,'cursor,'ctx] map (f : 'a -> 'b) (print : ('b,'cursor,'ctx) print) (v : 'a) (cursor : 'cursor) (ctx : 'ctx) =
  object (self)
    val mutable state =
      try `Begin (print (f v) cursor ctx)
      with _ -> `End

    method next =
      match state with
      | `Begin p ->
	  ( match p#next with
	  | Printed _ as x -> x
	  | Failed ->
	      state <- `End;
	      self#next)
      | `End -> Failed
  end
let map = new map

class ['a,'cursor,'ctx] ret (print : (unit,'cursor,'ctx) print) (v : 'a) (cursor : 'cursor) (ctx : 'ctx) =
  object (self)
    val mutable state = `Begin (print () cursor ctx)

    method next =
      match state with
      | `Begin p ->
	  ( match p#next with
	  | Printed _ as x -> x
	  | Failed ->
	      state <- `End;
	      self#next)
      | `End -> Failed
  end
let ret = new ret

class ['a,'cursor,'ctx] empty (v : 'a) (cursor : 'cursor) (ctx : 'ctx) =
  object (self)
    val mutable state = `Begin

    method next =
      match state with
      | `Begin ->
	  state <- `End;
	  Printed (cursor,ctx)
      | `End -> Failed
  end
let empty = new empty

class ['a,'cursor,'ctx] alt (print1 : ('a,'cursor,'ctx) print) (print2 : ('a,'cursor,'ctx) print) (v : 'a) (cursor : 'cursor) (ctx : 'ctx) =
  object (self)
    val mutable state = `First (print1 v cursor ctx)

    method next =
      match state with
      | `First p1 ->
	  ( match p1#next with
	  | Printed _ as x -> x
	  | Failed ->
	      state <- `Second (print2 v cursor ctx);
	      self#next)
      | `Second p2 ->
	  ( match p2#next with
	  | Printed _ as x -> x
	  | Failed ->
	      state <- `End;
	      self#next)
      | `End -> Failed
  end
let alt = new alt

class ['a,'cursor,'ctx] seq (print1 : ('a,'cursor,'ctx) print) (print2 : ('a,'cursor,'ctx) print) (v : 'a) (cursor : 'cursor) (ctx : 'ctx) =
  object (self)
    val mutable state = `First (print1 v cursor ctx)

    method next =
      match state with
      | `First p1 ->
	  ( match p1#next with
	  | Printed (cursor1,ctx1) ->
	      state <- `Second (p1, print2 v cursor1 ctx1);
	      self#next
	  | Failed ->
	      state <- `End;
	      self#next)
      | `Second (p1,p2) ->
	  ( match p2#next with
	  | Printed _ as x -> x
	  | Failed ->
	      state <- `First p1;
	      self#next)
      | `End -> Failed
  end
let seq = new seq

class ['a,'cursor,'ctx] cut (print1 : ('a,'cursor,'ctx) print) (print2 : ('a,'cursor,'ctx) print) (print3 : ('a,'cursor,'ctx) print) (v : 'a) (cursor : 'cursor) (ctx : 'ctx) =
  object (self)
    val mutable state = `First (print1 v cursor ctx)

    method next =
      match state with
      | `First p1 ->
	  ( match p1#next with
	  | Printed (cursor1,ctx1) ->
	      let cursor1' = if cursor#at_init then cursor1#init else cursor1 in
	      state <- `Second (print2 v cursor1' ctx1);
	      self#next
	  | Failed ->
	      state <- `Third (print3 v cursor ctx);
	      self#next)
      | `Second p2 ->
	  ( match p2#next with
	  | Printed _ as x -> x
	  | Failed ->
	      state <- `End;
	      self#next)
      | `Third p3 ->
	  ( match p3#next with
	  | Printed _ as x -> x
	  | Failed ->
	      state <- `End;
	      self#next)
      | `End -> Failed
  end
let cut = new cut

class ['a,'cursor,'ctx] opt (print_some : ('a,'cursor,'ctx) print) (print_none : (unit,'cursor,'ctx) print) (v_opt : 'a option) (cursor : 'cursor) (ctx : 'ctx) =
  object
    val mutable state =
      match v_opt with
      | Some v -> `Some (print_some v cursor ctx)
      | None -> `None (print_none () cursor ctx)

    method next =
      match state with
      | `Some p_some ->
	  ( match p_some#next with
	  | Printed _ as x -> x
	  | Failed ->
	      state <- `End;
	      Failed)
      | `None p_none ->
	  ( match p_none#next with
	  | Printed _ as x -> x
	  | Failed ->
	      state <- `End;
	      Failed)
      | `End -> Failed
  end
let opt = new opt

class ['a,'cursor,'ctx] check (pred : 'a -> bool) (v : 'a) (cursor : 'cursor) (ctx : 'ctx) =
  object (self)
    val mutable state = `Begin

    method next =
      match state with
      | `Begin ->
	  state <- `End;
	  if pred v
	  then Printed (cursor,ctx)
	  else Failed
      | `End -> Failed
  end
let check = new check

class ['a,'b,'cursor,'ctx] enum (f : 'a -> 'b list) (print : 'b -> ('a,'cursor,'ctx) print) (v : 'a) (cursor : 'cursor) (ctx : 'ctx) =
  object (self)
    val mutable state =
      match f v with
      | [] -> `End
      | v1::l1 -> `Begin (print v1 v cursor ctx, l1)

    method next =
      match state with 
      | `Begin (p1, l1) ->
	  ( match p1#next with
	  | Printed _ as x -> x
	  | Failed ->
	      state <- (match l1 with [] -> `End | v2::l2 -> `Begin (print v2 v cursor ctx, l2));
	      self#next)
      | `End -> Failed
  end
let enum = new enum

class ['a,'cursor,'ctx] get_context (print : 'ctx -> ('a,'cursor,'ctx) print) (v : 'a) (cursor : 'cursor) (ctx : 'ctx) =
  object
    inherit ['a,'ctx,'cursor,'ctx] enum (fun _ -> [ctx]) print v cursor ctx
  end
let get_context = new get_context

class ['a,'cursor,'ctx] set_context (new_ctx : 'ctx) (v : 'a) (cursor : 'cursor) (ctx : 'ctx) =
  object (self)
    val mutable state = `Begin

    method next =
      match state with
      | `Begin ->
	  state <- `End;
	  Printed (cursor,new_ctx)
      | `End -> Failed
  end
let set_context = new set_context

class ['cursor,'ctx] operation (op : 'cursor -> 'cursor) (cursor : 'cursor) (ctx : 'ctx) =
  object
    val mutable state = `Begin

    method next =
      match state with
      | `Begin ->
	  state <- `End;
	  Printed (op cursor, ctx)
      | `End -> Failed
  end
let operation = new operation


(* combinators *)

let is_empty_list = fun l -> l=[]

let rec many print v cursor ctx =
  (alt (seq (map List.hd print) (map List.tl (many print))) (check is_empty_list)) v cursor ctx

let some print v cursor ctx =
  (seq (map List.hd print) (map List.tl (many print))) v cursor ctx

let list1 elt sep v cursor ctx =
  (seq (map List.hd elt) (map List.tl (many (seq (ret sep) elt)))) v cursor ctx
(*
  seq (map List.hd elt) (map List.tl (list1_aux elt sep))
and list1_aux elt sep =
  alt (seq (ret sep) (seq (map List.hd elt) (map List.tl (list1_aux elt sep)))) empty
*)

let list0 elt sep nil v cursor ctx =
  (alt (list1 elt sep) (seq (check is_empty_list) nil)) v cursor ctx


(* returns one parsing result *)
let once (print : ('a,'cursor,'ctx) print) (v : 'a) (cursor : 'cursor) (ctx : 'ctx) : unit =
  let p = print v cursor ctx in
  match p#next with
  | Printed (cursor, ctx) -> cursor#print_flush
  | Failed -> failwith "Ipp.once: not a printable value"