Generalised.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}

{- |
   Module      : Data.GraphViz.Testing.Instances.Generalised
   Description : Generalised dot graph instances for Arbitrary.
   Copyright   : (c) Ivan Lazar Miljenovic
   License     : 3-Clause BSD-style
   Maintainer  : Ivan.Miljenovic@gmail.com
 -}
module Data.GraphViz.Testing.Instances.Generalised where

import Data.GraphViz.Testing.Instances.Attributes()
import Data.GraphViz.Testing.Instances.Common
import Data.GraphViz.Testing.Instances.Helpers()

import Data.GraphViz.Types.Generalised
import Data.GraphViz.Util(bool)

import Test.QuickCheck

import qualified Data.Sequence as Seq
import Control.Monad(liftM, liftM2, liftM4)

-- -----------------------------------------------------------------------------
-- Defining Arbitrary instances for the generalised types

instance (Arbitrary n) => Arbitrary (DotGraph n) where
  arbitrary = liftM4 DotGraph arbitrary arbitrary arbitrary genDStmts

  shrink (DotGraph str dir gid stmts) = map (DotGraph str dir gid)
                                          $ shrinkDStmts stmts

genDStmts :: (Arbitrary n) => Gen (DotStatements n)
genDStmts = sized (arbDS gaGraph True)

genDStmt :: (Arbitrary n) => Gen GlobalAttributes -> Bool
            -> Gen (DotStatement n)
genDStmt ga haveSGs = frequency
                      . bool id ((1,genSG):) haveSGs
                      $ [ (3, liftM GA ga)
                        , (5, liftM DN arbitrary)
                        , (7, liftM DE arbitrary)
                        ]
  where
    genSG = liftM SG arbitrary

shrinkDStmts :: (Arbitrary n) => DotStatements n -> [DotStatements n]
shrinkDStmts gds
  | len == 1  = map Seq.singleton . shrink $ Seq.index gds 0
  | otherwise = [gds1, gds2]
    where
      len = Seq.length gds
      -- Halve the sequence
      (gds1, gds2) = (len `div` 2) `Seq.splitAt` gds

instance (Arbitrary n) => Arbitrary (DotStatement n) where
  arbitrary = genDStmt gaGraph True

  shrink (GA ga) = map GA $ shrink ga
  shrink (SG sg) = map SG $ shrink sg
  shrink (DN dn) = map DN $ shrink dn
  shrink (DE de) = map DE $ shrink de

-- | If 'True', generate 'GDotSubGraph's; otherwise don't.
arbDS              :: (Arbitrary n) => Gen GlobalAttributes -> Bool -> Int -> Gen (DotStatements n)
arbDS ga haveSGs s = liftM Seq.fromList . resize s' . listOf $ genDStmt ga haveSGs
  where
    s' = min s 10


instance (Arbitrary n) => Arbitrary (DotSubGraph n) where
  arbitrary = do isClust <- arbitrary
                 let ga = bool gaSubGraph gaClusters isClust
                 liftM2 (DotSG isClust) arbitrary (sized $ arbDS ga False)

  shrink (DotSG isCl mid stmts) = map (DotSG isCl mid) $ shrinkDStmts stmts