(* File: GRANAL.ML *)

(* Project: GR *)

type env = (string * string list) list;

fun print_env (s, env : env) =
      (foreach
         (fn (key,info) =>
           (output(s, "\n"); output(s, key); output(s, " ->\n  ");
            print_set (s, info)))
         env;
       output(s, "\n"));

fun rules_to_env rules : env =
      map (fn Group(n,_) => (n, [] : string list)) rules;

exception Lookup_env;

fun lookup_env key [] =
      raise Lookup_env
  | lookup_env key ((key',info') :: rest) =
      if key=key' then info' else (lookup_env key rest);

exception Update_env;

fun update_env key info [] =
      raise Update_env
  | update_env key info ( (binding as (key',info')) :: rest) =
      if key=key' then
        (key,info) :: rest
      else
        binding :: update_env key info rest;

fun set_union ([], y) = y : string list
  | set_union (x, []) = x
  | set_union ((x as (a::x')), (y as (b::y'))) =
      if a < b then a :: set_union (x', y)
      else if b < a then b :: set_union (x, y')
      else a :: set_union (x', y');

fun fixed_point next init =
      let fun loop old =
                let val ()  = output(std_err, "*")
                    val new = next old
                in if new = old
                   then (output(std_err, "\n"); old)
                   else loop new
                end
      in output(std_err, "Iteration: "); loop init end;

fun nt_without (ns, Grammar (_, rules)) =
      foldright_map
        (op @)
        (fn Group (n, _) => if member n ns then [] else [n])
        (rules, []);

local
  fun next_alive rules alive =
        foldleft
          (fn (alive, Group(n, rhss)) =>
            foldleft 
              (fn (alive, Rhs rhs) =>
                    if exists (fn N n' => not(member n' alive)
                                | T _  => false)
                           rhs
                    then alive
                    else set_union (alive, [n]))
                  (alive, rhss))
          (alive, rules)
  fun find_alive (Grammar (_, rules)) =
        (output (std_err, "Finding alive non-terminals\n");
         fixed_point (next_alive rules) [])
in
  fun check_dead grammar =
        let
          val alive  = find_alive grammar
          val dead   = nt_without (alive, grammar)
        in 
          if null dead then ()
          else
            (output(std_err, "\nDead nonterminals:\n\n  ");
             print_set (std_err, dead);
             raise GrammarError "Imperfect grammar")
        end
end

local
  fun extract_nt rhss =
        foldleft
          (fn (ns, Rhs rhs) =>
            set_union(
              ns,
              (foldleft (fn (ns, N n) => set_union (ns, [n])
                          | (ns, T _) => ns)
                        ([], rhs))))
          ([], rhss)
  fun next_reachable rules reachable =
        foldleft
          (fn (reachable, Group(n, rhss)) =>
            if member n reachable then
              set_union (reachable, (extract_nt rhss))
            else
              reachable)
          (reachable, rules)
  fun find_reachable (Grammar (_, rules as (Group(start,_)::_))) =
        (output (std_err, "Finding reachable non-terminals\n");
         fixed_point (next_reachable rules) [start]);
in
  fun check_unreachable grammar =
        let
          val reachable    = find_reachable grammar
          val unreachable  = nt_without (reachable, grammar)
        in 
          if null unreachable then ()
          else
            (output(std_err, "\nUnreachable nonterminals:\n\n  ");
             print_set (std_err, unreachable);
             raise GrammarError "Imperfect grammar")
         end;
end;

fun is_tks_nullable nullable tks =
      forall (fn N n => member n nullable
               | T _ => false)
             tks;

local
  fun is_rhs_nullable nullable (Rhs rhs) =
        is_tks_nullable nullable rhs
  fun next_nullable rules nullable =
        foldleft
          (fn (nullable, Group(n, rhss)) =>
            if exists (is_rhs_nullable nullable) rhss then
              set_union (nullable, [n])
            else
              nullable)
          (nullable, rules);
in
  fun find_nullable (Grammar (_, rules)) =
        (output (std_err, "Finding nullable non-terminals\n");
         fixed_point (next_nullable rules) []);
end;

fun tks_starters nullable (senv : env) tks =
  let fun loop [] = []
        | loop ((T t) :: _) = [t]
        | loop ((N n) :: rest) =
            let val n_starters = lookup_env n senv
            in if member n nullable then
                 set_union (n_starters, (loop rest))
               else
                 n_starters
            end
  in loop tks end;

local
  fun rhs_starters nullable (senv : env) (Rhs rhs) =
         tks_starters nullable senv rhs
  fun rhs_list_starters nullable (senv : env) rhss =
        foldleft_map set_union (rhs_starters nullable senv) ([], rhss)
  fun next_starters nullable rules (senv : env) =
        foldleft
          (fn (senv, Group(n, rhss)) =>
            let val new_starters = rhs_list_starters nullable senv rhss
                val old_starters = lookup_env n senv
                val new_starters = set_union (old_starters, new_starters)
            in update_env n new_starters senv end)
          (senv, rules)
in
  fun find_starters (nullable, Grammar (_, rules)) =
        (output (std_err, "Finding starters of non-terminals\n");
         fixed_point (next_starters nullable rules) 
                     (rules_to_env rules))
end;

local
  fun update_followers (n, nullable, (senv : env), (fenv : env), x, rest) =
        let val old_followers = lookup_env x fenv
            val new_followers = tks_starters nullable senv rest
            val new_followers = set_union (old_followers, new_followers)
            val new_followers =
              if is_tks_nullable nullable rest then
                set_union (new_followers, lookup_env n fenv)
              else
                new_followers
           in update_env x new_followers fenv end
  fun rhs_followers n nullable (senv : env) (fenv: env, (Rhs rhs)) =
        foldleft_tl
          (fn (fenv, T t, rest) => fenv
            | (fenv, N x, rest) =>
                update_followers (n, nullable, senv, fenv, x, rest))
          (fenv, rhs);
  fun rhs_list_followers n nullable (senv :env) (fenv: env) rhss =
        foldleft
          (rhs_followers n nullable senv)
          (fenv, rhss)
  fun next_followers nullable (senv : env) rules (fenv : env) =
        foldleft
          (fn (fenv, Group(n, rhss)) =>
            rhs_list_followers n nullable senv fenv rhss)
          (fenv, rules)
in
  fun find_followers (nullable, (senv : env), Grammar (_, rules)) =
        (output (std_err, "Finding followers of non-terminals\n");
         fixed_point (next_followers nullable senv rules) 
                     (rules_to_env rules))
end;

fun print_ann_nt (s, nullable, n) =
      (if member n nullable then output(s, "#") else ();
       output(s, n));

fun print_ann_tks (s, nullable, []) =
      output(s, "/* empty */")
  | print_ann_tks (s, nullable, rhs) =
      foreach
        (fn (N n) => (print_ann_nt(s, nullable, n); output(s, " "))
          | (T t) => (output(s, t); output(s, " ")))
        rhs;

fun print_ann_rules (s, nullable, (senv : env), (fenv : env), n, rhss) =
  let fun loop (sep, acc_sel, []) =
            output(s, ";\n\n")
        | loop (sep, acc_sel, (Rhs rhs) :: rest) =
            let val sel = tks_starters nullable senv rhs
                val sel =
                  if is_tks_nullable nullable rhs
                  then set_union (sel, lookup_env n fenv)
                  else sel
                val acc_sel' = set_union (acc_sel, sel)
            in output(s, sep); output(s, " ");
               print_set (s, sel); output(s, "\n");
               if disjoint(acc_sel, sel) then () else
                 (output(std_err, "*** Conflict !!! ***\n");
                  output(s, "*** Conflict !!! ***\n"));
               output(s, "     ");
               print_ann_tks (s, nullable, rhs); 
               output(s, "\n");
               loop ("|", acc_sel', rest)
            end
  in loop (":", [], rhss) end;

fun print_ann_grammar (s, nullable, (senv : env), (fenv : env),
                       Grammar(_, rules)) =
      foreach
        (fn Group(n, rhss) =>
          (print_ann_nt (s, nullable, n);
           output(s, "\n");
           print_ann_rules (s, nullable, senv, fenv, n, rhss)))
        rules;

local
  fun env_with ns (env : env) =
        filter (fn (key,info) => member key ns) env
  fun add_end_marker (Grammar(ns, rules as (Group (start,_)::_))) =
        Grammar(ns, Group("$START", [Rhs [N start, T "$END"]])::rules)
in      
  fun analyze file_name =
        let
          val grammar  = read_grammar( file_name ^ ".g" )
          val os       = open_out( file_name ^ ".ga" )
          (* val ()       = print_grammar (os, grammar) *)
          val ()       = check_dead grammar
          val ()       = check_unreachable grammar
          val nullable = find_nullable grammar
          val ()       = 
            if null nullable then () else
              (output (os, "\nNullable nonterminals:\n\n  ");
               print_set (os, nullable);
               output(os, "\n\n"))
          val grammar' = add_end_marker grammar
          val senv     = find_starters (nullable, grammar')
          val ()       = 
            output(os, "\nThe starters of non-terminals:\n")
          val senv'    = tl senv
          val ()       = (print_env (os, senv'); output(os, "\n"))
          val fenv     = find_followers (nullable, senv, grammar')
          val ()       =
            output(os, "\nThe followers of nullable non-terminals:\n")
          val fenv'    = env_with nullable (tl fenv)
          val ()       = (print_env (os, fenv'); output(os, "\n"))
          val ()       = output(os, "\n*** Annotated grammar ***\n\n")
          val ()       = print_ann_grammar (os, nullable, senv, fenv, grammar)
        in close_out os end
end;