Commits

Sébastien Ferré committed 456ee21

[dcg] simplifications and optimisations (no skip, deterministic MANY/SOME/LIST)

Comments (0)

Files changed (3)

 let get_trace () = !trace
 let set_trace b = trace := b
 
-let union_msgs msgs1 msgs2 =
-  List.filter (fun msg1 -> not (List.mem msg1 msgs2)) msgs1 @ msgs2
+let union_msgs msgs1 msgs2 = Common.prof "Dcg.union_msgs" (fun () -> LSet.union msgs1 msgs2)
 
 
-type ('cursor, 'ctx, 'res, 'msg) result = Parsed of 'ctx * 'res * 'cursor | Failed of 'msg list
+type ('cursor, 'ctx, 'res, 'msg) result = Parsed of 'ctx * 'res * 'cursor | Failed of 'msg LSet.t
 
 class type ['ctx, 'res, 'cursor, 'msg] p =
   object
 class ['ctx,'res,'cursor,'msg] fail (ctx : 'ctx) (cursor : 'cursor) =
   object (self)
     method next : ('cursor, 'ctx, 'res, 'msg) result =
-      Failed ([] : 'msg list)
+      Failed ([] : 'msg LSet.t)
   end
 
 let fail = new fail
 
 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)
 	  state <- `End;
 	  Parsed (ctx, res, cursor)
       | `End ->
-	  Failed ([] : 'msg list) 
+	  Failed ([] : 'msg list)
   end
 
 let ret = new ret
 	      else begin
 		let coord = cursor#coord in
 		let msg = Msg.make name [||] (Msg.Locator.Point coord) in
-		state <- `Begin (msg::msgs, p1);
+		state <- `Begin (LSet.add msg msgs, p1);
 		self # next
 	      end
 	  | Failed msgs1 ->
   
 let enum_context = new enum_context
 
+class ['ctx, 'elt, 'cursor, 'msg] many (parse : ('ctx,'elt,'cursor,'msg) parse) (ctx : 'ctx) (cursor : 'cursor) =
+  object (self)
+    val mutable state = `Loop (ctx, [], cursor)
+
+    method next =
+      match state with
+      | `Loop (ctx,rev_l,cursor) ->
+	  ( match (parse ctx cursor) # next with
+	  | Parsed (ctx1, elt, cursor1) ->
+	      state <- `Loop (ctx1, elt::rev_l, cursor1);
+	      self # next
+	  | Failed _ ->
+	      state <- `End;
+	      Parsed (ctx, List.rev rev_l, cursor) )
+      | `End -> Failed ([] : 'msg list)
+  end
+
+let many = new many
+let some parse = parse |> fun x -> many parse --> (fun xs -> x::xs)
+
+class ['ctx, 'elt, 'sep, 'cursor, 'msg] list1_aux (p_elt : ('ctx,'elt,'cursor,'msg) parse) (p_sep : ('ctx,'sep,'cursor,'msg) parse) (ctx : 'ctx) (cursor : 'cursor) =
+  object (self)
+    val mutable state = `Loop (ctx, [], cursor)
+
+    method next =
+      match state with
+      | `Loop (ctx,rev_l,cursor) ->
+	  ( match (p_sep ctx cursor) # next with
+	  | Parsed (ctx1,_,cursor1) ->
+	      ( match (p_elt ctx1 cursor1) # next with
+	      | Parsed (ctx2,elt,cursor2) ->
+		  state <- `Loop (ctx2, elt::rev_l, cursor2);
+		  self#next
+	      | Failed msgs2 ->
+		  state <- `End;
+		  Parsed (ctx, List.rev rev_l, cursor) )
+	  | Failed msgs1 ->
+	      state <- `End;
+	      Parsed (ctx, List.rev rev_l, cursor) )
+      | `End -> Failed ([] : 'msg list)
+  end
+
+let list1_aux = new list1_aux
+
+let list1 p_elt p_sep = p_elt |> fun x -> list1_aux p_elt p_sep --> (fun xs -> x::xs)
+let list0 p_elt p_sep = (list1 p_elt p_sep) <|> (ret [])
+
 
 (* combinators *)
 
    p ? ==> opt p
 *)
 
-let rec many parse = (parse |> fun x -> many parse --> (fun xs -> x::xs)) <|> (ret [])
-let (<*>) = many
+let rec star parse = (parse |> fun x -> star parse --> (fun xs -> x::xs)) <|> (ret [])
+let (<*>) = star
 
 (* syntaxe ideale
-   p * ==> many p
+   p * ==> star p
 *)
 
-let some parse = parse |> fun x -> many parse --> (fun xs -> x::xs)
-let (<+>) = some
+let plus parse = parse |> fun x -> star parse --> (fun xs -> x::xs)
+let (<+>) = plus
 
 (* 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 =
 
 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 once parse ctx cursor = Common.prof "Dcg.once" (fun () ->
   let p = parse ctx cursor in
   match p # next with
   | Parsed (ctx, x, _) -> ctx, x
 	    else (best_coord, best_msg))
 	  (Msg.Locator.start msg.Msg.loc, msg.Msg.phrase)
 	  msgs in
-      raise (SyntaxError (line, col, best_msg))
+      raise (SyntaxError (line, col, best_msg)))
 
 (* returns all parsing results *)
-let all parse ctx cursor =
+let all parse ctx cursor = Common.prof "Dcg.all" (fun () ->
   let p = parse ctx cursor in
   let res = ref [] in
   begin try while true do
     | Parsed (ctx, x, _) -> res := (ctx, x) :: !res
     | Failed _ -> raise Not_found
   done with Not_found -> () end;
-  !res
+  !res)
 OCAMLC=ocamlc
-INCLUDES=                # all relevant -I options here
+INCLUDES= -I ..               # all relevant -I options here
 OCAMLFLAGS= $(INCLUDES)    # add other options for ocamlc here
 OCAMLDOCFLAGS= -d doc $(INCLUDES)
 
 
   end
 
-let string_match regexp s pos =
+let string_match regexp s pos = Common.prof "Matcher.string_match" (fun () ->
   if Str.string_match regexp s pos
   then Some (Str.matched_string s)
-  else None
+  else None)
 
 class virtual str =
   object
     method virtual get : Str.regexp -> int -> string option
     method virtual look : string -> int -> bool
     method virtual eof : int -> bool
-(*    method virtual at_eof : int -> bool *)
     method virtual at_init : int -> bool
     method virtual set_init : int -> unit
   end
 
     method eof p = (p >= len)
 
-(*    method at_eof p = (p >= len) *)
-
     method at_init p = (p <= offset)
 
     method set_init p = offset <- p
     val mutable len = String.length s0
     val mutable eof = eof0
 
-    method private expand =
+    method private expand = Common.prof "Matcher.str_channel#expand" (fun () ->
       try
 	s <- s ^ input_line ch ^ "\n";
 	len <- String.length s
       with End_of_file ->
-	eof <- true
+	eof <- true)
 
     method get regexp p =
       let pos = p-offset in
       assert (pos >= 0 && pos <= len);
       let res = ref (string_match regexp s pos) in
-      while not eof && !res = None && Str.string_partial_match regexp s pos do
+      while not eof &&
+	( match !res with
+	| Some w -> pos + String.length w >= len
+	| None -> Str.string_partial_match regexp s pos)
+      do
 	self#expand;
 	res := string_match regexp s pos
       done;
       done;
       eof && pos >= len
 
-(*
-    method at_eof p =
-      let pos = p-offset in
-      eof && pos >= len
-*)
-
     method at_init p =
       let pos = p-offset in
       pos <= 0
   in
   inner b (line, col)
 
-class cursor (skip : Str.regexp) (str : str) (p : int) (coord : Msg.Coord.t) =
+class cursor (*skip : Str.regexp*) (str : str) (p : int) (coord : Msg.Coord.t) =
   object (self)
     method coord = coord
 
-    method get (regexp : Str.regexp) : string option = str#get regexp p
+    method get (regexp : Str.regexp) : string option = 
+      Common.prof "Matcher.cursor#get" (fun () -> str#get regexp p)
 
-    method look (m : string) : bool = str#look m p
+    method look (m : string) : bool =
+      Common.prof "Matcher.cursor#look" (fun () -> str#look m p)
 
     method eof : bool = str#eof p
 
-(*    method at_eof : bool = str#at_eof p *)
-
     method at_init : bool = str#at_init p
 
-    method skip : cursor =
+(*
+    method skip : cursor = Common.prof "Matcher.cursor#skip" (fun () ->
       match str#get skip p with
       | Some m when m <> "" -> (self#shift m)#skip
-      | _ -> (self :> cursor)
+      | _ -> (self :> cursor))
+*)
 
-    method shift (m : string) : cursor =
+    method shift (m : string) : cursor = Common.prof "Matcher.cursor#shift" (fun () ->
       let len = String.length m in
       let p' = p + len in
       let coord' = shiftPos coord m 0 len in
-      new cursor skip str p' coord'
+      new cursor (*skip*) str p' coord')
 
     method init : unit =
 (*      print_endline (Token.toString ("init", coord)); *)
 
   end
 
-let cursor_of_string skip s = new cursor skip (new str_string s) 0 (1,1)
-let cursor_of_channel skip ch = new cursor skip (new str_channel ch) 0 (1,1)
+let cursor_of_string (*skip*) s = new cursor (*skip*) (new str_string s) 0 (1,1)
+let cursor_of_channel (*skip*) ch = new cursor (*skip*) (new str_channel ch) 0 (1,1)
 
 
 class ['ctx,'res] get (name : string) (regexp : Str.regexp) (f : Token.t -> 'res) (ctx : 'ctx) (cursor : cursor) =
       match state with
       | `Begin ->
 	  state <- `End;
-	  let cursor = cursor#skip in
+(*	  let cursor = cursor#skip in *)
 	  ( match cursor#get regexp with
 	  | Some m ->
 	      Parsed (ctx, f (m, cursor#coord), cursor#shift m)
 	  | None ->
-	      Failed [Msg.make (sprintf "%s expected" name) [||] (Msg.Locator.Point cursor#coord)])
+	      Failed [Msg.make (name ^ " expected") [||] (Msg.Locator.Point cursor#coord)])
       | `End -> Failed []
   end
 
   object (self)
     val mutable state = `Begin
 	
-    method next = 
+    method next =
       match state with
       | `Begin ->
 	  state <- `End;
-	  let cursor = cursor#skip in
+(*	  let cursor = cursor#skip in *)
 	  if cursor#look m
 	  then Parsed (ctx, (m, cursor#coord), cursor#shift m)
-	  else Failed [Msg.make (sprintf "'%s' expected" m) [||] (Msg.Locator.Point cursor#coord)]
+	  else Failed [Msg.make ("'" ^ m ^ "' expected") [||] (Msg.Locator.Point cursor#coord)]
       | `End -> Failed []
   end
 
       match state with
       | `Begin ->
 	  state <- `End;
-	  let cursor = cursor#skip in
+(*	  let cursor = cursor#skip in *)
 	  if cursor#eof
 	  then Parsed (ctx, ("<EOF>", cursor#coord), cursor)
 	  else Failed [Msg.make "<EOF> expected" [||] (Msg.Locator.Point cursor#coord)]
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.