(* -*- camlp4r -*- *)
(****************************************************************************)
(*                                                                          *)
(*                                   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
 *)

module Make (Structure : Structure.S) = struct
  module Tools = Tools.Make Structure;
  module Parser = Parser.Make Structure;
  open Structure;
  open Format;
  open Sig.Grammar;

  value is_before s1 s2 =
    match (s1, s2) with
    [ (Skeyword _ | Stoken _, Skeyword _ | Stoken _) -> False
    | (Skeyword _ | Stoken _, _) -> True
    | _ -> False ]
  ;
  value rec derive_eps =
    fun
    [ Slist0 _ | Slist0sep _ _ | Sopt _ -> True
    | Stry s -> derive_eps s
    | Stree t -> tree_derive_eps t
    | Slist1 _ | Slist1sep _ _ | Stoken _ | Skeyword _ ->
        (* For sure we cannot derive epsilon from these *)
        False
    | Smeta _ _ _ | Snterm _ | Snterml _ _ | Snext | Sself ->
        (* Approximation *)
        False ]
  and tree_derive_eps =
    fun
    [ LocAct _ _ -> True
    | Node {node = s; brother = bro; son = son} ->
        derive_eps s && tree_derive_eps son || tree_derive_eps bro
    | DeadEnd -> False ]
  ;

  value empty_lev lname assoc =
    let assoc =
      match assoc with
      [ Some a -> a
      | None -> LeftA ]
    in
    {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd}
  ;
  value change_lev entry lev n lname assoc =
    let a =
      match assoc with
      [ None -> lev.assoc
      | Some a ->
          do {
            if a <> lev.assoc && entry.egram.warning_verbose.val then do {
              eprintf "<W> Changing associativity of level \"%s\"\n" n;
              flush Pervasives.stderr
            }
            else ();
            a
          } ]
    in
    do {
      match lname with
      [ Some n ->
          if lname <> lev.lname && entry.egram.warning_verbose.val then do {
            eprintf "<W> Level label \"%s\" ignored\n" n; flush Pervasives.stderr
          }
          else ()
      | None -> () ];
      {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix;
      lprefix = lev.lprefix}
    }
  ;
  value change_to_self entry =
    fun
    [ Snterm e when e == entry -> Sself
    | x -> x ]
  ;


  value get_level entry position levs =
    match position with
    [ Some First -> ([], empty_lev, levs)
    | Some Last -> (levs, empty_lev, [])
    | Some (Level n) ->
        let rec get =
          fun
          [ [] ->
              do {
                eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
                  entry.ename;
                flush Pervasives.stderr;
                failwith "Grammar.extend"
              }
          | [lev :: levs] ->
              if Tools.is_level_labelled n lev then ([], change_lev entry lev n, levs)
              else
                let (levs1, rlev, levs2) = get levs in
                ([lev :: levs1], rlev, levs2) ]
        in
        get levs
    | Some (Before n) ->
        let rec get =
          fun
          [ [] ->
              do {
                eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
                  entry.ename;
                flush Pervasives.stderr;
                failwith "Grammar.extend"
              }
          | [lev :: levs] ->
              if Tools.is_level_labelled n lev then ([], empty_lev, [lev :: levs])
              else
                let (levs1, rlev, levs2) = get levs in
                ([lev :: levs1], rlev, levs2) ]
        in
        get levs
    | Some (After n) ->
        let rec get =
          fun
          [ [] ->
              do {
                eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
                  entry.ename;
                flush Pervasives.stderr;
                failwith "Grammar.extend"
              }
          | [lev :: levs] ->
              if Tools.is_level_labelled n lev then ([lev], empty_lev, levs)
              else
                let (levs1, rlev, levs2) = get levs in
                ([lev :: levs1], rlev, levs2) ]
        in
        get levs
    | None ->
        match levs with
        [ [lev :: levs] -> ([], change_lev entry lev "<top>", levs)
        | [] -> ([], empty_lev, []) ] ]
  ;

  value rec check_gram entry =
    fun
    [ Snterm e ->
        if e.egram != entry.egram then do {
          eprintf "\
  Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n"
            entry.ename e.ename;
          flush Pervasives.stderr;
          failwith "Grammar.extend error"
        }
        else ()
    | Snterml e _ ->
        if e.egram != entry.egram then do {
          eprintf "\
  Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n"
            entry.ename e.ename;
          flush Pervasives.stderr;
          failwith "Grammar.extend error"
        }
        else ()
    | Smeta _ sl _ -> List.iter (check_gram entry) sl
    | Slist0sep s t -> do { check_gram entry t; check_gram entry s }
    | Slist1sep s t -> do { check_gram entry t; check_gram entry s }
    | Slist0 s | Slist1 s | Sopt s | Stry s -> check_gram entry s
    | Stree t -> tree_check_gram entry t
    | Snext | Sself | Stoken _ | Skeyword _ -> () ]
  and tree_check_gram entry =
    fun
    [ Node {node = n; brother = bro; son = son} ->
        do {
          check_gram entry n;
          tree_check_gram entry bro;
          tree_check_gram entry son
        }
    | LocAct _ _ | DeadEnd -> () ]
  ;
  value get_initial =
    fun
    [ [Sself :: symbols] -> (True, symbols)
    | symbols -> (False, symbols) ]
  ;


  value insert_tokens gram symbols =
    let rec insert =
      fun
      [ Smeta _ sl _ -> List.iter insert sl
      | Slist0 s | Slist1 s | Sopt s | Stry s -> insert s
      | Slist0sep s t -> do { insert s; insert t }
      | Slist1sep s t -> do { insert s; insert t }
      | Stree t -> tinsert t
      | Skeyword kwd -> using gram kwd
      | Snterm _ | Snterml _ _ | Snext | Sself | Stoken _ -> () ]
    and tinsert =
      fun
      [ Node {node = s; brother = bro; son = son} ->
          do { insert s; tinsert bro; tinsert son }
      | LocAct _ _ | DeadEnd -> () ]
    in
    List.iter insert symbols
  ;

  value insert_tree entry gsymbols action tree =
    let rec insert symbols tree =
      match symbols with
      [ [s :: sl] -> insert_in_tree s sl tree
      | [] ->
          match tree with
          [ Node {node = s; son = son; brother = bro} ->
              Node {node = s; son = son; brother = insert [] bro}
          | LocAct old_action action_list ->
              let () =
                if entry.egram.warning_verbose.val then
                  eprintf "<W> Grammar extension: in [%s] some rule has been masked@."
                          entry.ename
                else ()
              in LocAct action [old_action :: action_list]
          | DeadEnd -> LocAct action [] ] ]
    and insert_in_tree s sl tree =
      match try_insert s sl tree with
      [ Some t -> t
      | None -> Node {node = s; son = insert sl DeadEnd; brother = tree} ]
    and try_insert s sl tree =
      match tree with
      [ Node {node = s1; son = son; brother = bro} ->
          if Tools.eq_symbol s s1 then
            let t = Node {node = s1; son = insert sl son; brother = bro} in
            Some t
          else if is_before s1 s || derive_eps s && not (derive_eps s1) then
            let bro =
              match try_insert s sl bro with
              [ Some bro -> bro
              | None ->
                  Node {node = s; son = insert sl DeadEnd; brother = bro} ]
            in
            let t = Node {node = s1; son = son; brother = bro} in
            Some t
          else
            match try_insert s sl bro with
            [ Some bro ->
                let t = Node {node = s1; son = son; brother = bro} in
                Some t
            | None -> None ]
      | LocAct _ _ | DeadEnd -> None ]
    in
    insert gsymbols tree
  ;
  value insert_level entry e1 symbols action slev =
    match e1 with
    [ True ->
        {assoc = slev.assoc; lname = slev.lname;
        lsuffix = insert_tree entry symbols action slev.lsuffix;
        lprefix = slev.lprefix}
    | False ->
        {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix;
        lprefix = insert_tree entry symbols action slev.lprefix} ]
  ;

  value levels_of_rules entry position rules =
    let elev =
      match entry.edesc with
      [ Dlevels elev -> elev
      | Dparser _ ->
          do {
            eprintf "Error: entry not extensible: \"%s\"\n" entry.ename;
            flush Pervasives.stderr;
            failwith "Grammar.extend"
          } ]
    in
    if rules = [] then elev
    else
      let (levs1, make_lev, levs2) = get_level entry position elev in
      let (levs, _) =
        List.fold_left
          (fun (levs, make_lev) (lname, assoc, level) ->
            let lev = make_lev lname assoc in
            let lev =
              List.fold_left
                (fun lev (symbols, action) ->
                    let symbols = List.map (change_to_self entry) symbols in
                    do {
                      List.iter (check_gram entry) symbols;
                      let (e1, symbols) = get_initial symbols;
                      insert_tokens entry.egram symbols;
                      insert_level entry e1 symbols action lev
                    })
                lev level
            in
            ([lev :: levs], empty_lev))
          ([], make_lev) rules
      in
      levs1 @ List.rev levs @ levs2
    ;

    value extend entry (position, rules) =
      let elev = levels_of_rules entry position rules in
      do {
        entry.edesc := Dlevels elev;
        entry.estart :=
          fun lev strm ->
            let f = Parser.start_parser_of_entry entry in
            do { entry.estart := f; f lev strm };
        entry.econtinue :=
          fun lev bp a strm ->
            let f = Parser.continue_parser_of_entry entry in
            do { entry.econtinue := f; f lev bp a strm }
      };

  end;