uni-uDrawGraph-2.2.0.2: UDrawGraph/Basic.hs
{-# LANGUAGE ScopedTypeVariables #-}
-- | 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.Unsafe
import Control.Concurrent.MVar
import qualified Control.Exception as Exception
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.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 =
(unlines $ replicate 3 "nothing",
unlines $ replicate 4 "ok")
-- 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,
linemode True,
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 <- Exception.try (getEnv envName)
return (case res of
Left (_ :: Exception.IOException) -> 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