Source

ocaml-lib / dcg / dcg.ml

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





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

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




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






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






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


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




Sébastien Ferré df9e4eb 
Sébastien Ferré 2b9f0b8 
Sébastien Ferré df9e4eb 


Sébastien Ferré 2b9f0b8 
Sébastien Ferré df9e4eb 


Sébastien Ferré 2b9f0b8 
Sébastien Ferré df9e4eb 




Sébastien Ferré 9afe174 


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

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

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








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



















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

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






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


























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

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





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


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






















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


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



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











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



Sébastien Ferré df9e4eb 




Sébastien Ferré 2b9f0b8 
Sébastien Ferré df9e4eb 
Sébastien Ferré 2b9f0b8 
Sébastien Ferré df9e4eb 


Sébastien Ferré 9afe174 



Sébastien Ferré 2b9f0b8 
Sébastien Ferré dc8d928 
Sébastien Ferré 2b9f0b8 
Sébastien Ferré dc8d928 




Sébastien Ferré 2b9f0b8 





Sébastien Ferré dc8d928 

Sébastien Ferré 2b9f0b8 

Sébastien Ferré dc8d928 



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






Sébastien Ferré 2b9f0b8 

Sébastien Ferré 9afe174 

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é 2b9f0b8 

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














Sébastien Ferré 2b9f0b8 

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