(****************************************************************************)

(*                                                                          *)

(*                                   OCaml                                  *)

(*                                                                          *)

(*                            INRIA Rocquencourt                            *)

(*                                                                          *)

(*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)

(*  en Automatique.  All rights reserved.  This file is distributed under   *)

(*  the terms of the GNU Library General Public License, with the special   *)

(*  exception on linking described in LICENSE at the top of the Camlp4      *)

(*  source tree.                                                            *)

(*                                                                          *)

(****************************************************************************)

(* Authors:

 * - Daniel de Rauglaudre: initial version

 * - Nicolas Pouillard: refactoring

 *)

(* PR#5090: don't do lookahead on get_prev_loc. *)

value get_prev_loc_only = ref False;

module Make (Structure : Structure.S) = struct

  open Structure;

  value empty_entry ename _ =

    raise (Stream.Error ("entry [" ^ ename ^ "] is empty"));

  value rec stream_map f = parser

    [ [: ` x; strm :] -> [: ` (f x); stream_map f strm :]

    | [: :] -> [: :] ];

  value keep_prev_loc strm =

    match Stream.peek strm with

    [ None -> [: :]

    | Some (tok0,init_loc) ->

      let rec go prev_loc strm1 =

        if get_prev_loc_only.val then

          [: `(tok0, {prev_loc; cur_loc = prev_loc; prev_loc_only = True});

             go prev_loc strm1 :]

        else

          match strm1 with parser

          [ [: `(tok,cur_loc); strm :] ->

              [: `(tok, {prev_loc; cur_loc; prev_loc_only = False});

                 go cur_loc strm :]

          | [: :] -> [: :] ]

      in go init_loc strm ];

  value drop_prev_loc strm = stream_map (fun (tok,r) -> (tok,r.cur_loc)) strm;

  value get_cur_loc strm =

    match Stream.peek strm with

    [ Some (_,r) -> r.cur_loc

    | None -> Loc.ghost ];

  value get_prev_loc strm =

    begin

      get_prev_loc_only.val := True;

      let result = match Stream.peek strm with

        [ Some (_, {prev_loc; prev_loc_only = True}) ->

            begin Stream.junk strm; prev_loc end

        | Some (_, {prev_loc; prev_loc_only = False}) -> prev_loc

        | None -> Loc.ghost ];

      get_prev_loc_only.val := False;

      result

    end;

  value is_level_labelled n lev =

    match lev.lname with

    [ Some n1 -> n = n1

    | None -> False ];

  value warning_verbose = ref True;

  value rec get_token_list entry tokl last_tok tree =

    match tree with

    [ Node {node = (Stoken _ | Skeyword _ as tok); son = son; brother = DeadEnd} ->

        get_token_list entry [last_tok :: tokl] tok son

    | _ ->

        if tokl = [] then None

        else Some (List.rev [last_tok :: tokl], last_tok, tree) ];

  value is_antiquot s =

    let len = String.length s in

    len > 1 && s.[0] = '$';

  value eq_Stoken_ids s1 s2 =

    not (is_antiquot s1) && not (is_antiquot s2) && s1 = s2;

  value logically_eq_symbols entry =

    let rec eq_symbols s1 s2 =

      match (s1, s2) with

      [ (Snterm e1, Snterm e2) -> e1.ename = e2.ename

      | (Snterm e1, Sself) -> e1.ename = entry.ename

      | (Sself, Snterm e2) -> entry.ename = e2.ename

      | (Snterml e1 l1, Snterml e2 l2) -> e1.ename = e2.ename && l1 = l2

      | (Slist0 s1, Slist0 s2) |

        (Slist1 s1, Slist1 s2) |

        (Sopt s1, Sopt s2) |

        (Stry s1, Stry s2) -> eq_symbols s1 s2

      | (Slist0sep s1 sep1, Slist0sep s2 sep2) |

        (Slist1sep s1 sep1, Slist1sep s2 sep2) ->

          eq_symbols s1 s2 && eq_symbols sep1 sep2

      | (Stree t1, Stree t2) -> eq_trees t1 t2

      | (Stoken (_, s1), Stoken (_, s2)) -> eq_Stoken_ids s1 s2

      | _ -> s1 = s2 ]

    and eq_trees t1 t2 =

      match (t1, t2) with

      [ (Node n1, Node n2) ->

          eq_symbols n1.node n2.node && eq_trees n1.son n2.son &&

          eq_trees n1.brother n2.brother

      | (LocAct _ _ | DeadEnd, LocAct _ _ | DeadEnd) -> True

      | _ -> False ]

    in

    eq_symbols;

  value rec eq_symbol s1 s2 =

    match (s1, s2) with

    [ (Snterm e1, Snterm e2) -> e1 == e2

    | (Snterml e1 l1, Snterml e2 l2) -> e1 == e2 && l1 = l2

    | (Slist0 s1, Slist0 s2) |

      (Slist1 s1, Slist1 s2) |

      (Sopt s1, Sopt s2) |

      (Stry s1, Stry s2) -> eq_symbol s1 s2

    | (Slist0sep s1 sep1, Slist0sep s2 sep2) |

      (Slist1sep s1 sep1, Slist1sep s2 sep2) ->

        eq_symbol s1 s2 && eq_symbol sep1 sep2

    | (Stree _, Stree _) -> False

    | (Stoken (_, s1), Stoken (_, s2)) -> eq_Stoken_ids s1 s2

    | _ -> s1 = s2 ]

  ;

end;