------------------------->  GNU Sather - sourcefile  <-------------------------
-- Copyright (C) 1995 by International Computer Science Institute            --
-- This file is part of the GNU Sather library. It is free software; you may --
-- redistribute  and/or modify it under the terms of the GNU Library General --
-- Public  License (LGPL)  as published  by the  Free  Software  Foundation; --
-- either version 2 of the license, or (at your option) any later version.   --
-- 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 Doc/LGPL for more details.       --
-- The license text is also available from:  Free Software Foundation, Inc., --
-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA                     --
-------------->  Please email comments to <bug-sather@gnu.org>  <--------------

-- menu.sa: Tk menus
-- Author: Matthias Ernst <tisi@beutlin.desy.de>

class TK_MENU_CFG is
   include TK_WIDGET_CFG_INCL
	 background->background,
	 foreground->foreground,
	 font->font,
	 borderwidth->borderwidth,
	 relief_none->relief_none,relief_raised->relief_raised,
	 relief_sunken->relief_sunken,
	 relief_flat->relief_flat,relief_ridge->relief_ridge,
	 relief_groove->relief_groove,
	 activeforeground->activeforeground,
	 activebackground->activebackground,
	 activeborderwidth->activeborderwidth,
	 disabledforeground->disabledforeground;
    
   tearoff(tearoff: BOOL) is
      config("tearoff", tearoff);
   end;
    
   tearoff(tearoff: BOOL): SAME is
      tearoff(tearoff);
      return self;
   end;
    
end; -- class TK_MENU_CFG
-------------------------------------------------------------------
class TK_MENU < $TK_WIDGET is
   -- a simplified version of Tk menus
   
   include TK_WIDGET_INCL{TK_MENU_CFG}
	 create ->;		-- create's aren't suitable for me
    
   private const tk_widget_type: STR := "menu";
    
   private default_config: TK_MENU_CFG is
      return TK_MENU_CFG::std
   end;
    
   private default_init(c: TK_MENU_CFG) is
      commands := #;
   end;
    
   act_on(id: INT, args: ARRAY{STR}) is
      -- ignore args
      commands[id].call
   end;
    
   -- creation needed to be overwritten since there's no packing for menus
    
   create(parent: $TK_WIDGET): SAME is 
      -- Use default packing and name
      return create(parent,"widget",default_config);
   end;
    
   create(parent: $TK_WIDGET,np: STR): SAME is 
      -- Use default packing and name
      return create(parent,np,default_config);
   end;
    
   create(parent: $TK_WIDGET,cf: TK_MENU_CFG): SAME is 
      return create(parent,"widget",cf);
   end;
    
   create(parent:$TK_WIDGET,np:STR,cf: TK_MENU_CFG): SAME pre ~void(cf) is
      res ::= new;
      name ::= fix_tcl_name(np)+'u'+UNIQ::next;
      deb("Creating widget named:"+name+" specfied name:"+np);
      res.init(parent,name,cf);
      res.register;      
      eval(res.actual_widget_name,"configure", cf.str);
	
      return res;
   end;
    
   --------------------------------------
    
   -- commands[id].call
   private attr commands: LIST{ROUT};
    
   --------------------------------------
   -- indices into the menu are integers
   -- some special indices:
   -- (see menu manual page for explanation)
    
   -- instead of feeding special strings to index
   -- you call these and give Tk the result.
    
   -- There's one problematic index:
   --   index_active may return -1, which means 'none'
    
   -- You may however not feed -1 as index argument into a procedure
    
    
   private index(s: STR): INT is
      index_str ::= GUI_APP_END::eval(actual_widget_name+" index " + s);
      -- possibly "none"
	
      if index_str = "none" then return -1
      else return #INT(index_str)
      end;
   end;
    
   index_active: INT is
      return index("active");
   end;
    
   index_end: INT is
      return index("end");
   end;
    
   index_at(y: FLT): INT is
      return index("@"+y);
   end;
    
   --------------------------------------
   -- adding entries
   -- with sugar for creation
   -- file_menu ::= #TK_MENU(...).
   --                    command("New",      bind(file_new)).
   --                    command("Open ...", bind(file_open)).
   --                    separator.
   --                    cascade("Language").command("English", 
   --                                              bind(set_lang("english"))).
   --                                       .command("German",
   --                                              bind(set_lang("german")))
   --                         .parent_menu.  -- end cascade
   --                    command("You got it now")
    

   command(label: STR, command: ROUT) is
      index ::= commands.size;
      commands.append(command);
	
      eval(path_name,"add command -label",
	   quote(label),"-command",quote("sather "+path_name+" "+index)); 
   end;
    
   command(label: STR, command: ROUT): SAME is
      command(label, command);
      return self;
   end;
    
   separator is
      eval(path_name, "add separator");
   end;
    
   separator: SAME is
      separator;
      return self;
   end;
   
   cascade(label: STR): SAME is
      -- returns empty submenu
	
      submenu ::= #SAME(self, "submenu", default_config);
	
      eval(path_name, "add cascade", "-label "
	   +quote(label), "-menu "+submenu.path_name);
	
      return submenu;
   end;
    
   parent_menu: SAME
   -- give the parent menu [of course, only if it is one]
   -- otherwise we get a runtime error
   is
      paren::=parent;
      typecase paren
      when SAME then return paren
      end;
   end;
	
   ----------------------------------------------------------------
   -- entry manipulation
   -- 
   -- for the moment, only dis/enabling is supported
   -- 
   -- dis/enabling of separators/tearoffs will be ignored
   ----------------------------------------------------------------
	
   disable(index: INT) is
      state_config(index, "-state disabled");
   end;
    
   enable(index: INT) is
      state_config(index, "-state normal");
   end;
    
   private state_config(index: INT, state: STR) is
      typestr ::= GUI_APP_END::eval(path_name + " type " + index);
	
      case typestr
      when "command", "cascade" then
	 eval(path_name, "entryconfigure", index, state);
      else			-- ignore
      end;
   end;
    
end; -- class TK_MENU
-------------------------------------------------------------------


