Testing.hs

{-# LANGUAGE Rank2Types, FlexibleContexts #-}

{- |
   Module      : Data.GraphViz.Testing
   Description : Test-suite for graphviz.
   Copyright   : (c) Ivan Lazar Miljenovic
   License     : 3-Clause BSD-style
   Maintainer  : Ivan.Miljenovic@gmail.com

   This defines a test-suite for the graphviz library.

   Limitations of the test suite are as follows:

   * For the most part, this library lets you use arbitrary numbers
     for String values.  However, this is not tested due to too many
     corner cases for special parsers that don't take arbitrary
     Strings.  As the Dot standard is ambiguous over whether you can
     or can't use numbers as Strings (more specifically, if they
     should be quoted or not), this is a user beware situation.

   * Same goes for empty Strings; sometimes they're allowed, sometimes
     they're not.  Thus, to simplify matters they're not generated.

   * The generated Strings are very simple, only composed of lower
     case letters, digits and some symbols.  This is because too many
     tests were \"failing\" due to some corner case; e.g. lower-case
     letters only because the parser parses Strings as lowercase, so
     if a particular String isn't valid (e.g. @\"all\"@ for 'LayerID',
     then the 'Arbitrary' instance has to ensure that all possible
     ways of capitalising that String isn't generated as a random
     'LRName'.

   * The generated 'DotRepr's are not guaranteed to be valid.

   * To avoid needless endless recursion, sub-graphs do not have their
     own internal sub-graphs.

   * This test suite isn't perfect: if you deliberately try to stuff
     something up, you probably can.
-}
module Data.GraphViz.Testing
       ( -- * Running the test suite.
         runChosenTests
       , runTests
       , runTest
         -- ** The tests themselves
       , Test(..)
       , defaultTests
       , test_printParseID_Attributes
       , test_generalisedSameDot
       , test_printParseID
       , test_preProcessingID
       , test_dotizeAugment
       , test_dotizeAugmentUniq
       , test_canonicalise
       , test_transitive
        -- * Re-exporting modules for manual testing.
       , module Data.GraphViz
       , module Data.GraphViz.Testing.Properties
         -- * Debugging printing
       , PrintDot(..)
       , printIt
       , renderDot
         -- * Debugging parsing
       , ParseDot(..)
       , parseIt
       , parseIt'
       , runParser
       , preProcess
       ) where

import Test.QuickCheck

import Data.GraphViz.Testing.Instances()
import Data.GraphViz.Testing.Properties

import Data.GraphViz
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
-- Can't use PatriciaTree because a Show instance is needed.
import Data.Graph.Inductive.Tree(Gr)

import System.Exit(ExitCode(..), exitWith)
import System.IO(hPutStrLn, stderr)

-- -----------------------------------------------------------------------------

runChosenTests       :: [Test] -> IO ()
runChosenTests tsts = do putStrLn msg
                         blankLn
                         runTests tsts
                         spacerLn
                         putStrLn successMsg
  where
    msg = "This is the test suite for the graphviz library.\n\
           \If any of these tests fail, please inform the maintainer,\n\
           \including full output of this test suite."

    successMsg = "All tests were successful!"


-- -----------------------------------------------------------------------------
-- Defining a Test structure and how to run tests.

-- | Defines the test structure being used.
data Test = Test { name       :: String
                 , lookupName :: String      -- ^ Should be lowercase
                 , desc       :: String
                 , tests      :: [IO Result] -- ^ QuickCheck test.
                 }

-- | Run all of the provided tests.
runTests :: [Test] -> IO ()
runTests = mapM_ ((>>) spacerLn . runTest)

-- | Run the provided test.
runTest     :: Test -> IO ()
runTest tst = do putStrLn title
                 blankLn
                 putStrLn $ desc tst
                 blankLn
                 run $ tests tst
                 blankLn
  where
    nm = '"' : name tst ++ "\""
    title = "Running test: " ++ nm ++ "."
    successMsg = "All tests for " ++ nm ++ " were successful!"
    gaveUpMsg = "Too many sample inputs for " ++ nm ++ " were rejected;\n\
                 \tentatively marking this as successful."
    failMsg = "The tests for " ++ nm ++ " failed!\n\
               \Not attempting any further tests."

    run [] = putStrLn successMsg
    run (t:ts) = do r <- t
                    case r of
                       Success{} -> run ts
                       GaveUp{}  -> putStrLn gaveUpMsg >> run ts
                       _         -> die failMsg

spacerLn :: IO ()
spacerLn = putStrLn (replicate 70 '=') >> blankLn

blankLn :: IO ()
blankLn = putStrLn ""

die     :: String -> IO a
die msg = do hPutStrLn stderr msg
             exitWith (ExitFailure 1)

qCheck :: (Testable prop) => prop -> IO Result
qCheck = quickCheckWithResult (stdArgs { maxSize = 50, maxSuccess = 200 })

-- -----------------------------------------------------------------------------
-- Defining the tests to use.

-- | The tests to run by default.
defaultTests :: [Test]
defaultTests = [ 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_transitive
               ]

-- | Test that 'Attributes' can be printed and then parsed back.
test_printParseID_Attributes :: Test
test_printParseID_Attributes
  = Test { name       = "Printing and parsing of Attributes"
         , lookupName = "attributes"
         , desc       = dsc
         , tests      = [qCheck prop]
         }
  where
    prop :: Attributes -> Property
    prop = prop_printParseListID

    dsc = "The most common source of errors in printing and parsing are for\n\
          \Attributes."

test_generalisedSameDot :: Test
test_generalisedSameDot
  = Test { name       = "Printing generalised Dot code"
         , lookupName = "makegeneralised"
         , desc       = dsc
         , tests      = [qCheck prop]
         }
    where
      prop :: DotGraph Int -> Bool
      prop = prop_generalisedSameDot

      dsc = "When generalising \"DotGraph\" values to other \"DotRepr\" values,\n\
             \the generated Dot code should be identical."

test_printParseID :: Test
test_printParseID
  = Test { name       = "Printing and Parsing DotReprs"
         , lookupName = "printparseid"
         , desc       = dsc
         , tests      = tsts
         }
  where
    tsts :: [IO Result]
    tsts = [ qCheck (prop_printParseID :: DotGraph    Int -> Bool)
           , qCheck (prop_printParseID :: G.DotGraph  Int -> Bool)
           , qCheck (prop_printParseID :: Gr.DotGraph Int -> Bool)
           ]

    dsc = "The graphviz library should be able to parse back in its own\n\
           \generated Dot code for any \"DotRepr\" instance"

test_preProcessingID :: Test
test_preProcessingID
  = Test { name       = "Pre-processing Dot code"
         , lookupName = "preprocessing"
         , desc       = dsc
         , tests      = [qCheck prop]
         }
  where
    prop :: DotGraph Int -> Bool
    prop = prop_preProcessingID

    dsc = "When parsing Dot code, some pre-processing is done to remove items\n\
           \such as comments and to join together multi-line strings.  This\n\
           \test verifies that this pre-processing doesn't affect actual\n\
           \Dot code by running the pre-processor on generated Dot code.\n\n\
           \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."

test_dotizeAugment :: Test
test_dotizeAugment
  = Test { name       = "Augmenting FGL Graphs"
         , lookupName = "augment"
         , desc       = dsc
         , tests      = [qCheck prop]
         }
  where
    prop :: Gr Char Double -> Bool
    prop = prop_dotizeAugment

    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."

test_dotizeHasAugment :: Test
test_dotizeHasAugment
  = Test { name       = "Ensuring augmentation of FGL Graphs"
         , lookupName = "hasaugment"
         , desc       = dsc
         , tests      = [qCheck prop]
         }
  where
    prop :: Gr Char Double -> Bool
    prop = prop_dotizeHasAugment

    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."

test_dotizeAugmentUniq :: Test
test_dotizeAugmentUniq
  = Test { name       = "Unique edges in augmented FGL Graphs"
         , lookupName = "augmentuniq"
         , desc       = dsc
         , tests      = [qCheck prop]
         }
  where
    prop :: Gr Char Double -> Bool
    prop = prop_dotizeAugmentUniq

    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."

test_findAllNodes :: Test
test_findAllNodes
  = Test { name       = "Ensure all nodes are found in a DotRepr"
         , lookupName = "findnodes"
         , desc       = dsc
         , tests      = map qCheck props
         }
  where
    props :: [Gr () () -> Bool]
    props = testAllGraphTypes prop_findAllNodes

    dsc = "nodeInformation should find all nodes in a DotRepr;\n\
           \this is tested by converting an FGL graph and comparing\n\
           \the nodes it should have to those that are found."

test_findAllNodesE :: Test
test_findAllNodesE
  = Test { name       = "Ensure all nodes are found in a node-less DotRepr"
         , lookupName = "findedgelessnodes"
         , desc       = dsc
         , tests      = map qCheck props
         }
  where
    props :: [Gr () () -> Bool]
    props = testAllGraphTypes prop_findAllNodesE

    dsc = "nodeInformation should find all nodes in a DotRepr,\n\
           \even if there are no explicit nodes in that graph.\n\
           \This is tested by converting an FGL graph and comparing\n\
           \the nodes it should have to those that are found."

test_findAllEdges :: Test
test_findAllEdges
  = Test { name       = "Ensure all edges are found in a DotRepr"
         , lookupName = "findedges"
         , desc       = dsc
         , tests      = map qCheck props
         }
  where
    props :: [Gr () () -> Bool]
    props = testAllGraphTypes prop_findAllEdges

    dsc = "nodeInformation should find all edges in a DotRepr;\n\
           \this is tested by converting an FGL graph and comparing\n\
           \the edges it should have to those that are found."

test_noGraphInfo :: Test
test_noGraphInfo
  = Test { name       = "Plain DotReprs should have no structural information"
         , lookupName = "nographinfo"
         , desc       = dsc
         , tests      = map qCheck props
         }
  where
    props :: [Gr () () -> Bool]
    props = testAllGraphTypes prop_noGraphInfo

    dsc = "When converting a Graph to a DotRepr, there should be no\n\
           \clusters or global attributes."

test_canonicalise :: Test
test_canonicalise
  = Test { name       = "Canonicalisation should be idempotent"
         , lookupName = "canonicalise"
         , desc       = dsc
         , tests      = [qCheck prop]
         }
  where
    prop :: DotGraph Int -> Bool
    prop = prop_canonicalise

    dsc = "Repeated application of canonicalise shouldn't have any further affect."

test_transitive :: Test
test_transitive
  = Test { name       = "Transitive reduction should be idempotent"
         , lookupName = "transitive"
         , desc       = dsc
         , tests      = [qCheck prop]
         }
  where
    prop :: DotGraph Int -> Bool
    prop = prop_transitive

    dsc = "Repeated application of transitiveReduction shouldn't have any further affect."

-- -----------------------------------------------------------------------------

-- | Used when a property takes in a DotRepr as the first argument to
--   indicate which instance it should test via 'fromCanonical'.
testAllGraphTypes      :: (Testable prop)
                          => (forall dg. (Eq (dg Int), DotRepr dg Int) => dg Int -> prop)
                          -> [prop]
testAllGraphTypes prop = [ prop (undefined :: DotGraph Int)
                         , prop (undefined :: G.DotGraph Int)
                         , prop (undefined :: Gr.DotGraph Int)
                         ]