home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Environments / Clean 1.2.4 / IOInterface / deltaEventIO.icl < prev    next >
Encoding:
Modula Implementation  |  1997-04-23  |  9.0 KB  |  273 lines  |  [TEXT/3PRM]
  1. implementation module deltaEventIO;
  2.  
  3. import StdClass,StdInt, StdBool, StdString;
  4. from StdMisc import abort;
  5. import    pointer;
  6. import    event, ioState, deltaIOSystem;
  7. from    timerDevice        import    TimerFunctions;
  8. from    menuDevice        import    MenuFunctions, IOStateChangeAppleMenuTitle;
  9. from    dialogDevice    import    DialogFunctions;
  10. from    dialogAbout        import    IOStateGetApplicationName;
  11. from    windowDevice    import    WindowFunctions, IOStateSetCursorShape, IOStateGetCursorPos,
  12.                                 IOStateGetLocalCursor, IOStateGetGlobalCursor;
  13.  
  14.  
  15. ::    InitialIO *s    :== [s ->  * ((IOState s) -> (s, IOState s))];
  16. ::    CursorInfo        :== (!Bool,!Bool,!WindowPtr);
  17.  
  18. InitCursorInfo        :== (False,False,0);
  19. SysEvtMask            :== 324;        // the address at which the system event mask is held
  20. DeviceMask            :== 383;        // UpdateMask + ActivMask + KeyboardMask + MouseMask + 1
  21.  
  22.  
  23. //    Starting an interaction:
  24.  
  25. StartIO    :: !(IOSystem *s (IOState *s)) !*s !(InitialIO *s) !EVENTS -> (!*s, !EVENTS);
  26. StartIO [] state _ events
  27.     =    (state, events);
  28. StartIO ioSystem state fs events
  29.     =    (stateN, IOStateEvents ioStateN)
  30.     where {
  31.         ioSystem1            = SortIOSystem (FinishIOSystem Devices ioSystem);
  32.         initIOState            = EmptyIOState events;
  33.         ioState0            = OpenIO ioSystem1 initIOState;
  34.         ioState1            = IOStateChangeToolbox SetSystemMaskForKeyUp ioState0;
  35.         ioState2            = ChangeAppleMenuTitle ioState1;
  36.         (state1,ioState3)    = DoInitialIO fs (state,ioState2);
  37.         (stateN,ioStateN)    = DoIO InitCursorInfo DoIOFunctions state1 ioState3;
  38.     };
  39.  
  40.  
  41. //    Starting a nested interaction:
  42.  
  43. NestIO :: !(IOSystem *t (IOState *t)) !*t !(InitialIO *t) !(IOState *s) -> (!*t, !IOState *s);
  44. NestIO [] state _ ioState
  45.     =    (state, ioState);
  46. NestIO ioSystem state fs ioState
  47.     =     (stateN, ShowIO (OldIOStateFromNew hIOState newIOStateN));
  48.     where {
  49.         ioSystem1                = SortIOSystem (FinishIOSystem Devices ioSystem);
  50.         (newIOState, hIOState)    = NewIOStateFromOld (HideIO ioState);
  51.         newIOState1                = OpenIO ioSystem1 newIOState;
  52.         newIOState2                = ChangeAppleMenuTitle newIOState1;
  53.         (state1, newIOState3)    = DoInitialIO fs (state,newIOState2);
  54.         (stateN, newIOStateN)    = DoIO InitCursorInfo DoIOFunctions state1 newIOState3;
  55.     };
  56.  
  57.  
  58. DoInitialIO    :: !(InitialIO *s) !(!*s, !IOState *s) -> (!*s, !IOState *s);
  59. DoInitialIO [f : fs] (s,ioState) = DoInitialIO fs (f s ioState);
  60. DoInitialIO _          s_ioState  = s_ioState;
  61.  
  62.  
  63. HideIO :: !(IOState s) -> IOState s;
  64. HideIO ioState = HideIO` ioState Devices;
  65.     
  66. HideIO`    :: !(IOState s) ![Device] -> IOState s;
  67. HideIO` ioState [d : ds]
  68. |    exists    = hide ioState2;
  69.             = ioState2;
  70.     where {
  71.         hide                = Device_HideFunction d;
  72.         (exists, ioState1)    = IOStateHasDevice ioState d;
  73.         ioState2            = HideIO` ioState1 ds;
  74.     };
  75. HideIO` ioState _ = ioState;
  76.  
  77.  
  78. ShowIO :: !(IOState s) -> IOState s;
  79. ShowIO ioState = ShowIO` ioState Devices;
  80.     
  81. ShowIO`    :: !(IOState s) ![Device] -> IOState s;
  82. ShowIO` ioState [d : ds]
  83. |    exists    = show ioState2;
  84.             = ioState2;
  85.     where {
  86.         show                = Device_ShowFunction d;
  87.         (exists, ioState1)    = IOStateHasDevice ioState d;
  88.         ioState2            = ShowIO` ioState1 ds;
  89.     };
  90. ShowIO` ioState _ = ioState;
  91.  
  92.  
  93. OpenIO :: !(IOSystem s (IOState s)) !(IOState s) -> IOState s;
  94. OpenIO [d : ds] ioState
  95.     =    open d (OpenIO ds ioState);
  96.     where {
  97.         open = Device_OpenFunction (DeviceSystemToDevice d);
  98.     };
  99. OpenIO _ ioState = ioState;
  100.  
  101.  
  102. DoIO :: !CursorInfo ![DoIOFunction *s] !*s !(IOState *s) -> (!*s, !IOState *s);
  103. DoIO cInfo ioFunctions state ioState
  104. |    closed    = (state1, ioState4);
  105.             = DoIO cInfo1 ioFunctions state1 ioState4;
  106.     where {
  107.         (cInfo1, ioState1) = SetRightCursorShape cInfo ioState;
  108.         (event,  ioState2) = IOStateAccessToolbox (GetEvent DeviceMask) ioState1;
  109.         (state1, ioState3) = LetDevicesDoIO ioFunctions event state ioState2;
  110.         (closed, ioState4) = IOStateClosed ioState3;
  111.     };
  112.  
  113. LetDevicesDoIO :: ![DoIOFunction *s] !Event !*s !(IOState *s) -> (!*s, !IOState *s);
  114. LetDevicesDoIO [doIO : doIOs] event state ioState
  115.     | thisMadeSense
  116.         = (state1, ioState1);
  117.         = LetDevicesDoIO doIOs event state1 ioState1;
  118.     {}{
  119.         (thisMadeSense, state1, ioState1) = doIO event state ioState;
  120.     };
  121. LetDevicesDoIO _ _ state ioState
  122.     = (state, ioState);
  123.  
  124. SetRightCursorShape :: !CursorInfo !(IOState s) -> (!CursorInfo, !IOState s);
  125. SetRightCursorShape (globalset, inframe, wptr) io
  126. |    not inframe` && (inframe || (not globalset` && globalset))
  127.     =     (cursor_info`, IOStateSetCursorShape gshape iog);
  128. |    not globalset` && inframe` && (not inframe || globalset || wptr <> wptr`)
  129.     =     (cursor_info`, IOStateSetCursorShape lshape iol);
  130.     =     (cursor_info`, io`);
  131.     where {
  132.         (gshape                   ,iog)= IOStateGetGlobalCursor io`;
  133.         (lshape                   ,iol)= IOStateGetLocalCursor  io`;
  134.         (globalset`,inframe`,wptr`,io`)= IOStateGetCursorPos    io;
  135.         cursor_info`                   = (globalset`,inframe`,wptr`);
  136.     };
  137.  
  138. ChangeAppleMenuTitle :: !(IOState s) -> IOState s;
  139. ChangeAppleMenuTitle io
  140. |    app_name == ""    = io`;
  141.                     = IOStateChangeAppleMenuTitle app_name io`;
  142.     where {
  143.         (app_name, io`) = IOStateGetApplicationName io;
  144.     };
  145.  
  146.  
  147. //    Quit the interaction in which this function is applied:
  148.  
  149. QuitIO :: !(IOState s) -> IOState s;
  150. QuitIO ioState
  151. |    closed    = ioState1;
  152.             = QuitIO (close ioState2);
  153.     where {
  154.         (closed, ioState1)    = IOStateClosed ioState;
  155.         (device, ioState2)    = IOStateGetAnyDevice ioState1;
  156.         close                = Device_CloseFunction (DeviceSystemStateToDevice device);
  157.     };
  158.  
  159. DeviceSystemStateToDevice :: !(DeviceSystemState s) -> Device;
  160. DeviceSystemStateToDevice (TimerSystemState     _) = TimerDevice;
  161. DeviceSystemStateToDevice (MenuSystemState     _) = MenuDevice;
  162. DeviceSystemStateToDevice (WindowSystemState _) = WindowDevice;
  163. DeviceSystemStateToDevice (DialogSystemState _) = DialogDevice;
  164.  
  165. /*    Apply a number of IOState transitions on the IOState:
  166.     the functions will be evaluated from their left to right appearance in the list.
  167. */
  168.  
  169. ChangeIOState :: ![(IOState s) -> IOState s] !(IOState s) -> IOState s;
  170. ChangeIOState [f : fs] ioState = ChangeIOState fs (f ioState);
  171. ChangeIOState _ ioState = ioState;
  172.  
  173.  
  174. //    The interface layer to all Event devices:
  175.  
  176. Devices            :== [MenuDevice, DialogDevice, WindowDevice, TimerDevice];
  177. DoIOFunctions    :==    [Device_DoIOFunction TimerDevice,
  178.                      Device_DoIOFunction MenuDevice,
  179.                      Device_DoIOFunction DialogDevice,
  180.                      Device_DoIOFunction WindowDevice];
  181.  
  182.  
  183. Device_ShowFunction    :: !Device -> ShowFunction s;
  184. Device_ShowFunction device = show;
  185.     where {
  186.         (show,_,_,_,_) = Device_Functions device;
  187.         };
  188.  
  189. Device_OpenFunction    :: !Device -> OpenFunction s;
  190. Device_OpenFunction device = open;
  191.     where {
  192.         (_,open,_,_,_) = Device_Functions device;
  193.     };
  194.  
  195. Device_DoIOFunction    :: !Device -> DoIOFunction s;
  196. Device_DoIOFunction device = io;
  197.     where {
  198.         (_,_,io,_,_) = Device_Functions device;
  199.     };
  200.  
  201. Device_CloseFunction :: !Device -> CloseFunction s;
  202. Device_CloseFunction device = close;
  203.     where {
  204.         (_,_,_,close,_) = Device_Functions device;
  205.     };
  206.  
  207. Device_HideFunction :: !Device -> HideFunction s;
  208. Device_HideFunction device = hide;
  209.     where {
  210.         (_,_,_,_,hide) = Device_Functions device;
  211.     };
  212.  
  213. Device_Functions :: !Device -> DeviceFunctions s;
  214. Device_Functions TimerDevice    = TimerFunctions;
  215. Device_Functions MenuDevice     = MenuFunctions;
  216. Device_Functions WindowDevice    = WindowFunctions;
  217. Device_Functions DialogDevice    = DialogFunctions;
  218. SortIOSystem :: !(IOSystem s (IOState s)) -> IOSystem s (IOState s);
  219. SortIOSystem [d : ds]
  220.     =    InsertIOSystem d device (Priority device) (SortIOSystem ds);
  221.     where {
  222.         device = DeviceSystemToDevice d;
  223.     };
  224. SortIOSystem ds = ds;
  225.  
  226. InsertIOSystem :: !(DeviceSystem s (IOState s)) !Device !Int !(IOSystem s (IOState s)) 
  227.     ->    IOSystem s (IOState s);
  228. InsertIOSystem d device priority ds=:[sorted_d : sorted_ds]
  229. |    priority >= Priority (DeviceSystemToDevice sorted_d)
  230.     =    [d : ds];
  231.     =    [sorted_d : InsertIOSystem d device priority sorted_ds];
  232. InsertIOSystem d _ _ _ = [d];
  233.  
  234. IOSystemContainsDevice :: !(IOSystem s (IOState s)) !Device -> Bool;
  235. IOSystemContainsDevice [d : ds] device
  236. |    eq_Device (DeviceSystemToDevice d) device    = True;
  237.                                                 = IOSystemContainsDevice ds device;
  238. IOSystemContainsDevice _ _ = False;
  239.  
  240. FinishIOSystem :: ![Device] !(IOSystem s (IOState s)) -> IOSystem s (IOState s);
  241. FinishIOSystem [d : ds] ioSystem
  242. |    IOSystemContainsDevice ioSystem d
  243.     =    FinishIOSystem ds ioSystem;
  244.     =     FinishIOSystem ds (InsertIOSystem (EmptyDevice d) d (Priority d) ioSystem);
  245. FinishIOSystem _ ioSystem = ioSystem;
  246.  
  247. EmptyDevice :: !Device -> DeviceSystem s (IOState s);
  248. EmptyDevice TimerDevice        = TimerSystem    [];
  249. EmptyDevice MenuDevice        = MenuSystem    [];
  250. EmptyDevice DialogDevice    = DialogSystem    [];
  251. EmptyDevice WindowDevice    = WindowSystem    [];
  252.  
  253. DeviceSystemToDevice :: !(DeviceSystem s (IOState s)) -> Device;
  254. DeviceSystemToDevice (TimerSystem    _) = TimerDevice;
  255. DeviceSystemToDevice (MenuSystem     _) = MenuDevice;
  256. DeviceSystemToDevice (WindowSystem    _) = WindowDevice;
  257. DeviceSystemToDevice (DialogSystem    _) = DialogDevice;
  258.  
  259. eq_Device    :: !Device !Device -> Bool;
  260. eq_Device TimerDevice    TimerDevice        = True;
  261. eq_Device MenuDevice     MenuDevice        = True;
  262. eq_Device WindowDevice    WindowDevice    = True;
  263. eq_Device DialogDevice    DialogDevice    = True;
  264. eq_Device _                _                = False; 
  265.  
  266. SetSystemMaskForKeyUp :: !Toolbox -> Toolbox;
  267. SetSystemMaskForKeyUp tb
  268.     =    tb2;
  269.     where {
  270.         (sysEvtMask,tb1)= LoadWord SysEvtMask tb;
  271.         tb2                = StoreWord SysEvtMask (sysEvtMask bitor KeyUpMask) tb1;
  272.     };
  273.