Source

planck / lib / pstate.ml

Full commit
open Spotlib.Spot

module Make(Str : Stream_intf.S)(State : sig type t end) : sig

  type error = Str.Pos.t * string

  type +'a t

  include Planck_intf.S 
    with module Str = Str
    and  type 'a t := 'a t
    and  type error := error

  val get : State.t t
  val put : State.t -> unit t

  val run : '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, 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 = t

  (** 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