Source

ocaml-lib / dcg / dcg.ml

Full commit
Sébastien Ferré 9afe174 
Sébastien Ferré df9e4eb 





Sébastien Ferré 45e2163 
Sébastien Ferré 9afe174 
Sébastien Ferré 45e2163 
Sébastien Ferré 9afe174 
Sébastien Ferré 45e2163 
Sébastien Ferré 9afe174 

Sébastien Ferré 45e2163 
Sébastien Ferré 9afe174 
Sébastien Ferré 45e2163 
Sébastien Ferré 9afe174 
Sébastien Ferré 45e2163 
Sébastien Ferré 9afe174 




Sébastien Ferré 45e2163 
Sébastien Ferré 9afe174 






Sébastien Ferré 45e2163 
Sébastien Ferré 9afe174 






Sébastien Ferré 45e2163 
Sébastien Ferré 9afe174 
Sébastien Ferré e850a59 
Sébastien Ferré 9afe174 

Sébastien Ferré e850a59 








Sébastien Ferré 9afe174 



Sébastien Ferré df9e4eb 
Sébastien Ferré 45e2163 
Sébastien Ferré df9e4eb 


Sébastien Ferré 45e2163 
Sébastien Ferré df9e4eb 


Sébastien Ferré 45e2163 
Sébastien Ferré df9e4eb 




Sébastien Ferré 9afe174 


Sébastien Ferré df9e4eb 
Sébastien Ferré 9afe174 

Sébastien Ferré 45e2163 
Sébastien Ferré 9afe174 
Sébastien Ferré e850a59 
Sébastien Ferré 9afe174 


Sébastien Ferré e850a59 

Sébastien Ferré 9afe174 

Sébastien Ferré e850a59 
Sébastien Ferré 9afe174 
Sébastien Ferré e850a59 

Sébastien Ferré 9afe174 

Sébastien Ferré e850a59 
Sébastien Ferré 9afe174 
Sébastien Ferré e850a59 
Sébastien Ferré 9afe174 








Sébastien Ferré 45e2163 
Sébastien Ferré 9afe174 
Sébastien Ferré e850a59 
Sébastien Ferré 9afe174 


Sébastien Ferré e850a59 
Sébastien Ferré 9afe174 
Sébastien Ferré 45e2163 
Sébastien Ferré e850a59 
Sébastien Ferré 9afe174 

Sébastien Ferré e850a59 
Sébastien Ferré 9afe174 
Sébastien Ferré e850a59 






Sébastien Ferré 9afe174 










Sébastien Ferré 45e2163 
Sébastien Ferré 9afe174 
Sébastien Ferré e850a59 
Sébastien Ferré 9afe174 


Sébastien Ferré e850a59 
Sébastien Ferré 9afe174 
Sébastien Ferré 45e2163 
Sébastien Ferré e850a59 

Sébastien Ferré 9afe174 
Sébastien Ferré e850a59 

Sébastien Ferré 9afe174 
Sébastien Ferré e850a59 












Sébastien Ferré 9afe174 













Sébastien Ferré e850a59 
Sébastien Ferré 9afe174 
Sébastien Ferré e850a59 
Sébastien Ferré 9afe174 

Sébastien Ferré e850a59 



















Sébastien Ferré 9afe174 









Sébastien Ferré 45e2163 
Sébastien Ferré 9afe174 



Sébastien Ferré df9e4eb 




Sébastien Ferré 45e2163 
Sébastien Ferré df9e4eb 
Sébastien Ferré 45e2163 
Sébastien Ferré df9e4eb 


Sébastien Ferré 9afe174 



Sébastien Ferré 45e2163 
Sébastien Ferré dc8d928 
Sébastien Ferré 2b9f0b8 
Sébastien Ferré dc8d928 




Sébastien Ferré 2b9f0b8 

Sébastien Ferré 45e2163 
Sébastien Ferré 2b9f0b8 


Sébastien Ferré dc8d928 

Sébastien Ferré 45e2163 
Sébastien Ferré 2b9f0b8 
Sébastien Ferré dc8d928 



Sébastien Ferré 45e2163 
Sébastien Ferré 9afe174 






Sébastien Ferré 45e2163 
Sébastien Ferré 2b9f0b8 
Sébastien Ferré 9afe174 

Sébastien Ferré 2b9f0b8 

Sébastien Ferré 45e2163 
Sébastien Ferré 2b9f0b8 






Sébastien Ferré 45e2163 
Sébastien Ferré 2b9f0b8 




Sébastien Ferré 45e2163 
Sébastien Ferré 2b9f0b8 








Sébastien Ferré 45e2163 
Sébastien Ferré 2b9f0b8 
Sébastien Ferré 45e2163 
Sébastien Ferré 2b9f0b8 






Sébastien Ferré 45e2163 
Sébastien Ferré 2b9f0b8 








Sébastien Ferré 45e2163 
Sébastien Ferré 2b9f0b8 




Sébastien Ferré 45e2163 
Sébastien Ferré 2b9f0b8 






Sébastien Ferré 9afe174 
Sébastien Ferré df9e4eb 
Sébastien Ferré 9afe174 





Sébastien Ferré df9e4eb 
Sébastien Ferré 9afe174 















Sébastien Ferré df9e4eb 
Sébastien Ferré 9afe174 

Sébastien Ferré df9e4eb 
Sébastien Ferré 9afe174 





Sébastien Ferré 45e2163 

Sébastien Ferré 9afe174 
Sébastien Ferré 2b9f0b8 
Sébastien Ferré 9afe174 
Sébastien Ferré e850a59 
Sébastien Ferré 9afe174 




Sébastien Ferré e850a59 

Sébastien Ferré 9afe174 
Sébastien Ferré e850a59 
Sébastien Ferré 9afe174 
Sébastien Ferré e850a59 
Sébastien Ferré 9afe174 

Sébastien Ferré 45e2163 

Sébastien Ferré 9afe174 


Sébastien Ferré 2b9f0b8 
Sébastien Ferré 9afe174 


let trace = ref false

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


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

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

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

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

let fail = new fail

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

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

let rise = new rise


class ['ctx, 'res0, 'res, 'cursor, 'msg] map (parse : ('ctx, 'res0, 'cursor, 'msg) parse) (f : 'res0 -> 'res) (ctx : 'ctx) (cursor : 'cursor) =
  object (self)
    val mutable state = `Begin (parse ctx cursor)

    method next =
      match state with
      | `Begin p ->
	  ( match p # next with
	  | Parsed (ctx1, res0, cursor') ->
	      Parsed (ctx1, f res0, cursor')
	  | Failed msgs ->
	      state <- `End msgs;
	      self#next)
      | `End msgs -> Failed msgs
  end

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

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

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

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

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

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

class ['ctx, 'res1, 'res, 'cursor, 'msg] seq (parse1 : ('ctx,'res1,'cursor,'msg) parse) (parse2 : 'res1 -> ('ctx,'res,'cursor,'msg) parse) (ctx : 'ctx) (cursor : 'cursor) =
  object (self)
    val mutable state = `First ([], parse1 ctx cursor)

    method next =
      match state with
      | `First (msgs, p1) ->
	  ( match p1 # next with
	  | Parsed (ctx1, res1, cursor1) ->
	      state <- `Second (msgs, p1, parse2 res1 ctx1 cursor1);
	      self # next
	  | Failed msgs1 ->
	      state <- `End (msgs1 @ msgs);
	      self # next)
      | `Second (msgs, p1,p2) ->
	  ( match p2 # next with
	  | Parsed _ as x -> x
	  | Failed msgs2 ->
	      state <- `First (msgs2 @ msgs, p1);
	      self # next)
      | `End msgs -> 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,'cursor,'msg] cut (parse1 : ('ctx,'res1,'cursor,'msg) parse) (parse2 : 'res1 -> ('ctx,'res,'cursor,'msg) parse) (parse3 : ('ctx,'res,'cursor,'msg) parse) (ctx : 'ctx) (cursor : 'cursor) =
  object (self)
    val mutable state = `First (parse1 ctx cursor)

    method next =
      match state with
      | `First p1 ->
	  ( match p1 # next with
	  | Parsed (ctx1, res1, cursor1) ->
	      if cursor#at_init then cursor1#init; (* forgetting the past *)
	      state <- `Second (parse2 res1 ctx1 cursor1);
	      self # next
	  | Failed msgs1 ->
	      state <- `Third (msgs1, parse3 ctx cursor);
	      self # next)
      | `Second p2 ->
	  ( match p2 # next with
	  | Parsed _ as x -> x
	  | Failed msgs2 ->
	      state <- `End msgs2;
	      self#next)
      | `Third (msgs, p3) ->
	  ( match p3 # next with
	  | Parsed _ as x -> x
	  | Failed msgs3 ->
	      state <- `End (msgs3 @ msgs);
	      self#next)
      | `End msgs -> Failed msgs
  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,'cursor,'msg] guard (parse1 : ('ctx,'res,'cursor,'msg) parse) (name : string) (pred : 'res -> bool) (ctx : 'ctx) (cursor : 'cursor) =
  object (self)
    val mutable state = `Begin ([], parse1 ctx cursor)

    method next =
      match state with
      | `Begin (msgs, p1) ->
	  ( match p1 # next with
	  | Parsed (ctx1, res1, cursor1) as x ->
	      if pred res1
	      then x
	      else begin
		let coord = cursor#coord in
		let msg = Msg.make name [||] (Msg.Locator.Point coord) in
		state <- `Begin (msg::msgs, p1);
		self # next
	      end
	  | Failed msgs1 ->
(*
	      let coord = cursor#coord in
	      let msg = Msg.make name [||] (Msg.Locator.Point coord) in
*)
	      state <- `End (msgs1 @ msgs);
	      self#next)
      | `End msgs -> Failed 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,'cursor,'msg] check (name : string) (pred : unit -> bool) (ctx : 'ctx) (cursor : 'cursor) =
  object (self)
    val mutable state = `Begin

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

let check = new check

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

    method next =
      match state with
      | None ->
	  state <- Some (f ());
	  if state = Some []
	  then
	    let coord = cursor#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, cursor)
      | Some [] -> Failed []
  end

let enum = new enum

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

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

let get_context = new get_context

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

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

let set_context = new set_context

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

    method next =
      match state with
      | `Begin ->
	  state <- `End;
	  if pred ctx
	  then
	    Parsed (ctx, ctx, cursor)
	  else
	    let coord = cursor#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,'cursor] enum_context (name : string) (f : 'ctx -> 'ctx list) (ctx : 'ctx) (cursor : 'cursor) =
  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 = cursor#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, (), cursor)
      | 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 cursor =
  let p = parse ctx cursor in
  match p # next with
  | Parsed (ctx, x, _) -> ctx, x
  | Failed [] ->
      raise (SyntaxError (1,1,"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.Msg.phrase)
	    else if best_coord = coord then (best_coord, msg.Msg.phrase ^ "; " ^ best_msg)
	    else (best_coord, best_msg))
	  (Msg.Locator.start msg.Msg.loc, msg.Msg.phrase)
	  msgs in
      raise (SyntaxError (line, col, best_msg))

(* returns all parsing results *)
let all parse ctx cursor =
  let p = parse ctx cursor 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