(* autodot main loop.
   Copyright (C) 2003, 2008 Jean Goubault-Larrecq and LSV, CNRS UMR 8643 & ENS Cachan.

   This file is part of h1.

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

   h1 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 General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with h1; see the file COPYING.  If not, write to
   the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
*)

open "xa_h";
open "sort_h";
open "gensym_h";
open "yyerror_h";

val version = "1.0 - Jul 13, 2003";

val node_style = ref ({} : string -m> string); (* maps predicates to dot node style
						(filled, solid, dashed, dotted, bold, invis). *)
val node_color = ref ({} : string -m> string); (* maps predicates to dot node outline color
						(e.g., white, black, red, green, blue, yellow,
						magenta, cyan, burlywoord, etc.) *)

fun print_fmodel_dot (f as |[put, ...]|, defs : definitions, states : states, tables : tables) =
    let val p = print f
	memofun state_name q = q : string
	fun pstate q = p (pack (state_name q))
    in
	(put "digraph G {\n  size = \"8.5,11\";\n  rankdir = TB;\n  node[shape=circle];\n";
	 iterate
	   let val delim0 = " [";
	       val delimr = ref delim0
	   in
	       put "  "; p (pack q);
	       (case preds <| !node_style of
		    {P => style, ...} => (put (!delimr); delimr := ",";
					  put "style=";
					  p (pack style))
		  | _ => ());
	      (case preds <| !node_color of
		   {P => color, ...} => (put (!delimr); delimr := ",";
					 put "color=";
					 p (pack color))
		 | _ => ());
	      if !delimr = delim0
		  then ()
	      else put "]";
	      put ";\n"
	   end
	 | q => preds in map states
	 end;
	 iterate
	   iterate
	     (case vl of
		  [v1] => (put "  "; pstate v1;
			   put " -> "; pstate v;
			   put " [label=";
			   p (pack f);
			   put "];\n")
		| _ => 
		  let val trans = gensym "trans"
		      val ir = ref 0
		  in
		      put "  "; put trans;
		      put " [shape=record,height=0,width=0,label="; p (pack fname);
		      put "];\n";
		      iterate
			(put "  "; pstate vi;
			 put " -> "; put trans;
			 (case vl of
			      [_, _, ...] => (put ":";
					      inc ir;
					      put "port";
					      p (pack (!ir)))
			    | _ => ());
			      (*put " [dir=none]";*)
			      put ";\n")
		      | vi in list vl
		      end;
		      put "  "; put trans;
		      (case vl of
			   [_, _, ...] => put ":out"
			 | _ => ());
			   put " -> "; pstate v;
			   put ";\n"
		  end)
	   | vl => v in map table
	   end
	 | f => (k, table) in map tables
	 val fname = if empty table
			 then f
		     else case choose table of
			      nil => f
			    | [_] => f
			    | l => let val fd as |[put, convert, ...]| = outstring "<out>"
				       val delimr = ref ""
				       val ir = ref 0
				   in
				       put f;
				       iterate
					 (put (!delimr); delimr := ""; inc ir;
					  put "|<port"; print fd (pack (!ir)); put "> ")
				       | _ in list l
				       end;
				       convert ()
				   end
	 end;
	 put "}\n")
    end;

fun infile_or_stdin "-" = stdin
  | infile_or_stdin name =
    let val |[get, getline, ...]| = infile name
    in
	|[get=get, getline=getline]|
    end;

fun usage () =
    (#put stderr "Usage: autodot <flags>* filename.\n\
     \  Version ";
     #put stderr version;
     #put stderr ", Copyright (C) Jean Goubault-Larrecq;\n\
      \     see file COPYRIGHT.\n\
      \  autodot comes with ABSOLUTELY NO WARRANTY; see file COPYING, sections 11, 12.\n\
      \  This is free software, and you are welcome to redistribute it\n\
      \  under certain conditions; see TERMS AND CONDITIONS in file COPYING.\n\
      \    Use '-' instead of filename to read from stdin.\n\
      \  Flags are:\n\
      \    -h prints this help.\n\
      \    -color <pred> <color> shows states satisfying <pred> with outline color <color>;\n\
      \           <color> may be white, black, red, green, blue, yellow, magenta, cyan,\n\
      \           burlywood, \"<hue>,<saturation>,<brightness>\";\n\
      \           although several -color flags can be given, this yields unpredictable\n\
      \           results on states satisfying several colored predicates.\n\
      \    -style <pred> <style> shows states satisfying <pred> with style <style>;\n\
      \           <style> may be filled, solid, dashed, dotted, bold, invis;\n\
      \           although several -style flags can be given, this yields unpredictable\n\
      \           results on states satisfying several styled predicates.\n";
     #flush stderr ());

fun do_args ["-h"] = usage ()
  | do_args ("-h"::l) = (usage (); do_args l)
  | do_args ("-color"::P::color::l) =
    (node_color := !node_color ++ {P => color};
     do_args l)
  | do_args ("-style"::P::style::l) =
    (node_style := !node_style ++ {P => style};
     do_args l)
  | do_args (filename :: l) =
    (if not (null l)
	 then (#put stderr "ignored junk after filename (";
	       #put stderr filename;
	       #put stderr ")\n";
	       #flush stderr ())
     else ();
	 let val f = infile_or_stdin filename
	     val yyd = glex_data (f, fn _ => true)
	     val yyloc = glex_loc yyd
	     val hyd = gyacc_data (yyd, xmlautolex, xanone (), xa_value, yyloc, yyerror yyloc)
	 in
	     case xmlautoparse hyd of
		 SOME (xamodel (defs, states, tables)) =>
		 (print_fmodel_dot (stdout, defs, states, tables);
		  #flush stdout ();
		  quit 0)
	       | _ =>
		 (#put stderr "Parsing failed: stop.\n"; #flush stderr ();
		  quit 2)
	 end handle IO n => (#put stderr filename;
			     #put stderr ": ";
			     #put stderr (iomsg n);
			     #put stderr "\n";
			     #flush stderr ();
			     quit 2)
		  | XmlUnterminatedCommentEvt => (#put stderr "Unterminated comment: stop.\n";
						  #flush stderr ();
						  quit 2)
		  | EOFEncounteredEvt => (#put stderr "End of file reached unexpectedly: stop.\n";
						  #flush stderr ();
						  quit 2))
  | do_args nil = (#put stderr "Missing filename.\n"; usage (); quit 2)
  | do_args _ = (usage ();
		 quit 2)
    ;

fun main () =
    do_args (args ());
