diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/UDrawGraph/Basic.hs b/UDrawGraph/Basic.hs new file mode 100644 --- /dev/null +++ b/UDrawGraph/Basic.hs @@ -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 diff --git a/UDrawGraph/Graph.hs b/UDrawGraph/Graph.hs new file mode 100644 --- /dev/null +++ b/UDrawGraph/Graph.hs @@ -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 diff --git a/UDrawGraph/Types.hs b/UDrawGraph/Types.hs new file mode 100644 --- /dev/null +++ b/UDrawGraph/Types.hs @@ -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 1997/99 +-- Adapted to daVinci 2.1: Tim Geisler 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")) diff --git a/uni-uDrawGraph.cabal b/uni-uDrawGraph.cabal new file mode 100644 --- /dev/null +++ b/uni-uDrawGraph.cabal @@ -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) + +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