File: FGL.hs

package info (click to toggle)
haskell-graphviz 2999.17.0.1-1
  • links: PTS, VCS
  • area: main
  • in suites: jessie, jessie-kfreebsd
  • size: 1,488 kB
  • sloc: haskell: 12,152; makefile: 2
file content (47 lines) | stat: -rw-r--r-- 1,766 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances #-}

{- |
   Module      : Data.GraphViz.Testing.Instances.FGL
   Description : 'Arbitrary' instances for FGL graphs.
   Copyright   : (c) Ivan Lazar Miljenovic
   License     : 3-Clause BSD-style
   Maintainer  : Ivan.Miljenovic@gmail.com

   This module defines the 'Arbitrary' instances for FGL 'DynGraph'
   graphs.  Note that this instance cannot be in
   "Data.GraphViz.Testing.Instances", as this instance requires the
   FlexibleInstances extension, which makes some of the other
   'Arbitrary' instances fail to type-check.
-}
module Data.GraphViz.Testing.Instances.FGL() where

import Test.QuickCheck

import Data.GraphViz.Internal.Util (uniq)

import Control.Monad              (liftM, liftM3)
import Data.Function              (on)
import Data.Graph.Inductive.Graph (Graph, delNode, mkGraph, nodes)
import Data.List                  (sortBy)

-- -----------------------------------------------------------------------------
-- Arbitrary instance for FGL graphs.

instance (Graph g, Arbitrary n, Arbitrary e) => Arbitrary (g n e) where
  arbitrary = do ns <- suchThat genNs (not . null)
                 let nGen = elements ns
                 lns <- mapM makeLNode ns
                 les <- liftM (sortBy (compare `on` toE)) . listOf
                        $ makeLEdge nGen
                 return $ mkGraph lns les
    where
      genNs = liftM uniq arbitrary
      toE (f,t,_) = (f,t)
      makeLNode n = liftM ((,) n) arbitrary
      makeLEdge nGen = liftM3 (,,) nGen nGen arbitrary

  shrink gr = case nodes gr of
                   -- Need to have at least 2 nodes before we delete one!
                   ns@(_:_:_) -> map (`delNode` gr) ns
                   _          -> []