-- | This file was taken from Sven Panne's page on 31st July 2001.
-- I have since changed it a little.  The version before these
-- changes may be found in DaVinciTypes.hs.orig.

-----------------------------------------------------------------------------------------
-- Haskell binding for daVinci API
--
-- Original version:       Sven Panne  <Sven.Panne@informatik.uni-muenchen.de>  1997/99
-- Adapted to daVinci 2.1: Tim Geisler <Tim.Geisler@informatik.uni-muenchen.de> May 1998
--                         marked all extensions with '(V2.1 API)'
-----------------------------------------------------------------------------------------
-- Some changes to names from daVinci API:
--    foo_bar              => FooBar
--    baz                  => DVBaz   in case of name collision
--    foo x  and    foo    => Foo (Maybe x)
--
-- Note: There are some exceptions to the above rules (but I can't remember...  ;-)

module UDrawGraph.Types(
   DaVinciCmd(..), GraphCmd(..), MultiCmd(..), MenuCmd(..), FileMenuCmd(..),
   ViewMenuCmd(..), NavigationMenuCmd(..), AbstractionMenuCmd(..), LayoutMenuCmd(..),
   AppMenuCmd(..), SetCmd(..), WindowCmd(..), TclCmd(..), SpecialCmd(..),
   VisualCmd(..), DragAndDropCmd(..), -- (V2.1 API)

   DaVinciAnswer(..),

   Node(..), Edge(..), Attribute(..),

   NodeUpdate(..), EdgeUpdate(..), AttrChange(..),
   MixedUpdate(..), TypeChange(..), -- (V2.1 API)

   MenuEntry(..), IconEntry(..),
   VisualRule(..), -- (V2.1 API)

   NodeId(..), EdgeId(..), MenuId(..), MenuLabel(..), MenuMne(..),
   MenuAcc(..), IconId(..), Type(..), Filename(..), ContextId(..),
   WindowId(..), -- (V2.1 API)

   Orient(..), Direction(..), Btype(..), MenuMod(..)
   )
where

--- API commands ----------------------------------------------------------

data DaVinciCmd =                   -- Commands of the API (top-level).
    Graph GraphCmd                     -- Graph category
  | Multi MultiCmd                     -- Multi category
  | Menu MenuCmd                       -- Menu category
  | AppMenu AppMenuCmd                 -- AppMenu category
  | DVSet SetCmd                       -- Set category
  | Window WindowCmd                   -- Window category
  | Tcl TclCmd                         -- Tcl category
  | Special SpecialCmd                 -- Special category
  | DVNothing                          -- No operation, for syncronization.
  | Visual VisualCmd                   -- Visual category (V2.1 API)
  | DragAndDrop DragAndDropCmd         -- Drag and Drop category (V2.1 API)
  deriving Eq

data GraphCmd =                     -- Send and update graphs
    New [Node]                         -- Send new graph
  | NewPlaced [Node]                   -- Dito, better layout
  | Update [NodeUpdate] [EdgeUpdate]   -- Send graph updates
  | ChangeAttr [AttrChange]            -- Change attributes
  | UpdateAndChangeAttr [NodeUpdate] [EdgeUpdate] [AttrChange]
                                       -- Combination of both
  | UpdateMixed [MixedUpdate]          -- Send mixed graph updates (V2.1 API)
  | UpdateAndChangeAttrMixed [MixedUpdate] [AttrChange]
                                       -- Combination of both (V2.1 API)
  | ChangeType [TypeChange]            -- Change types (V2.1 API)
  deriving Eq

data MultiCmd =                     -- For multi-graph mode
    NewContext                         -- Open graph context
  | OpenContext ContextId              -- Dito, but ID is given
  | SetContext ContextId               -- Switch to context
  | SetContextWindow ContextId WindowId
                                       -- switch to context and window (V2.1 API)
  deriving Eq

data MenuCmd =                      -- Call functions of menu
    File FileMenuCmd                   -- File menu category
  | View ViewMenuCmd                   -- View menu category
  | Navigation NavigationMenuCmd       -- Navigation menu category
  | Abstraction AbstractionMenuCmd     -- Abstraction menu category
  | Layout LayoutMenuCmd               -- Layout menu category
  deriving Eq

data FileMenuCmd =                  -- File menu functions
    ClearGraph                         -- Clear graph.
  | OpenGraph Filename                 -- Load graph from file
  | OpenGraphPlaced Filename           -- Dito, better layout
  | OpenStatus Filename                -- Load status from file
  | SaveGraph Filename                 -- Save graph as term
  | SaveStatus Filename                -- Save graph as status
  | Print (Maybe Filename)             -- Save as PostScript
  | Close                              -- Close graph window
  | Exit                               -- Exit daVinci
  deriving Eq

data ViewMenuCmd =                  -- View menu functions
    OpenNewView                        -- Open additional view
  | OpenSurveyView                     -- Open survey view
  | FullScale                          -- Set scale to 100%
  | FitScaleToWindow                   -- Set scale to fit
  | Scale (Maybe Int)                  -- Set scale to Int
  | GraphInfo                          -- Open Graph Info dialog
  | DaVinciInfo                        -- Open daVinci Info dialog
  deriving Eq

data NavigationMenuCmd =            -- Navigation menu functions
    SelectParents [NodeId]             -- Select parents of nodes
  | SelectSiblings [NodeId]            -- Select siblings of nodes
  | SelectChilds [NodeId]              -- Select childs of nodes
  | SelectChildren [NodeId]            -- Select childs of nodes (V2.1 API)
  | Navigator (Maybe (NodeId,Direction,Bool)) -- Navigate in graph
  | Find (Maybe (String,Bool,Bool))    -- Find a node
  deriving Eq

data AbstractionMenuCmd =           -- Abstraction menu functions
    HideSubgraph [NodeId]              -- Hide subgraphs of nodes
  | ShowSubgraph [NodeId]              -- Show subgraphs of nodes
  | RestoreAllSubgraphs                -- Show all hidden subgr
  | HideEdges [NodeId]                 -- Hide edges of nodes
  | ShowEdges [NodeId]                 -- Show edges of nodes
  | RestoreAllEdges                    -- Show all hidden edges
  deriving Eq

data LayoutMenuCmd =                -- Layout menu functions
    ImproveAll                         -- Start layout algorithm
  | ImproveVisible                     -- Dito, only visible nodes
  | CompactAll                         -- Compact graph layout
  | Orientation Orient                 -- Switch orientation
  deriving Eq

data AppMenuCmd =                   -- Create menus/icons
    CreateMenus [MenuEntry]            -- Add menus in Edit
  | CreateIcons [IconEntry]            -- Add icons in icon-bar
  | ActivateMenus [MenuId]             -- Enable menus
  | ActivateIcons [IconId]             -- Enable icons
  | ControlFileEvents                  -- Get events of File menu
  deriving Eq

data SetCmd =                       -- Set options
    LayoutAccuracy Int                 -- Layout algorithm params
  | KeepNodesAtLevels Bool             -- Keep nodes at levels
  | FontSize Int                       -- Node font size
  | GapWidth Int                       -- Min. node distance
  | GapHeight Int                      -- Min. level distance
  | MultiEdgeGap Int                   -- Distance for multi-edges
  | SelfEdgeRadius Int                 -- Distance for self-edges
  | ScrollingOnSelection Bool          -- Auto focusing node
  | AnimationSpeed Int                 -- Speed of animation
  | NoCache Bool                       -- Control pixmap caching. Details
  | RulesFirst Bool                    -- Should rules overlap attributes? (V2.1 API)
  deriving Eq

data WindowCmd =                    -- Control windows
    Title String                       -- Set window title
  | ShowMessage String                 -- Left footer message
  | ShowStatus String                  -- Right footer message
  | Position Int Int                   -- Window origin x/y
  | Size Int Int                       -- Window width/height
  | Raise                              -- Raise window
  | Iconify                            -- Iconify window
  | Deiconify                          -- Deiconify window
  | Activate                           -- Enable interaction
  | Deactivate                         -- Disable interaction
  | FileBrowser Bool String String String String [Btype] Bool
                                       -- Show file browser
  deriving Eq

data TclCmd =                       -- Tcl/Tk interface
    DVEval String                      -- Eval Tcl/Tk script
  | EvalFile Filename                  -- Dito, from file
  deriving Eq

data SpecialCmd =                   -- Special commands
    SelectNodes [NodeId]               -- Select specified nodes
  | SelectEdge EdgeId                  -- Select specified edge
  | FocusNode NodeId                   -- Scroll to specified node
  | FocusNodeAnimated NodeId           -- Dito, with animation
  | ShowUrl String                     -- Display HTML-page
  | Version                            -- show version number (V3.0)
  deriving Eq

data VisualCmd =                    -- Visual commands (V2.1 API)
    NewRules [VisualRule]              -- Specify new rules
  | AddRules [VisualRule]              -- Add rules or exchange existing ones
  deriving Eq

data DragAndDropCmd =               -- Drag and Drop commands (V2.1 API)
    DraggingOn                         -- Switch dragging on
  | DragAndDropOn                      -- Switch drag&drop on
  | DraggingOff                        -- Switch drag* off
  | NewNodeAtCoord NodeUpdate          -- Insert at coordinate
  | NewEdgeAndNodeAtCoord NodeUpdate EdgeUpdate
                                       -- Dito, plus edge where node is the child
  deriving Eq

--- API Answers -----------------------------------------------------------

data DaVinciAnswer =                      -- Answers from the API
    Ok                                    -- Positive confirmer
  | CommunicationError String             -- Negative confirmer
  | NodeSelectionsLabels [NodeId]         -- Labels of sel. nodes
  | NodeDoubleClick                       -- Sel. node double-clicked
  | EdgeSelectionLabel EdgeId             -- Label of sel. edge
  | EdgeSelectionLabels NodeId NodeId     -- Dito, parent/child
  | EdgeDoubleClick                       -- Sel. edge double-clicked
  | MenuSelection MenuId                  -- ID of selected menu
  | IconSelection IconId                  -- ID of selected icon
  | Context ContextId                     -- Other context (graph)
  | TclAnswer String                      -- Answer from Tcl script
  | BrowserAnswer String String           -- File browser result
  | Disconnect                            -- Termination request
  | Closed                                -- Context (graph) closed
  | Quit                                  -- daVinci terminated
  | PopupSelectionNode NodeId MenuId      -- Pop-up menu selected. (V2.1 API)
  | PopupSelectionEdge EdgeId MenuId      -- Pop-up menu selected (V2.1 API)
  | CreateNode                            -- Dragging answer (V2.1 API)
  | CreateNodeAndEdge NodeId              -- Parent ID of new edge (V2.1 API)
  | CreateEdge NodeId NodeId              -- Node IDs of new edge (V2.1 API)
  | DropNode NodeId ContextId WindowId NodeId
                                          -- Node A dropped on B (V2.1 API)
  | ContextWindow ContextId WindowId      -- Context ID + window ID (V2.1 API)
  | OpenWindow                            -- New window opened (V2.1 API)
  | CloseWindow WindowId                  -- Window closed (V2.1 API)
  | Versioned String                      -- answers special(version). (V3.0).
  deriving (Eq,Ord)

--- Term Representation for Graphs ----------------------------------------

data Node =
    N NodeId Type [Attribute] [Edge]   -- Node with ID/type/attr/childs
  | R NodeId                           -- Reference to a node
  deriving Eq

data Edge = E EdgeId Type [Attribute] Node -- Edges with ID/type/attr/child
  deriving Eq

data Attribute =
    A String String                    -- regular node/edge attributes (key/val)
  | M [MenuEntry]                      -- pop-up menu for node/edge (V2.1 API)
  deriving Eq

--- Graph Updates ---------------------------------------------------------

data NodeUpdate =                      -- Delete or remove nodes
    DeleteNode NodeId
  | NewNode NodeId Type [Attribute]
  deriving Eq

data EdgeUpdate =                      -- Delete or remove edges
    DeleteEdge EdgeId
  | NewEdge EdgeId Type [Attribute] NodeId NodeId
  | NewEdgeBehind EdgeId EdgeId Type [Attribute] NodeId NodeId
  deriving Eq

data MixedUpdate =                     -- Node or Edge update (V2.1)
    NU NodeUpdate                         -- wrapper needed in Haskell
  | EU EdgeUpdate                         -- wrapper needed in Haskell
  deriving Eq

data AttrChange =                      -- Change attributes
    Node NodeId [Attribute]
  | Edge EdgeId [Attribute]
  deriving Eq

data TypeChange =                      -- Change types (V2.1 API)
    NodeType NodeId Type                  -- Label, type
  | EdgeType EdgeId Type                  -- Label, type
  deriving Eq

--- Application Menus and Icons -------------------------------------------

data MenuEntry =                       -- Create Menus
    MenuEntry MenuId MenuLabel
  | MenuEntryMne MenuId MenuLabel MenuMne MenuMod MenuAcc
  | SubmenuEntry MenuId MenuLabel [MenuEntry]
  | SubmenuEntryMne MenuId MenuLabel [MenuEntry] MenuMne
  | BlankMenuEntry
  | MenuEntryDisabled MenuId MenuLabel -- (V2.1 API)
  | SubmenuEntryDisabled MenuId MenuLabel [MenuEntry] -- (V2.1 API)
  deriving Eq

data IconEntry =                       -- Create Icons
    IconEntry IconId Filename String
  | BlankIconEntry
  deriving Eq

--- Visualization Rules (V2.1 API) ---------------------------------------

data VisualRule =                      -- (V2.1 API)
    NR Type [Attribute]                  -- Rules for all nodes of given type
  | ER Type [Attribute]                  -- Rules for all edges of given type
  deriving Eq

--- String Sorts ----------------------------------------------------------

newtype NodeId    = NodeId String    deriving (Eq,Ord)   -- Unique node ID
newtype EdgeId    = EdgeId String    deriving (Eq,Ord)   -- Unique edge ID
newtype MenuId    = MenuId String    deriving (Eq,Ord)   -- Unique menu ID
newtype MenuLabel = MenuLabel String deriving Eq   -- Text of menu entry
newtype MenuMne   = MenuMne String   deriving Eq   -- Motif mnemonic char
newtype MenuAcc   = MenuAcc String   deriving Eq   -- Motif accelerator key
newtype IconId    = IconId String    deriving (Eq,Ord)   -- Unique icon ID
newtype Type      = Type String      deriving (Eq,Ord)   -- Arbitrary type
newtype Filename  = Filename String  deriving Eq   -- Valid Filename
newtype ContextId = ContextId String deriving (Eq,Ord)   -- Context ID
newtype WindowId  = WindowId String  deriving (Eq,Ord) -- Window ID (V2.1 API)

--- Basic Sorts -----------------------------------------------------------

data Orient      = TopDown | BottomUp | LeftRight | RightLeft deriving Eq
data Direction   = Up | Down | DVLeft | DVRight deriving Eq
data Btype       = Bt String String String deriving Eq
                                           -- Text, pattern and title postfix
data MenuMod     = Alternate | Shift | Control | Meta | None deriving Eq
                                           -- Motif modifier key

---------------------------------------------------------------------------
-- Show instances for daVinci API commands
--
-- Everything would be *much* easier if daVinci allowed spaces in commands...

instance Show DaVinciCmd where
   showsPrec _ (Graph graphCmd)                     = showFunc1  "graph" graphCmd
   showsPrec _ (Multi multiCmd)                     = showFunc1  "multi" multiCmd
   showsPrec _ (Menu menuCmd)                       = showFunc1  "menu" menuCmd
   showsPrec _ (AppMenu appMenuCmd)                 = showFunc1  "app_menu" appMenuCmd
   showsPrec _ (DVSet setCmd)                       = showFunc1  "set" setCmd
   showsPrec _ (Window windowCmd)                   = showFunc1  "window" windowCmd
   showsPrec _ (Tcl tclCmd)                         = showFunc1  "tcl" tclCmd
   showsPrec _ (Special specialCmd)                 = showFunc1  "special" specialCmd
   showsPrec _ DVNothing                            = showString "nothing"
   showsPrec _ (Visual visualCmd)                   = showFunc1  "visual" visualCmd
   showsPrec _ (DragAndDrop dragAndDropCmd)         = showFunc1  "drag_and_drop" dragAndDropCmd

instance Show GraphCmd where
   showsPrec _ (New nodes)                          = showFunc1  "new" nodes
   showsPrec _ (NewPlaced nodes)                    = showFunc1  "new_placed" nodes
   showsPrec _ (Update nUpds eUpds)                 = showFunc2  "update" nUpds eUpds
   showsPrec _ (ChangeAttr aChs)                    = showFunc1  "change_attr" aChs
   showsPrec _ (UpdateAndChangeAttr nUpds eUpds aChs)
                                                    = showFunc3  "update_and_change_attr" nUpds eUpds aChs
   showsPrec _ (UpdateMixed mUpds)                  = showFunc1  "mixed_update" mUpds
   showsPrec _ (UpdateAndChangeAttrMixed mUpds aChs)= showFunc2  "update_and_change_attr" mUpds aChs
   showsPrec _ (ChangeType tChs)                    = showFunc1  "change_type" tChs

instance Show MultiCmd where
   showsPrec _ NewContext                           = showString "new_context"
   showsPrec _ (OpenContext contextId)              = showFunc1  "open_context" contextId
   showsPrec _ (SetContext contextId)               = showFunc1  "set_context" contextId
   showsPrec _ (SetContextWindow contextId windowId)= showFunc2  "set_context" contextId windowId

instance Show MenuCmd where
   showsPrec _ (File fCmd)                          = showFunc1  "file" fCmd
   showsPrec _ (View vCmd)                          = showFunc1  "view" vCmd
   showsPrec _ (Navigation nCmd)                    = showFunc1  "navigation" nCmd
   showsPrec _ (Abstraction aCmd)                   = showFunc1  "abstraction" aCmd
   showsPrec _ (Layout lCmd)                        = showFunc1  "layout" lCmd

instance Show FileMenuCmd where
   showsPrec _ ClearGraph                           = showString "new"
   showsPrec _ (OpenGraph fname)                    = showFunc1  "open_graph" fname
   showsPrec _ (OpenGraphPlaced fname)              = showFunc1  "open_graph_placed" fname
   showsPrec _ (OpenStatus fname)                   = showFunc1  "open_status" fname
   showsPrec _ (SaveGraph fname)                    = showFunc1  "save_graph" fname
   showsPrec _ (SaveStatus fname)                   = showFunc1  "save_status" fname
   showsPrec _ (Print Nothing)                      = showString "print"
   showsPrec _ (Print (Just fname))                 = showFunc1  "print" fname
   showsPrec _ Close                                = showString "close"
   showsPrec _ Exit                                 = showString "exit"

instance Show ViewMenuCmd where
   showsPrec _ OpenNewView                          = showString "open_new_view"
   showsPrec _ OpenSurveyView                       = showString "open_survey_view"
   showsPrec _ FullScale                            = showString "full_scale"
   showsPrec _ FitScaleToWindow                     = showString "fit_scale_to_window"
   showsPrec _ (Scale Nothing)                      = showString "scale"
   showsPrec _ (Scale (Just scale))                 = showFunc1  "scale" scale
   showsPrec _ GraphInfo                            = showString "graph_info"
   showsPrec _ DaVinciInfo                          = showString "daVinci_info"

instance Show NavigationMenuCmd where
   showsPrec _ (SelectParents nodeIds)              = showFunc1  "select_parents" nodeIds
   showsPrec _ (SelectSiblings nodeIds)             = showFunc1  "select_siblings" nodeIds
    -- TODO: change 'childs' to 'children'. But then it's no longer V2.0.x compatible ...
   showsPrec _ (SelectChilds nodeIds)               = showFunc1  "select_childs" nodeIds
   showsPrec _ (SelectChildren nodeIds)             = showFunc1  "select_childs" nodeIds
   showsPrec _ (Navigator Nothing)                  = showString "navigator"
   showsPrec _ (Navigator (Just (nodeId,dir,flag))) = showFunc3  "navigator" nodeId dir flag
   showsPrec _ (Find Nothing)                       = showString "find"
   showsPrec _ (Find (Just (txt,cas,exact)))        = showFunc3  "find" txt cas exact

instance Show AbstractionMenuCmd where
   showsPrec _ (HideSubgraph nodeIds)               = showFunc1  "hide_subgraph" nodeIds
   showsPrec _ (ShowSubgraph nodeIds)               = showFunc1  "show_subgraph" nodeIds
   showsPrec _ RestoreAllSubgraphs                  = showString "restore_all_subgraphs"
   showsPrec _ (HideEdges nodeIds)                  = showFunc1  "hide_edges" nodeIds
   showsPrec _ (ShowEdges nodeIds)                  = showFunc1  "show_edges" nodeIds
   showsPrec _ RestoreAllEdges                      = showString "restore_all_edges"

instance Show LayoutMenuCmd where
   showsPrec _ ImproveAll                           = showString "improve_all"
   showsPrec _ ImproveVisible                       = showString "improve_visible"
   showsPrec _ CompactAll                           = showString "compact_all"
   showsPrec _ (Orientation orient)                 = showFunc1  "orientation" orient

instance Show AppMenuCmd where
   showsPrec _ (CreateMenus menuEntries)            = showFunc1  "create_menus" menuEntries
   showsPrec _ (CreateIcons iconEntries)            = showFunc1  "create_icons" iconEntries
   showsPrec _ (ActivateMenus menuIds)              = showFunc1  "activate_menus" menuIds
   showsPrec _ (ActivateIcons iconIds)              = showFunc1  "activate_icons" iconIds
   showsPrec _ ControlFileEvents                    = showString "control_file_events"

instance Show SetCmd where
   showsPrec _ (LayoutAccuracy x)                   = showFunc1  "layout_accuracy" x
   showsPrec _ (KeepNodesAtLevels x)                = showBoolFunc "keep_nodes_at_levels" x
   showsPrec _ (FontSize x)                         = showFunc1  "font_size" x
   showsPrec _ (GapWidth x)                         = showFunc1  "gap_width" x
   showsPrec _ (GapHeight x)                        = showFunc1  "gap_height" x
   showsPrec _ (MultiEdgeGap x)                     = showFunc1  "multi_edge_gap" x
   showsPrec _ (SelfEdgeRadius x)                   = showFunc1  "self_edge_radius" x
   showsPrec _ (ScrollingOnSelection x)             = showBoolFunc "scrolling_on_selection" x
   showsPrec _ (AnimationSpeed x)                   = showFunc1  "animation_speed" x
   showsPrec _ (NoCache x)                          = showBoolFunc "no_cache" x
   showsPrec _ (RulesFirst x)                       = showBoolFunc "rules_first" x

instance Show WindowCmd where
   showsPrec _ (Title str)                          = showFunc1  "title" str
   showsPrec _ (ShowMessage str)                    = showFunc1  "show_message" str
   showsPrec _ (ShowStatus str)                     = showFunc1  "show_status" str
   showsPrec _ (Position x y)                       = showFunc2  "position" x y
   showsPrec _ (Size w h)                           = showFunc2  "size" w h
   showsPrec _ Raise                                = showString "raise"
   showsPrec _ Iconify                              = showString "iconify"
   showsPrec _ Deiconify                            = showString "deiconify"
   showsPrec _ Activate                             = showString "activate"
   showsPrec _ Deactivate                           = showString "deactivate"
   showsPrec _ (FileBrowser open title btn dir file tps hid)
                                                    = showFunc7 "file_browser" open title btn dir file tps hid

instance Show TclCmd where
   showsPrec _ (DVEval str)                         = showFunc1  "eval" str
   showsPrec _ (EvalFile fname)                     = showFunc1  "eval_file" fname

instance Show SpecialCmd where
   showsPrec _ (SelectNodes nodes)                  = showFunc1  "select_nodes" nodes
   showsPrec _ (SelectEdge edges)                   = showFunc1  "select_edges" edges
   showsPrec _ (FocusNode nodeIds)                  = showFunc1  "focus_node" nodeIds
   showsPrec _ (FocusNodeAnimated nodeIds)          = showFunc1  "focus_node_animated" nodeIds
   showsPrec _ (ShowUrl url)                        = showFunc1  "show_url" url
   showsPrec _ Version                              = showString "version"

instance Show VisualCmd where
   showsPrec _ (NewRules visualRules)               = showFunc1  "new_rules" visualRules
   showsPrec _ (AddRules visualRules)               = showFunc1  "add_rules" visualRules

instance Show DragAndDropCmd where
   showsPrec _ DraggingOn                           = showString "dragging_on"
   showsPrec _ DragAndDropOn                        = showString "drag_and_drop_on"
   showsPrec _ DraggingOff                          = showString "dragging_off"
   showsPrec _ (NewNodeAtCoord nUpd)                = showFunc1  "new_node_at_coord" nUpd
   showsPrec _ (NewEdgeAndNodeAtCoord nUpd eUpd)    = showFunc2  "new_edge_and_node_at_coord" nUpd eUpd
---------------------------------------------------------------------------

instance Show DaVinciAnswer where
   showsPrec _ Ok                                   = showString "ok"
   showsPrec _ (CommunicationError msg)             = showFunc1  "communication_error" msg
   showsPrec _ (NodeSelectionsLabels nodeIds)       = showFunc1  "node_selections_labels" nodeIds
   showsPrec _ NodeDoubleClick                      = showString "node_double_click"
   showsPrec _ (EdgeSelectionLabel edgeId)          = showFunc1  "edge_selection_label" edgeId
   showsPrec _ (EdgeSelectionLabels parent child)   = showFunc2  "edge_selection_labels" parent child
   showsPrec _ EdgeDoubleClick                      = showString "edge_double_click"
   showsPrec _ (MenuSelection menuId)               = showFunc1  "menu_selection" menuId
   showsPrec _ (IconSelection iconId)               = showFunc1  "icon_selection" iconId
   showsPrec _ (Context contextId)                  = showFunc1  "context" contextId
   showsPrec _ (TclAnswer retVal)                   = showFunc1  "tcl_answer" retVal
   showsPrec _ (BrowserAnswer file typ)             = showFunc2  "browser_answer" file typ
   showsPrec _ Disconnect                           = showString "disconnect"
   showsPrec _ Closed                               = showString "close"
   showsPrec _ Quit                                 = showString "quit"
   showsPrec _ (PopupSelectionNode nId mId)         = showFunc2  "popup_selection_node" nId mId
   showsPrec _ (PopupSelectionEdge eId mId)         = showFunc2  "popup_selection_edge" eId mId
   showsPrec _ CreateNode                           = showString "create_node"
   showsPrec _ (CreateNodeAndEdge nId)              = showFunc1  "create_node_and_edge" nId
   showsPrec _ (CreateEdge nId1 nId2)               = showFunc2  "create_edge" nId1 nId2
   showsPrec _ (DropNode nId1 cId2 wId2 nId2)       = showFunc4 "drop_node" nId1 cId2 wId2 nId2
   showsPrec _ (ContextWindow cId wId)              = showFunc2  "context_window" cId wId
   showsPrec _ OpenWindow                           = showString "open_window"
   showsPrec _ (CloseWindow wId)                    = showFunc1  "close_window" wId
   showsPrec _ (Versioned string)                   = showFunc1 "version" string
instance Read DaVinciAnswer where
   readsPrec _ r =
      [ (Ok,                                        s) | ("ok",                     s) <- lexR       ] ++
      [ (CommunicationError m,                      t) | ("communication_error",    s) <- lexR ,
                                                         ([m],                      t) <- readArgs s ] ++
      [ (Versioned m    ,                           t) | ("version",                s) <- lexR ,
                                                         ([m],                      t) <- readArgs s ] ++
      [ (NodeSelectionsLabels (map NodeId n),       t) | ("node_selections_labels", s) <- lexR ,
                                                         (n,                        t) <- readStrs s ] ++
      [ (NodeDoubleClick,                           s) | ("node_double_click",      s) <- lexR       ] ++
      [ (EdgeSelectionLabel (EdgeId e),             t) | ("edge_selection_label",   s) <- lexR ,
                                                         ([e],                      t) <- readArgs s ] ++
      [ (EdgeSelectionLabels (NodeId p) (NodeId c), t) | ("edge_selection_labels",  s) <- lexR ,
                                                         ([p,c],                    t) <- readArgs s ] ++
      [ (EdgeDoubleClick,                           s) | ("edge_double_click",      s) <- lexR       ] ++
      [ (MenuSelection (MenuId m),                  t) | ("menu_selection",         s) <- lexR ,
                                                         ([m],                      t) <- readArgs s ] ++
      [ (IconSelection (IconId i),                  t) | ("icon_selection",         s) <- lexR ,
                                                         ([i],                      t) <- readArgs s ] ++
      [ (Context (ContextId c),                     t) | ("context",                s) <- lexR ,
                                                         ([c],                      t) <- readArgs s ] ++
      [ (TclAnswer a,                               t) | ("tcl_answer",             s) <- lexR ,
                                                         ([a],                      t) <- readArgs s ] ++
      [ (BrowserAnswer f y,                         t) | ("browser_answer",         s) <- lexR ,
                                                         ([f,y],                    t) <- readArgs s ] ++
      [ (Disconnect,                                s) | ("disconnect",             s) <- lexR       ] ++
      [ (Closed,                                    s) | ("close",                 s) <- lexR       ] ++
      [ (Quit,                                      s) | ("quit",                   s) <- lexR       ] ++
      [ (PopupSelectionNode (NodeId n) (MenuId m),  t) | ("popup_selection_node",   s) <- lexR ,
                                                         ([n,m],                    t) <- readArgs s ] ++
      [ (PopupSelectionEdge (EdgeId e) (MenuId m),  t) | ("popup_selection_edge",   s) <- lexR ,
                                                         ([e,m],                    t) <- readArgs s ] ++
      [ (CreateNode,                                s) | ("create_node",            s) <- lexR       ] ++
      [ (CreateNodeAndEdge (NodeId n),              t) | ("create_node_and_edge",   s) <- lexR ,
                                                         ([n],                      t) <- readArgs s ] ++
      [ (CreateEdge (NodeId n1) (NodeId n2),        t) | ("create_edge",            s) <- lexR ,
                                                         ([n1, n2],                 t) <- readArgs s ] ++
      [ (DropNode (NodeId n1) (ContextId c2) (WindowId w2) (NodeId n2), t)
                                                       | ("drop_node",              s) <- lexR ,
                                                         ([n1,c2,w2,n2],            t) <- readArgs s ] ++
      [ (ContextWindow (ContextId c) (WindowId w), t)| ("context_window",           s) <- lexR ,
                                                         ([c,w],                    t) <- readArgs s ] ++
      [ (OpenWindow,                                s) | ("open_window",            s) <- lexR       ] ++
      [ (CloseWindow (WindowId w),                  t) | ("close_window",           s) <- lexR ,
                                                         ([w],                      t) <- readArgs s ]

         where lexR = lex r

               readArgs :: ReadS [String]
               readArgs s = [ (x:xs, v) | ("(", t) <- lex s,
                                          (x,   u) <- reads t,
                                          (xs,  v) <- readArgs2 u ]

               readArgs2 :: ReadS [String]
               readArgs2 s = [ ([],   t) | (")",t) <- lex s ] ++
                             [ (x:xs, v) | (",",t) <- lex s,
                                           (x,  u) <- reads t,
                                           (xs, v) <- readArgs2 u ]

               readStrs :: ReadS [String]
               readStrs = reads

---------------------------------------------------------------------------

instance Show Node where
   showsPrec _ (N nodeId typ attrs edges) = showLabeled nodeId (showFunc3 "n" typ attrs edges)
   showsPrec _ (R nodeId)                 = showFunc1 "r" nodeId
   showList = showLst

instance Show Edge where
   showsPrec _ (E edgeId typ attrs node) = showLabeled edgeId (showFunc3 "e" typ attrs node)
   showList = showLst

instance Show Attribute where
   showsPrec _ (A key value)   = showFunc2 "a" key value
   showsPrec _ (M menuEntries) = showFunc1 "m" menuEntries
   showList = showLst

instance Show NodeUpdate where
   showsPrec _ (DeleteNode nodeId)        = showFunc1 "delete_node" nodeId
   showsPrec _ (NewNode nodeId typ attrs) = showFunc3 "new_node" nodeId typ attrs
   showList = showLst

instance Show EdgeUpdate where
   showsPrec _ (DeleteEdge edgeId) = showFunc1 "delete_edge" edgeId
   showsPrec _ (NewEdge edgeId typ attrs nodeId1 nodeId2) = showFunc5 "new_edge" edgeId typ attrs nodeId1 nodeId2
   showsPrec _ (NewEdgeBehind edgeId1 edgeId2 typ attrs nodeId1 nodeId2) = showFunc6 "new_edge_behind" edgeId1 edgeId2 typ attrs nodeId1 nodeId2
   showList = showLst

instance Show MixedUpdate where
   showsPrec _ (NU nUpd) = shows nUpd
   showsPrec _ (EU eUpd) = shows eUpd
   showList = showLst

instance Show AttrChange where
   showsPrec _ (Node nodeId attrs) = showFunc2 "node" nodeId attrs
   showsPrec _ (Edge edgeId attrs) = showFunc2 "edge" edgeId attrs
   showList = showLst

instance Show TypeChange where
   showsPrec _ (NodeType nodeId typ) = showFunc2 "node" nodeId typ
   showsPrec _ (EdgeType edgeId typ) = showFunc2 "edge" edgeId typ
   showList = showLst

---------------------------------------------------------------------------

instance Show MenuEntry where
   showsPrec _ (MenuEntry menuId menuLabel) = showFunc2 "menu_entry" menuId menuLabel
   showsPrec _ (MenuEntryMne menuId menuLabel menuMne menuMod menuAcc) = showFunc5 "menu_entry_mne" menuId menuLabel menuMne menuMod menuAcc
   showsPrec _ (SubmenuEntry menuId menuLabel menuEntries) = showFunc3 "submenu_entry" menuId menuLabel menuEntries
   showsPrec _ (SubmenuEntryMne menuId menuLabel menuEntries menuMne) = showFunc4 "submenu_entry_mne" menuId menuLabel menuEntries menuMne
   showsPrec _ BlankMenuEntry = showString "blank"
   showsPrec _ (MenuEntryDisabled menuId menuLabel) = showFunc2 "menu_entry_disabled" menuId menuLabel
   showsPrec _ (SubmenuEntryDisabled menuId menuLabel menuEntries) = showFunc3 "submenu_entry_disabled" menuId menuLabel menuEntries

instance Show IconEntry where
   showsPrec _ (IconEntry iconId filename descr) = showFunc3 "icon_entry" iconId filename descr
   showsPrec _ BlankIconEntry                    = showString "blank"

---------------------------------------------------------------------------

instance Show VisualRule where
   showsPrec _ (NR typ attrs) = showFunc2 "nr" typ attrs
   showsPrec _ (ER typ attrs) = showFunc2 "er" typ attrs
   showList = showLst

---------------------------------------------------------------------------

instance Show NodeId where
   showsPrec _ (NodeId s) = shows s
   showList = showLst

instance Show EdgeId where
   showsPrec _ (EdgeId s) = shows s
   showList = showLst

instance Show MenuId where
   showsPrec _ (MenuId s) = shows s
   showList = showLst

instance Show MenuLabel where
   showsPrec _ (MenuLabel s) = shows s
   showList = showLst

instance Show MenuMne where
   showsPrec _ (MenuMne s) = shows s
   showList = showLst

instance Show MenuAcc where
   showsPrec _ (MenuAcc s) = shows s
   showList = showLst

instance Show IconId where
   showsPrec _ (IconId s) = shows s
   showList = showLst

instance Show Type where
   showsPrec _ (Type s) = shows s
   showList = showLst

instance Show Filename where
   showsPrec _ (Filename s) = shows s
   showList = showLst

instance Show ContextId where
   showsPrec _ (ContextId s) = shows s
   showList = showLst

instance Show WindowId where
   showsPrec _ (WindowId s) = shows s
   showList = showLst

---------------------------------------------------------------------------

instance Show Orient where
   showsPrec _ TopDown   = showString "top_down"
   showsPrec _ BottomUp  = showString "bottom_up"
   showsPrec _ LeftRight = showString "left_right"
   showsPrec _ RightLeft = showString "right_left"

instance Show Direction where
   showsPrec _ Up      = showString "up"
   showsPrec _ Down    = showString "down"
   showsPrec _ DVLeft  = showString "left"
   showsPrec _ DVRight = showString "right"

instance Show Btype where
   showsPrec _ (Bt txt pat post) = showFunc3 "bt" txt pat post

instance Show MenuMod where
   showsPrec _ Alternate = showString "alt"
   showsPrec _ Shift     = showString "shift"
   showsPrec _ Control   = showString "control"
   showsPrec _ Meta      = showString "meta"
   showsPrec _ None      = showString "none"

---------------------------------------------------------------------------

showFunc1 :: Show a => String -> a -> ShowS
showFunc1 funcName arg1 =
   showString funcName . showParen True (shows arg1)

showFunc2 :: (Show a,Show b) => String -> a -> b -> ShowS
showFunc2 funcName arg1 arg2 =
   showString funcName . showParen True (shows arg1 . showChar ',' .
                                         shows arg2)

showFunc3 :: (Show a,Show b,Show c) => String -> a -> b -> c -> ShowS
showFunc3 funcName arg1 arg2 arg3 =
   showString funcName . showParen True (shows arg1 . showChar ',' .
                                         shows arg2 . showChar ',' .
                                         shows arg3)

showFunc4 :: (Show a,Show b,Show c,Show d) => String -> a -> b -> c -> d -> ShowS
showFunc4 funcName arg1 arg2 arg3 arg4 =
   showString funcName . showParen True (shows arg1 . showChar ',' .
                                         shows arg2 . showChar ',' .
                                         shows arg3 . showChar ',' .
                                         shows arg4)

showFunc5 :: (Show a,Show b,Show c,Show d,Show e) => String -> a -> b -> c -> d -> e -> ShowS
showFunc5 funcName arg1 arg2 arg3 arg4 arg5 =
   showString funcName . showParen True (shows arg1 . showChar ',' .
                                         shows arg2 . showChar ',' .
                                         shows arg3 . showChar ',' .
                                         shows arg4 . showChar ',' .
                                         shows arg5)

showFunc6 :: (Show a,Show b,Show c,Show d,Show e,Show f) => String -> a -> b -> c -> d -> e -> f -> ShowS
showFunc6 funcName arg1 arg2 arg3 arg4 arg5 arg6 =
   showString funcName . showParen True (shows arg1 . showChar ',' .
                                         shows arg2 . showChar ',' .
                                         shows arg3 . showChar ',' .
                                         shows arg4 . showChar ',' .
                                         shows arg5 . showChar ',' .
                                         shows arg6)

showFunc7 :: (Show a,Show b,Show c,Show d,Show e,Show f,Show g) => String -> a -> b -> c -> d -> e -> f -> g -> ShowS
showFunc7 funcName arg1 arg2 arg3 arg4 arg5 arg6 arg7 =
   showString funcName . showParen True (shows arg1 . showChar ',' .
                                         shows arg2 . showChar ',' .
                                         shows arg3 . showChar ',' .
                                         shows arg4 . showChar ',' .
                                         shows arg5 . showChar ',' .
                                         shows arg6 . showChar ',' .
                                         shows arg7)

showLabeled :: Show a => a -> ShowS -> ShowS
showLabeled iD arg = showChar 'l' . showParen True (shows iD . showChar ',' . arg)

showLst :: Show a => [a] -> ShowS
showLst []       = showString "[]"
showLst (x:xs)   = showChar '[' . shows x . showl xs
                   where showl []     = showChar ']'
                         showl (y:ys) = showChar ',' . shows y . showl ys

showBoolFunc :: String -> Bool -> ShowS
showBoolFunc funcName flag =
   showString funcName . showParen True (showString (if flag then "true" else "false"))