{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverlappingInstances #-}

-- |
-- Description: Extended Interface for Graph Display
--
-- GraphConfigure contains definitions for the various configuration
-- options for "GraphDisp" objects.  These should be implemented
-- using the 'HasConfig', 'HasConfigValue' and 'ModifyHasDef',
-- applied to instances of
-- 'GraphParms', 'NodeTypeParms' and 'ArcTypeParms'.
module Graphs.GraphConfigure(
   GraphAllConfig, -- this is a subclass of GraphAll plus ALL configuration
                   -- options in this file.
   HasGraphConfigs, -- all options for configuring graphs
   HasNodeTypeConfigs, -- ditto node types
   HasNodeModifies, -- all options for modifying nodes.
   HasArcTypeConfigs, -- ditto arc types

   HasConfig(($$),configUsed), -- from Computation
   HasConfigValue(($$$),configUsed'),
                   -- HasConfig lifted to options/configurations of kind
                   -- 1 which take a Typeable value.
   HasModifyValue(..),
      -- used for changing properties of existing objects.

   -- LocalMenu describes menus or buttons for objects that carry a value,
   -- IE nodes or arcs.
   LocalMenu(..),

   -- GlobalMenu describes menus or buttons for objects that don't carry a
   -- value, IE graphs.
   GlobalMenu(..),

   -- function for combining global menus.
   combineGlobalMenus, -- :: [GlobalMenu] -> GlobalMenu

   -- MenuPrim is supposed to be the generalised Menu/Button type.
   MenuPrim(..), -- a type with TWO parameters.  We provide maps
                       -- and monadic methods for both.
   mapMenuPrim,
   mapMenuPrim',
   mapMMenuPrim,
   mapMMenuPrim',

   -- Titles for graphs and objects
   GraphTitle(..),
   ValueTitle(..),
   ValueTitleSource(..),

   -- Shapes for nodes
   Shape(..),

   -- Colours
   Color(..),

   -- Edge patterns
   EdgePattern(..),

   -- Edge Direction (_DIR)
   EdgeDir(..),

   -- Edge Head (HEAD)
   Head(..),

   NodeArcsHidden(..), -- Setting if a node's arcs are hidden or not.
   Border(..), -- Specifying a node's border.
   BorderSource(..), -- allowing it to depend on a source.
   FontStyle(..), -- Specifying the font style for a node.
   FontStyleSource(..), -- allowing it to depend on a source.
   ModifyHasDef(..),
      -- specifies default values for these options.

   -- Drag and Drop actions.
   GraphGesture(..),
   NodeGesture(..),
   NodeDragAndDrop(..),

   -- Double click actions
   DoubleClickAction(..),

   -- Graph Miscellaneous Flags
   OptimiseLayout(..),
   SurveyView(..),
   AllowDragging(..),
   AllowClose(..),
   defaultAllowClose,
   FileMenuAct(..),FileMenuOption(..),

   Orientation(..),
   ActionWrapper(..),

   -- ($$$?) is used for Maybe (option), where Nothing means
   -- "No change".
   ($$$?),
   ) where

import Util.Computation(HasConfig(($$),configUsed),done)
import Util.ExtendedPrelude
import Util.Dynamics(Dyn,Typeable)
import Util.Messages
import Util.Sources
import Util.Delayer

import HTk.Toolkit.MenuType

import Graphs.GraphDisp

------------------------------------------------------------------------
-- HasConfigValue is a useful extension of HasConfig for types that
-- take a Typeable value; EG node and arc configurations.
------------------------------------------------------------------------

class HasConfigValue option configuration where
   ($$$) :: Typeable value
      => option value -> configuration value -> configuration value

   configUsed' :: Typeable value
      => option value -> configuration value -> Bool

infixr 0 $$$

instance (Typeable value,HasConfigValue option configuration)
   => HasConfig (option value) (configuration value) where
   $$ :: option value -> configuration value -> configuration value
($$) = option value -> configuration value -> configuration value
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
($$$)
   configUsed :: option value -> configuration value -> Bool
configUsed = option value -> configuration value -> Bool
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> Bool
configUsed'

-- | $$$? can be a useful abbreviation
($$$?) :: (HasConfigValue option configuration,Typeable value)
    => Maybe (option value) -> configuration value -> configuration value
$$$? :: Maybe (option value) -> configuration value -> configuration value
($$$?) Maybe (option value)
Nothing configuration value
configuration = configuration value
configuration
($$$?) (Just option value
option) configuration value
configuration = option value -> configuration value -> configuration value
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
($$$) option value
option configuration value
configuration

infixr 0 $$$?


------------------------------------------------------------------------
-- HasModifyValue is used for dynamic changes to nodes and arcs.
------------------------------------------------------------------------

class HasModifyValue option graph object where
   modify :: Typeable value => option -> graph -> object value -> IO ()

instance HasModifyValue option graph object
   => HasModifyValue (Maybe option) graph object
   where
      modify :: Maybe option -> graph -> object value -> IO ()
modify Maybe option
Nothing graph
_ object value
_ = IO ()
forall (m :: * -> *). Monad m => m ()
done
      modify (Just option
option) graph
graph object value
node = option -> graph -> object value -> IO ()
forall option graph (object :: * -> *) value.
(HasModifyValue option graph object, Typeable value) =>
option -> graph -> object value -> IO ()
modify option
option graph
graph object value
node

------------------------------------------------------------------------
-- Menus and buttons
-- As in DaVinci, a menu is simply considered as a tree of buttons,
-- allowing an elegant recursive definition.
-- We define MenuPrim as it may be useful for
-- implementations, so they don't have to define their own datatypes
-- for menus.
------------------------------------------------------------------------

instance GraphConfig GlobalMenu

newtype GlobalMenu = GlobalMenu(MenuPrim (Maybe String) (IO ()))

instance NodeTypeConfig LocalMenu

instance ArcTypeConfig LocalMenu

newtype LocalMenu value =
   LocalMenu(MenuPrim (Maybe String) (value -> IO()))

instance HasCoMapIO LocalMenu where
   coMapIO :: (a -> IO b) -> LocalMenu b -> LocalMenu a
coMapIO a -> IO b
a2bAct (LocalMenu MenuPrim (Maybe String) (b -> IO ())
menuPrim) =
      MenuPrim (Maybe String) (a -> IO ()) -> LocalMenu a
forall value.
MenuPrim (Maybe String) (value -> IO ()) -> LocalMenu value
LocalMenu
         (((b -> IO ()) -> a -> IO ())
-> MenuPrim (Maybe String) (b -> IO ())
-> MenuPrim (Maybe String) (a -> IO ())
forall a b c. (a -> b) -> MenuPrim c a -> MenuPrim c b
mapMenuPrim
            (\ b -> IO ()
b2Act ->
               (\ a
aValue ->
                  do
                     b
bValue <- a -> IO b
a2bAct a
aValue
                     b -> IO ()
b2Act b
bValue
                  )
               )
            MenuPrim (Maybe String) (b -> IO ())
menuPrim
            )

-- | As a service to MMiSS we provide a function which combines
-- several GlobalMenus into one.
combineGlobalMenus :: [GlobalMenu] -> GlobalMenu
combineGlobalMenus :: [GlobalMenu] -> GlobalMenu
combineGlobalMenus [GlobalMenu]
globalMenus =
   MenuPrim (Maybe String) (IO ()) -> GlobalMenu
GlobalMenu
      (Maybe String
-> [MenuPrim (Maybe String) (IO ())]
-> MenuPrim (Maybe String) (IO ())
forall subMenuValue value.
subMenuValue
-> [MenuPrim subMenuValue value] -> MenuPrim subMenuValue value
Menu Maybe String
forall a. Maybe a
Nothing ((GlobalMenu -> MenuPrim (Maybe String) (IO ()))
-> [GlobalMenu] -> [MenuPrim (Maybe String) (IO ())]
forall a b. (a -> b) -> [a] -> [b]
map (\ (GlobalMenu MenuPrim (Maybe String) (IO ())
menu) -> MenuPrim (Maybe String) (IO ())
menu) [GlobalMenu]
globalMenus))


------------------------------------------------------------------------
-- Titles
------------------------------------------------------------------------

data GraphTitle = GraphTitle String
instance GraphConfig GraphTitle

instance GraphConfig (SimpleSource GraphTitle)

-- | Provide a function which computes a node or arc title string to be
-- displayed.
data ValueTitle value = ValueTitle (value -> IO String)

-- | Provide a function which computes a source which generates a dynamically-
-- changing title.
data ValueTitleSource value
    = ValueTitleSource (value -> IO (SimpleSource String))

instance NodeTypeConfig ValueTitle

instance NodeTypeConfig ValueTitleSource

instance ArcTypeConfig ValueTitle

instance HasCoMapIO ValueTitle where
   coMapIO :: (a -> IO b) -> ValueTitle b -> ValueTitle a
coMapIO a -> IO b
a2bAct (ValueTitle b -> IO String
b2StringAct) =
      (a -> IO String) -> ValueTitle a
forall value. (value -> IO String) -> ValueTitle value
ValueTitle (
         \ a
aValue ->
            do
               b
bValue <- a -> IO b
a2bAct a
aValue
               b -> IO String
b2StringAct b
bValue
            )

------------------------------------------------------------------------
-- Drag and Drop
-- These are inspired by DaVinci's Drag and Drop functions.
-- Each configuration gives a corresponding action to perform.
-- We give DaVinci's suggested applications.
-- NB - where these are used the AllowDragging True
-- operator should also have been set for the graph.
------------------------------------------------------------------------

-- | Action to be performed after mouse action not involving any node but
-- somewhere on the graph.
--
-- If you want to use this, the graph parameters need to include
-- 'AllowDragging' 'True'
data GraphGesture = GraphGesture (IO ())

instance GraphConfig GraphGesture

-- | Action to be performed when the user drags a node somewhere else,
-- but not onto another node.
--
-- If you want to use this, the graph parameters need to include
-- 'AllowDragging' 'True'
data NodeGesture value = NodeGesture (value -> IO ())

instance NodeTypeConfig NodeGesture

instance HasCoMapIO NodeGesture where
   coMapIO :: (a -> IO b) -> NodeGesture b -> NodeGesture a
coMapIO a -> IO b
a2bAct (NodeGesture b -> IO ()
b2StringAct) =
      (a -> IO ()) -> NodeGesture a
forall value. (value -> IO ()) -> NodeGesture value
NodeGesture (
         \ a
aValue ->
            do
               b
bValue <- a -> IO b
a2bAct a
aValue
               b -> IO ()
b2StringAct b
bValue
            )

-- | Action to be performed when the user drags one node onto another.
-- The dragged node's value is passed as a Dyn (since it could have any
-- type).
--
-- If you want to use this, the graph parameters need to include
-- 'AllowDragging' 'True'
data NodeDragAndDrop value = NodeDragAndDrop (Dyn -> value -> IO ())

instance NodeTypeConfig NodeDragAndDrop

------------------------------------------------------------------------
-- Double click actions
------------------------------------------------------------------------

-- | Action to be performed when a node or arc is double-clicked.
newtype DoubleClickAction value = DoubleClickAction (value -> IO ())

instance NodeTypeConfig DoubleClickAction

instance ArcTypeConfig DoubleClickAction

------------------------------------------------------------------------
-- Shape, colours, and edge patterns
------------------------------------------------------------------------

-- | This datatype is based on "DaVinciClasses", including several
-- name clashes.  However we omit 'Textual', add the file argument
-- to 'Icon' and the shape 'Triangle'.  This datatype may get bigger!
data Shape value = Box | Circle | Ellipse | Rhombus | Triangle |
   Icon FilePath deriving (ReadPrec [Shape value]
ReadPrec (Shape value)
Int -> ReadS (Shape value)
ReadS [Shape value]
(Int -> ReadS (Shape value))
-> ReadS [Shape value]
-> ReadPrec (Shape value)
-> ReadPrec [Shape value]
-> Read (Shape value)
forall value. ReadPrec [Shape value]
forall value. ReadPrec (Shape value)
forall value. Int -> ReadS (Shape value)
forall value. ReadS [Shape value]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Shape value]
$creadListPrec :: forall value. ReadPrec [Shape value]
readPrec :: ReadPrec (Shape value)
$creadPrec :: forall value. ReadPrec (Shape value)
readList :: ReadS [Shape value]
$creadList :: forall value. ReadS [Shape value]
readsPrec :: Int -> ReadS (Shape value)
$creadsPrec :: forall value. Int -> ReadS (Shape value)
Read,Int -> Shape value -> ShowS
[Shape value] -> ShowS
Shape value -> String
(Int -> Shape value -> ShowS)
-> (Shape value -> String)
-> ([Shape value] -> ShowS)
-> Show (Shape value)
forall value. Int -> Shape value -> ShowS
forall value. [Shape value] -> ShowS
forall value. Shape value -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Shape value] -> ShowS
$cshowList :: forall value. [Shape value] -> ShowS
show :: Shape value -> String
$cshow :: forall value. Shape value -> String
showsPrec :: Int -> Shape value -> ShowS
$cshowsPrec :: forall value. Int -> Shape value -> ShowS
Show)

instance NodeTypeConfig Shape

-- | The user is responsible for making sure this String is properly
-- formatted.  To quote from the daVinci documentation:
--
-- > Can be used to define the background color of a node. The value of this
-- > attribute may be any X-Window colorname (see file lib/rgb.txt in your X11
-- > directory) or any RGB color specification in a format like "#0f331e",
-- > where 0f is the hexadecimal value for the red part of the color, 33 is
-- > the green part and 1e is the blue.  Hence, a pallet of 16.7 million
-- > colors is supported. The default color for nodes is "white".
--
-- There is a function for constructing \"RGB color specification\"s in
-- "Colour".
newtype Color value = Color String deriving (ReadPrec [Color value]
ReadPrec (Color value)
Int -> ReadS (Color value)
ReadS [Color value]
(Int -> ReadS (Color value))
-> ReadS [Color value]
-> ReadPrec (Color value)
-> ReadPrec [Color value]
-> Read (Color value)
forall value. ReadPrec [Color value]
forall value. ReadPrec (Color value)
forall value. Int -> ReadS (Color value)
forall value. ReadS [Color value]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Color value]
$creadListPrec :: forall value. ReadPrec [Color value]
readPrec :: ReadPrec (Color value)
$creadPrec :: forall value. ReadPrec (Color value)
readList :: ReadS [Color value]
$creadList :: forall value. ReadS [Color value]
readsPrec :: Int -> ReadS (Color value)
$creadsPrec :: forall value. Int -> ReadS (Color value)
Read,Int -> Color value -> ShowS
[Color value] -> ShowS
Color value -> String
(Int -> Color value -> ShowS)
-> (Color value -> String)
-> ([Color value] -> ShowS)
-> Show (Color value)
forall value. Int -> Color value -> ShowS
forall value. [Color value] -> ShowS
forall value. Color value -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Color value] -> ShowS
$cshowList :: forall value. [Color value] -> ShowS
show :: Color value -> String
$cshow :: forall value. Color value -> String
showsPrec :: Int -> Color value -> ShowS
$cshowsPrec :: forall value. Int -> Color value -> ShowS
Show)
instance NodeTypeConfig Color

instance ArcTypeConfig Color

-- | The pattern of an edge
data EdgePattern value = Solid | Dotted | Dashed | Thick | Double
   deriving (ReadPrec [EdgePattern value]
ReadPrec (EdgePattern value)
Int -> ReadS (EdgePattern value)
ReadS [EdgePattern value]
(Int -> ReadS (EdgePattern value))
-> ReadS [EdgePattern value]
-> ReadPrec (EdgePattern value)
-> ReadPrec [EdgePattern value]
-> Read (EdgePattern value)
forall value. ReadPrec [EdgePattern value]
forall value. ReadPrec (EdgePattern value)
forall value. Int -> ReadS (EdgePattern value)
forall value. ReadS [EdgePattern value]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [EdgePattern value]
$creadListPrec :: forall value. ReadPrec [EdgePattern value]
readPrec :: ReadPrec (EdgePattern value)
$creadPrec :: forall value. ReadPrec (EdgePattern value)
readList :: ReadS [EdgePattern value]
$creadList :: forall value. ReadS [EdgePattern value]
readsPrec :: Int -> ReadS (EdgePattern value)
$creadsPrec :: forall value. Int -> ReadS (EdgePattern value)
Read,Int -> EdgePattern value -> ShowS
[EdgePattern value] -> ShowS
EdgePattern value -> String
(Int -> EdgePattern value -> ShowS)
-> (EdgePattern value -> String)
-> ([EdgePattern value] -> ShowS)
-> Show (EdgePattern value)
forall value. Int -> EdgePattern value -> ShowS
forall value. [EdgePattern value] -> ShowS
forall value. EdgePattern value -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EdgePattern value] -> ShowS
$cshowList :: forall value. [EdgePattern value] -> ShowS
show :: EdgePattern value -> String
$cshow :: forall value. EdgePattern value -> String
showsPrec :: Int -> EdgePattern value -> ShowS
$cshowsPrec :: forall value. Int -> EdgePattern value -> ShowS
Show)

instance ArcTypeConfig EdgePattern

-- | The user is responsible for making sure this String is properly
-- formatted.  To quote from the daVinci documentation:
--
-- > This attribute is used to control the arrow of an edge. In a graph visualization,
-- > each edge usually has an arrow pointing to the child node. This attribute can be
-- > used to let the arrow be drawn inverse (i.e. pointing to the parent), to get an arrow
-- > at both sides of an edge or to suppress arrows for a particular edge. The supported
-- > attribute values are: "last" (1 arrow pointing to the child, default), \"first\"
-- >(1 arrow to the parent), "both" (2 arrows to the parent and to children) and "none"
-- >(no arrows).
--
data EdgeDir value = Dir String deriving (ReadPrec [EdgeDir value]
ReadPrec (EdgeDir value)
Int -> ReadS (EdgeDir value)
ReadS [EdgeDir value]
(Int -> ReadS (EdgeDir value))
-> ReadS [EdgeDir value]
-> ReadPrec (EdgeDir value)
-> ReadPrec [EdgeDir value]
-> Read (EdgeDir value)
forall value. ReadPrec [EdgeDir value]
forall value. ReadPrec (EdgeDir value)
forall value. Int -> ReadS (EdgeDir value)
forall value. ReadS [EdgeDir value]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [EdgeDir value]
$creadListPrec :: forall value. ReadPrec [EdgeDir value]
readPrec :: ReadPrec (EdgeDir value)
$creadPrec :: forall value. ReadPrec (EdgeDir value)
readList :: ReadS [EdgeDir value]
$creadList :: forall value. ReadS [EdgeDir value]
readsPrec :: Int -> ReadS (EdgeDir value)
$creadsPrec :: forall value. Int -> ReadS (EdgeDir value)
Read, Int -> EdgeDir value -> ShowS
[EdgeDir value] -> ShowS
EdgeDir value -> String
(Int -> EdgeDir value -> ShowS)
-> (EdgeDir value -> String)
-> ([EdgeDir value] -> ShowS)
-> Show (EdgeDir value)
forall value. Int -> EdgeDir value -> ShowS
forall value. [EdgeDir value] -> ShowS
forall value. EdgeDir value -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EdgeDir value] -> ShowS
$cshowList :: forall value. [EdgeDir value] -> ShowS
show :: EdgeDir value -> String
$cshow :: forall value. EdgeDir value -> String
showsPrec :: Int -> EdgeDir value -> ShowS
$cshowsPrec :: forall value. Int -> EdgeDir value -> ShowS
Show)

instance ArcTypeConfig EdgeDir


-- | The user is responsible for making sure this String is properly
-- formatted.  To quote from the daVinci documentation:
--
-- >  With this attribute you can control the shape of the edge's arrows.
-- > The possible values are: "farrow" (default), "arrow", "fcircle", and "circle",
-- > where a leading 'f' means filled.
--
data Head value = Head String deriving (ReadPrec [Head value]
ReadPrec (Head value)
Int -> ReadS (Head value)
ReadS [Head value]
(Int -> ReadS (Head value))
-> ReadS [Head value]
-> ReadPrec (Head value)
-> ReadPrec [Head value]
-> Read (Head value)
forall value. ReadPrec [Head value]
forall value. ReadPrec (Head value)
forall value. Int -> ReadS (Head value)
forall value. ReadS [Head value]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Head value]
$creadListPrec :: forall value. ReadPrec [Head value]
readPrec :: ReadPrec (Head value)
$creadPrec :: forall value. ReadPrec (Head value)
readList :: ReadS [Head value]
$creadList :: forall value. ReadS [Head value]
readsPrec :: Int -> ReadS (Head value)
$creadsPrec :: forall value. Int -> ReadS (Head value)
Read, Int -> Head value -> ShowS
[Head value] -> ShowS
Head value -> String
(Int -> Head value -> ShowS)
-> (Head value -> String)
-> ([Head value] -> ShowS)
-> Show (Head value)
forall value. Int -> Head value -> ShowS
forall value. [Head value] -> ShowS
forall value. Head value -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Head value] -> ShowS
$cshowList :: forall value. [Head value] -> ShowS
show :: Head value -> String
$cshow :: forall value. Head value -> String
showsPrec :: Int -> Head value -> ShowS
$cshowsPrec :: forall value. Int -> Head value -> ShowS
Show)

instance ArcTypeConfig Head

------------------------------------------------------------------------
-- Node miscellaneous flags
------------------------------------------------------------------------

class ModifyHasDef modification where
   def :: modification
   isDef :: modification -> Bool

-- | If True, arcs from the node are not displayed.
newtype NodeArcsHidden = NodeArcsHidden Bool

instance ModifyHasDef NodeArcsHidden where
   def :: NodeArcsHidden
def = Bool -> NodeArcsHidden
NodeArcsHidden Bool
False
   isDef :: NodeArcsHidden -> Bool
isDef (NodeArcsHidden Bool
b) = Bool -> Bool
not Bool
b

-- | The border of this node
data Border = NoBorder | SingleBorder | DoubleBorder

-- | Compute a 'Border' which dynamically changes.
data BorderSource value = BorderSource (value -> IO (SimpleSource Border))

instance NodeTypeConfig BorderSource

{- Modification is no longer approved of for Borders, which should be
   set by Sources. -}
{-
instance ModifyHasDef Border where
   def = SingleBorder
   isDef SingleBorder = True
   isDef _ = False
-}

-- | The font in which the label of this node is displayed.
data FontStyle = NormalFontStyle | BoldFontStyle | ItalicFontStyle
   | BoldItalicFontStyle deriving (FontStyle -> FontStyle -> Bool
(FontStyle -> FontStyle -> Bool)
-> (FontStyle -> FontStyle -> Bool) -> Eq FontStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FontStyle -> FontStyle -> Bool
$c/= :: FontStyle -> FontStyle -> Bool
== :: FontStyle -> FontStyle -> Bool
$c== :: FontStyle -> FontStyle -> Bool
Eq)

{- Modification is no longer approved for FontStyle's, which should
   be set by Sources.
instance ModifyHasDef FontStyle where
   def = BoldFontStyle
   isDef BoldFontStyle = True
   isDef _ = False
-}

-- | Compute a 'FontStyle' which dynamically changes.
data FontStyleSource value
    = FontStyleSource (value -> IO (SimpleSource FontStyle))

instance NodeTypeConfig FontStyleSource

------------------------------------------------------------------------
-- Graph Miscellaneous Flags.
-- (Fairly daVinci specific)
-- Where these are unset, they should always default to False.
------------------------------------------------------------------------

-- | If 'True', try hard to optimise the layout of the graph
-- on redrawing it.
newtype OptimiseLayout = OptimiseLayout Bool


instance GraphConfig OptimiseLayout

-- | If True, add a survey view of the graph; IE display
-- a picture of the whole graph which fits onto the
-- screen (without displaying everything)
-- as well as a picture of the details (which may not
-- fit onto the screen).
--
-- (The user can do this anyway from daVinci's menus.)
newtype SurveyView = SurveyView Bool

instance GraphConfig SurveyView

-- | If True, allow Drag-and-Drop operators.
newtype AllowDragging = AllowDragging Bool

-- | If set, action which is invoked if the user attempts to close the
-- window.  If the action returns True, we close it.
--
-- WARNING.  This action is performed in the middle of the event loop,
-- so please don't attempt to do any further graph interactions during it.
-- (But HTk interactions should be fine.)
newtype AllowClose = AllowClose (IO Bool)

defaultAllowClose :: AllowClose
defaultAllowClose :: AllowClose
defaultAllowClose = IO Bool -> AllowClose
AllowClose (String -> IO Bool
confirmMess String
"Really close window?")


-- | The following options are provided specially by DaVinci (see, for now,
-- <http://www.informatik.uni-bremen.de/daVinci/old/docs/reference/api/api_app_menu_cmd.html>
-- for the daVinci2.1 documentation.  If a 'FileMenuAct' is used as
-- a configuration with a specified action, the corresponding option is
-- enabled in the daVinci File menu, and the action is performed when the
-- option is selected.
--
-- The 'AllowClose' configuration and 'CloseMenuOption' both set the action
-- to be taken when the user selects a close event, and each overrides the
-- other.
--
-- By default the Close and Print options are enabled, however these
-- and other options can be disabled by specifing 'Nothing' as the
-- second argument to FileMenuAct.
data FileMenuOption =
      NewMenuOption | OpenMenuOption | SaveMenuOption | SaveAsMenuOption
   |  PrintMenuOption | CloseMenuOption | ExitMenuOption deriving (Eq FileMenuOption
Eq FileMenuOption
-> (FileMenuOption -> FileMenuOption -> Ordering)
-> (FileMenuOption -> FileMenuOption -> Bool)
-> (FileMenuOption -> FileMenuOption -> Bool)
-> (FileMenuOption -> FileMenuOption -> Bool)
-> (FileMenuOption -> FileMenuOption -> Bool)
-> (FileMenuOption -> FileMenuOption -> FileMenuOption)
-> (FileMenuOption -> FileMenuOption -> FileMenuOption)
-> Ord FileMenuOption
FileMenuOption -> FileMenuOption -> Bool
FileMenuOption -> FileMenuOption -> Ordering
FileMenuOption -> FileMenuOption -> FileMenuOption
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FileMenuOption -> FileMenuOption -> FileMenuOption
$cmin :: FileMenuOption -> FileMenuOption -> FileMenuOption
max :: FileMenuOption -> FileMenuOption -> FileMenuOption
$cmax :: FileMenuOption -> FileMenuOption -> FileMenuOption
>= :: FileMenuOption -> FileMenuOption -> Bool
$c>= :: FileMenuOption -> FileMenuOption -> Bool
> :: FileMenuOption -> FileMenuOption -> Bool
$c> :: FileMenuOption -> FileMenuOption -> Bool
<= :: FileMenuOption -> FileMenuOption -> Bool
$c<= :: FileMenuOption -> FileMenuOption -> Bool
< :: FileMenuOption -> FileMenuOption -> Bool
$c< :: FileMenuOption -> FileMenuOption -> Bool
compare :: FileMenuOption -> FileMenuOption -> Ordering
$ccompare :: FileMenuOption -> FileMenuOption -> Ordering
$cp1Ord :: Eq FileMenuOption
Ord,FileMenuOption -> FileMenuOption -> Bool
(FileMenuOption -> FileMenuOption -> Bool)
-> (FileMenuOption -> FileMenuOption -> Bool) -> Eq FileMenuOption
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileMenuOption -> FileMenuOption -> Bool
$c/= :: FileMenuOption -> FileMenuOption -> Bool
== :: FileMenuOption -> FileMenuOption -> Bool
$c== :: FileMenuOption -> FileMenuOption -> Bool
Eq)

data FileMenuAct = FileMenuAct FileMenuOption (Maybe (IO ()))

instance GraphConfig FileMenuAct

instance GraphConfig AllowDragging

-- | Allows the user to specify a 'Delayer'.  This will postpone redrawing
-- on the graph.
instance GraphConfig Delayer

instance GraphConfig AllowClose

-- | Which way up the graph is.
--
-- We copy the DaVinciTypes constructors, though of course this will
-- mean we have to painfully convert one to the other.
data Orientation = TopDown | BottomUp | LeftRight | RightLeft

instance GraphConfig Orientation

-- | Function to be applied to all user actions.  This is useful
-- for exception wrappers and so on.
newtype ActionWrapper = ActionWrapper (IO () -> IO ())


instance GraphConfig ActionWrapper

------------------------------------------------------------------------
-- Grouping options
-- GraphAllConfig
------------------------------------------------------------------------

class (
   GraphParms graphParms,
   HasConfig GlobalMenu graphParms,HasConfig GraphTitle graphParms,
   HasConfig GraphGesture graphParms,HasConfig OptimiseLayout graphParms,
   HasConfig SurveyView graphParms,HasConfig AllowDragging graphParms,
   HasConfig AllowClose graphParms,HasConfig Orientation graphParms,
   HasConfig FileMenuAct graphParms,HasConfig ActionWrapper graphParms,
   HasConfig (SimpleSource GraphTitle) graphParms,
   HasConfig Delayer graphParms
   )
   => HasGraphConfigs graphParms

instance (
   GraphParms graphParms,
   HasConfig GlobalMenu graphParms,HasConfig GraphTitle graphParms,
   HasConfig GraphGesture graphParms,HasConfig OptimiseLayout graphParms,
   HasConfig SurveyView graphParms,HasConfig AllowDragging graphParms,
   HasConfig AllowClose graphParms,HasConfig Orientation graphParms,
   HasConfig FileMenuAct graphParms,HasConfig ActionWrapper graphParms,
   HasConfig (SimpleSource GraphTitle) graphParms,
   HasConfig Delayer graphParms
   )
   => HasGraphConfigs graphParms

class (
   NodeTypeParms nodeTypeParms,
   HasConfigValue LocalMenu nodeTypeParms,
   HasConfigValue ValueTitle nodeTypeParms,
   HasConfigValue ValueTitleSource nodeTypeParms,
   HasConfigValue FontStyleSource nodeTypeParms,
   HasConfigValue BorderSource nodeTypeParms,
   HasConfigValue NodeGesture nodeTypeParms,
   HasConfigValue NodeDragAndDrop nodeTypeParms,
   HasConfigValue DoubleClickAction nodeTypeParms,
   HasConfigValue Shape nodeTypeParms,
   HasConfigValue Color nodeTypeParms
   )
   => HasNodeTypeConfigs nodeTypeParms


instance (
   NodeTypeParms nodeTypeParms,
   HasConfigValue LocalMenu nodeTypeParms,
   HasConfigValue ValueTitle nodeTypeParms,
   HasConfigValue ValueTitleSource nodeTypeParms,
   HasConfigValue FontStyleSource nodeTypeParms,
   HasConfigValue BorderSource nodeTypeParms,
   HasConfigValue NodeGesture nodeTypeParms,
   HasConfigValue NodeDragAndDrop nodeTypeParms,
   HasConfigValue DoubleClickAction nodeTypeParms,
   HasConfigValue Shape nodeTypeParms,
   HasConfigValue Color nodeTypeParms
   )
   => HasNodeTypeConfigs nodeTypeParms

class (
   HasModifyValue NodeArcsHidden graph node
--  HasModifyValue Border graph node
-- HasModifyValue FontStyle graph node
   ) => HasNodeModifies graph node

instance (
   HasModifyValue NodeArcsHidden graph node
--   HasModifyValue Border graph node
--  HasModifyValue FontStyle graph node
   ) => HasNodeModifies graph node

class (
   ArcTypeParms arcTypeParms,
   HasConfigValue DoubleClickAction arcTypeParms,
   HasConfigValue LocalMenu arcTypeParms,
   HasConfigValue ValueTitle arcTypeParms,
   HasConfigValue Color arcTypeParms,
   HasConfigValue EdgePattern arcTypeParms,
   HasConfigValue EdgeDir arcTypeParms,
   HasConfigValue Head arcTypeParms
  )
   => HasArcTypeConfigs arcTypeParms

instance (
   ArcTypeParms arcTypeParms,
   HasConfigValue DoubleClickAction arcTypeParms,
   HasConfigValue LocalMenu arcTypeParms,
   HasConfigValue ValueTitle arcTypeParms,
   HasConfigValue Color arcTypeParms,
   HasConfigValue EdgePattern arcTypeParms,
   HasConfigValue EdgeDir arcTypeParms,
   HasConfigValue Head arcTypeParms)
   => HasArcTypeConfigs arcTypeParms

class
   (GraphAll graph graphParms node nodeType nodeTypeParms
      arc arcType arcTypeParms,
   HasGraphConfigs graphParms,
   HasNodeTypeConfigs nodeTypeParms,
   HasNodeModifies graph node,
   HasArcTypeConfigs arcTypeParms
   )
   => GraphAllConfig graph graphParms node nodeType nodeTypeParms
         arc arcType arcTypeParms

instance
   (GraphAll graph graphParms node nodeType nodeTypeParms
      arc arcType arcTypeParms,
   HasGraphConfigs graphParms,
   HasNodeTypeConfigs nodeTypeParms,
   HasNodeModifies graph node,
   HasArcTypeConfigs arcTypeParms
   )
   => GraphAllConfig graph graphParms node nodeType nodeTypeParms
         arc arcType arcTypeParms