graphviz 2999.17.0.1 → 2999.17.0.2
raw patch · 5 files changed
+116/−40 lines, 5 filesdep ~basedep ~containersdep ~directoryPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
Dependency ranges changed: base, containers, directory, filepath, polyparse, process, text
API changes (from Hackage documentation)
+ Data.GraphViz.Exception: CmdNotFound :: String -> GraphvizException
Files
- Data/GraphViz/Commands/IO.hs +49/−5
- Data/GraphViz/Exception.hs +2/−0
- graphviz.cabal +2/−2
- tests/Data/GraphViz/Testing.hs +47/−17
- tests/RunTests.hs +16/−16
Data/GraphViz/Commands/IO.hs view
@@ -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'
Data/GraphViz/Exception.hs view
@@ -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
graphviz.cabal view
@@ -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,
tests/Data/GraphViz/Testing.hs view
@@ -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
tests/RunTests.hs view
@@ -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 ++ " <key> 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