uni-uDrawGraph (empty) → 2.2.0.0
raw patch · 6 files changed
+3359/−0 lines, 6 filesdep +basedep +containersdep +uni-eventssetup-changed
Dependencies added: base, containers, uni-events, uni-graphs, uni-posixutil, uni-reactor, uni-util
Files
- LICENSE +123/−0
- Setup.hs +2/−0
- UDrawGraph/Basic.hs +624/−0
- UDrawGraph/Graph.hs +1833/−0
- UDrawGraph/Types.hs +752/−0
- uni-uDrawGraph.cabal +25/−0
+ LICENSE view
@@ -0,0 +1,123 @@+License Agreement++Preamble++The aim of this licence agreement is to enable the free use of the+software that is described in the sequel by anyone. In order to+guarantee this, it is necessary to set up rules for the use of the+software that hold for any user.++Provider of this licence is the University of Bremen, represented by+its principal (called "licence provider" in the sequel). The provider+of the licence has developed the "Uniform Workbench" (just+called "software" in the sequel). The software includes a+graphical tool for accessing documents stored in a versioned repository,+but also contains libraries and some other tools.++Following the ideas of open source software, the licence provider+gives access to the software without fee for anyone (called "licence+taker" in the sequel) under the following conditions which are similar+to the Lesser Gnu Public License (LGPL). Each licence taker obligates+himself to follow the terms of use below.++++1 Principle++Each licence taker appreciating these terms of use receives a simple+right, not resctricted in time and space and without any fee, to use+the software, in particular, to copy, distribute and process+it. Exclusively the following terms of use do hold. The licence+provider explicitly contradicts any conflicting terms of business. By+making use of the rights described below, in particular by copying or+distributing it, a licence treaty between the licence provider and the+licence takes is concluded.++++2 Copying++The licence taker has the right to make and distribute unmodified+copies of the software on any media. Prerequisite for this is that the+licence provider and this licence agreement is clearly recognizable,+and that the sources are distributed together with the software.++++3 Modification and Distribution++The licence taker has the right to modify copies of the software (or+parts thereof) and to distribute these modifications under the terms+of 2 above and the following conditions:++1. The modified software has to carry a clear mark that points to the+original licence provider, the modification that has been made, and+the date of the modification.++2. The licence taker has to ensure that the software as a whole or+parts of it are accessible to third parties under the terms of this+licence agreement without fee.++3. If during the modification a copyright of the licence taker+emerges, then this copyright must be put under the terms of this+licence if the modified software is distributed.+++4 Other duties++1. Reference to the validity of this licence agreement must not be+modified or deleted by the licence taker.++2. The use of the software by third parties must not be conditioned by+the fulfilment of duties that are not mentioned in this licence+agreement.++3. The use of the software must not be prevented or complicated by+means fo technical protection, in particular copy protection means.++++5 Liability, Update++1. Liability of the licence provider is restriced to fraudulent+withheld factual or legal errors. The licence provider does not give+any warranty, and neither ensures any properties of the+software. Furthermore, he is liable only for those damages that are+caused by willful or grossly negligent violation of duty.++2. The licence provider has the right to update these terms of use at+any time.+++++6 Forum for users++The licence provider does provide neither support nor+consultation. Without acknowledgement of any legal duty, the licence+provider will care about the installation of a user forum for+discussions about the software and its further development.+++7 Legal domicile++It is agreed that the law of the Federal Republic of Germany is valid+for this licence agreement. For any lawsuits or legal actions emerging+from this licence agreement, it is agreed that exclusively German+courts are competent. Legal domicile is Bremen.+++8 Termination through Offence++Any violation of a duty of this agreement automatically terminates the+rights of use of the offender.++++9 Salvatorian Clause++If any rule of this agreement should be or become inoperative,+validity of the other rules is not affected. The parties will care+about replacing the invalid rule by some valid rule that comes close+to the purpose of this agreement.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ UDrawGraph/Basic.hs view
@@ -0,0 +1,624 @@+-- | DaVinciBasic contains the code to do the following things:+-- (1) get daVinci going (it calls it via a ChildProcess).+-- (2) open new contexts.+-- (3) pass on events and sort answers out for particular+-- contexts.+-- It uses the DaVinciTypes module to parse the different+-- results, but makes minimal attempts to interpret the+-- different datatypes (the main reason for doing so is+-- to interpret DaVinciAnswer to work out what to do+-- with a particular answer).+module UDrawGraph.Basic(+ Context, -- refers to a context, IE a particular (independent) graph.+ -- instance of Eq, Ord.++ newContext, -- :: (DaVinciAnswer -> IO ()) -> IO Context+ -- Open a new context (and start daVinci, if this is the first time).+ -- The argument is a sink for asynchronous output relating+ -- to the context, such as drag-and-drop messages.+ -- Also, "Quit" messages, indicating that daVinci itself+ -- is terminated, are broadcast to every context.++ doInContextGeneral, -- :: DaVinciCmd -> Context -> IO DaVinciAnswer+ -- do a context-specific command in the context, returning the+ -- resulting answer.++ doInContext, -- :: DaVinciCmd -> Context -> IO ()+ -- do a context-specific command in the context. If the answer+ -- isn't OK, complain vigorously, and throw an exception.++ withHandler, -- :: (DaVinciAnswer -> IO ()) -> Context -> IO a -> IO a+ -- temporarily change the handler of this context.+ -- If withHandler is used twice simultaneously on the same context, the+ -- second invocation will block, until the first one terminates.++ -- Generating unique identifiers.++ newType, -- :: Context -> IO Type+ -- returns a new, unique, type identifier.+ newNodeId, -- :: Context -> IO NodeId+ -- Generate a unique nodeId for this context+ newEdgeId, -- :: Context -> IO EdgeId+ newMenuId, -- :: Context -> IO MenuId++ -- Version information+ daVinciVersion, -- :: Maybe String+ -- For versions before 3.0, this is Nothing. For 3.0 onwards,+ -- it will be the string returned by the (new) "special(version)"+ -- commands++ exitDaVinci, -- exit function because normal do in context end up in+ -- infinite blocking thread++ ) where++import Data.Maybe+import Data.List (isPrefixOf)+import System.IO.Error as IO++import System.IO.Unsafe+import Control.Concurrent.MVar+import qualified Control.Exception as Exception(try)+import Foreign.C.String+import Data.IORef+import System.Environment++import Util.Object+import Util.WBFiles+import Util.Computation as Computation (propagate, done)+import Util.FileNames+import Util.Registry+import Util.UniqueString+import Util.Thread+import Util.ExtendedPrelude (mapOrd, mapEq)++import Events.Spawn+import Events.Events+import Events.Channels+import Events.Destructible+import Events.Synchronized++import Reactor.BSem+import Posixutil.ChildProcess+import Reactor.InfoBus++import qualified UDrawGraph.Types as DaVinciTypes+import UDrawGraph.Types hiding (DaVinciAnswer(Context))+import UDrawGraph.Types (DaVinciAnswer())+++-- ---------------------------------------------------------------------+-- The DaVinci process+-- ---------------------------------------------------------------------++-- daVinci will be the only value of type DaVinci.+data DaVinci = DaVinci {+ childProcess :: ChildProcess,+ contextRegistry :: Registry ContextId Context,+ currentContextIdMVar :: MVar ContextId,+ destroyActMVar :: MVar (IO ()),+ -- This MVar contains the destruction action.+ responseMVar :: MVar (ContextId,DaVinciAnswer),+ -- The daVinci answer dispatcher writes answers to specific+ -- commands to this MVar, from which they should be picked+ -- up quickly!+ oID :: ObjectID, -- Unique identifier, needed for registerTool++ version :: Maybe String -- For daVinci versions before 3.0 Nothing,+ -- Afterwards, should be the version of daVinci.+ }++daVinci :: DaVinci+daVinci = unsafePerformIO newDaVinci+{-# NOINLINE daVinci #-}++challengeResponsePair :: (String,String)+challengeResponsePair =+ ("nothing"++recordSep++"nothing"++recordSep++"nothing",+ "ok"++recordSep++"ok"++recordSep++"ok"++recordSep++"ok"++recordSep)+-- 3 nothings and 4 oks, because daVinci also outputs an extra "ok"+-- right at the beginning.++newDaVinci :: IO DaVinci+newDaVinci =+ do+ daVinciPath <- getDaVinciPath+ daVinciIconsOpt <- getDaVinciIcons+ env <- getEnvironment+ let+ configs = [+ environment $ maybe id+ (\ daVinciIcons -> (("DAVINCI_ICONDIR", daVinciIcons) :))+ daVinciIconsOpt env,+ arguments ["-pipe"],+ standarderrors False,+ challengeResponse challengeResponsePair,+ toolName "daVinci"+ ]+ childProcess <- newChildProcess daVinciPath configs++-- Send initial command.+ sendMsg childProcess (show (Special Version))+-- We will collect the answer from this in a moment . . .++ contextRegistry <- newRegistry+ currentContextIdMVar <- newMVar invalidContextId+ typeSource <- newUniqueStringSource+ destroyActMVar <- newEmptyMVar+ responseMVar <- newEmptyMVar+ oID <- newObject++-- Collect initial answers from daVinci.+ versionAnswer <- getNextAnswer childProcess+ -- With the exception of "Menu(File(Exit))" which will be used in+ -- a couple of lines to terminate daVinci, all commands in future will+ -- be channelled through doInContextVeryGeneral, and all answers through+ -- the answer dispatcher.+ let+ version = case versionAnswer of+ Versioned str -> Just str+ CommunicationError _ -> Nothing++ daVinci =+ DaVinci {+ childProcess = childProcess,+ contextRegistry = contextRegistry,+ currentContextIdMVar = currentContextIdMVar,+ destroyActMVar = destroyActMVar,+ responseMVar = responseMVar,+ oID = oID,+ version = version+ }++ destroyAnswerDispatcher <- spawn (answerDispatcher daVinci)+ putMVar destroyActMVar (+ do+ deregisterTool daVinci+ forAllContexts destroy+ sendMsg childProcess (show(Menu(File(Exit))))+ -- ask daVinci nicely to go, before we kill it.+ destroy childProcess+ destroyAnswerDispatcher+ )++ registerToolDebug "daVinci" daVinci+ return daVinci++daVinciVersion :: Maybe String+daVinciVersion = version daVinci++workAroundDaVinciBug1 :: Bool+workAroundDaVinciBug1 =+ case daVinciVersion of+ Just "daVinci Presenter Professional 3.0.3" -> True+ Just "daVinci Presenter Professional 3.0.4" -> True+ Just "daVinci Presenter Professional 3.0.5" -> True+ _ -> False++daVinciSkip :: IO ()+daVinciSkip =+ if workAroundDaVinciBug1 then delay (secs 0.1) else done++instance Destroyable DaVinci where+ destroy (DaVinci {+ destroyActMVar = destroyActMVar,+ responseMVar = responseMVar+ }) =+ do+ destroyAct <- takeMVar destroyActMVar+ putMVar destroyActMVar done+ destroyAct+ tryPutMVar responseMVar+ (invalidContextId,CommunicationError+ "daVinci ended before command completed")+ done++instance Object DaVinci where+ objectID daVinci = oID daVinci++-- ---------------------------------------------------------------------+-- Code for getting the environment that is or might be relevant to daVinci in+-- a portable way.+-- ---------------------------------------------------------------------++getDaVinciEnvironment :: IO [(String,String)]+getDaVinciEnvironment =+ do+ let+ getEnvOpt :: String -> IO (Maybe (String,String))+ getEnvOpt envName =+ do+ res <- IO.try (getEnv envName)+ return (case res of+ Left error -> Nothing+ Right envVal -> Just (envName,envVal)+ )++ daVinciEnvs+ <- mapM getEnvOpt [+ "DISPLAY","LD_LIBRARY_PATH","DAVINCIHOME","LANG","OSTYPE",+ "PATH","PWD","USER"]++ return (catMaybes (daVinciEnvs :: [Maybe (String,String)]))+++-- ---------------------------------------------------------------------+-- Contexts+-- ---------------------------------------------------------------------++data Context = Context {+ contextId :: ContextId,+ destructChannel :: Channel (),+ typeSource :: UniqueStringSource,+ idSource :: UniqueStringSource,+ -- source for node and edge ids (which we keep distinct).+ menuIdSource :: UniqueStringSource,+ -- source for menu ids.++ handlerIORef :: IORef (DaVinciAnswer -> IO ()),+ -- contains current handler+ withHandlerLock :: BSem+ -- locks withHandler operations+ }++newContext :: (DaVinciAnswer -> IO ()) -> IO Context+newContext handler =+ do+ (newContextId,result)+ <- doInContextVeryGeneral (Multi NewContext) Nothing+ case result of+ Ok -> done+ CommunicationError str ->+ error ("DaVinciBasic: newContext returned error "++str)+ destructChannel <- newChannel+ typeSource <- newUniqueStringSource+ idSource <- newUniqueStringSource+ menuIdSource <- newUniqueStringSource+ handlerIORef <- newIORef handler+ withHandlerLock <- newBSem++ let+ newContext = Context {+ contextId = newContextId,+ destructChannel = destructChannel,+ typeSource = typeSource,+ idSource = idSource,+ menuIdSource = menuIdSource,+ handlerIORef = handlerIORef,+ withHandlerLock = withHandlerLock+ }+ setValue (contextRegistry daVinci) newContextId newContext+ return newContext++instance Destroyable Context where+ destroy (context@ Context {contextId = contextId}) =+ do+ deleted <- deleteFromRegistryBool (contextRegistry daVinci) contextId+ if not deleted+ then+ done -- someone else has already deleted this context+ else+ do+ -- delete context+ -- Things get tricky here.+ -- The menu(file(close)) command we use, to delete the+ -- context, will generate a "close" event, but no+ -- "Ok" response. doInContext (and the more generalised+ -- versions) expect an Ok response. We can't reclassify+ -- close, because the user might generate it from the+ -- file menu. Instead we naughtily forge an "Ok" response+ -- in advance, by writing it to responseMVar.+ putMVar (responseMVar daVinci) (contextId,Ok)+ doInContext (Menu(File(Close))) context+++instance Destructible Context where+ destroyed context = receive (destructChannel context)++-- exit function because normal do in context end up in infinite blocking thread+exitDaVinci :: Context -> IO ()+exitDaVinci (context@ Context {contextId = contextId}) = do+ putMVar (responseMVar daVinci) (contextId,Ok)+ doInContext (Menu(File(Exit))) context++doInContext :: DaVinciCmd -> Context -> IO ()+doInContext daVinciCmd context =+ do+ answer <- doInContextGeneral daVinciCmd context+ case answer of+ Ok -> done+ CommunicationError str ->+ error ("DaVinciBasic: "++(show daVinciCmd)+++ " returned error "++str)+ -- TclAnswer is also theoretically possible, if someone+ -- is foolish enough to use doInContext with a Tcl command.++doInContextGeneral :: DaVinciCmd -> Context -> IO DaVinciAnswer+doInContextGeneral daVinciCmd context =+ do+ (cId,answer) <- doInContextVeryGeneral daVinciCmd (Just context)+ return answer++-- doInContextVeryGeneral is the all-purpose daVinci command+-- function, which is good enough, for example, for+-- context-setting functions, which require extra generality+-- and are only used in this module.+--+-- doInContextVeryGeneral is locked on currentContextIdMVar.+-- If contextOpt is Just (something), we set+-- the context and the MVar to (something), if different from+-- the existing value, and check that the returned context from+-- daVinci is also (something).+-- If contextOpt is Nothing, we change the MVar to the returned context+-- from daVinci.+doInContextVeryGeneral :: DaVinciCmd -> Maybe Context+ -> IO (ContextId,DaVinciAnswer)+doInContextVeryGeneral daVinciCmd contextOpt =+ do+ -- Pack the command as a String. (This also prevents+ -- us having to do too much precomputation during the+ -- locked period.)+ let+ cmdString = shows daVinciCmd "\n"+ cIdOpt = (fmap contextId) contextOpt++ DaVinci {+ childProcess = childProcess,+ responseMVar = responseMVar,+ currentContextIdMVar = currentContextIdMVar+ } = daVinci++ withCStringLen cmdString (\ cStringLen ->+ -- packing the command string this early has the advantage of forcing+ -- it to be fully evaluated before we lock daVinci.+ do+ currentContextId <- takeMVar currentContextIdMVar+ -- Here is where daVinci actually gets created, if necessary.+ -- Change context id, if necessary.+ case cIdOpt of+ Nothing -> done+ Just newContextId ->+ if currentContextId == newContextId+ then+ done+ else+ do+ sendMsg childProcess+ (show(Multi(SetContext newContextId)))+ (gotContextId,result) <- takeMVar responseMVar+ if gotContextId /= newContextId+ then+ do+ putStrLn ("daVinci bug: "+ ++ "set_context returned wrong context")+ failSafeSetContext newContextId+ else+ done+ daVinciSkip+ case result of+ Ok -> done+ _ -> error ("set_context returned "+++ (show result))+ sendMsgRaw childProcess cStringLen+ result@(gotContextId,daVinciAnswer) <- takeMVar responseMVar+ putMVar currentContextIdMVar gotContextId+ case cIdOpt of+ Nothing -> done+ Just newContextId ->+ if gotContextId == newContextId+ then+ done+ else+ do+ putStrLn "daVinci bug: Mismatch in returned context"+ failSafeSetContext gotContextId+ return result+ )++failSafeSetContext :: ContextId -> IO ()+failSafeSetContext contextId =+ do+ putStrLn "Trying again with setContext"+ sendMsg (childProcess daVinci) (show(Multi(SetContext contextId)))+ (gotContextId,result) <- takeMVar (responseMVar daVinci)+ if gotContextId /= contextId+ then+ do+ putStrLn "Yet another mismatch; trying again with delay"+ delay (secs 0.1)+ failSafeSetContext contextId+ else+ done++++forAllContexts :: (Context -> IO ()) -> IO ()+forAllContexts contextAct =+ do+ idsContexts <- listRegistryContents (contextRegistry daVinci)+ sequence_ (map (contextAct . snd) idsContexts)++invalidContextId :: ContextId+-- This should not equal any context id auto-generated by+-- daVinci. As a matter of fact daVinci seems to generate only+-- ids starting with an underline, and gets confused by null+-- context ids.+invalidContextId = ContextId ""+++withHandler :: (DaVinciAnswer -> IO ()) -> Context -> IO a -> IO a+withHandler newHandler context act =+ do+ result <- synchronize (withHandlerLock context) (+ do+ let+ ioRef = handlerIORef context++ oldHandler <- readIORef ioRef+ writeIORef ioRef newHandler+ result <- Exception.try act+ writeIORef ioRef oldHandler+ return result+ )+ Computation.propagate result++-- ---------------------------------------------------------------------+-- Answer dispatcher+-- This has three jobs:+-- (0) handle the file-menu events we allow, namely "#%print" and "#%close".+-- (1) It runs the handler attached to the context.+-- (2) It sends the destruct event for a context when appropriate.+-- (IE we receive a "close" message for that context, or+-- a "quit" message for any context).+-- ---------------------------------------------------------------------++-- Classification of answers from daVinci.+data AnswerDestination =+ Response -- result of a command to daVinci+ | LocalEvent -- an event particular to a context+ | GlobalEvent -- an event to be forwarded to all contexts.++answerDestination :: DaVinciAnswer -> AnswerDestination+answerDestination Ok = Response+answerDestination (CommunicationError _) = Response+answerDestination (TclAnswer _) = Response+answerDestination (Versioned _) = Response+answerDestination DaVinciTypes.Quit = GlobalEvent+answerDestination Disconnect = GlobalEvent+-- this should never occur actually, since we are starting daVinci+answerDestination _ = LocalEvent++data DestroysContext = Yes | No++destroysContext :: DaVinciAnswer -> DestroysContext+destroysContext Closed = Yes+destroysContext DaVinciTypes.Quit = Yes+destroysContext (CloseWindow _) = Yes+destroysContext _ = No++answerDispatcher :: DaVinci -> IO ()+-- We expect all commands from now on to be multi.+answerDispatcher (daVinci@DaVinci{+ childProcess = childProcess,+ contextRegistry = contextRegistry,+ currentContextIdMVar = currentContextIdMVar,+ responseMVar = responseMVar+ }) =+ do+ answerDispatcher'+ where+ forward :: DaVinciAnswer -> Context -> IO ()+ forward daVinciAnswer context =+ do+ handler <- readIORef (handlerIORef context)+ handler daVinciAnswer+ case destroysContext daVinciAnswer of+ Yes ->+ do+ -- Invalidate current context.+ takeMVar currentContextIdMVar+ putMVar currentContextIdMVar (ContextId "")+ sync (noWait (send (destructChannel context) ()))+ No -> done++ answerDispatcher' =+ do+ (contextId,daVinciAnswer) <- getMultiAnswer childProcess+ case answerDestination daVinciAnswer of+ LocalEvent ->+ do+ contextOpt <- getValueOpt contextRegistry contextId+ case contextOpt of+ Nothing -> done+ -- this can theoretically happen if there is an+ -- event immediately after the context is opened+ -- and before newContext registers it.+ Just context -> forward daVinciAnswer context+ Response ->+ do+ tryPutMVar responseMVar (contextId,daVinciAnswer)+ done+ GlobalEvent ->+ forAllContexts (forward daVinciAnswer)+ answerDispatcher'+++getMultiAnswer :: ChildProcess -> IO (ContextId,DaVinciAnswer)+-- Get next answer (associated with a ContextId). We assume these+-- are never split by an intervening error.+getMultiAnswer childProcess =+ do+ answer1 <- getNextAnswer childProcess+ case answer1 of+ DaVinciTypes.Context contextId ->+ do+ answer2 <- getNextAnswer childProcess+ return (contextId,answer2)+ _ -> error ("Unexpected daVinci answer expecting contextId: "+ ++ show answer1)++{- unused+simpleExec :: ChildProcess -> DaVinciCmd -> IO ()+ -- used during initialisation, before we've entered multi-mode.+ -- If the result isn't OK we provoke an error.+simpleExec childProcess cmd =+ do+ sendMsg childProcess (show cmd)+ answer <- getNextAnswer childProcess+ case answer of+ Ok -> done+ _ -> error ("daVinci failure: command " ++ show cmd ++ " returned "+ ++ show answer)+ -}++getNextAnswer :: ChildProcess -> IO DaVinciAnswer+getNextAnswer childProcess =+ do+ line <- readMsg childProcess+ if isPrefixOf "program error:" line+ then+ do+ putStrLn line+ putStrLn "************ DAvINCI BUG IGNORED ***************"+ getNextAnswer childProcess+ else+ return (read line)++-- ---------------------------------------------------------------------+-- Generating new identifiers.+-- ---------------------------------------------------------------------++newType :: Context -> IO Type+newType context =+ do+ typeString <- newUniqueString (typeSource context)+ return (Type typeString)++newNodeId :: Context -> IO NodeId+newNodeId context =+ do+ nodeString <- newUniqueString (idSource context)+ return (NodeId nodeString)++newEdgeId :: Context -> IO EdgeId+newEdgeId context =+ do+ edgeString <- newUniqueString (idSource context)+ return (EdgeId edgeString)+++newMenuId :: Context -> IO MenuId+newMenuId context =+ do+ menuIdString <- newUniqueString (menuIdSource context)+ return (MenuId menuIdString)++-- ---------------------------------------------------------------------+-- Instances of Eq and Ord for Context+-- ---------------------------------------------------------------------++instance Eq Context where+ (==) = mapEq contextId++instance Ord Context where+ compare = mapOrd contextId
+ UDrawGraph/Graph.hs view
@@ -0,0 +1,1833 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverlappingInstances #-}++-- | This is the implementation of modules GraphDisp and GraphConfigure for+-- daVinci. See those files for explanation of the names.+-- We encode, for example, the type parameter node as DaVinciNode,+-- and so on for other type parameters, prefixing with \"DaVinci\" and+-- capitalising the next letter. But the only variable you should normally+-- need from this module is 'daVinciSort'.+module UDrawGraph.Graph(+ daVinciSort, -- Magic type parameter indicating we want to use daVinci.++ DaVinciGraph (pendingChangesLock),+ DaVinciGraphParms,++ DaVinciNode,+ DaVinciNodeType,+ DaVinciNodeTypeParms,++ DaVinciArc,+ DaVinciArcType,+ DaVinciArcTypeParms,+ getDaVinciGraphContext -- :: DaVinciGraph -> Context+ ) where++import Data.Maybe++import Data.IORef+import qualified Data.Set as Set+import qualified Data.Map as Map+import Control.Concurrent+import qualified Data.Dynamic+import qualified Data.List as List++import Util.Sources+import Util.Sink+import Util.Delayer+import qualified Util.UniqueString as UniqueString+import qualified Util.VariableList as VariableList++import Util.Computation (done)+import Util.Dynamics+import Util.Registry+import Util.ExtendedPrelude+import Util.Thread+import Util.CompileFlags+import Util.Messages++import Events.Channels+import Events.Events+import Events.Destructible+import Events.Synchronized++import Reactor.BSem++import qualified Graphs.GraphDisp as GraphDisp (Graph)+import Graphs.GraphDisp hiding (Graph)+import qualified Graphs.GraphConfigure as GConf (MenuPrim(Menu), Orientation(..))+import Graphs.GraphConfigure hiding (MenuPrim(Menu), Orientation(..))++import UDrawGraph.Types+import UDrawGraph.Basic+++------------------------------------------------------------------------+-- How you refer to everything+------------------------------------------------------------------------++daVinciSort :: GraphDisp.Graph DaVinciGraph+ DaVinciGraphParms DaVinciNode DaVinciNodeType DaVinciNodeTypeParms+ DaVinciArc DaVinciArcType DaVinciArcTypeParms+daVinciSort = displaySort++instance GraphAllConfig DaVinciGraph DaVinciGraphParms+ DaVinciNode DaVinciNodeType DaVinciNodeTypeParms+ DaVinciArc DaVinciArcType DaVinciArcTypeParms++-- -----------------------------------------------------------------------+-- Graphs.+-- -----------------------------------------------------------------------++data DaVinciGraph = DaVinciGraph {+ context :: Context,++ -- For each node and edge we give (a) its type, (b) its value.+ nodes :: Registry NodeId NodeData,+ edges :: Registry EdgeId ArcData,++ pendingChangesMVar :: MVar [MixedUpdate],+ -- This refers to changes to the structure of the graph+ -- which haven't yet been sent to daVinci. Only some+ -- changes can be delayed in this way, namely+ -- node and edge additions and deletions.+ -- Changes to types are not delayed. Changes to attribute values,+ -- cause this list to be flushed, as does redrawPrim.+ pendingChangesLock :: BSem,+ -- This lock is acquired during, flushPendingChanges, newNodePrim,+ -- and setNodeTitle.+ -- Where both pendingChangesLock and pendingChangesMVar are needed,+ -- the first should be got first.++ globalMenuActions :: Registry MenuId (IO ()),+ otherActions :: Registry DaVinciAnswer (IO ()),+ -- The node and edge types contain other event handlers.++ lastSelectionRef :: IORef LastSelection,++ doImprove :: Bool,+ -- improveAll on redrawing graph.++ destructionChannel :: Channel (),++ destroyActions :: IO (),+ -- Various actions to be done when the graph is closed.++ redrawChannel :: Channel Bool,+ -- Sending True along this channel indicates that a+ -- redraw is desired.+ -- Sending False along it ends the appropriate thread.++ delayer :: Delayer,+ redrawAction :: DelayedAction+ -- this is the action that actually gets done when the user actually+ -- asks for a redraw.+ } deriving (Typeable)++data LastSelection = LastNone | LastNode NodeId | LastEdge EdgeId++data DaVinciGraphParms = DaVinciGraphParms {+ graphConfigs :: [DaVinciGraph -> IO ()], -- General setups+ surveyView :: Bool,+ configDoImprove :: Bool,+ configFileMenuActions+ :: Map.Map FileMenuOption (DaVinciGraph -> IO ()),+ configGlobalMenu :: Maybe GlobalMenu,+ configActionWrapper :: IO () -> IO (),+ graphTitleSource :: Maybe (SimpleSource GraphTitle),+ delayerOpt :: Maybe Delayer,+ configOrientation :: Maybe GConf.Orientation+ }++instance Eq DaVinciGraph where+ (==) = mapEq context++instance Ord DaVinciGraph where+ compare = mapOrd context++instance Destroyable DaVinciGraph where+ destroy (daVinciGraph @ DaVinciGraph {+ context = context,nodes = nodes,edges = edges,+ globalMenuActions = globalMenuActions,otherActions = otherActions,+ destroyActions = destroyActions,redrawChannel = redrawChannel,+ delayer = delayer,redrawAction = redrawAction}) =+ do+ cancelDelayedAct delayer redrawAction+ sync (noWait (send redrawChannel False))+ destroyActions+ destroy context+ emptyRegistry nodes+ emptyRegistry edges+ emptyRegistry globalMenuActions+ emptyRegistry otherActions+ signalDestruct daVinciGraph++instance Destructible DaVinciGraph where+ destroyed (DaVinciGraph {destructionChannel = destructionChannel}) =+ receive destructionChannel++getDaVinciGraphContext :: DaVinciGraph -> Context+getDaVinciGraphContext g = context g++signalDestruct :: DaVinciGraph -> IO ()+signalDestruct daVinciGraph =+ sync(noWait(send (destructionChannel daVinciGraph) ()))++-- | We run a separate thread for redrawing. The idea is that when more than+-- one redraw request arrives while daVinci is already redrawing, we only+-- send one. This means it is not too bad when we make a lot of changes,+-- redrawing each one.+redrawThread :: DaVinciGraph -> IO ()+redrawThread (daVinciGraph @ DaVinciGraph{+ context = context,doImprove = doImprove,redrawChannel = redrawChannel}) =+ do+ b1 <- sync (receive redrawChannel)+ bs <- getAllQueued (receive redrawChannel)+ if and (b1:bs)+ then+ do+ flushPendingChanges daVinciGraph+ if doImprove+ then+ doInContext (Menu(Layout(ImproveAll)))+ context+ else+ done+ redrawThread daVinciGraph+ else+ done++instance HasDelayer DaVinciGraph where+ toDelayer daVinciGraph = delayer daVinciGraph++instance GraphClass DaVinciGraph where+ redrawPrim (daVinciGraph @ DaVinciGraph{+ delayer = delayer,redrawAction = redrawAction}) =+ delayedAct delayer redrawAction+++instance NewGraph DaVinciGraph DaVinciGraphParms where+ newGraphPrim (DaVinciGraphParms {graphConfigs = graphConfigs,+ configDoImprove = configDoImprove,surveyView = surveyView,+ configFileMenuActions = configFileMenuActions,+ configGlobalMenu = configGlobalMenu,+ configActionWrapper = configActionWrapper,+ configOrientation = configOrientation,+ graphTitleSource = graphTitleSource,delayerOpt = delayerOpt}) =+ do+ nodes <- newRegistry+ edges <- newRegistry+ globalMenuActions <- newRegistry+ otherActions <- newRegistry+ lastSelectionRef <- newIORef LastNone++ graphMVar <- newEmptyMVar+ -- this will hold the graph when it's completed. This is needed+ -- by some of the handler actions.+++ let+ -- We now come to write the handler function for+ -- the context. This is quite complex so we handle the+ -- various cases one by one, in separate functions.++ handler :: DaVinciAnswer -> IO ()+ handler daVinciAnswer+ = configActionWrapper (handler1 daVinciAnswer)+ --+ -- The handler needs to depend on the context, so that it+ -- can handle Close and Print events appropriately.+ handler1 :: DaVinciAnswer -> IO ()+ -- In general, the rule is that if we don't find+ -- a handler function, we do nothing. We do, however,+ -- assume that where a menuId is quoted, there is+ -- an associated handler. If not, this is (probably)+ -- a bug in daVinci.+ handler1 daVinciAnswer = case daVinciAnswer of+ NodeSelectionsLabels nodes -> actNodeSelections nodes+ NodeDoubleClick -> nodeDoubleClick+ EdgeSelectionLabel edge -> actEdgeSelections edge+ EdgeDoubleClick -> edgeDoubleClick+ MenuSelection menuId -> actGlobalMenu menuId+ PopupSelectionNode nodeId menuId ->+ actNodeMenu nodeId menuId+ PopupSelectionEdge edgeId menuId ->+ actEdgeMenu edgeId menuId+ CreateNodeAndEdge nodeId -> actCreateNodeAndEdge nodeId+ CreateEdge nodeFrom nodeTo -> actCreateEdge nodeFrom nodeTo+ _ ->+ do+ action <- getValueDefault done otherActions daVinciAnswer+ action+ -- Update lastSelectionRef. This contains the+ -- last selected node or edge, in case we are about to+ -- double-click or call a menu.+ actNodeSelections :: [NodeId] -> IO ()+ actNodeSelections [nodeId] =+ writeIORef lastSelectionRef (LastNode nodeId)+ actNodeSelections _ = done -- not a double-click.++ actEdgeSelections :: EdgeId -> IO ()+ actEdgeSelections edgeId =+ writeIORef lastSelectionRef (LastEdge edgeId)++ -- With node and edge double clicks we also expect the+ -- node or edge to be recently selected and in lastSelectionRef+ nodeDoubleClick :: IO ()+ nodeDoubleClick =+ do+ lastSelection <- readIORef lastSelectionRef+ case lastSelection of+ LastNode nodeId ->+ do+ NodeData nodeDataData <- getValueHere nodes nodeId+ (nodeDoubleClickAction (typeData nodeDataData))+ (valueData nodeDataData)+ _ -> error "DaVinciGraph: confusing node double click"++ edgeDoubleClick :: IO ()+ edgeDoubleClick =+ do+ lastSelection <- readIORef lastSelectionRef+ case lastSelection of+ LastEdge edgeId ->+ do+ ArcData arcType arcValue+ <- getValueHere edges edgeId+ (arcDoubleClickAction arcType) arcValue+ _ -> error "DaVinciGraph: confusing edge double click"+ actGlobalMenu :: MenuId -> IO ()+ actGlobalMenu (MenuId ('#':'%':fileMenuStr)) =+ case toFileMenuOption fileMenuStr of+ Nothing -> alertMess ("Mysterious daVinci fileMenu "+ ++ fileMenuStr ++ " ignored")+ Just reservedMenuOption ->+ case Map.lookup reservedMenuOption configFileMenuActions of+ Nothing ->+ if fileMenuStr == "close"+ then+ alertMess ("The application has disabled "+ ++ " the close action for this window.")+ else+ alertMess ("Unexpected daVinci fileMenu "+ ++ fileMenuStr ++ " ignored")+ Just graphAction ->+ do+ graph <- readMVar graphMVar+ graphAction graph+ actGlobalMenu menuId =+ do+ action <- getValueHere globalMenuActions menuId+ action++ actNodeMenu :: NodeId -> MenuId -> IO ()+ actNodeMenu nodeId menuId =+ do+ NodeData nodeDataData <- getValueHere nodes nodeId+ menuAction <- getValueHere (+ nodeMenuActions (typeData nodeDataData)) menuId+ menuAction (valueData nodeDataData)++ actEdgeMenu :: EdgeId -> MenuId -> IO ()+ actEdgeMenu edgeId menuId =+ do+ ArcData arcType arcValue <- getValueHere edges edgeId+ menuAction <- getValueHere (arcMenuActions arcType) menuId+ menuAction arcValue++ -- We now do the drag-and-drops. There is no special+ -- handler for the create node action, since this is+ -- done by the otherActions handler.+ actCreateNodeAndEdge nodeId =+ do+ NodeData nodeDataData <- getValueHere nodes nodeId+ (createNodeAndEdgeAction (typeData nodeDataData))+ (valueData nodeDataData)++ actCreateEdge :: NodeId -> NodeId -> IO ()+ actCreateEdge nodeId1 nodeId2 =+ do+ NodeData nodeDataData1 <- getValueHere nodes nodeId2+ NodeData nodeDataData2 <- getValueHere nodes nodeId1++ (createEdgeAction (typeData nodeDataData2))+ (toDyn (valueData nodeDataData1))+ (valueData nodeDataData2)++ context <- newContext handler++ pendingChangesMVar <- newMVar []+ destructionChannel <- newChannel+ redrawChannel <- newChannel+ pendingChangesLock <- newBSem++ let+ setTitle :: GraphTitle -> IO ()+ setTitle (GraphTitle graphTitle)+ = doInContext (Window (Title graphTitle)) context++ -- Sink for changing the title+ (addSink,destroySink) <-+ case graphTitleSource of+ Nothing -> return (done,done)+ Just graphTitleSource ->+ do+ sink <- newSink setTitle+ let+ addSink =+ do+ currentTitle <- addOldSink graphTitleSource sink+ setTitle currentTitle+ return (addSink,invalidate sink)+ let+ setOrientation :: GConf.Orientation -> IO ()+ setOrientation orientation0 =+ let+ orientation1 = case orientation0 of+ GConf.TopDown -> TopDown+ GConf.BottomUp -> BottomUp+ GConf.LeftRight -> LeftRight+ GConf.RightLeft -> RightLeft+ in+ doInContext (Menu (Layout (+ Orientation orientation1)))+ context++ case configOrientation of+ Nothing -> done+ Just orientation -> setOrientation orientation++ -- Set up a delayer and a redraw action which uses it.+ delayer <- case delayerOpt of+ Just delayer -> return delayer+ Nothing -> newDelayer++ redrawAction+ <- newDelayedAction (sync(noWait(send redrawChannel True)))+ let+ daVinciGraph =+ DaVinciGraph {+ context = context,+ nodes = nodes,+ edges = edges,+ globalMenuActions = globalMenuActions,+ otherActions = otherActions,+ pendingChangesMVar = pendingChangesMVar,+ pendingChangesLock = pendingChangesLock,+ doImprove = configDoImprove,+ lastSelectionRef = lastSelectionRef,+ destructionChannel = destructionChannel,+ destroyActions = destroySink,+ redrawChannel = redrawChannel,+ delayer = delayer,+ redrawAction = redrawAction+ }++ putMVar graphMVar daVinciGraph++ setValue otherActions Closed (signalDestruct daVinciGraph)+ setValue otherActions Quit (signalDestruct daVinciGraph)++ sequence_ (fmap ($ daVinciGraph) (reverse graphConfigs))++ -- Take control of File Menu events.+ doInContext (AppMenu (ControlFileEvents)) context+ let+ -- Work out which options to enable.+ fileMenuIds = fmap+ (\ (option,_) -> MenuId ("#%"++(fromFileMenuOption option)))+ (Map.toList configFileMenuActions)++ -- Attach globalMenu if necessary and get its menuids as well.+ -- (All global menu-ids need to be activated at once.)+ globalMenuIds <- case configGlobalMenu of+ Nothing -> return []+ Just globalMenu -> mkGlobalMenu daVinciGraph globalMenu++ -- Activate global menus.+ doInContext+ (AppMenu (ActivateMenus (fileMenuIds ++ globalMenuIds)))+ context++ addSink++ -- Do some initial commands.+ doInContext (DVSet(GapWidth 4)) context+ doInContext (DVSet(GapHeight 40)) context+ if surveyView+ then+ doInContext (Menu(View(OpenSurveyView))) context+ else+ done++ forkIODebug (redrawThread daVinciGraph)++ return daVinciGraph++instance GraphParms DaVinciGraphParms where+ emptyGraphParms = DaVinciGraphParms {+ graphConfigs = [],configDoImprove = False,surveyView = False,+ graphTitleSource = Nothing,delayerOpt = Nothing,+ configFileMenuActions = initialFileMenuActions,+ configActionWrapper = (\ act ->+ do+ forkIODebug act+ done+ ),+ configOrientation = Nothing,+ configGlobalMenu = Nothing+ }++initialFileMenuActions :: Map.Map FileMenuOption (DaVinciGraph -> IO ())+initialFileMenuActions = Map.fromList [+ (PrintMenuOption,+ (\ graph -> doInContext+ (Menu (File (Print Nothing))) (context graph))+ ),+ (CloseMenuOption,+ (\ graph ->+ do+ proceed <- confirmMess "Really close window?"+ if proceed then destroy graph else done+ )+ )+ ]++addGraphConfigCmd :: DaVinciCmd -> DaVinciGraphParms -> DaVinciGraphParms+addGraphConfigCmd daVinciCmd daVinciGraphParms =+ daVinciGraphParms {+ graphConfigs = (\ daVinciGraph ->+ doInContext daVinciCmd (context daVinciGraph))+ : (graphConfigs daVinciGraphParms)+ }++instance HasConfig GraphTitle DaVinciGraphParms where+ configUsed _ _ = True+ ($$) (GraphTitle graphTitle) =+ addGraphConfigCmd (Window(Title graphTitle))+++instance HasConfig Delayer DaVinciGraphParms where+ configUsed _ _ = True+ ($$) delayer graphParms = graphParms {delayerOpt = Just delayer}++instance HasConfig (SimpleSource GraphTitle) DaVinciGraphParms where+ configUsed _ _ = True+ ($$) graphTitleSource graphParms+ = graphParms {graphTitleSource = Just graphTitleSource}++instance HasConfig OptimiseLayout DaVinciGraphParms where+ configUsed _ _ = True+ ($$) (OptimiseLayout configDoImprove) daVinciGraphParms =+ daVinciGraphParms {configDoImprove = configDoImprove}++instance HasConfig SurveyView DaVinciGraphParms where+ configUsed _ _ = True+ ($$) (SurveyView surveyView) daVinciGraphParms =+ daVinciGraphParms {surveyView = surveyView}++instance HasConfig AllowClose DaVinciGraphParms where+ configUsed _ _ = True+ ($$) (AllowClose closeDialogue) =+ let+ actFn (graph :: DaVinciGraph) =+ do+ proceed <- closeDialogue+ if proceed then destroy graph else done+ in+ ($$) (CloseMenuOption,Just actFn)++instance HasConfig FileMenuAct DaVinciGraphParms where+ configUsed _ _ = True+ ($$) (FileMenuAct option actFnOpt) =+ let+ graphActFnOpt = case actFnOpt of+ Nothing -> Nothing+ Just actFn ->+ let+ graphActFn :: DaVinciGraph -> IO ()+ graphActFn = const actFn+ in+ Just graphActFn+ in+ ($$) (option,graphActFnOpt)++instance HasConfig (FileMenuOption,(Maybe (DaVinciGraph -> IO ())))+ DaVinciGraphParms where++ configUsed _ _ = True+ ($$) (option,actFnOpt) daVinciGraphParms =+ let+ configFileMenuActions0 = configFileMenuActions daVinciGraphParms+ configFileMenuActions1 = case actFnOpt of+ Nothing -> Map.delete option configFileMenuActions0+ Just actFn -> Map.insert option actFn configFileMenuActions0+ in+ daVinciGraphParms {configFileMenuActions = configFileMenuActions1}+++instance HasConfig GConf.Orientation DaVinciGraphParms where+ configUsed _ _ = True+ ($$) orientation daVinciGraphParms =+ daVinciGraphParms {configOrientation = Just orientation}++instance HasConfig ActionWrapper DaVinciGraphParms where+ configUsed _ _ = True+ ($$) (ActionWrapper wrapper) daVinciGraphParms =+ daVinciGraphParms {configActionWrapper = wrapper}++instance HasConfig AllowDragging DaVinciGraphParms where+ configUsed _ _ = True++ ($$) (AllowDragging allowDragging) =+ addGraphConfigCmd (DragAndDrop+ (if allowDragging then DraggingOn else DraggingOff))++instance HasConfig GlobalMenu DaVinciGraphParms where+ configUsed _ _ = True+ ($$) globalMenu graphParms =+ graphParms {configGlobalMenu = Just globalMenu}++-- Create a global menu and return the ids of the menu-entries, which+-- still need to be activated.+mkGlobalMenu :: DaVinciGraph -> GlobalMenu -> IO [MenuId]+mkGlobalMenu daVinciGraph globalMenu =+ do+ menuEntries <- encodeGlobalMenu globalMenu daVinciGraph+ doInContext (AppMenu(CreateMenus menuEntries))+ (context daVinciGraph)+ return (getMenuIds menuEntries)++instance HasConfig GraphGesture DaVinciGraphParms where+ configUsed _ _ = True+ ($$) (GraphGesture action) graphParms =+ graphParms {+ graphConfigs =+ (\ daVinciGraph ->+ setValue (otherActions daVinciGraph) CreateNode action+ ) : (graphConfigs graphParms)+ }+++instance GraphConfig graphConfig+ => HasConfig graphConfig DaVinciGraphParms where++ configUsed graphConfig graphParms = False+ ($$) graphConfig graphParms = graphParms++-- -----------------------------------------------------------------------+-- Nodes+-- -----------------------------------------------------------------------++data DaVinciNode value = DaVinciNode NodeId deriving (Typeable)++-- | Tiresomely we need to make the \"real\" node type untyped.+-- This is so that the interactor which handles drag-and-drop+-- can get the type out without knowing what it is.+data DaVinciNodeType value = DaVinciNodeType {+ nodeType :: Type,+ nodeText :: value -> IO (SimpleSource String),+ -- how to compute the displayed name of the node+ fontStyle :: Maybe (value -> IO (SimpleSource FontStyle)),+ -- how to compute the font style of the node+ border :: Maybe (value -> IO (SimpleSource Border)),+ -- how to compute the border of the node+ nodeMenuActions :: Registry MenuId (value -> IO ()),+ nodeDoubleClickAction :: value -> IO (),+ createNodeAndEdgeAction :: value -> IO (),+ createEdgeAction :: Dyn -> value -> IO ()+ } deriving (Typeable)++data NodeData = forall value . Typeable value =>+ NodeData (NodeDataData value)++-- Extra type is necessary because GHC forbids named typed fields with+-- an existential type.+data NodeDataData value = NodeDataData {+ typeData :: DaVinciNodeType value,+ valueData :: value,+ sink :: SinkID+ }++data DaVinciNodeTypeParms value =+ DaVinciNodeTypeParms {+ nodeAttributes :: Attributes value,+ configNodeText :: value -> IO (SimpleSource String),+ configFontStyle :: Maybe (value -> IO (SimpleSource FontStyle)),+ configBorder :: Maybe (value -> IO (SimpleSource Border)),+ configNodeDoubleClickAction :: value -> IO (),+ configCreateNodeAndEdgeAction :: value -> IO (),+ configCreateEdgeAction :: Dyn -> value -> IO ()+ }++instance Eq1 DaVinciNode where+ eq1 (DaVinciNode n1) (DaVinciNode n2) = (n1 == n2)++instance Ord1 DaVinciNode where+ compare1 (DaVinciNode n1) (DaVinciNode n2) = compare n1 n2++instance Eq1 DaVinciNodeType where+ eq1 = mapEq nodeType+++newNodePrim1 :: Typeable value+ => DaVinciGraph -> DaVinciNodeType value -> value -> NodeId+ -> IO (DaVinciNode value)+newNodePrim1 (daVinciGraph @ DaVinciGraph {context=context,nodes=nodes})+ nodeType1+ (value :: value) nodeId =+ do+ attributes <- setUpNodeType daVinciGraph nodeType1 value nodeId+ let+ (daVinciNode :: DaVinciNode value) = DaVinciNode nodeId++ synchronize (pendingChangesLock daVinciGraph) (+ addNodeUpdate daVinciGraph (+ NewNode nodeId (nodeType nodeType1) attributes)+ )+ return daVinciNode++-- | setUpNodeType is used for doing Haskell-side initialisations+-- either after (a) a new node has been created, or (b) we have changed+-- the type.+setUpNodeType :: Typeable value+ => DaVinciGraph -> DaVinciNodeType value -> value -> NodeId+ -> IO [Attribute]+setUpNodeType (daVinciGraph @ DaVinciGraph {context=context,nodes=nodes})+ (nodeType @ DaVinciNodeType {+ nodeType = daVinciNodeType,nodeText = nodeText,+ fontStyle = fontStyle,border = border})+ (value :: value) nodeId =+ do+ thisNodeTextSource <- nodeText value+ fontStyleSourceOpt <- case fontStyle of+ Nothing -> return Nothing+ Just getFontStyleSource ->+ do+ fontStyleSource <- getFontStyleSource value+ return (Just fontStyleSource)++ borderSourceOpt <- case border of+ Nothing -> return Nothing+ Just getBorderSource ->+ do+ borderSource <- getBorderSource value+ return (Just borderSource)+ let+ (daVinciNode :: DaVinciNode value) = DaVinciNode nodeId+ sinkID <- newSinkID+ transformValue nodes nodeId (\ nodeDataOpt ->+ do+ case nodeDataOpt of+ Nothing -> done+ Just (NodeData oldNodeData) -> invalidate (sink oldNodeData)+ -- this prevents any more updates to these nodes.+ let+ newNodeData = NodeDataData {+ typeData = nodeType,+ valueData = value,+ sink = sinkID+ }+ return (Just (NodeData newNodeData),())+ )+ let+ addNodeAction+ :: SimpleSource a+ -> (DaVinciGraph -> DaVinciNode value -> a -> IO b)+ -> IO a+ addNodeAction source actFun =+ do+ let+ updateFn a =+ do+ actFun daVinciGraph daVinciNode a+ done+ (a,_) <- addNewSinkGeneral source updateFn sinkID+ return a++ synchronize (pendingChangesLock daVinciGraph) (+ do+ thisNodeText <- addNodeAction thisNodeTextSource setNodeTitle+ let+ attributes1 = [titleAttribute thisNodeText]++ attributes2 <-+ case fontStyleSourceOpt of+ Nothing -> return attributes1+ Just fontStyleSource ->+ do+ thisFontStyle+ <- addNodeAction fontStyleSource setFontStyle+ return (fontStyleAttribute thisFontStyle+ : attributes1)+ attributes3 <-+ case borderSourceOpt of+ Nothing -> return attributes2+ Just borderSource ->+ do+ thisBorder <- addNodeAction borderSource setBorder+ return (borderAttribute thisBorder+ : attributes2)+ return attributes3+ )++instance NewNode DaVinciGraph DaVinciNode DaVinciNodeType where+ newNodePrim graph nodeType value =+ do+ nodeId <- newNodeId (context graph)+ newNodePrim1 graph nodeType value nodeId++ setNodeTypePrim graph (node@ (DaVinciNode nodeId) :: DaVinciNode value)+ nodeType1 =+ do+ -- Check first to see if the type really needs changing.+ goAhead <-+ do+ nodeDataOpt <- getValueOpt (nodes graph) nodeId+ return (case nodeDataOpt of+ Nothing -> False -- Node seems to have been deleted anyway+ Just (NodeData nodeData) ->+ let+ nodeType0 = typeData nodeData+ in+ nodeType nodeType0 /= nodeType nodeType1+ )+ if goAhead+ then+ do+ flushPendingChanges graph+ value <- getNodeValuePrim graph node+ attributes <- setUpNodeType graph nodeType1 value nodeId+ synchronize (pendingChangesLock graph) (+ do+ doInContext+ (Graph (ChangeType+ [NodeType nodeId (nodeType nodeType1)]))+ (context graph)+ doInContext+ (Graph (ChangeAttr [+ Node nodeId attributes]))+ (context graph)+ )+ else+ done++instance DeleteNode DaVinciGraph DaVinciNode where+ deleteNodePrim (daVinciGraph @+ DaVinciGraph {context = context,nodes = nodes})+ (DaVinciNode nodeId) =+ transformValue nodes nodeId (\ nodeDataOpt ->+ case nodeDataOpt of+ Nothing -> return (nodeDataOpt,())+ Just (NodeData nodeDataData) ->+ do+ invalidate (sink nodeDataData)+ addNodeUpdate daVinciGraph (DeleteNode nodeId)+ return (Nothing,())+ )++ getNodeValuePrim (daVinciGraph @ DaVinciGraph {+ context = context,nodes = nodes}) (DaVinciNode nodeId) =+ do+ (Just (NodeData nodeDataData)) <- getValueOpt nodes nodeId+ return (coDyn (valueData nodeDataData))++ setNodeValuePrim+ (daVinciGraph @ DaVinciGraph {context = context,nodes = nodes})+ (daVinciNode @ (DaVinciNode nodeId))+ newValue =+ do+ typeOpt <- transformValue nodes nodeId+ (\ nodeDataOpt ->+ return (+ case nodeDataOpt of+ Nothing -> (nodeDataOpt,Nothing)+ Just (NodeData nodeDataData0) ->+ let+ nodeDataData1 = nodeDataData0 {+ valueData = coDyn newValue}+ in+ (Just (NodeData nodeDataData1),+ Just (coDyn (typeData nodeDataData1)))+ )+ )++ case typeOpt of+ Nothing -> done -- node has disappeared+ Just nodeType ->+ do+ newTitleSource <- nodeText nodeType newValue+ newTitle <- readContents newTitleSource+ setNodeTitle daVinciGraph daVinciNode newTitle+ done++ getMultipleNodesPrim daVinciGraph mkAct =+ do+ channel <- newChannel++ lastSel <- newIORef Nothing++ let+ mapNode :: NodeId -> DaVinciNodeType value -> DaVinciNode value+ mapNode nodeId _ = DaVinciNode nodeId++ closeAct =+ do+ errorMess+ "Unexpected close interrupting multiple node selection!"+ signalDestruct daVinciGraph++ newHandler :: DaVinciAnswer -> IO ()+ newHandler answer = case answer of+ NodeSelectionsLabels [nodeId]+ -> writeIORef lastSel (Just nodeId)+ NodeSelectionsLabels _ -> done -- not a double click+ NodeDoubleClick ->+ do+ nodeIdOpt <- readIORef lastSel+ case nodeIdOpt of+ Nothing -> errorMess "Confusing node selection ignored"+ Just nodeId ->+ do+ nodeDataOpt+ <- getValueOpt (nodes daVinciGraph) nodeId+ case nodeDataOpt of+ Nothing -> errorMess+ "Confusing node selection ignored (2)"+ Just (NodeData nodeDataData) ->+ do+ let+ wrappedNode = WrappedNode+ (mapNode nodeId (+ typeData nodeDataData))+ sync(noWait(send channel wrappedNode))++ EdgeSelectionLabel _ -> done+ EdgeSelectionLabels _ _ -> done+ Closed -> closeAct+ Quit -> closeAct+ _ -> errorMess+ "Other user input ignored during multiple node selection"+++ act = mkAct (receive channel)++ withHandler newHandler (context daVinciGraph) act++instance SetNodeFocus DaVinciGraph DaVinciNode where+ setNodeFocusPrim (daVinciGraph @+ DaVinciGraph {context = context,nodes = nodes})+ (DaVinciNode nodeId) =+ transformValue nodes nodeId (\ nodeDataOpt ->+ case nodeDataOpt of+ Nothing -> return (nodeDataOpt,())+ Just (NodeData nodeDataData) ->+ do+ doInContext (Special (FocusNodeAnimated nodeId)) context+ return (nodeDataOpt,())+ )+++instance NodeClass DaVinciNode++instance NodeTypeClass DaVinciNodeType++instance NewNodeType DaVinciGraph DaVinciNodeType DaVinciNodeTypeParms where+ newNodeTypePrim+ (daVinciGraph@(DaVinciGraph {context = context}))+ (DaVinciNodeTypeParms {+ nodeAttributes = nodeAttributes,+ configNodeText = configNodeText,+ configFontStyle = configFontStyle,+ configBorder = configBorder,+ configNodeDoubleClickAction = configNodeDoubleClickAction,+ configCreateNodeAndEdgeAction+ = configCreateNodeAndEdgeAction,+ configCreateEdgeAction = configCreateEdgeAction+ }) =+ do+ nodeType <- newType context+ (nodeMenuActions,daVinciAttributes) <-+ encodeAttributes nodeAttributes daVinciGraph+ doInContext (Visual(AddRules [NR nodeType daVinciAttributes])) context++ let+ nodeText = configNodeText+ fontStyle = configFontStyle+ border = configBorder+ nodeDoubleClickAction = configNodeDoubleClickAction+ createNodeAndEdgeAction = configCreateNodeAndEdgeAction+ createEdgeAction = configCreateEdgeAction+ return (DaVinciNodeType {+ nodeType = nodeType,+ nodeText = nodeText,+ fontStyle = fontStyle,+ border = border,+ nodeMenuActions = nodeMenuActions,+ nodeDoubleClickAction = nodeDoubleClickAction,+ createNodeAndEdgeAction = createNodeAndEdgeAction,+ createEdgeAction = createEdgeAction+ })++instance NodeTypeParms DaVinciNodeTypeParms where+ emptyNodeTypeParms = DaVinciNodeTypeParms {+ nodeAttributes = emptyAttributes,+ configNodeText = const (return (staticSimpleSource "")),+ configFontStyle = Nothing,+ configBorder = Nothing,+ configNodeDoubleClickAction = const done,+ configCreateNodeAndEdgeAction = const done,+ configCreateEdgeAction = const (const done)+ }++ coMapNodeTypeParms coMapFn+ (DaVinciNodeTypeParms {+ nodeAttributes = nodeAttributes,+ configNodeText = configNodeText,+ configFontStyle = configFontStyle,+ configBorder = configBorder,+ configNodeDoubleClickAction = configNodeDoubleClickAction,+ configCreateNodeAndEdgeAction = configCreateNodeAndEdgeAction,+ configCreateEdgeAction = configCreateEdgeAction+ }) =+ DaVinciNodeTypeParms {+ nodeAttributes = coMapAttributes coMapFn nodeAttributes,+ configNodeText = configNodeText . coMapFn,+ configFontStyle = (fmap (. coMapFn) configFontStyle),+ configBorder = (fmap (. coMapFn) configBorder),+ configNodeDoubleClickAction = configNodeDoubleClickAction . coMapFn,+ configCreateNodeAndEdgeAction =+ configCreateNodeAndEdgeAction . coMapFn,+ configCreateEdgeAction = (\ dyn ->+ (configCreateEdgeAction dyn) . coMapFn)+ }++instance NodeTypeConfig graphConfig+ => HasConfigValue graphConfig DaVinciNodeTypeParms where++ configUsed' nodeTypeConfig nodeTypeParms = False+ ($$$) nodeTypeConfig nodeTypeParms = nodeTypeParms++------------------------------------------------------------------------+-- Node type configs for titles, shapes, and so on.+------------------------------------------------------------------------++instance HasConfigValue ValueTitle DaVinciNodeTypeParms where+ configUsed' _ _ = True+ ($$$) (ValueTitle nodeText') parms =+ let+ nodeText value =+ do+ initial <- nodeText' value+ return (staticSimpleSource initial)+ in+ parms { configNodeText = nodeText }++instance HasConfigValue ValueTitleSource DaVinciNodeTypeParms where+ configUsed' _ _ = True+ ($$$) (ValueTitleSource nodeText) parms =+ parms { configNodeText = nodeText }++instance HasConfigValue FontStyleSource DaVinciNodeTypeParms where+ configUsed' _ _ = True+ ($$$) (FontStyleSource fontStyleSource) parms =+ parms { configFontStyle = Just fontStyleSource }++instance HasConfigValue BorderSource DaVinciNodeTypeParms where+ configUsed' _ _ = True+ ($$$) (BorderSource borderSource) parms =+ parms { configBorder = Just borderSource }++instance HasConfigValue Shape DaVinciNodeTypeParms where+ configUsed' _ _ = True+ ($$$) shape parms =+ let+ nodeAttributes0 = nodeAttributes parms+ shaped shape = Att "_GO" shape $$$ nodeAttributes0+ nodeAttributes1 =+ case shape of+ Box -> shaped "box"+ Circle -> shaped "circle"+ Ellipse -> shaped "ellipse"+ Rhombus -> shaped "rhombus"+ Triangle -> shaped "triangle"+ Icon filePath ->+ Att "ICONFILE" filePath $$$+ shaped "icon"+ in+ parms {nodeAttributes = nodeAttributes1}++instance HasConfigValue Color DaVinciNodeTypeParms where+ configUsed' _ _ = True+ ($$$) (Color colorName) parms =+ parms {nodeAttributes = (Att "COLOR" colorName) $$$+ (nodeAttributes parms)}++instance HasConfigValue LocalMenu DaVinciNodeTypeParms where+ configUsed' _ _ = True+ ($$$) localMenu parms =+ parms {nodeAttributes = localMenu $$$ (nodeAttributes parms)}++instance HasConfigValue DoubleClickAction DaVinciNodeTypeParms where+ configUsed' _ _ = True+ ($$$) (DoubleClickAction action) parms =+ parms {configNodeDoubleClickAction = action}++------------------------------------------------------------------------+-- Instances of HasModifyValue+------------------------------------------------------------------------++instance HasModifyValue NodeArcsHidden DaVinciGraph DaVinciNode where+ modify (NodeArcsHidden hide) daVinciGraph (DaVinciNode nodeId) =+ do+ flushPendingChanges daVinciGraph+ doInContext (Menu (+ Abstraction ((if hide then HideEdges else ShowEdges) [nodeId])+ )) (context daVinciGraph)+ case daVinciVersion of+ Just _ -> done+ Nothing ->+ -- work around daVinci 2 bug which causes edge hiding to be+ -- delayed+ doInContext (Graph (ChangeAttr ([Node nodeId []])))+ (context daVinciGraph)++instance HasModifyValue Attribute DaVinciGraph DaVinciNode where+ modify attribute daVinciGraph (DaVinciNode nodeId) =+ do+ flushPendingChanges daVinciGraph+ doInContext+ (Graph (ChangeAttr [Node nodeId [attribute]]))+ (context daVinciGraph)++instance HasModifyValue (String,String) DaVinciGraph DaVinciNode where+ modify (key,value) = modify (A key value)+++------------------------------------------------------------------------+-- Node type configs for drag and drop+------------------------------------------------------------------------++instance HasConfigValue NodeGesture DaVinciNodeTypeParms where+ configUsed' _ _ = True+ ($$$) (NodeGesture actFn) nodeTypeParms =+ nodeTypeParms {configCreateNodeAndEdgeAction = actFn}++instance HasConfigValue NodeDragAndDrop DaVinciNodeTypeParms where+ configUsed' _ _ = True+ ($$$) (NodeDragAndDrop actFn) nodeTypeParms =+ nodeTypeParms {configCreateEdgeAction = actFn}++-- -----------------------------------------------------------------------+-- Arcs+-- -----------------------------------------------------------------------++data DaVinciArc value = DaVinciArc EdgeId deriving (Typeable)++-- Like nodes, the "real" type is monomorphic.+data DaVinciArcType value = DaVinciArcType {+ arcType :: Type,+ arcMenuActions :: Registry MenuId (value -> IO ()),+ arcDoubleClickAction :: value -> IO (),+ arcArcText :: value -> IO (SimpleSource String)+-- arcTitleFunc :: value -> String+ } deriving (Typeable)++data DaVinciArcTypeParms value =+ DaVinciArcTypeParms {+ arcAttributes :: Attributes value,+ configArcDoubleClickAction :: value -> IO (),+ configArcText :: value -> IO (SimpleSource String)+-- configArcTitleFunc :: value -> String+ }+ | InvisibleArcTypeParms++data ArcData = forall value . Typeable value+ => ArcData (DaVinciArcType value) value+++instance Eq1 DaVinciArc where+ eq1 (DaVinciArc n1) (DaVinciArc n2) = (n1 == n2)++instance Ord1 DaVinciArc where+ compare1 (DaVinciArc n1) (DaVinciArc n2) = compare n1 n2++addArcGeneral :: Typeable value+ => DaVinciGraph -> DaVinciArcType value+ -> DaVinciArc value -> value+ -> DaVinciNode nodeFromValue -> DaVinciNode nodeToValue+ -> IO ()+addArcGeneral+ (daVinciGraph @ DaVinciGraph {edges = edges})+ daVinciArcType (DaVinciArc edgeId) value+ (DaVinciNode nodeFrom) (DaVinciNode nodeTo) =+ do+ if daVinciArcType `eq1` invisibleArcType+ then+ done+ else+ do+ s <- (arcArcText daVinciArcType) value+ arcText <- readContents(s)+ atts <- return ([titleAttribute arcText])+ setValue edges edgeId (ArcData daVinciArcType value)+ addEdgeUpdate daVinciGraph+ (NewEdge edgeId (arcType daVinciArcType) atts nodeFrom nodeTo)++instance NewArc DaVinciGraph DaVinciNode DaVinciNode DaVinciArc+ DaVinciArcType+ where+ newArcPrim daVinciGraph daVinciArcType value nodeFrom nodeTo =+ do+ edgeId <- newEdgeId (context daVinciGraph)+ let+ newArc = DaVinciArc edgeId++ addArcGeneral daVinciGraph daVinciArcType newArc value+ nodeFrom nodeTo++ return newArc++ newArcListDrawerPrim+ (daVinciGraph @ DaVinciGraph {context = context,edges = edges})+ nodeFrom =+ -- We ignore positional data for now, since daVinci does too.++ let+ newPos _ aOpt =+ do+ edgeId <- newEdgeId context+ let+ newArc = DaVinciArc edgeId+ case aOpt of+ Nothing -> done+ Just (daVinciArcType,value,WrappedNode nodeTo) ->+ addArcGeneral daVinciGraph daVinciArcType newArc+ value nodeFrom nodeTo+ return newArc++ setPos (arc@(DaVinciArc edgeId)) aOpt =+ do+ -- Delete the old, if present+ delPos arc++ -- Add the new+ case aOpt of+ Nothing -> done+ Just (daVinciArcType,value,WrappedNode nodeTo) ->+ addArcGeneral daVinciGraph daVinciArcType arc+ value nodeFrom nodeTo++ delPos (DaVinciArc edgeId) =+ do+ -- Delete the old, if present+ deleteOld <- deleteFromRegistryBool edges edgeId+ if deleteOld+ then+ addEdgeUpdate daVinciGraph (DeleteEdge edgeId)+ else+ done++ redraw' = redrawPrim daVinciGraph++ listDrawer = VariableList.ListDrawer {+ VariableList.newPos = newPos,VariableList.setPos = setPos,+ VariableList.delPos = delPos,VariableList.redraw = redraw'}+ in+ listDrawer++instance SetArcType DaVinciGraph DaVinciArc DaVinciArcType where+ setArcTypePrim daVinciGraph (davinciArc@(DaVinciArc edgeId))+ daVinciArcType =+ error "Sorry, setArcType is not implemented for daVinci"++instance DeleteArc DaVinciGraph DaVinciArc where+ deleteArcPrim (daVinciGraph @ DaVinciGraph {edges=edges,context = context})+ (DaVinciArc edgeId) =+ do+ addEdgeUpdate daVinciGraph (DeleteEdge edgeId)+ deleteFromRegistry edges edgeId++ getArcValuePrim (daVinciGraph @ DaVinciGraph {+ context = context,edges = edges}) (DaVinciArc edgeId) =+ do+ (Just (ArcData _ arcValue)) <- getValueOpt edges edgeId+ return (coDyn arcValue)++ setArcValuePrim (daVinciGraph @ DaVinciGraph {+ context = context,edges = edges}) (DaVinciArc edgeId) newValue =+ do+ flushPendingChanges daVinciGraph+ transformValue edges edgeId+ (\ (Just (ArcData edgeType _)) ->+ return (Just (ArcData edgeType (coDyn newValue)),()))++instance ArcClass DaVinciArc++instance Eq1 DaVinciArcType where+ eq1 = mapEq arcType++instance Ord1 DaVinciArcType where+ compare1 = mapOrd arcType++instance ArcTypeClass DaVinciArcType where+ invisibleArcType = DaVinciArcType {+ arcType = Type (UniqueString.newNonUnique "Invisible"),+ arcMenuActions = error "daVinciGraph.invisible1",+ arcDoubleClickAction = error "daVinciGraph.invisible2",+ arcArcText = error "daVinciGraph.invisible3"+ }++instance NewArcType DaVinciGraph DaVinciArcType DaVinciArcTypeParms where+ newArcTypePrim _ InvisibleArcTypeParms = return invisibleArcType++ newArcTypePrim+ (daVinciGraph@DaVinciGraph{context = context})+ (DaVinciArcTypeParms{arcAttributes = arcAttributes,+ configArcDoubleClickAction = configArcDoubleClickAction,+ configArcText = configArcText+-- configArcTitleFunc = configArcTitleFunc+ }) =+ do+ arcType <- newType context+ (arcMenuActions,attributes)+ <- encodeAttributes arcAttributes daVinciGraph+ doInContext (Visual(AddRules [ER arcType attributes])) context+ let+ arcDoubleClickAction = configArcDoubleClickAction+ arcArcText = configArcText+ return (DaVinciArcType {+ arcType = arcType,+ arcMenuActions = arcMenuActions,+ arcDoubleClickAction = arcDoubleClickAction,+ arcArcText = arcArcText+ })++instance ArcTypeParms DaVinciArcTypeParms where+ emptyArcTypeParms = DaVinciArcTypeParms {+ arcAttributes = emptyAttributes,+ configArcDoubleClickAction = const done,+ configArcText = const (return (staticSimpleSource ""))+ }++ invisibleArcTypeParms = InvisibleArcTypeParms++ coMapArcTypeParms coMapFn+ (DaVinciArcTypeParms {+ arcAttributes = arcAttributes,+ configArcDoubleClickAction = configArcDoubleClickAction,+ configArcText = configArcText+ }) =+ (DaVinciArcTypeParms {+ arcAttributes = coMapAttributes coMapFn arcAttributes,+ configArcDoubleClickAction = configArcDoubleClickAction . coMapFn,+ configArcText = configArcText . coMapFn+ })+ coMapArcTypeParms coMapFn InvisibleArcTypeParms = InvisibleArcTypeParms+++instance HasConfigValue Color DaVinciArcTypeParms where+ configUsed' _ _ = True+ ($$$) (Color colorName) parms =+ parms {arcAttributes = (Att "EDGECOLOR" colorName) $$$+ (arcAttributes parms)}++instance HasConfigValue EdgeDir DaVinciArcTypeParms where+ configUsed' _ _ = True+ ($$$) (Dir dirStr) parms =+ parms {arcAttributes = (Att "_DIR" dirStr) $$$+ (arcAttributes parms)}++instance HasConfigValue Head DaVinciArcTypeParms where+ configUsed' _ _ = True+ ($$$) (Head headStr) parms =+ parms {arcAttributes = (Att "HEAD" headStr) $$$+ (arcAttributes parms)}++instance HasConfigValue EdgePattern DaVinciArcTypeParms where+ configUsed' _ _ = True+ ($$$) edgePattern parms =+ let+ pattern = case edgePattern of+ Solid -> "solid"+ Dotted -> "dotted"+ Dashed -> "dashed"+ Thick -> "thick"+ Double -> "double"+ in+ parms {arcAttributes = (Att "EDGEPATTERN" pattern) $$$+ (arcAttributes parms)}++instance HasConfigValue LocalMenu DaVinciArcTypeParms where+ configUsed' _ _ = True+ ($$$) localMenu parms =+ parms {arcAttributes = localMenu $$$ (arcAttributes parms)}++instance ArcTypeConfig arcTypeConfig+ => HasConfigValue arcTypeConfig DaVinciArcTypeParms where++ configUsed' arcTypeConfig arcTypeParms = False+ ($$$) arcTypeConfig arcTypeParms = arcTypeParms+++instance HasConfigValue DoubleClickAction DaVinciArcTypeParms where+ configUsed' _ _ = True+ ($$$) (DoubleClickAction action) parms =+ parms {configArcDoubleClickAction = action}++{--+instance HasConfigValue TitleFunc DaVinciArcTypeParms where+ configUsed' _ _ = True+ ($$$) (TitleFunc func) parms =+ parms {configArcTitleFunc = func}+--}++instance HasConfigValue ValueTitle DaVinciArcTypeParms where+ configUsed' _ _ = True+ ($$$) (ValueTitle arcText') parms =+ let+ arcText value =+ do+ initial <- arcText' value+ return (staticSimpleSource initial)+ in+ parms { configArcText = arcText }+++------------------------------------------------------------------------+-- Attributes in general+-- The Attributes type encodes the attributes in a DaVinciNodeTypeParms+-- or a DaVinciArcTypeParms+------------------------------------------------------------------------++data Attributes value = Attributes {+ options :: Map.Map String String,+ menuOpt :: Maybe (LocalMenu value)+ }++emptyAttributes :: Attributes value+emptyAttributes = Attributes {+ options = Map.empty,+ menuOpt = Nothing+ }++coMapAttributes :: (value2 -> value1) -> Attributes value1+ -> Attributes value2+coMapAttributes coMapFn (Attributes{options = options,menuOpt = menuOpt0}) =+ let+ menuOpt1 =+ fmap -- deals with Maybe+ (\ (LocalMenu menu0) ->+ (LocalMenu (mapMenuPrim (. coMapFn) menu0))+ )+ menuOpt0+ in+ Attributes{options = options,menuOpt = menuOpt1}++++data Att value = Att String String+-- An attribute++instance HasConfigValue Att Attributes where+ configUsed' _ _ = True+ ($$$) (Att key value) attributes =+ attributes {+ options = Map.insert key value (options attributes)+ }++instance HasConfigValue LocalMenu Attributes where+ configUsed' _ _ = True+ ($$$) localMenu attributes =+ attributes {menuOpt = Just localMenu}++encodeAttributes :: Typeable value => Attributes value -> DaVinciGraph+ -> IO (Registry MenuId (value -> IO ()),[Attribute])+encodeAttributes attributes daVinciGraph =+ do+ let+ keysPart =+ fmap+ (\ (key,value) -> A key value)+ (Map.toList (options attributes))+ case menuOpt attributes of+ Nothing -> return (+ error "MenuId returned by daVinci for object with no menu!",+ keysPart)+ Just localMenu ->+ do+ (registry,menuEntries) <-+ encodeLocalMenu localMenu daVinciGraph+ return (registry,M menuEntries : keysPart)++------------------------------------------------------------------------+-- Menus+------------------------------------------------------------------------++encodeLocalMenu :: Typeable value => LocalMenu value -> DaVinciGraph+ -> IO (Registry MenuId (value -> IO ()),[MenuEntry])+-- Construct a local menu associated with a particular type,+-- returning (a) a registry mapping MenuId's to actions;+-- (b) the [MenuEntry] to be passed to daVinci.+encodeLocalMenu+ (LocalMenu (menuPrim0 :: GConf.MenuPrim (Maybe String) (value -> IO ())))+ (DaVinciGraph {context = context}) =+ do+ registry <- newRegistry+ (menuPrim1 :: GConf.MenuPrim (Maybe String) MenuId) <-+ mapMMenuPrim+ (\ valueToAct ->+ do+ menuId <- newMenuId context+ setValue registry menuId valueToAct+ return menuId+ )+ menuPrim0+ (menuPrim2 :: GConf.MenuPrim (Maybe String,MenuId) MenuId) <-+ mapMMenuPrim'+ (\ stringOpt ->+ do+ menuId <- newMenuId context+ return (stringOpt,menuId)+ )+ menuPrim1+ return (registry,encodeDaVinciMenu menuPrim2)++getMenuIds :: [MenuEntry] -> [MenuId]+getMenuIds [] = []+getMenuIds (first:rest) = theseIds ++ getMenuIds rest+ where+ theseIds :: [MenuId]+ theseIds = case first of+ MenuEntry menuId _ -> [menuId]+ MenuEntryMne menuId _ _ _ _ -> [menuId]+ SubmenuEntry menuId _ menuEntries -> menuId : getMenuIds menuEntries+ SubmenuEntryMne menuId _ menuEntries _ ->+ menuId : getMenuIds menuEntries+ BlankMenuEntry -> []+ _ -> error "DaVinciGraph: (Sub)MenuEntryDisabled not yet handled."++encodeGlobalMenu :: GlobalMenu -> DaVinciGraph -> IO [MenuEntry]+-- This constructs a global menu. The menuId actions are written+-- directly into the graphs globalMenuActions registry.+encodeGlobalMenu (GlobalMenu+ (menuPrim0 :: GConf.MenuPrim (Maybe String) (IO ())))+ (DaVinciGraph {context = context,globalMenuActions = globalMenuActions})+ =+ do+ (menuPrim1 :: GConf.MenuPrim (Maybe String) MenuId) <-+ mapMMenuPrim+ (\ action ->+ do+ menuId <- newMenuId context+ setValue globalMenuActions menuId action+ return menuId+ )+ menuPrim0+ (menuPrim2 :: GConf.MenuPrim (Maybe String,MenuId) MenuId) <-+ mapMMenuPrim'+ (\ stringOpt ->+ do+ menuId <- newMenuId context+ return (stringOpt,menuId)+ )+ menuPrim1+ return (encodeDaVinciMenu menuPrim2)++encodeDaVinciMenu :: GConf.MenuPrim (Maybe String,MenuId) MenuId -> [MenuEntry]+-- Used for encoding all menus. The MenuId in the first argument is+-- used as all submenus need to have a unique menuId, even though+-- daVinci can't send that as an event.+encodeDaVinciMenu menuHead =+ case menuHead of+ GConf.Menu (Nothing,_) menuPrims ->+ encodeMenuList menuPrims+ GConf.Menu (Just label,menuId) menuPrims ->+ [SubmenuEntry menuId (MenuLabel label) (encodeMenuList menuPrims)]+ single -> [encodeMenuItem single]++ where+ encodeMenuList :: [GConf.MenuPrim (Maybe String,MenuId) MenuId]+ -> [MenuEntry]+ encodeMenuList menuPrims = fmap encodeMenuItem menuPrims++ encodeMenuItem :: GConf.MenuPrim (Maybe String,MenuId) MenuId+ -> MenuEntry+ encodeMenuItem (Button label menuId) = MenuEntry menuId (MenuLabel label)+ encodeMenuItem (GConf.Menu (labelOpt,menuId) menuItems) =+ SubmenuEntry menuId (MenuLabel (fromMaybe "" labelOpt))+ (encodeMenuList menuItems)+ encodeMenuItem Blank = BlankMenuEntry++-- -----------------------------------------------------------------------+-- Handling pending changes+-- -----------------------------------------------------------------------++addNodeUpdate :: DaVinciGraph -> NodeUpdate -> IO ()+addNodeUpdate (DaVinciGraph {pendingChangesMVar = pendingChangesMVar})+ nodeUpdate =+ do+ pendingChanges <- takeMVar pendingChangesMVar+ putMVar pendingChangesMVar (NU nodeUpdate : pendingChanges)+++addEdgeUpdate :: DaVinciGraph -> EdgeUpdate -> IO ()+addEdgeUpdate (DaVinciGraph {pendingChangesMVar = pendingChangesMVar})+ edgeUpdate =+ do+ pendingChanges <- takeMVar pendingChangesMVar+ putMVar pendingChangesMVar (EU edgeUpdate : pendingChanges)++sortPendingChanges :: [MixedUpdate] -> DaVinciCmd+-- This is tricky because for daVinci 2.1 mixed updates don't work properly,+-- so we need to feed the updates as a list of node updates followed by+-- a list of edge updates.+sortPendingChanges pendingChanges =+ if isJust daVinciVersion+ then+ -- daVinci has version at least 3.0, and so multi_update works.+ Graph(UpdateMixed (reverse pendingChanges))+ else+ sortPendingChanges1 pendingChanges++sortPendingChanges1 :: [MixedUpdate] -> DaVinciCmd+sortPendingChanges1 pendingChanges =+ let+ (nodeUpdates :: [NodeUpdate],edgeUpdates1 :: [EdgeUpdate]) =+ foldr -- so that the nodes are in the same order as in list.+ (\ change (nodesSF,edgesSF) ->+ case change of+ NU(n @ (NewNode _ _ _)) -> (n:nodesSF,edgesSF)+ NU(n @ (DeleteNode _)) -> (n:nodesSF,edgesSF)+ EU(e @ (NewEdge _ _ _ _ _)) -> (nodesSF,e:edgesSF)+ EU(e @ (DeleteEdge _)) -> (nodesSF,e:edgesSF)+ )+ ([],[])+ pendingChanges++ -- We need to eliminate NewEdge updates for edges+ -- containing deleted nodes, and DeleteEdge updates for these+ -- eliminated edges.+ finalState = toFinalState pendingChanges++ deletedNodes :: Set.Set NodeId+ deletedNodes = Set.fromList (mapMaybe+ (\ update -> case update of+ NU (DeleteNode nodeId) -> Just nodeId+ _ -> Nothing+ )+ finalState+ )++ (edgeUpdates2 :: [EdgeUpdate],obsoleteEdges :: Set.Set EdgeId) =+ foldl+ (\ (eSF,oSF) e -> case e of+ (NewEdge edgeId _ _ nodeFrom nodeTo) ->+ if (Set.member nodeFrom deletedNodes) ||+ (Set.member nodeTo deletedNodes)+ then (eSF,Set.insert edgeId oSF)+ else (e:eSF,oSF)+ _ -> (e:eSF,oSF)+ )+ ([],Set.empty)+ edgeUpdates1++ (edgeUpdates3 :: [EdgeUpdate]) = List.filter+ (\ e -> case e of+ DeleteEdge edgeId -> not (Set.member edgeId obsoleteEdges)+ _ -> True+ )+ (reverse edgeUpdates2)+ in+ Graph(Update nodeUpdates edgeUpdates3)++removeNullifyingChanges :: [MixedUpdate] -> [MixedUpdate]+removeNullifyingChanges [] = []+removeNullifyingChanges (update:r) = case update of+ NU (DeleteNode nid) -> case findN nid of+ (r,[]) -> update:removeNullifyingChanges r+ (h,_:t) -> removeNullifyingChanges $ h ++ t+ EU (DeleteEdge eid) -> case findE eid of+ (r,[]) -> update:removeNullifyingChanges r+ (h,_:t) -> removeNullifyingChanges $ h ++ t+ -- EU (NewEdgeBehind eid _ _ _ _ _) ->+ _ -> update:removeNullifyingChanges r+ where+ findN i = span (\ mu -> case mu of+ NU (NewNode nid' _ _) -> i /= nid'+ _ -> True) r+ findE i = span (\ mu -> case mu of+ EU (NewEdge eid' _ _ _ _) -> i /= eid'+ _ -> True) r++flushPendingChanges :: DaVinciGraph -> IO ()+flushPendingChanges (DaVinciGraph {context = context,nodes = nodes,+ edges = edges,pendingChangesMVar = pendingChangesMVar,+ pendingChangesLock = pendingChangesLock}) =+ synchronize pendingChangesLock (+ do+ pendingChanges <- takeMVar pendingChangesMVar+ putMVar pendingChangesMVar []+ case removeNullifyingChanges pendingChanges of+ [] -> done+ ps -> do+ let isDelete u = case u of+ NU (DeleteNode _) -> True+ EU (DeleteEdge _) -> True+ _ -> False+ splitUp = List.groupBy (\ u1 u2 ->+ isDelete u1 == isDelete u2)+ mapM_ (\ p -> doInContext (sortPendingChanges p) context)+ $ reverse $ splitUp ps+ -- Delete registry entries for all now-irrelevant node and edge+ -- entries.+ -- NB. This will miss deleting entries for edges which are+ -- attached to nodes which get deleted without being+ -- deleted themselves, but I can't be bothered now to do+ -- anything about this.+ sequence_ (fmap+ (\ pendingChange -> case pendingChange of+ NU (DeleteNode nodeId) -> deleteFromRegistry nodes nodeId+ EU (DeleteEdge edgeId) -> deleteFromRegistry edges edgeId+ _ -> done+ )+ (toFinalState pendingChanges)+ )+ )++-- For each node or edge created or destroyed in the list, delete all but+-- the first operation applied to it (== the last added to the list)+toFinalState :: [MixedUpdate] -> [MixedUpdate]+toFinalState = uniqOrdByKeyOrder toId+ where+ toId :: MixedUpdate -> Either NodeId EdgeId+ toId (NU (DeleteNode nodeId)) = Left nodeId+ toId (NU (NewNode nodeId _ _)) = Left nodeId+ toId (EU (DeleteEdge edgeId)) = Right edgeId+ toId (EU (NewEdge edgeId _ _ _ _)) = Right edgeId+ toId (EU (NewEdgeBehind _ edgeId _ _ _ _)) = Right edgeId++-- -----------------------------------------------------------------------+-- Setting node titles and font styles.+-- -----------------------------------------------------------------------++-- | This is called internally, by the function set up by newNodePrim.+-- The function returns False to indicate that this function failed as+-- the node has been deleted.+-- (This behaviour may now be useless anyway but I can't be bothered+-- to change it.)+setNodeTitle :: Typeable value => DaVinciGraph -> DaVinciNode value -> String+ -> IO Bool+setNodeTitle daVinciGraph (daVinciNode@(DaVinciNode nodeId)) newTitle =+ do+ flushPendingChanges daVinciGraph+ nodeDataOpt <- getValueOpt (nodes daVinciGraph) nodeId+ case nodeDataOpt of+ Nothing -> return False+ Just (nodeData :: NodeData) ->+ do+ modify (titleAttribute newTitle) daVinciGraph daVinciNode+ return True++titleAttribute :: String -> Attribute+titleAttribute title = A "OBJECT" title++-- | This function similarly changes the font style.+setFontStyle :: Typeable value => DaVinciGraph -> DaVinciNode value+ -> FontStyle -> IO Bool+setFontStyle daVinciGraph (daVinciNode@(DaVinciNode nodeId)) fontStyle =+ do+ flushPendingChanges daVinciGraph+ nodeDataOpt <- getValueOpt (nodes daVinciGraph) nodeId+ case nodeDataOpt of+ Nothing -> return False+ Just (nodeData :: NodeData) ->+ do+ modify (fontStyleAttribute fontStyle) daVinciGraph daVinciNode+ return True++fontStyleAttribute :: FontStyle -> Attribute+fontStyleAttribute fontStyle =+ let+ fontStyleStr = case fontStyle of+ NormalFontStyle -> "normal"+ BoldFontStyle -> "bold"+ ItalicFontStyle -> "italic"+ BoldItalicFontStyle -> "bold_italic"+ in+ A "FONTSTYLE" fontStyleStr++-- | This function similarly changes the border.+setBorder :: Typeable value => DaVinciGraph -> DaVinciNode value+ -> Border -> IO Bool+setBorder daVinciGraph (daVinciNode@(DaVinciNode nodeId)) border =+ do+ flushPendingChanges daVinciGraph+ nodeDataOpt <- getValueOpt (nodes daVinciGraph) nodeId+ case nodeDataOpt of+ Nothing -> return False+ Just (nodeData :: NodeData) ->+ do+ modify (borderAttribute border) daVinciGraph daVinciNode+ return True++borderAttribute :: Border -> Attribute+borderAttribute border =+ let+ borderStr = case border of+ NoBorder -> "none"+ SingleBorder -> "single"+ DoubleBorder -> "double"+ in+ A "BORDER" borderStr++-- -----------------------------------------------------------------------+-- Turning a FileMenuOption into a String and vice-versa+-- -----------------------------------------------------------------------++fromFileMenuOption :: FileMenuOption -> String+fromFileMenuOption option =+ case lookup option menuOptionList of+ Just s -> s++toFileMenuOption :: String -> Maybe FileMenuOption+toFileMenuOption s =+ lookup s (fmap (\ (o,s) -> (s,o)) menuOptionList)++menuOptionList :: [(FileMenuOption,String)]+menuOptionList = [+ (NewMenuOption, "new"),+ (OpenMenuOption, "open"),+ (SaveMenuOption, "save"),+ (SaveAsMenuOption,"saveas"),+ (PrintMenuOption, "print"),+ (CloseMenuOption, "close"),+ (ExitMenuOption, "exit")+ ]++-- -----------------------------------------------------------------------+-- Miscellaneous functions+-- -----------------------------------------------------------------------++-- Transforming one type to another when we know they are+-- actually identical . . .+coDyn :: (Typeable a,Typeable b) => a -> b+coDyn valueA =+ case Data.Dynamic.cast valueA of+ Just valueB -> valueB++-- ---------------------------------------------------------------------+-- A safer version of getValue+-- ---------------------------------------------------------------------++getValueHere :: GetSetRegistry registry from to => registry -> from -> IO to+getValueHere =+ if isDebug+ then+ getValueSafe "DaVinciGraph getValue"+ else+ getValue
+ UDrawGraph/Types.hs view
@@ -0,0 +1,752 @@+-- | 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"))
+ uni-uDrawGraph.cabal view
@@ -0,0 +1,25 @@+name: uni-uDrawGraph+version: 2.2.0.0+build-type: Simple+license: LGPL+license-file: LICENSE+author: uniform@informatik.uni-bremen.de+maintainer: Christian.Maeder@dfki.de+homepage: http://www.informatik.uni-bremen.de/uniform/wb+category: GUI+synopsis: Graphs binding+description: Binding to uDrawGraph (formerly daVinci)+ <http://www.informatik.uni-bremen.de/uDrawGraph/>+cabal-version: >= 1.4+Tested-With: GHC==6.8.3, GHC==6.10.4, GHC==6.12.3++library+ exposed-modules: UDrawGraph.Types, UDrawGraph.Basic, UDrawGraph.Graph++ build-depends: base >=3 && < 5, containers, uni-util, uni-events,+ uni-posixutil, uni-reactor, uni-graphs++ if impl(ghc < 6.10)+ extensions: PatternSignatures+ else+ ghc-options: -fwarn-unused-imports -fno-warn-warnings-deprecations