Do we need a mouse trap?

[Ana Maria Abrao]

Adrian Hey wrote:

>  How can anybody get their programs to work if there
> really is a bug in ObjectIO?

No, you are not the only one to strugle with ObjectIO.
However, I am not here to help you, but to ask for
help myself. Maybe you can help me (my problem is
considerably simpler than yours). Or else, Peter Achten
or Nick Kallen could send me a suggestion. My problem is
the following: I want to glue controls and menu items
at runtime. My idea was to make a list of strings, each
one representing a control. Then, I would use a recursive
program to  sweep through this list, and glue the
controls together. Since the controls are not of the same
type, it is not possible to use ListLS. The program that
I want to write is something like this:

MNU1 (MENU nm entries) ids ps
# (error, ps)= openMenu undef (mkM entries) ps
| error <> NoError= closeProcess ps
| otherwise= ps
where
{ //mkM xs= Menu nm ( ListLS [MenuItem item []\\ item <- xs]) []
  mkM xs= Menu nm (menuM xs) []
; menuM [x]= MenuItem x []
; menuM [x:xs]= (MenuItem x []) :+: (menuM xs)
};


If I try to compile this program, I get an error message, saying
that "menuM" cannot unify demanded type MenuItem a b 
with :+: MenuItem MenuItem a b. The only way to get my program
running was to force everything into ListLS. To do this, I
must refraim from mixing simple menus, with submenus and separators.
I need to glue components at runtime because I want to build
a tool to build and test simple graphic interfaces using Object IO
(something like Visual Prolog our Delphi). Since nobody would be
willing to examine my somewhat oversized program, I wrote a
striped down version, where I work only with menus. The striped
down program is simple enough for you people to analyze in ten
to twenty minutes and give me some feedback. Thanks to everybody
who takes the trouble to examine my lousy code. By the way, I
have used ListLS in a very unatural scheme, in order to make
the program run. For instance, in the original program,
 I used a ListLS for ButtonControls, another for EditControls,
and so on. I glue these ListLS together with :+: even when they
are empty. In the case of menus, you can examine below, and
discover what a pigish work I have done. To make a long story
short, I reduced all menu entries to the same type, in order
to make feasible the use of ListLS. 

//================================================================
module makeMenu;
import StdEnv, StdIO;

// I am badly in need of a visual tool to make the use of
// Clean Object I/O more confortable. Romans used to
// say: Si non fecerimus, quis faciet (If we don't do
// it, who will?) Then, I tried to do it. The fact is
// that I wasn't able to do it, because I couldn't
// figure out how to glue things with :+:
// I simplified my program to show the trouble. I think
// that it is small enough to be analyzed by some one
// more knowledgeable than myself, who could tell me
// where I made a mistake.

// I use DEVICES to store information about the components
// of my GUI (Things like menus and dialogs). First, the 
// components will be created dinamically, in the CAD tool.
// The menus, windows and dialogs will be at the designer's 
// disposition for testing. Their structure will be 
// stored as a local state. From information stored at the 
// local state, the system is supposed to generate a Clean 
// program, with an object IO interface. One will write 
// a very simple prototype which works only for menus.

:: DEVICES :== [IODEVICE];

:: IODEVICE = 
    MENU String [String] | 
    MENUMENU String [(String, [String])] |
    SUBMENUS [(String, [String])] |
    DEVICEdescriptionERROR String | 
    ITEM String |
    ITEMS [String] |
    DUMB | Fail;
    
:: Local= {menuStruct:: DEVICES};

Start world
# (ids, world)= openIds 20 world
= startIO {menuStruct= []} 0 [Dlg ids] [] world;

// To teste these ideas, I prepared the dialog below.
// It will just read a menu, let the designer test it,
// and store it in a file as a Clean program.
Dlg ids ps
# (error, ps)= openDialog 0 readInfo ps
| error <> NoError= closeProcess ps
| otherwise= ps
where
{ [dlgID, ed1ID, qID, mID, msgID:_]= ids
; width= hmm 60.0
  /* Components are: 
    ed1- An EditControl, where user types
    a description of the menu. Here is an example:
        File [New Open Close Quit]
    An example with submenus:
        Primatae
          macacus [gorila chimpanzee]
          micus [leo vulgar]
    quitB - ButtonControl to quit the CAD.
    menuB - ButtonControl to create a menu with information
            contained in EditControl ed1.
    msg - EditControl, where I intend to output error
          message (in a very distant future, of course).
  */
; components= ed1 :+: quitB :+: menuB :+: msg
; ed1= EditControl "" width  4  ed1Attrs
; msg= EditControl "" width 4 msgAttrs
; quitB= ButtonControl "Quit" quitAttrs
; menuB= ButtonControl "CreateMenu" createMnuAttrs

; ed1Attrs= [ControlId ed1ID, ed1Pos]
; createMnuAttrs= [ControlId mID, cMnuPos, createMnuControl]
; createMnuControl= ControlFunction (noLS createMnu)
; msgAttrs= [ControlId msgID, msgPos]
; quitAttrs= [ControlId qID, quitPos, quitControl]
; quitControl= ControlFunction (noLS closeProcess)

//  Components Lay-out
; ed1Pos= ControlPos (Left, zero)
; msgPos= ControlPos (RightTo ed1ID, zero)
; cMnuPos= ControlPos (Below ed1ID, zero)
; quitPos= ControlPos (RightTo mID, zero)

; wPos= (LeftBottom, {vx= 20, vy= -100})
; dlgAttrs= [WindowId dlgID, WindowPos wPos]
; readInfo= Dialog "DataEntry" components dlgAttrs

  // Here is the function createMenu, which is activated
  // when user press the menuB ControlButton. It retrieves
  // information already stored in ls (components).
  // Then, it reads the description of the menu from
  // EditControl ed1. Then, it parses the description,
  // producing a structure of type IODEVICE. From that
  // structure, it produces a menu for user to test. Besides
  // this, the structure is added to the local state, to
  // be processed later on, producing a Clean program.
; createMnu p=:{ls}
  # components= ls.menuStruct
  ; (jWin, p) = accPIO (getWindow dlgID) p
  ; [(ok, jText):_]= getControlTexts [ed1ID] (fromJust jWin)
  ; txt= fromJust jText
  ; mnu= parseMenu  (LexAnalyzer txt)
  ; p= MNU1 mnu [ids!!11, ids!!12, ids!!13] p
  = { p & ls= {menuStruct= [mnu:components]} }
};


/* HERE LIES ALL MY TROUBLES. THE FACT IS THAT
  I WAS ABLE TO PRODUCE ONLY COMPONENTS OF TYPE
  ListLS. EVERY ATTEMPT TO GLUE COMPONENTS WITH :+:
  FAILED MISERABLY. HOW NICE IT WOULD BE IF I COULD
  WRITE SOMETHING LIKE...
  
MNU1 (MENU nm entries) ids ps
# (error, ps)= openMenu undef (mkM entries) ps
| error <> NoError= closeProcess ps
| otherwise= ps
where
{ //mkM xs= Menu nm ( ListLS [MenuItem item []\\ item <- xs]) []
  mkM xs= Menu nm (menuM xs) []
; menuM [x]= MenuItem x []
; menuM [x:xs]= (MenuItem x []) :+: (menuM xs)
};

If I try to run the cute program which is above this line, I get
the following nasty error message:
  "menuM" cannot unify demanded type MenuItem a b with :+: MenuItem
MenuItem a b
  
Please, help me!!!!!! 
Peter Achten, do you have something to tell me?
Nick, what about you?
  */

/* The program below works. However, I cannot mix types
in the ListLS. For instance, I cannot add separators to
my menus. I cannot mix MenuItem with SubMenu either. */
MNU1 (MENU nm entries) ids ps
# (error, ps)= openMenu undef mkM ps
| error <> NoError= closeProcess ps
| otherwise= ps
where
{ mkM = Menu nm ( ListLS [MenuItem item []\\ item <- entries]) []};

MNU1 (MENUMENU nm entries) ids ps
# (error, ps)= openMenu undef mkM ps
| error <> NoError= closeProcess ps
| otherwise= ps
where
{ mkM = Menu nm ( ListLS [SubMenu item (ListLS [MenuItem i []\\ i <-
xs]) []
                          \\ (item, xs) <- entries]) []
};

MNU1 _ ids ps= ps;

notFail Fail= False;
notFail xx= True;
itHasFailed Fail= True;
itHasFailed xx= False;
fromIODEVICE (ITEMS items)= items;


SubsParse (Fail, xs)= (Fail, xs);
SubsParse (_,[TName nm, TSeparator '[':xs1])
# (resp, xs) = mnuSubsParse (DUMB, xs1)
| notFail resp= (buildMenu nm resp, xs);
SubsParse (_,xs)= (Fail, xs);

mnuSubsParse (Fail, xs)= (Fail, xs);
mnuSubsParse (_, xs)
# (s, xs)= parseMenu1 (DUMB, xs)
| notFail s= moreSubs (s, xs);
mnuSubsParse (t, xs)= (Fail, xs);

moreSubs (Fail, xs)= (Fail, xs);
moreSubs (MENU nm items, [])= (SUBMENUS  [(nm, items)], []);
moreSubs (MENU nm items, xs)
# (ss, xs)= mnuSubsParse (DUMB, xs)
| notFail ss= (SUBMENUS [(nm, items): fromSUB ss], xs);
moreSubs (failure, xs)= (Fail, xs);

fromSUB (SUBMENUS ss)= ss;

mnuItemsParse (Fail, xs)= (Fail, xs);
mnuItemsParse (_, xs)
# (item, xs)= mnuItem (DUMB, xs)
| notFail item= moreItems (item, xs);
mnuItemsParse (t, xs)= (Fail, xs);

moreItems (Fail, xs)= (Fail, xs);
moreItems (ITEM item, [TSeparator ']':xs])= (ITEMS [item], xs);
moreItems (ITEM item, xs)
# (items, xs)= mnuItemsParse (DUMB, xs)
| notFail items= (ITEMS [item: fromIODEVICE items], xs);
moreItems (failure, xs)= (Fail, xs);

mnuItem (Fail, xs)= (Fail, xs);
mnuItem (DUMB, [TName str: xs])= (ITEM str, xs);
mnuItem  (_, xs)= (Fail, xs);

ErrPos xs1 xs= 
  (take (1+ length xs1 - length xs) xs1)++
    [TName "<ERROR>"]++ xs;

parseMenu1 (Fail, xs)= (Fail, xs);
parseMenu1 (_, [TName nm, TSeparator '[':xs1])
# (resp, xs) = mnuItemsParse (DUMB, xs1)
| notFail resp= (buildMenu nm resp, xs);
parseMenu1 (_, xs)= (Fail, xs);

parseMenu [TName nm1, TName nm2:xs1]
# (resp, xs) = mnuSubsParse (DUMB, [TName nm2:xs1])
| notFail resp= buildSubMenus nm1 resp;
parseMenu [TName nm, TSeparator '[':xs1]
# (resp, xs) = mnuItemsParse (DUMB, xs1)
; f= TSeparator '['
| itHasFailed resp= DEVICEdescriptionERROR (TheError (ErrPos [f:xs1]
xs))
| otherwise= buildMenu nm resp;
parseMenu xs= DEVICEdescriptionERROR (TheError (ErrPos xs []));

buildMenu nm (ITEMS xs)= MENU nm xs;
buildSubMenus nm (SUBMENUS xs)= MENUMENU nm xs;

TheError [ERRORAT err: xs]= "Lexical error: "+++ err;
TheError []= "Unexpected end of file";
TheError xs= loopError xs ""
where
{ loopError [] acc= acc
; loopError [x:xs] acc= loopError xs (acc+++(describeThisString x))
; describeThisString (TName str)= " "+++str+++" "
; describeThisString (TSeparator c)= " "+++{c}+++" "
; describeThisString TEOF= " Unexpected End of File "};


:: Tk= TName String | TSeparator Char | TEOF | TNO | ERRORAT String;

LexAnalyzer s= tokens (getToken 0)
where
{ getToken i  | i >= size s= (i, TEOF)
; getToken i  | isSpace s.[i]= getToken (i+1)
; getToken i  | isSeparator s.[i] = (i+1, TSeparator s.[i])
; getToken i  | isAlpha s.[i]= getName i (i+1)
; getToken i = (i, TNO)
  
; getName i j | j >= size s= (j, TName (s%(i, j-1)))
; getName i j | isSpace s.[j]= (j, TName (s%(i, j-1)))
; getName i j | isSeparator s.[j]= (j, TName (s%(i, j-1)))
; getName i j | isAlphanum s.[j]= getName i (j+1)
; getName i j = (j, TNO)

; isSeparator x= any ((==) x) ['()[]{},;:.+*-/_!']

; tokens (i, TEOF)= []
; tokens (i, TNO)= [ERRORAT ((s%(0,i))+++"<-Lexical Error!")]
; tokens (i, x)= Cons x (tokens (getToken i))

; Cons x [ERRORAT e:xs]= [ERRORAT e]
; Cons x xs= [x:xs]};