Source file uRe.ml

# 1 "Camomile/public/uRe.ml"
(** Regular expression engine. *)

(* Copyright (C) 2003 Yamagata Yoriyuki. distributed with LGPL *)

(* This library is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2 of *)
(* the License, or (at your option) any later version. *)

(* As a special exception to the GNU Library General Public License, you *)
(* may link, statically or dynamically, a "work that uses this library" *)
(* with a publicly distributed version of this library to produce an *)
(* executable file containing portions of this library, and distribute *)
(* that executable file under terms of your choice, without any of the *)
(* additional requirements listed in clause 6 of the GNU Library General *)
(* Public License. By "a publicly distributed version of this library", *)
(* we mean either the unmodified Library as distributed by the authors, *)
(* or a modified version of this library that is distributed under the *)
(* conditions defined in clause 3 of the GNU Library General Public *)
(* License. This exception does not however invalidate any other reasons *)
(* why the executable file might be covered by the GNU Library General *)
(* Public License . *)

(* This library is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU *)
(* Lesser General Public License for more details. *)

(* You should have received a copy of the GNU Lesser General Public *)
(* License along with this library; if not, write to the Free Software *)
(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 *)
(* USA *)

(* You can contact the authour by sending email to *)
(* yoriyuki.y@gmail.com *)

type regexp  =
  [ `Alt of regexp * regexp
  | `Seq of regexp * regexp
  | `Rep of regexp
  | `Repn of regexp * int * int option
  | `After of regexp
  | `Before of regexp
  | `Epsilon
  | `Group of regexp
  | `OneChar
  | `String of UChar.t list
  | `Set of USet.t
  | `BoS
  | `EoS ]

type match_semantics = [ `First | `Shortest | `Longest ]

let rec no_group  = function
    `Alt (r1, r2) -> `Alt (no_group r1, no_group r2)
  | `Seq (r1, r2) -> `Alt (no_group r1, no_group r2)
  | `Rep r -> `Rep (no_group r)
  | `Group r -> r
  | r -> r

module type Type = sig
  type text
  type index
  type compiled_regexp

  module SubText : 
    SubText.Type with type ur_text = text and type ur_index = index

  val compile : regexp -> compiled_regexp

  val regexp_match : ?sem:match_semantics ->
    compiled_regexp -> text -> index -> SubText.t option array option
  val string_match : compiled_regexp -> text -> index -> bool
  val search_forward : ?sem:match_semantics ->
    compiled_regexp -> text -> index -> SubText.t option array option
end

module Make (Text : UnicodeString.Type) = struct
  type text = Text.t
  type index = Text.index

  module SubText = SubText.Make (Text)

  type instr  =
      String of UChar.t list
    | OneChar
    | Set of USet.t
    | Par of instr * instr
    | Seq of instr * instr
    | Rep of instr
    | Repn of instr * int * int option
    | Epsilon
    | Group of int * instr
    | BoS
    | EoS
    | Before of instr
    | After of instr
    | Group_end of int * Text.index

  type compiled_regexp = int * instr

  let compile (r : regexp) = 
    let rec loop n = function
        `Alt (r1, r2) ->
        let n, r1 = loop n r1 in
        let n, r2 = loop n r2 in
        n, Par (r1, r2)
      | `Seq (r1, r2) ->
        let n, r1 = loop n r1 in
        let n, r2 = loop n r2 in
        n, Seq (r1, r2)
      | `Rep r ->
        let n, r = loop n r in
        n, Rep r
      | `Repn (r, n, m) ->
        let n, r = loop n r in
        n, Repn (r, n, m)
      | `Group r ->
        let n', r = loop (n + 1) r in
        n', Group (n, r)
      | `Epsilon -> n, Epsilon
      | `String s -> n, String s
      | `OneChar -> n, OneChar
      | `Set s -> n, Set s
      | `BoS -> n, BoS
      | `EoS -> n, EoS
      | `After r ->
        let n, r = loop n r in
        n, After r
      | `Before r ->
        let n, r = loop n r in
        n, Before r in
    loop 1 r

  let rec string_match t i = function
      [] -> i
    | u :: rest ->
      if Text.out_of_range t i then raise Exit else
      if UChar.eq (Text.look t i) u then
        string_match t (Text.next t i) rest
      else
        raise Exit

  let reverse_string_match t i us =
    let us = List.rev us in
    let rec loop i  = function
        [] -> i
      | u :: rest ->
        if Text.out_of_range t i then raise Exit else
        if UChar.eq (Text.look t i) u then
          loop (Text.prev t i) rest
        else
          raise Exit in
    loop i us

  let dec_opt = function
      None -> None
    | Some m -> Some (m - 1)

  let rec exec_first groups t i = function
    | [] -> i, groups
    | Seq (r1, r2) :: rest ->
      exec_first groups t i (r1 :: r2 :: rest)
    | Rep r :: rest as rs -> 
      (try exec_first groups t i rest with Exit -> 
         exec_first groups t i (r :: rs))
    | Repn (r, n, m) :: rest ->
      if n > 0 then
        exec_first groups t i (r :: Repn (r, n-1, dec_opt m) :: rest)
      else (match m with
            None ->
            exec_first groups t i (Rep r :: rest)
          | Some m ->
            if m <= 0 then exec_first groups t i rest else
              let s = Repn (r, 0, Some (m-1)) in
              try exec_first groups t i rest with Exit ->
                exec_first groups t i (r :: s :: rest))
    | Par (r1, r2) :: rest -> 
      (try exec_first groups t i (r1 :: rest) with Exit -> 
         exec_first groups t i (r2 :: rest))
    | Group (n, r) :: rest ->
      exec_first groups t i (r :: Group_end (n, i) :: rest)
    | Group_end (n, i0) :: rest ->
      let s = SubText.refer t i0 i in
      exec_first ((n, s) :: groups) t i rest
    | String t0 :: rest -> 
      exec_first groups t (string_match t i t0) rest
    | OneChar :: rest ->
      if Text.out_of_range t i then raise Exit else
        exec_first groups t (Text.next t i) rest
    | Set s :: rest -> 
      (if Text.out_of_range t i then raise Exit else
         match USet.mem (Text.look t i) s with
           true -> exec_first groups t (Text.next t i) rest
         | false -> raise Exit)
    | Epsilon :: rest -> exec_first groups t i rest
    | BoS :: rest ->
      if Text.compare_index t i (Text.nth t 0) > 0 then raise Exit else
        exec_first groups t i rest
    | EoS :: rest ->
      if Text.compare_index t i (Text.last t) <= 0 then raise Exit else
        exec_first groups t i rest
    | After r :: rest ->
      let _, groups = reverse groups t i [r] in
      exec_first groups t i rest
    | Before r :: rest ->
      let _, groups = exec_first groups t i [r] in
      exec_first groups t i rest
  and reverse g t i = function
    | [] -> i, g
    | Seq (r1, r2) :: rest ->
      reverse g t i (r2 :: r1 :: rest)
    | Rep r :: rest as rs -> 
      (try reverse g t i rest with Exit -> 
         reverse g t i (r :: rs))
    | Repn (r, n, m) :: rest ->
      if n > 0 then
        reverse g t i (r :: Repn (r, n-1, dec_opt m) :: rest)
      else (match m with
            None ->
            reverse g t i (Rep r :: rest)
          | Some m ->
            if m <= 0 then reverse g t i rest else
              let s = Repn (r, 0, Some (m-1)) in
              try reverse g t i rest with Exit ->
                reverse g t i (r :: s :: rest))
    | Par (r1, r2) :: rest -> 
      (try reverse g t i (r1 :: rest) with Exit -> 
         reverse g t i (r2 :: rest))
    | Group (n, r) :: rest ->
      reverse g t i (r :: Group_end (n, i) :: rest)
    | Group_end (n, j) :: rest ->
      let s = SubText.refer t i j in
      reverse ((n, s) :: g) t i rest
    | String t0 :: rest -> 
      reverse g t (reverse_string_match t i t0) rest
    | OneChar :: rest ->
      if Text.out_of_range t i then raise Exit else
        reverse g t (Text.prev t i) rest
    | Set s :: rest -> 
      (if Text.out_of_range t i then raise Exit else
         match USet.mem (Text.look t i) s with
           true -> reverse g t (Text.prev t i) rest
         | false -> raise Exit)
    | Epsilon :: rest -> reverse g t i rest
    | BoS :: rest ->
      if Text.compare_index t i (Text.nth t 0) > 0 then raise Exit else
        reverse g t i rest
    | EoS :: rest ->
      if Text.compare_index t i (Text.last t) <= 0 then raise Exit else
        reverse g t i rest
    | After r :: rest ->
      let _, g = reverse g t i [r] in
      reverse g t i rest
    | Before r :: rest ->
      let _, g = exec_first g t i [r] in
      reverse g t i rest

  let rec exec_longest groups t i = function
    | [] -> i, groups
    | Seq (r1, r2) :: rest ->
      exec_longest groups t i (r1 :: r2 :: rest)
    | Rep r :: rest as rs -> 
      (try
         let i1, g1 = exec_longest groups t i rest in try
           let i2, g2 = exec_longest groups t i (r :: rs) in
           if Text.compare_index t i1 i2 >= 0 then i1, g1 else i2, g2
         with Exit -> 
           i1, g1
       with Exit -> 
         exec_longest groups t i (r :: rs))
    | Repn (r, n, m) :: rest ->
      if n > 0 then
        exec_longest groups t i (r :: Repn (r, n-1, dec_opt m) :: rest)
      else (match m with
            None ->
            exec_longest groups t i (Rep r :: rest)
          | Some m ->
            if m <= 0 then exec_longest groups t i rest else
              let s = Repn (r, 0, Some (m-1)) in 
              try 
                let i1, g1 = exec_longest groups t i rest in 
                try
                  let i2, g2 = exec_longest groups t i (r :: s :: rest) in 
                  if Text.compare_index t i1 i2 >= 0 then i1, g1 else i2, g2
                with Exit ->
                  i1, g1
              with Exit ->
                exec_longest groups t i (r :: s :: rest))
    | Par (r1, r2) :: rest -> 
      (try exec_longest groups t i (r1 :: rest) with Exit -> 
         exec_longest groups t i (r2 :: rest))
    | Group (n, r) :: rest ->
      exec_longest groups t i (r :: Group_end (n, i) :: rest)
    | Group_end (n, i0) :: rest ->
      let s = SubText.refer t i0 i in
      exec_longest ((n, s) :: groups) t i rest
    | String t0 :: rest -> 
      exec_longest groups t (string_match t i t0) rest
    | OneChar :: rest ->
      if Text.out_of_range t i then raise Exit else
        exec_longest groups t (Text.next t i) rest
    | Set s :: rest -> 
      (if Text.out_of_range t i then raise Exit else
         match USet.mem (Text.look t i) s with
           true -> exec_longest groups t (Text.next t i) rest
         | false -> raise Exit)
    | Epsilon :: rest -> exec_longest groups t i rest
    | BoS :: rest ->
      if Text.compare_index t i (Text.nth t 0) > 0 then raise Exit else
        exec_longest groups t i rest
    | EoS :: rest ->
      if Text.compare_index t i (Text.last t) <= 0 then raise Exit else
        exec_longest groups t i rest
    | After r :: rest ->
      let _, g = reverse groups t i [r] in
      exec_longest g t i rest
    | Before r :: rest ->
      let _, g = exec_first groups t i [r] in
      exec_longest g t i rest

  let rec exec_shortest groups t i = function
    | [] -> i, groups
    | Seq (r1, r2) :: rest ->
      exec_shortest groups t i (r1 :: r2 :: rest)
    | Rep r :: rest as rs -> 
      (try
         let i1, g1 = exec_shortest groups t i rest in try
           let i2, g2 = exec_shortest groups t i (r :: rs) in
           if Text.compare_index t i1 i2 <= 0 then i1, g1 else i2, g2
         with Exit -> 
           i1, g1
       with Exit -> 
         exec_shortest groups t i (r :: rs))
    | Repn (r, n, m) :: rest ->
      if n > 0 then
        exec_shortest groups t i (r :: Repn (r, n-1, dec_opt m) :: rest)
      else (match m with
            None ->
            exec_shortest groups t i (Rep r :: rest)
          | Some m ->
            if m <= 0 then exec_shortest groups t i rest else
              let s = Repn (r, 0, Some (m-1)) in 
              try 
                let i1, g1 = exec_shortest groups t i rest in 
                try
                  let i2, g2 = exec_shortest groups t i (r :: s :: rest) in 
                  if Text.compare_index t i1 i2 <= 0 then i1, g1 else i2, g2
                with Exit ->
                  i1, g1
              with Exit ->
                exec_shortest groups t i (r :: s :: rest))
    | Par (r1, r2) :: rest -> 
      (try exec_shortest groups t i (r1 :: rest) with Exit -> 
         exec_shortest groups t i (r2 :: rest))
    | Group (n, r) :: rest ->
      exec_shortest groups t i (r :: Group_end (n, i) :: rest)
    | Group_end (n, i0) :: rest ->
      let s = SubText.refer t i0 i in
      exec_shortest ((n, s) :: groups) t i rest
    | String t0 :: rest -> 
      exec_shortest groups t (string_match t i t0) rest
    | OneChar :: rest ->
      if Text.out_of_range t i then raise Exit else
        exec_shortest groups t (Text.next t i) rest
    | Set s :: rest -> 
      (if Text.out_of_range t i then raise Exit else
         match USet.mem (Text.look t i) s with
           true -> exec_shortest groups t (Text.next t i) rest
         | false -> raise Exit)
    | Epsilon :: rest -> exec_shortest groups t i rest
    | BoS :: rest ->
      if Text.compare_index t i (Text.nth t 0) > 0 then raise Exit else
        exec_shortest groups t i rest
    | EoS :: rest ->
      if Text.compare_index t i (Text.last t) <= 0 then raise Exit else
        exec_shortest groups t i rest
    | After r :: rest ->
      let _, g = reverse groups t i [r] in
      exec_shortest g t i rest
    | Before r :: rest ->
      let _, g = exec_first groups t i [r] in
      exec_shortest g t i rest

  let set_groups groups g =
    let rec loop = function
        [] -> ()
      | (n, s) :: rest -> 
        groups.(n) <- Some s;
        loop rest in
    loop (List.rev g)

  let regexp_match ?(sem=`Longest) (n, r) t i =
    let groups = Array.make n None in
    try match sem with
        `First -> 
        let j, g = exec_first [] t i [r] in
        set_groups groups g;
        groups.(0) <- Some (SubText.refer t i j);
        Some groups
      | `Shortest -> 
        let j, g = exec_shortest [] t i [r] in
        set_groups groups g;
        groups.(0) <- Some (SubText.refer t i j);
        Some groups
      | `Longest ->
        let j, g = exec_longest [] t i [r] in
        set_groups groups g;
        groups.(0) <- Some (SubText.refer t i j);
        Some groups
    with Exit -> None

  let string_match (_, r) t i =
    try ignore (exec_first [] t i [r]); true with Exit -> false

  let search_forward ?(sem=`Longest) ((n, r) as c) t i =
    let groups = Array.make n None in
    let rec scan i =
      if Text.out_of_range t i then None else
        try let j, g = exec_first [] t i [r] in Some (i, j, g) with Exit -> 
          scan (Text.next t i) in
    match scan i with
      Some (i, j, g) ->
      (match sem with
         `First ->
         set_groups groups g;
         groups.(0) <- Some (SubText.refer t i j);
         Some groups
       | _ ->
         regexp_match ~sem c t i)
    | None -> None

end