diff --git a/Data/GraphViz/Commands/IO.hs b/Data/GraphViz/Commands/IO.hs --- a/Data/GraphViz/Commands/IO.hs +++ b/Data/GraphViz/Commands/IO.hs @@ -38,7 +38,7 @@ import Control.Concurrent (MVar, forkIO, newEmptyMVar, putMVar, takeMVar) import Control.Exception (IOException, evaluate, finally) -import Control.Monad (liftM) +import Control.Monad (liftM, unless) import Control.Monad.Trans.State import qualified Data.ByteString as SB import Data.ByteString.Lazy (ByteString) @@ -46,8 +46,11 @@ import Data.Text.Encoding.Error (UnicodeException) import Data.Text.Lazy (Text) import qualified Data.Text.Lazy.Encoding as T +import System.Directory (canonicalizePath, doesFileExist, + executable, findExecutable, + getHomeDirectory, getPermissions) import System.Exit (ExitCode (ExitSuccess)) -import System.FilePath ((<.>)) +import System.FilePath (joinPath, splitDirectories, (<.>)) import System.IO (Handle, IOMode (ReadMode, WriteMode), hClose, hGetContents, hPutChar, @@ -152,9 +155,12 @@ -> (Handle -> IO a) -- ^ Obtaining the output; should be strict. -> dg n -> IO a -runCommand cmd args hf dg - = mapException notRunnable $ - withSystemTempFile ("graphviz" <.> "dot") $ \dotFile dotHandle -> do +runCommand cmd args hf dg = do + isEx <- isExecutable cmd + unless isEx (throw $ CmdNotFound cmd) + + mapException notRunnable $ + withSystemTempFile ("graphviz" <.> "gv") $ \dotFile dotHandle -> do finally (hPutCompactDot dotHandle dg) (hClose dotHandle) bracket (runInteractiveProcess cmd (args ++ [dotFile]) Nothing Nothing) @@ -214,3 +220,41 @@ -- | Store the result of the 'Handle' consumption into the 'MVar'. signalWhenDone :: (Handle -> IO a) -> Handle -> MVar a -> IO () signalWhenDone f h mv = f h >>= putMVar mv >> return () + +canonicalizeExecutable :: String -> IO (Maybe FilePath) +canonicalizeExecutable cmd = liftMaybePlus (findExecutable cmd) checkPath + where + -- Check to see if it's an explicitly listed command + checkPath = handle noSuchFile $ + do fp <- canonicalizePath' cmd + prm <- getPermissions fp + if executable prm + then return (Just fp) + else return Nothing + + noSuchFile :: IOException -> IO (Maybe FilePath) + noSuchFile = const (return Nothing) + +isExecutable :: FilePath -> IO Bool +isExecutable cmd = findExecutable cmd >>= maybe checkPath (const (return True)) + where + -- Check to see if it's an explicitly listed command + checkPath = handle noSuchFile $ + do fp <- canonicalizePath' cmd + ex <- doesFileExist fp + if ex + then executable `fmap` getPermissions fp + else return False + + noSuchFile :: IOException -> IO Bool + noSuchFile = const (return False) + +liftMaybePlus :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a) +liftMaybePlus mm1 mm2 = mm1 >>= maybe mm2 (return . Just) + +canonicalizePath' :: FilePath -> IO FilePath +canonicalizePath' fp = do fp' <- case splitDirectories fp of + "~":ds -> do hd <- getHomeDirectory + return (joinPath (hd:ds)) + _ -> return fp + canonicalizePath fp' diff --git a/Data/GraphViz/Exception.hs b/Data/GraphViz/Exception.hs --- a/Data/GraphViz/Exception.hs +++ b/Data/GraphViz/Exception.hs @@ -35,6 +35,7 @@ | NotUTF8Dot String | GVProgramExc String | NotCustomAttr String + | CmdNotFound String deriving (Eq, Ord, Typeable) instance Show GraphvizException where @@ -42,5 +43,6 @@ showsPrec _ (NotUTF8Dot str) = showString $ "Invalid UTF-8 Dot code: " ++ str showsPrec _ (GVProgramExc str) = showString $ "Error running utility program: " ++ str showsPrec _ (NotCustomAttr str) = showString $ "Not a custom Attribute: " ++ str + showsPrec _ (CmdNotFound str) = showString $ "Command not found: " ++ str instance Exception GraphvizException diff --git a/graphviz.cabal b/graphviz.cabal --- a/graphviz.cabal +++ b/graphviz.cabal @@ -1,5 +1,5 @@ Name: graphviz -Version: 2999.17.0.1 +Version: 2999.17.0.2 Stability: Beta Synopsis: Bindings to Graphviz for graph visualisation. Description: { @@ -64,7 +64,7 @@ temporary >=1.1 && <1.3, fgl >= 5.4 && < 5.6, filepath, - polyparse == 1.9.*, + polyparse >=1.9 && <1.12, bytestring >= 0.9 && < 0.11, colour == 2.3.*, transformers >= 0.2 && < 0.5, diff --git a/tests/Data/GraphViz/Testing.hs b/tests/Data/GraphViz/Testing.hs --- a/tests/Data/GraphViz/Testing.hs +++ b/tests/Data/GraphViz/Testing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE Rank2Types, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, Rank2Types #-} {- | Module : Data.GraphViz.Testing @@ -46,11 +46,13 @@ -- ** The tests themselves , Test(..) , defaultTests + , allTests , test_printParseID_Attributes , test_generalisedSameDot , test_printParseID , test_preProcessingID , test_dotizeAugment + , test_dotizeHasAugment , test_dotizeAugmentUniq , test_canonicalise , test_canonicaliseNodes @@ -74,21 +76,21 @@ import Test.QuickCheck -import Data.GraphViz.Testing.Instances() +import Data.GraphViz.Testing.Instances () import Data.GraphViz.Testing.Properties -import Data.GraphViz -import Data.GraphViz.Algorithms(CanonicaliseOptions) -import Data.GraphViz.Parsing(parseIt, parseIt', runParser) -import Data.GraphViz.PreProcessing(preProcess) -import Data.GraphViz.Printing(printIt, renderDot) +import Data.GraphViz +import Data.GraphViz.Algorithms (CanonicaliseOptions) +import Data.GraphViz.Parsing (parseIt, parseIt', runParser) +import Data.GraphViz.PreProcessing (preProcess) +import Data.GraphViz.Printing (printIt, renderDot) import qualified Data.GraphViz.Types.Generalised as G -import qualified Data.GraphViz.Types.Graph as Gr +import qualified Data.GraphViz.Types.Graph as Gr -- Can't use PatriciaTree because a Show instance is needed. -import Data.Graph.Inductive.Tree(Gr) +import Data.Graph.Inductive.Tree (Gr) -import System.Exit(ExitCode(..), exitWith) -import System.IO(hPutStrLn, stderr) +import System.Exit (ExitCode (..), exitWith) +import System.IO (hPutStrLn, stderr) -- ----------------------------------------------------------------------------- @@ -166,9 +168,13 @@ , test_generalisedSameDot , test_printParseID , test_preProcessingID - , test_dotizeAugment - , test_dotizeHasAugment - , test_dotizeAugmentUniq + -- These require dot and neato to be installed and + -- configured properly. As such, don't run them by + -- default. + + -- , test_dotizeAugment + -- , test_dotizeHasAugment + -- , test_dotizeAugmentUniq , test_findAllNodes , test_findAllNodesE , test_findAllEdges @@ -180,6 +186,26 @@ , test_transitiveNodes ] +-- | All available tests. +allTests :: [Test] +allTests = [ test_printParseID_Attributes + , test_generalisedSameDot + , test_printParseID + , test_preProcessingID + , test_dotizeAugment + , test_dotizeHasAugment + , test_dotizeAugmentUniq + , test_findAllNodes + , test_findAllNodesE + , test_findAllEdges + , test_noGraphInfo + , test_canonicalise + , test_canonicaliseNodes + , test_canonicaliseEdges + , test_transitive + , test_transitiveNodes + ] + -- | Test that 'Attributes' can be printed and then parsed back. test_printParseID_Attributes :: Test test_printParseID_Attributes @@ -244,6 +270,10 @@ \This test is not run on generalised Dot graphs as if it works for\n\ \normal dot graphs then it should also work for generalised ones." +augMsg :: String +augMsg = "\n\nThis requires dot and neato to be installed, and for `dot' to be\n\ + \to be in the output of `dot -Txxx`." + test_dotizeAugment :: Test test_dotizeAugment = Test { name = "Augmenting FGL Graphs" @@ -258,7 +288,7 @@ dsc = "The various Graph to Graph functions in Data.GraphViz should\n\ \only _augment_ the graph labels and not change the graphs\n\ \themselves. This test compares the original graphs to these\n\ - \augmented graphs and verifies that they are the same." + \augmented graphs and verifies that they are the same." ++ augMsg test_dotizeHasAugment :: Test test_dotizeHasAugment @@ -273,7 +303,7 @@ dsc = "The various Graph to Graph functions in Data.GraphViz should\n\ \actually agument the graph labels; this ensures that all labels\n\ - \actually have attached Attributes after augmentation." + \actually have attached Attributes after augmentation." ++ augMsg test_dotizeAugmentUniq :: Test test_dotizeAugmentUniq @@ -289,7 +319,7 @@ dsc = "When augmenting a graph with multiple edges, as long as no\n\ \Attributes are provided that override the default settings,\n\ \then each edge between two nodes should have a unique position\n\ - \Attribute, etc." + \Attribute, etc." ++ augMsg test_findAllNodes :: Test test_findAllNodes diff --git a/tests/RunTests.hs b/tests/RunTests.hs --- a/tests/RunTests.hs +++ b/tests/RunTests.hs @@ -10,27 +10,27 @@ -} module Main where -import Data.GraphViz.Testing( Test(name, lookupName) - , defaultTests, runChosenTests) +import Data.GraphViz.Testing (Test (name, lookupName), allTests, defaultTests, + runChosenTests) -import Data.Char(toLower) -import Data.Maybe(mapMaybe) -import qualified Data.Map as Map -import Data.Map(Map) -import Control.Arrow((&&&)) -import Control.Monad(when) -import System.Environment(getArgs, getProgName) -import System.Exit(ExitCode(ExitSuccess), exitWith) +import Control.Arrow ((&&&)) +import Control.Monad (when) +import Data.Char (toLower) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (mapMaybe) +import System.Environment (getArgs, getProgName) +import System.Exit (exitSuccess) -- ----------------------------------------------------------------------------- main :: IO () main = do opts <- getArgs let opts' = map (map toLower) opts - hasArg arg = any (arg==) opts' + hasArg arg = arg `elem` opts' when (hasArg "help") helpMsg let tests = if hasArg "all" - then defaultTests + then allTests else mapMaybe getTest opts' tests' = if null tests then defaultTests @@ -39,20 +39,20 @@ testLookup :: Map String Test testLookup = Map.fromList - $ map (lookupName &&& id) defaultTests + $ map (lookupName &&& id) allTests getTest :: String -> Maybe Test getTest = (`Map.lookup` testLookup) helpMsg :: IO () -helpMsg = getProgName >>= (putStr . msg) >> exitWith ExitSuccess +helpMsg = getProgName >>= (putStr . msg) >> exitSuccess where msg nm = unlines [ "This utility is the test-suite for the graphviz library for Haskell." , "Various tests are available; see the table below for a complete list." , "There are several ways of running this program:" , "" - , " " ++ nm ++ " Run all of the tests" + , " " ++ nm ++ " Run the default set of tests" , " " ++ nm ++ " all Run all of the tests" , " " ++ nm ++ " help Get this help message" , " " ++ nm ++ " Run the test associated with each key," @@ -68,7 +68,7 @@ : map fmtName testNames where andLen = ((id &&& length) .) - testNames = map (andLen lookupName &&& andLen name) defaultTests + testNames = map (andLen lookupName &&& andLen name) allTests fmtName ((ln,lnl),(n,_)) = concat [ ln , replicate (maxLN-lnl+spacerLen) ' ' , n