Source

ocaml-lib / dcg / dcg.ml

Full commit

let trace = ref false

let get_trace () = !trace
let set_trace b = trace := b


type ('str, 'res, 'msg) result = Parsed of 'res * 'str | Failed of 'msg list

class type ['res, 'str, 'msg] p =
  object
    method next : ('str, 'res, 'msg) result
  end

type ('res, 'str, 'msg) parse = 'str -> ('res, 'str, 'msg) p

class ['res,'str,'msg] fail (str : 'str) =
  object (self)
    method next : ('str, 'res, 'msg) result =
      Failed ([] : 'msg list)
  end

let fail = new fail

class ['str,'msg] rise (str : 'str) =
  object (self)
    val mutable state = `Begin

    method next =
      match state with
      | `Begin ->
	  state <- `End;
	  Parsed (str, str)
      | `End ->
	  Failed ([] : 'msg list)
  end

let rise = new rise


class ['res0, 'res, 'str, 'msg] map (parse : ('res0, 'str, 'msg) parse) (f : 'res0 -> 'res) (str : 'str) =
  object (self)
    val mutable p = parse str

    method next =
      match p # next with
      | Parsed (res0, str') -> Parsed (f res0, str')
      | Failed msgs -> Failed msgs
  end

let map = new map
let (-->) = map

class ['res, 'str, 'msg] ret (res : 'res) (str : 'str) =
  object (self)
    val mutable state = `Begin

    method next : ('str,'res,'msg) result =
      match state with
      | `Begin ->
	  state <- `End;
	  Parsed (res, str)
      | `End ->
	  Failed ([] : 'msg list) 
  end

let ret = new ret

(* syntaxe ideale
   param = p --> expr ==> map p (fun param -> expr)
   --> expr ==> ret expr
*)

class ['res, 'str, 'msg] alt (parse1 : ('res, 'str, 'msg) parse) (parse2 : ('res, 'str, 'msg) parse) (str : 'str) =
  object (self)
    val mutable state = `First
    val mutable p = parse1 str
    val mutable msgs = []

    method next =
      match state with
      | `First ->
	  ( match p # next with
	  | Parsed _ as x -> x
	  | Failed msgs1 ->
	      state <- `Second;
	      p <- parse2 str;
	      msgs <- msgs1 @ msgs;
	      self # next)
      | `Second ->
	  ( match p # next with
	  | Parsed _ as x -> x
	  | Failed msgs2 ->
	      state <- `End;
	      msgs <- msgs2 @ msgs;
	      self # next)
      | `End ->
	  Failed msgs
  end

let alt = new alt
let (<|>) = alt

(* syntaxe ideale
   p1 | p2 ==> alt p1 p2
*)

class ['res1, 'res, 'str, 'msg] seq (parse1 : ('res1,'str,'msg) parse) (parse2 : 'res1 -> ('res,'str,'msg) parse) (str : 'str) =
  object (self)
    val mutable state = `First
    val p1 = parse1 str
    val mutable p2_opt = None (* delaying the creation of p2 because of possible loops *)
    val mutable msgs = []

    method next =
      match state with
      | `First ->
	  ( match p1 # next with
	  | Parsed (res1, str1) ->
	      state <- `Second;
	      p2_opt <- Some (parse2 res1 str1);
	      self # next
	  | Failed msgs1 ->
	      state <- `End;
	      msgs <- msgs1 @ msgs;
	      self # next)
      | `Second ->
	  ( match p2_opt with
	  | Some p2 ->
	      ( match p2 # next with
	      | Parsed _ as x -> x
	      | Failed msgs2 ->
		  state <- `First;
		  msgs <- msgs2 @ msgs;
		  self # next)
	  | None -> assert false)
      | `End -> Failed msgs
  end

let seq = new seq
let (|>) = seq
let (|>>) parse1 parse2 = parse1 |> fun _ -> parse2

(* syntaxe ideale
   p1; p2 ==> seq p1 (fun _ -> p2)
   param = p1; p2 ==> seq p1 (fun param -> p2)
*)

class ['res1,'res,'str,'msg] cut (parse1 : ('res1,'str,'msg) parse) (parse2 : 'res1 -> ('res,'str,'msg) parse) (parse3 : ('res,'str,'msg) parse) (str : 'str) =
  object (self)
    val mutable state = `First
    val p1 = parse1 str
    val mutable p_opt = None

    method next =
      match state with
      | `First ->
	  ( match p1 # next with
	  | Parsed (res1, str1) ->
	      state <- `Second;
	      p_opt <- Some (parse2 res1 str1);
	      self # next
	  | Failed _ ->
	      state <- `Third;
	      p_opt <- Some (parse3 str);
	      self # next)
      | `Second ->
	  ( match p_opt with
	  | Some p -> p # next
	  | None -> assert false)
      | `Third ->
	  ( match p_opt with
	  | Some p -> p # next
	  | None -> assert false)
  end

let cut = new cut
let (<!>) = cut
let (<!>>) parse1 parse2 parse3 = cut parse1 (fun _ -> parse2) parse3
let (</>) f x = f x
    (* parse1 <!> fun _ -> parse2 </> parse3 *)
    (* parse1 <!>> parse2 </> parse3 *)

(* syntaxe ideale
   if param = p1 then p2 else p3 ==> cut p1 (fun param -> p2) p3
   if p1 then p2 else p3 ==> cut p1 (fun _ -> p2) p3
*)

class ['res,'str,'msg] guard (parse : ('res,'str,'msg) parse) (name : string) (pred : 'res -> bool) (str : 'str) =
  object (self)
    val p = parse str

    method next =
      match p # next with
      | Parsed (res1, str1) as x ->
	  if pred res1
	  then x
	  else self # next
      | Failed msgs ->
	  let s, p, coord = str # params in
	  let msg = Msg.make name [||] (Msg.Locator.Point coord) in
	  Failed (msg::msgs)
  end

let guard = new guard
let (<&>) = guard
    (* parse <&> name </> pred *)

(* syntaxe ideale
   param = p1 when expr_bool else expr_string ==> guard p1 expr_string (fun param -> expr_bool)
*)

class ['str, 'msg] check (name : string) (pred : unit -> bool) (str : 'str) =
  object (self)
    val mutable state = `Begin

    method next =
      match state with
      | `Begin ->
	  state <- `End;
	  if pred ()
	  then
	    Parsed ((), str)
	  else
	    let s, p, coord = str # params in
	    let msg = Msg.make name [||] (Msg.Locator.Point coord) in
	    Failed [msg]
      | `End -> Failed []
  end

let check = new check

class ['res,'str,'msg] enum (name : string) (f : unit -> 'res list) (str : 'str) =
  object (self)
    val mutable state : 'res list = None

    method next =
      match state with
      | None ->
	  state <- Some (f ());
	  self#next
      | Some [] ->
	  let s, p, coord = str # params in
	  let msg = Msg.make name [||] (Msg.Locator.Point coord) in
	  Failed [msg]
      | Some (x::xs) ->
	  state <- Some xs;
	  Parsed (x, str)
  end

let enum = new enum

(*
class ['str, 'msg] eps (str : 'str) =
  object (self)
    val mutable state = `Begin

    method next =
      match state with
      | `Begin ->
	  state <- `End;
	  Parsed ((), str)
      | `End ->
	  Failed ([] : 'msg list)
  end

let eps = new eps
*)

let opt parse x = parse <|> (ret x)
let (<?>) = opt

(* syntaxe ideale
   p ? ==> opt p
*)

let rec many parse = (parse |> fun x -> many parse --> (fun xs -> x::xs)) <|> (ret [])
let (<*>) = many

(* syntaxe ideale
   p * ==> many p
*)

let some parse = parse |> fun x -> many parse --> (fun xs -> x::xs)
let (<+>) = some

(* syntaxe ideale
   p + ==> some p
*)

let rec list1 p_elt p_sep =
  p_elt |> fun x -> list1_aux p_elt p_sep --> fun xs -> x::xs
and list1_aux p_elt p_sep =
  (p_sep |>> p_elt |> fun x -> list1_aux p_elt p_sep --> fun xs -> x::xs) <|> (ret [])

let list0 p_elt p_sep =
  (list1 p_elt p_sep) <|> (ret [])


exception SyntaxError of int * int * string
    (* line, column, msg *)

(* returns one parsing result *)
let once parse str =
  let p = parse str in
  match p # next with
  | Parsed (x, _) -> x
  | Failed [] ->
      raise (SyntaxError (0,0,"Syntax error"))
  | Failed (msg::msgs) ->
      let (line, col), best_msg =
	List.fold_left
	  (fun (best_coord, best_msg) msg ->
	    let coord = Msg.Locator.start msg.Msg.loc in
	    if best_coord < coord
	    then (coord, msg)
	    else (best_coord, best_msg))
	  (Msg.Locator.start msg.Msg.loc, msg)
	  msgs in
      raise (SyntaxError (line, col, Msg.toString best_msg))

(* returns all parsing results *)
let all parse str =
  let p = parse str in
  let res = ref [] in
  begin try while true do
    match p # next with
    | Parsed (x, _) -> res := x :: !res
    | Failed _ -> raise Not_found
  done with Not_found -> () end;
  !res