1----------------------------------------------------------------------------------------- 2-- Haskell binding for daVinci API 3-- 4-- Original version: Sven Panne <Sven.Panne@informatik.uni-muenchen.de> 1997/99 5-- Adapted to daVinci 2.1: Tim Geisler <Tim.Geisler@informatik.uni-muenchen.de> May 1998 6-- marked all extensions with '(V2.1 API)' 7----------------------------------------------------------------------------------------- 8-- Some changes to names from daVinci API: 9-- foo_bar => FooBar 10-- baz => DVBaz in case of name collision 11-- foo x and foo => Foo (Maybe x) 12-- 13-- Note: There are some exceptions to the above rules (but I can't remember... ;-) 14 15module DaVinciTypes( 16 DaVinciCmd(..), GraphCmd(..), MultiCmd(..), MenuCmd(..), FileMenuCmd(..), 17 ViewMenuCmd(..), NavigationMenuCmd(..), AbstractionMenuCmd(..), LayoutMenuCmd(..), 18 AppMenuCmd(..), SetCmd(..), WindowCmd(..), TclCmd(..), SpecialCmd(..), 19 VisualCmd(..), DragAndDropCmd(..), -- (V2.1 API) 20 21 DaVinciAnswer(..), 22 23 Node(..), Edge(..), Attribute(..), 24 25 NodeUpdate(..), EdgeUpdate(..), AttrChange(..), 26 MixedUpdate(..), TypeChange(..), -- (V2.1 API) 27 28 MenuEntry(..), IconEntry(..), 29 VisualRule(..), -- (V2.1 API) 30 31 NodeId(..), EdgeId(..), MenuId(..), MenuLabel(..), MenuMne(..), 32 MenuAcc(..), IconId(..), Type(..), Filename(..), ContextId(..), 33 WindowId(..), -- (V2.1 API) 34 35 Orient(..), Direction(..), Btype(..), MenuMod(..) 36 ) 37where 38 39--- API commands ---------------------------------------------------------- 40 41data DaVinciCmd = -- Commands of the API (top-level). 42 Graph GraphCmd -- Graph category 43 | Multi MultiCmd -- Multi category 44 | Menu MenuCmd -- Menu category 45 | AppMenu AppMenuCmd -- AppMenu category 46 | DVSet SetCmd -- Set category 47 | Window WindowCmd -- Window category 48 | Tcl TclCmd -- Tcl category 49 | Special SpecialCmd -- Special category 50 | DVNothing -- No operation, for syncronization. 51 | Visual VisualCmd -- Visual category (V2.1 API) 52 | DragAndDrop DragAndDropCmd -- Drag and Drop category (V2.1 API) 53 deriving Eq 54 55data GraphCmd = -- Send and update graphs 56 New [Node] -- Send new graph 57 | NewPlaced [Node] -- Dito, better layout 58 | Update [NodeUpdate] [EdgeUpdate] -- Send graph updates 59 | ChangeAttr [AttrChange] -- Change attributes 60 | UpdateAndChangeAttr [NodeUpdate] [EdgeUpdate] [AttrChange] 61 -- Combination of both 62 | UpdateMixed [MixedUpdate] -- Send mixed graph updates (V2.1 API) 63 | UpdateAndChangeAttrMixed [MixedUpdate] [AttrChange] 64 -- Combination of both (V2.1 API) 65 | ChangeType [TypeChange] -- Change types (V2.1 API) 66 deriving Eq 67 68data MultiCmd = -- For multi-graph mode 69 NewContext -- Open graph context 70 | OpenContext ContextId -- Dito, but ID is given 71 | SetContext ContextId -- Switch to context 72 | SetContextWindow ContextId WindowId 73 -- switch to context and window (V2.1 API) 74 deriving Eq 75 76data MenuCmd = -- Call functions of menu 77 File FileMenuCmd -- File menu category 78 | View ViewMenuCmd -- View menu category 79 | Navigation NavigationMenuCmd -- Navigation menu category 80 | Abstraction AbstractionMenuCmd -- Abstraction menu category 81 | Layout LayoutMenuCmd -- Layout menu category 82 deriving Eq 83 84data FileMenuCmd = -- File menu functions 85 ClearGraph -- Clear graph. 86 | OpenGraph Filename -- Load graph from file 87 | OpenGraphPlaced Filename -- Dito, better layout 88 | OpenStatus Filename -- Load status from file 89 | SaveGraph Filename -- Save graph as term 90 | SaveStatus Filename -- Save graph as status 91 | Print (Maybe Filename) -- Save as PostScript 92 | Close -- Close graph window 93 | Exit -- Exit daVinci 94 deriving Eq 95 96data ViewMenuCmd = -- View menu functions 97 OpenNewView -- Open additional view 98 | OpenSurveyView -- Open survey view 99 | FullScale -- Set scale to 100% 100 | FitScaleToWindow -- Set scale to fit 101 | Scale (Maybe Int) -- Set scale to Int 102 | GraphInfo -- Open Graph Info dialog 103 | DaVinciInfo -- Open daVinci Info dialog 104 deriving Eq 105 106data NavigationMenuCmd = -- Navigation menu functions 107 SelectParents [NodeId] -- Select parents of nodes 108 | SelectSiblings [NodeId] -- Select siblings of nodes 109 | SelectChilds [NodeId] -- Select childs of nodes 110 | SelectChildren [NodeId] -- Select childs of nodes (V2.1 API) 111 | Navigator (Maybe (NodeId,Direction,Bool)) -- Navigate in graph 112 | Find (Maybe (String,Bool,Bool)) -- Find a node 113 deriving Eq 114 115data AbstractionMenuCmd = -- Abstraction menu functions 116 HideSubgraph [NodeId] -- Hide subgraphs of nodes 117 | ShowSubgraph [NodeId] -- Show subgraphs of nodes 118 | RestoreAllSubgraphs -- Show all hidden subgr 119 | HideEdges [NodeId] -- Hide edges of nodes 120 | ShowEdges [NodeId] -- Show edges of nodes 121 | RestoreAllEdges -- Show all hidden edges 122 deriving Eq 123 124data LayoutMenuCmd = -- Layout menu functions 125 ImproveAll -- Start layout algorithm 126 | ImproveVisible -- Dito, only visible nodes 127 | CompactAll -- Compact graph layout 128 | Orientation Orient -- Switch orientation 129 deriving Eq 130 131data AppMenuCmd = -- Create menus/icons 132 CreateMenus [MenuEntry] -- Add menus in Edit 133 | CreateIcons [IconEntry] -- Add icons in icon-bar 134 | ActivateMenus [MenuId] -- Enable menus 135 | ActivateIcons [IconId] -- Enable icons 136 | ControlFileEvents -- Get events of File menu 137 deriving Eq 138 139data SetCmd = -- Set options 140 LayoutAccuracy Int -- Layout algorithm params 141 | KeepNodesAtLevels Bool -- Keep nodes at levels 142 | FontSize Int -- Node font size 143 | GapWidth Int -- Min. node distance 144 | GapHeight Int -- Min. level distance 145 | MultiEdgeGap Int -- Distance for multi-edges 146 | SelfEdgeRadius Int -- Distance for self-edges 147 | ScrollingOnSelection Bool -- Auto focusing node 148 | AnimationSpeed Int -- Speed of animation 149 | NoCache Bool -- Control pixmap caching. Details 150 | RulesFirst Bool -- Should rules overlap attributes? (V2.1 API) 151 deriving Eq 152 153data WindowCmd = -- Control windows 154 Title String -- Set window title 155 | ShowMessage String -- Left footer message 156 | ShowStatus String -- Right footer message 157 | Position Int Int -- Window origin x/y 158 | Size Int Int -- Window width/height 159 | Raise -- Raise window 160 | Iconify -- Iconify window 161 | Deiconify -- Deiconify window 162 | Activate -- Enable interaction 163 | Deactivate -- Disable interaction 164 | FileBrowser Bool String String String String [Btype] Bool 165 -- Show file browser 166 deriving Eq 167 168data TclCmd = -- Tcl/Tk interface 169 DVEval String -- Eval Tcl/Tk script 170 | EvalFile Filename -- Dito, from file 171 deriving Eq 172 173data SpecialCmd = -- Special commands 174 SelectNodes [NodeId] -- Select specified nodes 175 | SelectEdge EdgeId -- Select specified edge 176 | FocusNode NodeId -- Scroll to specified node 177 | FocusNodeAnimated NodeId -- Dito, with animation 178 | ShowUrl String -- Display HTML-page 179 deriving Eq 180 181data VisualCmd = -- Visual commands (V2.1 API) 182 NewRules [VisualRule] -- Specify new rules 183 | AddRules [VisualRule] -- Add rules or exchange existing ones 184 deriving Eq 185 186data DragAndDropCmd = -- Drag and Drop commands (V2.1 API) 187 DraggingOn -- Switch dragging on 188 | DragAndDropOn -- Switch drag&drop on 189 | DraggingOff -- Switch drag* off 190 | NewNodeAtCoord NodeUpdate -- Insert at coordinate 191 | NewEdgeAndNodeAtCoord NodeUpdate EdgeUpdate 192 -- Dito, plus edge where node is the child 193 deriving Eq 194 195--- API Answers ----------------------------------------------------------- 196 197data DaVinciAnswer = -- Answers from the API 198 Ok -- Positive confirmer 199 | CommunicationError String -- Negative confirmer 200 | NodeSelectionsLabels [NodeId] -- Labels of sel. nodes 201 | NodeDoubleClick -- Sel. node double-clicked 202 | EdgeSelectionLabel EdgeId -- Label of sel. edge 203 | EdgeSelectionLabels NodeId NodeId -- Dito, parent/child 204 | EdgeDoubleClick -- Sel. edge double-clicked 205 | MenuSelection MenuId -- ID of selected menu 206 | IconSelection IconId -- ID of selected icon 207 | Context ContextId -- Other context (graph) 208 | TclAnswer String -- Answer from Tcl script 209 | BrowserAnswer String String -- File browser result 210 | Disconnect -- Termination request 211 | Closed -- Context (graph) closed 212 | Quit -- daVinci terminated 213 | PopupSelectionNode NodeId MenuId -- Pop-up menu selected. (V2.1 API) 214 | PopupSelectionEdge EdgeId MenuId -- Pop-up menu selected (V2.1 API) 215 | CreateNode -- Dragging answer (V2.1 API) 216 | CreateNodeAndEdge NodeId -- Parent ID of new edge (V2.1 API) 217 | CreateEdge NodeId NodeId -- Node IDs of new edge (V2.1 API) 218 | DropNode ContextId WindowId NodeId ContextId WindowId NodeId 219 -- Node A dropped on B (V2.1 API) 220 | ContextWindow ContextId WindowId -- Context ID + window ID (V2.1 API) 221 | OpenWindow -- New window opened (V2.1 API) 222 | CloseWindow WindowId -- Window closed (V2.1 API) 223 deriving Eq 224 225--- Term Representation for Graphs ---------------------------------------- 226 227data Node = 228 N NodeId Type [Attribute] [Edge] -- Node with ID/type/attr/childs 229 | R NodeId -- Reference to a node 230 deriving Eq 231 232data Edge = E EdgeId Type [Attribute] Node -- Edges with ID/type/attr/child 233 deriving Eq 234 235data Attribute = 236 A String String -- regular node/edge attributes (key/val) 237 | M [MenuEntry] -- pop-up menu for node/edge (V2.1 API) 238 deriving Eq 239 240--- Graph Updates --------------------------------------------------------- 241 242data NodeUpdate = -- Delete or remove nodes 243 DeleteNode NodeId 244 | NewNode NodeId Type [Attribute] 245 deriving Eq 246 247data EdgeUpdate = -- Delete or remove edges 248 DeleteEdge EdgeId 249 | NewEdge EdgeId Type [Attribute] NodeId NodeId 250 | NewEdgeBehind EdgeId EdgeId Type [Attribute] NodeId NodeId 251 deriving Eq 252 253data MixedUpdate = -- Node or Edge update (V2.1) 254 NU NodeUpdate -- wrapper needed in Haskell 255 | EU EdgeUpdate -- wrapper needed in Haskell 256 deriving Eq 257 258data AttrChange = -- Change attributes 259 Node NodeId [Attribute] 260 | Edge EdgeId [Attribute] 261 deriving Eq 262 263data TypeChange = -- Change types (V2.1 API) 264 NodeType NodeId Type -- Label, type 265 | EdgeType EdgeId Type -- Label, type 266 deriving Eq 267 268--- Application Menus and Icons ------------------------------------------- 269 270data MenuEntry = -- Create Menus 271 MenuEntry MenuId MenuLabel 272 | MenuEntryMne MenuId MenuLabel MenuMne MenuMod MenuAcc 273 | SubmenuEntry MenuId MenuLabel [MenuEntry] 274 | SubmenuEntryMne MenuId MenuLabel [MenuEntry] MenuMne 275 | BlankMenuEntry 276 | MenuEntryDisabled MenuId MenuLabel -- (V2.1 API) 277 | SubmenuEntryDisabled MenuId MenuLabel [MenuEntry] -- (V2.1 API) 278 deriving Eq 279 280data IconEntry = -- Create Icons 281 IconEntry IconId Filename String 282 | BlankIconEntry 283 deriving Eq 284 285--- Visualization Rules (V2.1 API) --------------------------------------- 286 287data VisualRule = -- (V2.1 API) 288 NR Type [Attribute] -- Rules for all nodes of given type 289 | ER Type [Attribute] -- Rules for all edges of given type 290 deriving Eq 291 292--- String Sorts ---------------------------------------------------------- 293 294newtype NodeId = NodeId String deriving Eq -- Unique node ID 295newtype EdgeId = EdgeId String deriving Eq -- Unique edge ID 296newtype MenuId = MenuId String deriving Eq -- Unique menu ID 297newtype MenuLabel = MenuLabel String deriving Eq -- Text of menu entry 298newtype MenuMne = MenuMne String deriving Eq -- Motif mnemonic char 299newtype MenuAcc = MenuAcc String deriving Eq -- Motif accelerator key 300newtype IconId = IconId String deriving Eq -- Unique icon ID 301newtype Type = Type String deriving Eq -- Arbitrary type 302newtype Filename = Filename String deriving Eq -- Valid Filename 303newtype ContextId = ContextId String deriving Eq -- Context ID 304newtype WindowId = WindowId String deriving Eq -- Window ID (V2.1 API) 305 306--- Basic Sorts ----------------------------------------------------------- 307 308data Orient = TopDown | BottomUp | LeftRight | RightLeft deriving Eq 309data Direction = Up | Down | DVLeft | DVRight deriving Eq 310data Btype = Bt String String String deriving Eq 311 -- Text, pattern and title postfix 312data MenuMod = Alternate | Shift | Control | Meta | None deriving Eq 313 -- Motif modifier key 314 315--------------------------------------------------------------------------- 316-- Show instances for daVinci API commands 317-- 318-- Everything would be *much* easier if daVinci allowed spaces in commands... 319 320instance Show DaVinciCmd where 321 showsPrec _ (Graph graphCmd) = showFunc1 "graph" graphCmd 322 showsPrec _ (Multi multiCmd) = showFunc1 "multi" multiCmd 323 showsPrec _ (Menu menuCmd) = showFunc1 "menu" menuCmd 324 showsPrec _ (AppMenu appMenuCmd) = showFunc1 "app_menu" appMenuCmd 325 showsPrec _ (DVSet setCmd) = showFunc1 "set" setCmd 326 showsPrec _ (Window windowCmd) = showFunc1 "window" windowCmd 327 showsPrec _ (Tcl tclCmd) = showFunc1 "tcl" tclCmd 328 showsPrec _ (Special specialCmd) = showFunc1 "special" specialCmd 329 showsPrec _ DVNothing = showString "nothing" 330 showsPrec _ (Visual visualCmd) = showFunc1 "visual" visualCmd 331 showsPrec _ (DragAndDrop dragAndDropCmd) = showFunc1 "visual" dragAndDropCmd 332 333instance Show GraphCmd where 334 showsPrec _ (New nodes) = showFunc1 "new" nodes 335 showsPrec _ (NewPlaced nodes) = showFunc1 "new_placed" nodes 336 showsPrec _ (Update nUpds eUpds) = showFunc2 "update" nUpds eUpds 337 showsPrec _ (ChangeAttr aChs) = showFunc1 "change_attr" aChs 338 showsPrec _ (UpdateAndChangeAttr nUpds eUpds aChs) 339 = showFunc3 "update_and_change_attr" nUpds eUpds aChs 340 showsPrec _ (UpdateMixed mUpds) = showFunc1 "update" mUpds 341 showsPrec _ (UpdateAndChangeAttrMixed mUpds aChs)= showFunc2 "update_and_change_attr" mUpds aChs 342 showsPrec _ (ChangeType tChs) = showFunc1 "change_type" tChs 343 344instance Show MultiCmd where 345 showsPrec _ NewContext = showString "new_context" 346 showsPrec _ (OpenContext contextId) = showFunc1 "open_context" contextId 347 showsPrec _ (SetContext contextId) = showFunc1 "set_context" contextId 348 showsPrec _ (SetContextWindow contextId windowId)= showFunc2 "set_context" contextId windowId 349 350instance Show MenuCmd where 351 showsPrec _ (File fCmd) = showFunc1 "file" fCmd 352 showsPrec _ (View vCmd) = showFunc1 "view" vCmd 353 showsPrec _ (Navigation nCmd) = showFunc1 "navigation" nCmd 354 showsPrec _ (Abstraction aCmd) = showFunc1 "abstraction" aCmd 355 showsPrec _ (Layout lCmd) = showFunc1 "layout" lCmd 356 357instance Show FileMenuCmd where 358 showsPrec _ ClearGraph = showString "new" 359 showsPrec _ (OpenGraph fname) = showFunc1 "open_graph" fname 360 showsPrec _ (OpenGraphPlaced fname) = showFunc1 "open_graph_placed" fname 361 showsPrec _ (OpenStatus fname) = showFunc1 "open_status" fname 362 showsPrec _ (SaveGraph fname) = showFunc1 "save_graph" fname 363 showsPrec _ (SaveStatus fname) = showFunc1 "save_status" fname 364 showsPrec _ (Print Nothing) = showString "print" 365 showsPrec _ (Print (Just fname)) = showFunc1 "print" fname 366 showsPrec _ Close = showString "close" 367 showsPrec _ Exit = showString "exit" 368 369instance Show ViewMenuCmd where 370 showsPrec _ OpenNewView = showString "open_new_view" 371 showsPrec _ OpenSurveyView = showString "open_survey_view" 372 showsPrec _ FullScale = showString "full_scale" 373 showsPrec _ FitScaleToWindow = showString "fit_scale_to_window" 374 showsPrec _ (Scale Nothing) = showString "scale" 375 showsPrec _ (Scale (Just scale)) = showFunc1 "scale" scale 376 showsPrec _ GraphInfo = showString "graph_info" 377 showsPrec _ DaVinciInfo = showString "daVinci_info" 378 379instance Show NavigationMenuCmd where 380 showsPrec _ (SelectParents nodeIds) = showFunc1 "select_parents" nodeIds 381 showsPrec _ (SelectSiblings nodeIds) = showFunc1 "select_siblings" nodeIds 382 -- TODO: change 'childs' to 'children'. But then it's no longer V2.0.x compatible ... 383 showsPrec _ (SelectChilds nodeIds) = showFunc1 "select_childs" nodeIds 384 showsPrec _ (SelectChildren nodeIds) = showFunc1 "select_childs" nodeIds 385 showsPrec _ (Navigator Nothing) = showString "navigator" 386 showsPrec _ (Navigator (Just (nodeId,dir,flag))) = showFunc3 "navigator" nodeId dir flag 387 showsPrec _ (Find Nothing) = showString "find" 388 showsPrec _ (Find (Just (txt,cas,exact))) = showFunc3 "find" txt cas exact 389 390instance Show AbstractionMenuCmd where 391 showsPrec _ (HideSubgraph nodeIds) = showFunc1 "hide_subgraph" nodeIds 392 showsPrec _ (ShowSubgraph nodeIds) = showFunc1 "show_subgraph" nodeIds 393 showsPrec _ RestoreAllSubgraphs = showString "restore_all_subgraphs" 394 showsPrec _ (HideEdges nodeIds) = showFunc1 "hide_edges" nodeIds 395 showsPrec _ (ShowEdges nodeIds) = showFunc1 "show_edges" nodeIds 396 showsPrec _ RestoreAllEdges = showString "restore_all_edges" 397 398instance Show LayoutMenuCmd where 399 showsPrec _ ImproveAll = showString "improve_all" 400 showsPrec _ ImproveVisible = showString "improve_visible" 401 showsPrec _ CompactAll = showString "compact_all" 402 showsPrec _ (Orientation orient) = showFunc1 "orientation" orient 403 404instance Show AppMenuCmd where 405 showsPrec _ (CreateMenus menuEntries) = showFunc1 "create_menus" menuEntries 406 showsPrec _ (CreateIcons iconEntries) = showFunc1 "create_icons" iconEntries 407 showsPrec _ (ActivateMenus menuIds) = showFunc1 "activate_menus" menuIds 408 showsPrec _ (ActivateIcons iconIds) = showFunc1 "activate_icons" iconIds 409 showsPrec _ ControlFileEvents = showString "control_file_events" 410 411instance Show SetCmd where 412 showsPrec _ (LayoutAccuracy x) = showFunc1 "layout_accuracy" x 413 showsPrec _ (KeepNodesAtLevels x) = showBoolFunc "keep_nodes_at_levels" x 414 showsPrec _ (FontSize x) = showFunc1 "font_size" x 415 showsPrec _ (GapWidth x) = showFunc1 "gap_width" x 416 showsPrec _ (GapHeight x) = showFunc1 "gap_height" x 417 showsPrec _ (MultiEdgeGap x) = showFunc1 "multi_edge_gap" x 418 showsPrec _ (SelfEdgeRadius x) = showFunc1 "self_edge_radius" x 419 showsPrec _ (ScrollingOnSelection x) = showBoolFunc "scrolling_on_selection" x 420 showsPrec _ (AnimationSpeed x) = showFunc1 "animation_speed" x 421 showsPrec _ (NoCache x) = showBoolFunc "no_cache" x 422 showsPrec _ (RulesFirst x) = showBoolFunc "rules_first" x 423 424instance Show WindowCmd where 425 showsPrec _ (Title str) = showFunc1 "title" str 426 showsPrec _ (ShowMessage str) = showFunc1 "show_message" str 427 showsPrec _ (ShowStatus str) = showFunc1 "show_status" str 428 showsPrec _ (Position x y) = showFunc2 "position" x y 429 showsPrec _ (Size w h) = showFunc2 "size" w h 430 showsPrec _ Raise = showString "raise" 431 showsPrec _ Iconify = showString "iconify" 432 showsPrec _ Deiconify = showString "deiconify" 433 showsPrec _ Activate = showString "activate" 434 showsPrec _ Deactivate = showString "deactivate" 435 showsPrec _ (FileBrowser open title btn dir file tps hid) 436 = showFunc7 "file_browser" open title btn dir file tps hid 437 438instance Show TclCmd where 439 showsPrec _ (DVEval str) = showFunc1 "eval" str 440 showsPrec _ (EvalFile fname) = showFunc1 "eval_file" fname 441 442instance Show SpecialCmd where 443 showsPrec _ (SelectNodes nodes) = showFunc1 "select_nodes" nodes 444 showsPrec _ (SelectEdge edges) = showFunc1 "select_edges" edges 445 showsPrec _ (FocusNode nodeIds) = showFunc1 "focus_node" nodeIds 446 showsPrec _ (FocusNodeAnimated nodeIds) = showFunc1 "focus_node_animated" nodeIds 447 showsPrec _ (ShowUrl url) = showFunc1 "show_url" url 448 449instance Show VisualCmd where 450 showsPrec _ (NewRules visualRules) = showFunc1 "new_rules" visualRules 451 showsPrec _ (AddRules visualRules) = showFunc1 "add_rules" visualRules 452 453instance Show DragAndDropCmd where 454 showsPrec _ DraggingOn = showString "dragging_on" 455 showsPrec _ DragAndDropOn = showString "drag_and_drop_on" 456 showsPrec _ DraggingOff = showString "dragging_off" 457 showsPrec _ (NewNodeAtCoord nUpd) = showFunc1 "new_node_at_coord" nUpd 458 showsPrec _ (NewEdgeAndNodeAtCoord nUpd eUpd) = showFunc2 "new_edge_and_node_at_coord" nUpd eUpd 459--------------------------------------------------------------------------- 460 461instance Show DaVinciAnswer where 462 showsPrec _ Ok = showString "ok" 463 showsPrec _ (CommunicationError msg) = showFunc1 "communication_error" msg 464 showsPrec _ (NodeSelectionsLabels nodeIds) = showFunc1 "node_selections_labels" nodeIds 465 showsPrec _ NodeDoubleClick = showString "node_double_click" 466 showsPrec _ (EdgeSelectionLabel edgeId) = showFunc1 "edge_selection_label" edgeId 467 showsPrec _ (EdgeSelectionLabels parent child) = showFunc2 "edge_selection_labels" parent child 468 showsPrec _ EdgeDoubleClick = showString "edge_double_click" 469 showsPrec _ (MenuSelection menuId) = showFunc1 "menu_selection" menuId 470 showsPrec _ (IconSelection iconId) = showFunc1 "icon_selection" iconId 471 showsPrec _ (Context contextId) = showFunc1 "context" contextId 472 showsPrec _ (TclAnswer retVal) = showFunc1 "tcl_answer" retVal 473 showsPrec _ (BrowserAnswer file typ) = showFunc2 "browser_answer" file typ 474 showsPrec _ Disconnect = showString "disconnect" 475 showsPrec _ Closed = showString "closed" 476 showsPrec _ Quit = showString "quit" 477 showsPrec _ (PopupSelectionNode nId mId) = showFunc2 "popup_selection_node" nId mId 478 showsPrec _ (PopupSelectionEdge eId mId) = showFunc2 "popup_selection_edge" eId mId 479 showsPrec _ CreateNode = showString "create_node" 480 showsPrec _ (CreateNodeAndEdge nId) = showFunc1 "create_node_and_edge" nId 481 showsPrec _ (CreateEdge nId1 nId2) = showFunc2 "create_edge" nId1 nId2 482 showsPrec _ (DropNode cId1 wId1 nId1 cId2 wId2 nId2) = showFunc6 "drop_node" cId1 wId1 nId1 cId2 wId2 nId2 483 showsPrec _ (ContextWindow cId wId) = showFunc2 "context_window" cId wId 484 showsPrec _ OpenWindow = showString "open_window" 485 showsPrec _ (CloseWindow wId) = showFunc1 "close_window" wId 486 487instance Read DaVinciAnswer where 488 readsPrec _ r = 489 [ (Ok, s) | ("ok", s) <- lexR ] ++ 490 [ (CommunicationError m, t) | ("communication_error", s) <- lexR , 491 ([m], t) <- readArgs s ] ++ 492 [ (NodeSelectionsLabels (map NodeId n), t) | ("node_selections_labels", s) <- lexR , 493 (n, t) <- readStrs s ] ++ 494 [ (NodeDoubleClick, s) | ("node_double_click", s) <- lexR ] ++ 495 [ (EdgeSelectionLabel (EdgeId e), t) | ("edge_selection_label", s) <- lexR , 496 ([e], t) <- readArgs s ] ++ 497 [ (EdgeSelectionLabels (NodeId p) (NodeId c), t) | ("edge_selection_labels", s) <- lexR , 498 ([p,c], t) <- readArgs s ] ++ 499 [ (EdgeDoubleClick, s) | ("edge_double_click", s) <- lexR ] ++ 500 [ (MenuSelection (MenuId m), t) | ("menu_selection", s) <- lexR , 501 ([m], t) <- readArgs s ] ++ 502 [ (IconSelection (IconId i), t) | ("icon_selection", s) <- lexR , 503 ([i], t) <- readArgs s ] ++ 504 [ (Context (ContextId c), t) | ("context", s) <- lexR , 505 ([c], t) <- readArgs s ] ++ 506 [ (TclAnswer a, t) | ("tcl_answer", s) <- lexR , 507 ([a], t) <- readArgs s ] ++ 508 [ (BrowserAnswer f y, t) | ("browser_answer", s) <- lexR , 509 ([f,y], t) <- readArgs s ] ++ 510 [ (Disconnect, s) | ("disconnect", s) <- lexR ] ++ 511 [ (Closed, s) | ("closed", s) <- lexR ] ++ 512 [ (Quit, s) | ("quit", s) <- lexR ] ++ 513 [ (PopupSelectionNode (NodeId n) (MenuId m), t) | ("popup_selection_node", s) <- lexR , 514 ([n,m], t) <- readArgs s ] ++ 515 [ (PopupSelectionEdge (EdgeId e) (MenuId m), t) | ("popup_selection_edge", s) <- lexR , 516 ([e,m], t) <- readArgs s ] ++ 517 [ (CreateNode, s) | ("create_node", s) <- lexR ] ++ 518 [ (CreateNodeAndEdge (NodeId n), t) | ("create_node_and_edge", s) <- lexR , 519 ([n], t) <- readArgs s ] ++ 520 [ (CreateEdge (NodeId n1) (NodeId n2), t) | ("create_edge", s) <- lexR , 521 ([n1, n2], t) <- readArgs s ] ++ 522 [ (DropNode (ContextId c1) (WindowId w1) (NodeId n1) (ContextId c2) (WindowId w2) (NodeId n2), t) 523 | ("drop_node", s) <- lexR , 524 ([c1,w1,n1,c2,w2,n2], t) <- readArgs s ] ++ 525 [ (ContextWindow (ContextId c) (WindowId w), t)| ("context_window", s) <- lexR , 526 ([c,w], t) <- readArgs s ] ++ 527 [ (OpenWindow, s) | ("open_window", s) <- lexR ] ++ 528 [ (CloseWindow (WindowId w), t) | ("close_window", s) <- lexR , 529 ([w], t) <- readArgs s ] 530 531 where lexR = lex r 532 533 readArgs :: ReadS [String] 534 readArgs s = [ (x:xs, v) | ("(", t) <- lex s, 535 (x, u) <- reads t, 536 (xs, v) <- readArgs2 u ] 537 538 readArgs2 :: ReadS [String] 539 readArgs2 s = [ ([], t) | (")",t) <- lex s ] ++ 540 [ (x:xs, v) | (",",t) <- lex s, 541 (x, u) <- reads t, 542 (xs, v) <- readArgs2 u ] 543 544 readStrs :: ReadS [String] 545 readStrs = reads 546 547--------------------------------------------------------------------------- 548 549instance Show Node where 550 showsPrec _ (N nodeId typ attrs edges) = showLabeled nodeId (showFunc3 "n" typ attrs edges) 551 showsPrec _ (R nodeId) = showFunc1 "r" nodeId 552 showList = showLst 553 554instance Show Edge where 555 showsPrec _ (E edgeId typ attrs node) = showLabeled edgeId (showFunc3 "e" typ attrs node) 556 showList = showLst 557 558instance Show Attribute where 559 showsPrec _ (A key value) = showFunc2 "a" key value 560 showsPrec _ (M menuEntries) = showFunc1 "m" menuEntries 561 showList = showLst 562 563instance Show NodeUpdate where 564 showsPrec _ (DeleteNode nodeId) = showFunc1 "delete_node" nodeId 565 showsPrec _ (NewNode nodeId typ attrs) = showFunc3 "new_node" nodeId typ attrs 566 showList = showLst 567 568instance Show EdgeUpdate where 569 showsPrec _ (DeleteEdge edgeId) = showFunc1 "delete_edge" edgeId 570 showsPrec _ (NewEdge edgeId typ attrs nodeId1 nodeId2) = showFunc5 "new_edge" edgeId typ attrs nodeId1 nodeId2 571 showsPrec _ (NewEdgeBehind edgeId1 edgeId2 typ attrs nodeId1 nodeId2) = showFunc6 "new_edge_behind" edgeId1 edgeId2 typ attrs nodeId1 nodeId2 572 showList = showLst 573 574instance Show MixedUpdate where 575 showsPrec _ (NU nUpd) = shows nUpd 576 showsPrec _ (EU eUpd) = shows eUpd 577 showList = showLst 578 579instance Show AttrChange where 580 showsPrec _ (Node nodeId attrs) = showFunc2 "node" nodeId attrs 581 showsPrec _ (Edge edgeId attrs) = showFunc2 "edge" edgeId attrs 582 showList = showLst 583 584instance Show TypeChange where 585 showsPrec _ (NodeType nodeId typ) = showFunc2 "node" nodeId typ 586 showsPrec _ (EdgeType edgeId typ) = showFunc2 "edge" edgeId typ 587 showList = showLst 588 589--------------------------------------------------------------------------- 590 591instance Show MenuEntry where 592 showsPrec _ (MenuEntry menuId menuLabel) = showFunc2 "menu_entry" menuId menuLabel 593 showsPrec _ (MenuEntryMne menuId menuLabel menuMne menuMod menuAcc) = showFunc5 "menu_entry_mne" menuId menuLabel menuMne menuMod menuAcc 594 showsPrec _ (SubmenuEntry menuId menuLabel menuEntries) = showFunc3 "submenu_entry" menuId menuLabel menuEntries 595 showsPrec _ (SubmenuEntryMne menuId menuLabel menuEntries menuMne) = showFunc4 "submenu_entry_mne" menuId menuLabel menuEntries menuMne 596 showsPrec _ BlankMenuEntry = showString "blank" 597 showsPrec _ (MenuEntryDisabled menuId menuLabel) = showFunc2 "menu_entry_disabled" menuId menuLabel 598 showsPrec _ (SubmenuEntryDisabled menuId menuLabel menuEntries) = showFunc3 "submenu_entry_disabled" menuId menuLabel menuEntries 599 600instance Show IconEntry where 601 showsPrec _ (IconEntry iconId filename descr) = showFunc3 "icon_entry" iconId filename descr 602 showsPrec _ BlankIconEntry = showString "blank" 603 604--------------------------------------------------------------------------- 605 606instance Show VisualRule where 607 showsPrec _ (NR typ attrs) = showFunc2 "nr" typ attrs 608 showsPrec _ (ER typ attrs) = showFunc2 "er" typ attrs 609 showList = showLst 610 611--------------------------------------------------------------------------- 612 613instance Show NodeId where 614 showsPrec _ (NodeId s) = shows s 615 showList = showLst 616 617instance Show EdgeId where 618 showsPrec _ (EdgeId s) = shows s 619 showList = showLst 620 621instance Show MenuId where 622 showsPrec _ (MenuId s) = shows s 623 showList = showLst 624 625instance Show MenuLabel where 626 showsPrec _ (MenuLabel s) = shows s 627 showList = showLst 628 629instance Show MenuMne where 630 showsPrec _ (MenuMne s) = shows s 631 showList = showLst 632 633instance Show MenuAcc where 634 showsPrec _ (MenuAcc s) = shows s 635 showList = showLst 636 637instance Show IconId where 638 showsPrec _ (IconId s) = shows s 639 showList = showLst 640 641instance Show Type where 642 showsPrec _ (Type s) = shows s 643 showList = showLst 644 645instance Show Filename where 646 showsPrec _ (Filename s) = shows s 647 showList = showLst 648 649instance Show ContextId where 650 showsPrec _ (ContextId s) = shows s 651 showList = showLst 652 653instance Show WindowId where 654 showsPrec _ (WindowId s) = shows s 655 showList = showLst 656 657--------------------------------------------------------------------------- 658 659instance Show Orient where 660 showsPrec _ TopDown = showString "top_down" 661 showsPrec _ BottomUp = showString "bottom_up" 662 showsPrec _ LeftRight = showString "left_right" 663 showsPrec _ RightLeft = showString "right_left" 664 665instance Show Direction where 666 showsPrec _ Up = showString "up" 667 showsPrec _ Down = showString "down" 668 showsPrec _ DVLeft = showString "left" 669 showsPrec _ DVRight = showString "right" 670 671instance Show Btype where 672 showsPrec _ (Bt txt pat post) = showFunc3 "bt" txt pat post 673 674instance Show MenuMod where 675 showsPrec _ Alternate = showString "alt" 676 showsPrec _ Shift = showString "shift" 677 showsPrec _ Control = showString "control" 678 showsPrec _ Meta = showString "meta" 679 showsPrec _ None = showString "none" 680 681--------------------------------------------------------------------------- 682 683showFunc1 :: Show a => String -> a -> ShowS 684showFunc1 funcName arg1 = 685 showString funcName . showParen True (shows arg1) 686 687showFunc2 :: (Show a,Show b) => String -> a -> b -> ShowS 688showFunc2 funcName arg1 arg2 = 689 showString funcName . showParen True (shows arg1 . showChar ',' . 690 shows arg2) 691 692showFunc3 :: (Show a,Show b,Show c) => String -> a -> b -> c -> ShowS 693showFunc3 funcName arg1 arg2 arg3 = 694 showString funcName . showParen True (shows arg1 . showChar ',' . 695 shows arg2 . showChar ',' . 696 shows arg3) 697 698showFunc4 :: (Show a,Show b,Show c,Show d) => String -> a -> b -> c -> d -> ShowS 699showFunc4 funcName arg1 arg2 arg3 arg4 = 700 showString funcName . showParen True (shows arg1 . showChar ',' . 701 shows arg2 . showChar ',' . 702 shows arg3 . showChar ',' . 703 shows arg4) 704 705showFunc5 :: (Show a,Show b,Show c,Show d,Show e) => String -> a -> b -> c -> d -> e -> ShowS 706showFunc5 funcName arg1 arg2 arg3 arg4 arg5 = 707 showString funcName . showParen True (shows arg1 . showChar ',' . 708 shows arg2 . showChar ',' . 709 shows arg3 . showChar ',' . 710 shows arg4 . showChar ',' . 711 shows arg5) 712 713showFunc6 :: (Show a,Show b,Show c,Show d,Show e,Show f) => String -> a -> b -> c -> d -> e -> f -> ShowS 714showFunc6 funcName arg1 arg2 arg3 arg4 arg5 arg6 = 715 showString funcName . showParen True (shows arg1 . showChar ',' . 716 shows arg2 . showChar ',' . 717 shows arg3 . showChar ',' . 718 shows arg4 . showChar ',' . 719 shows arg5 . showChar ',' . 720 shows arg6) 721 722showFunc7 :: (Show a,Show b,Show c,Show d,Show e,Show f,Show g) => String -> a -> b -> c -> d -> e -> f -> g -> ShowS 723showFunc7 funcName arg1 arg2 arg3 arg4 arg5 arg6 arg7 = 724 showString funcName . showParen True (shows arg1 . showChar ',' . 725 shows arg2 . showChar ',' . 726 shows arg3 . showChar ',' . 727 shows arg4 . showChar ',' . 728 shows arg5 . showChar ',' . 729 shows arg6 . showChar ',' . 730 shows arg7) 731 732showLabeled :: Show a => a -> ShowS -> ShowS 733showLabeled iD arg = showChar 'l' . showParen True (shows iD . showChar ',' . arg) 734 735showLst :: Show a => [a] -> ShowS 736showLst [] = showString "[]" 737showLst (x:xs) = showChar '[' . shows x . showl xs 738 where showl [] = showChar ']' 739 showl (y:ys) = showChar ',' . shows y . showl ys 740 741showBoolFunc :: String -> Bool -> ShowS 742showBoolFunc funcName flag = 743 showString funcName . showParen True (showString (if flag then "true" else "false")) 744