Source

ocaml-lib / dcg / dcg.ml

Full commit

let trace = ref false

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


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

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

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

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

let fail = new fail

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

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

let rise = new rise


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

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

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

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

    method next : ('str,'ctx,'res,'msg) result =
      match state with
      | `Begin ->
	  state <- `End;
	  Parsed (ctx, 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 ['ctx, 'res, 'str, 'msg] alt (parse1 : ('ctx, 'res, 'str, 'msg) parse) (parse2 : ('ctx, 'res, 'str, 'msg) parse) (ctx : 'ctx) (str : 'str) =
  object (self)
    val mutable state = `First
    val mutable p = parse1 ctx str
    val mutable msgs = []

    method next =
      match state with
      | `First ->
	  ( match p # next with
	  | Parsed _ as x -> x
	  | Failed msgs1 ->
	      state <- `Second;
	      p <- parse2 ctx 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 ['ctx, 'res1, 'res, 'str, 'msg] seq (parse1 : ('ctx,'res1,'str,'msg) parse) (parse2 : 'res1 -> ('ctx,'res,'str,'msg) parse) (ctx : 'ctx) (str : 'str) =
  object (self)
    val mutable state = `First
    val p1 = parse1 ctx 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 (ctx1, res1, str1) ->
	      state <- `Second;
	      p2_opt <- Some (parse2 res1 ctx1 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 ['ctx,'res1,'res,'str,'msg] cut (parse1 : ('ctx,'res1,'str,'msg) parse) (parse2 : 'res1 -> ('ctx,'res,'str,'msg) parse) (parse3 : ('ctx,'res,'str,'msg) parse) (ctx : 'ctx) (str : 'str) =
  object (self)
    val mutable state = `First
    val p1 = parse1 ctx str
    val mutable p_opt = None

    method next =
      match state with
      | `First ->
	  ( match p1 # next with
	  | Parsed (ctx1, res1, str1) ->
	      state <- `Second;
	      p_opt <- Some (parse2 res1 ctx1 str1);
	      self # next
	  | Failed _ ->
	      state <- `Third;
	      p_opt <- Some (parse3 ctx 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 ['ctx,'res,'str,'msg] guard (parse : ('ctx,'res,'str,'msg) parse) (name : string) (pred : 'res -> bool) (ctx : 'ctx) (str : 'str) =
  object (self)
    val p = parse ctx str

    method next =
      match p # next with
      | Parsed (ctx1, res1, str1) as x ->
	  if pred res1
	  then x
	  else self # next
      | Failed msgs ->
	  let coord = str#coord 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 ['ctx,'str,'msg] check (name : string) (pred : unit -> bool) (ctx : 'ctx) (str : 'str) =
  object (self)
    val mutable state = `Begin

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

let check = new check

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

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

let enum = new enum

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

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

let get_context = new get_context

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

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

let set_context = new set_context

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

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

let check_context = new check_context

class ['ctx,'str] enum_context (name : string) (f : 'ctx -> 'ctx list) (ctx : 'ctx) (str : 'str) =
  object (self)
    val mutable state : 'ctx list option = None

    method next =
      match state with
      | None ->
	  state <- Some (f ctx);
	  if state = Some []
	  then
	    let coord = str#coord in
	    let msg = Msg.make name [||] (Msg.Locator.Point coord) in
	    Failed [msg]
	  else self#next
      | Some (ctx1::l1) ->
	  state <- Some l1;
	  Parsed (ctx1, (), str)
      | Some [] -> Failed []
  end
  
let enum_context = new enum_context


(* combinators *)

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 ctx str =
  let p = parse ctx str in
  match p # next with
  | Parsed (ctx, x, _) -> ctx, 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 ctx str =
  let p = parse ctx str in
  let res = ref [] in
  begin try while true do
    match p # next with
    | Parsed (ctx, x, _) -> res := (ctx, x) :: !res
    | Failed _ -> raise Not_found
  done with Not_found -> () end;
  !res