Source

planck / lib / stoken.ml

Full commit
(** Stream of parser result, i.e. results of a lowr parser, or a lexer.
   With memoization.
*)

module type S = sig

  module Under : Planck_intf.S

  module Elem : Elem.S
  module Pos : Position.S
  module Attr : sig
    type t
    val position      : t -> Pos.t
    val last_position : t -> Pos.t option
    val memo          : t -> Smemo.memo
  end

  include Stream_intf.X with type elem := Elem.t
                        and  type pos  := Pos.t
                        and  type attr := Attr.t

  (* CR jfuruse: Elem, Pos and Attr are overridden by restricted ones by this inclusion! *)
  include Smemo.X with type stream := t

  val create : (Elem.t option * Pos.t) Under.t -> Under.Str.t -> t
  val last_position : t -> Pos.t option
end


module Make(Elem : Elem.S)(Pos : Position.S)(P : sig 
  include Planck_intf.S
  val run : 'a t -> Str.t -> ('a * Str.t, error) Result.t
end) = struct

  module Under = P

  module Base = struct
    module Elem = Elem
    module Pos = Pos
    module Attr = struct
      type t = { last_position : Pos.t option (* last consumed token position *);
                 position      : Pos.t;
                 memo          : Smemo.memo
               }
      let position t = t.position
      let last_position t = t.last_position
      let memo t = t.memo
    end
  end
  include Base

  module Str = Stream.Extend(Base)
  include Str

  include Smemo.Extend(struct
    include Base
    include Str
    let memo = Base.Attr.memo
  end)

  let create (m : ('a option * Pos.t) P.t) = fun st ->
    let rec f last_pos st = lazy begin
      match P.run m st with
      | Result.Ok ((None, pos), _st') -> 
          null_desc { Attr.last_position = last_pos; 
                      position      = pos; 
                      memo          = Smemo.create () } (* EOS case *)
      | Result.Ok ((Some v, pos), st') -> 
          cons_desc v { Attr.last_position = last_pos;
                        position = pos;
                        memo = Smemo.create () } (f (Some pos) st')
      | Result.Error (pos, s) -> raise (P.Critical_error (pos, s))
    end
    in
    f None st
  ;;

  let last_position st : Pos.t option = Base.Attr.last_position (attr st)
end