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

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

   This module defines the 'Arbitrary' instances for the various types
   used to represent Graphviz Dot code.

   Note that they do not generally generate /sensible/ values for the
   various types; in particular, there's no guarantee that the
   'Attributes' chosen for a particular value type are indeed legal
   for that type.
-}
module Data.GraphViz.Testing.Instances() where

import Data.GraphViz.Parsing(isNumString)

import Data.GraphViz.Attributes
import Data.GraphViz.Types
import Data.GraphViz.Types.Generalised

import Test.QuickCheck

import Data.Char(toLower)
import Data.List(nub)
import qualified Data.Sequence as Seq
import Control.Monad(liftM, liftM2, liftM3, liftM4, guard)
import Data.Word(Word8)

-- -----------------------------------------------------------------------------
-- Defining Arbitrary instances for the overall types

instance (Eq a, Arbitrary a) => Arbitrary (DotGraph a) where
  arbitrary = liftM4 DotGraph arbitrary arbitrary arbitrary arbitrary

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

instance Arbitrary GraphID where
  arbitrary = oneof [ liftM Str arbString
                    , liftM Int arbitrary
                    , liftM Dbl $ suchThat arbitrary notInt
                    , liftM HTML arbitrary
                    ]

  shrink (Str s) = map Str $ shrinkString s
  shrink (Int i) = map Int $ shrink i
  shrink (Dbl d) = map Dbl $ filter notInt $ shrink d
  shrink (HTML u) = map HTML $ shrink u

instance (Eq a, Arbitrary a) => Arbitrary (DotStatements a) where
  arbitrary = sized (arbDS True)

  shrink ds@(DotStmts gas sgs ns es) = do gas' <- shrinkL gas
                                          sgs' <- shrinkL sgs
                                          ns' <- shrinkL ns
                                          es' <- shrinkL es
                                          returnCheck ds
                                            $ DotStmts gas' sgs' ns' es'

-- | If 'True', generate 'DotSubGraph's; otherwise don't.
arbDS           :: (Arbitrary a, Eq a) => Bool -> Int -> Gen (DotStatements a)
arbDS haveSGs s = liftM4 DotStmts arbitrary genSGs arbitrary arbitrary
  where
    s' = min s 2
    genSGs = if haveSGs
             then resize s' arbitrary
             else return []

instance Arbitrary GlobalAttributes where
  arbitrary = oneof [ liftM GraphAttrs arbList
                    , liftM NodeAttrs  arbList
                    , liftM EdgeAttrs  arbList
                    ]

  shrink (GraphAttrs atts) = map GraphAttrs $ nonEmptyShrinks atts
  shrink (NodeAttrs  atts) = map NodeAttrs  $ nonEmptyShrinks atts
  shrink (EdgeAttrs  atts) = map EdgeAttrs  $ nonEmptyShrinks atts

instance (Eq a, Arbitrary a) => Arbitrary (DotSubGraph a) where
  arbitrary = liftM3 DotSG arbitrary arbitrary (sized $ arbDS False)

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

instance (Arbitrary a) => Arbitrary (DotNode a) where
  arbitrary = liftM2 DotNode arbitrary arbitrary

  shrink (DotNode n as) = map (DotNode n) $ shrinkList as

instance (Arbitrary a) => Arbitrary (DotEdge a) where
  arbitrary = liftM4 DotEdge arbitrary arbitrary arbitrary arbitrary

  shrink (DotEdge f t isDir as) = map (DotEdge f t isDir) $ shrinkList as

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

instance (Eq a, Arbitrary a) => Arbitrary (GDotGraph a) where
  arbitrary = liftM4 GDotGraph arbitrary arbitrary arbitrary genGDStmts

  shrink (GDotGraph str dir gid stmts) = map (GDotGraph str dir gid)
                                         $ shrinkGDStmts stmts

genGDStmts :: (Eq a, Arbitrary a) => Gen (GDotStatements a)
genGDStmts = sized (arbGDS True)

shrinkGDStmts :: (Eq a, Arbitrary a) => GDotStatements a -> [GDotStatements a]
shrinkGDStmts 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 (Eq a, Arbitrary a) => Arbitrary (GDotStatement a) where
  -- Don't want as many sub-graphs as nodes, etc.
  arbitrary = frequency [ (3, liftM GA arbitrary)
                        , (1, liftM SG arbitrary)
                        , (5, liftM DN arbitrary)
                        , (7, liftM DE arbitrary)
                        ]

  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.
arbGDS           :: (Arbitrary a, Eq a) => Bool -> Int -> Gen (GDotStatements a)
arbGDS haveSGs s = liftM (Seq.fromList . checkSGs) (resize s' arbList)
  where
    checkSGs = if haveSGs
               then id
               else filter notSG
    notSG SG{} = False
    notSG _    = True

    s' = min s 10


instance (Eq a, Arbitrary a) => Arbitrary (GDotSubGraph a) where
  arbitrary = liftM3 GDotSG arbitrary arbitrary (sized $ arbGDS False)

  shrink (GDotSG isCl mid stmts) = map (GDotSG isCl mid) $ shrinkGDStmts stmts

-- -----------------------------------------------------------------------------
-- Defining Arbitrary instances for Attributes

instance Arbitrary Attribute where
    arbitrary = oneof [ liftM Damping arbitrary
                      , liftM K arbitrary
                      , liftM URL arbitrary
                      , liftM ArrowHead arbitrary
                      , liftM ArrowSize arbitrary
                      , liftM ArrowTail arbitrary
                      , liftM Aspect arbitrary
                      , liftM Bb arbitrary
                      , liftM BgColor arbitrary
                      , liftM Center arbitrary
                      , liftM Charset arbString
                      , liftM ClusterRank arbitrary
                      , liftM ColorScheme arbitrary
                      , liftM Color arbList
                      , liftM Comment arbString
                      , liftM Compound arbitrary
                      , liftM Concentrate arbitrary
                      , liftM Constraint arbitrary
                      , liftM Decorate arbitrary
                      , liftM DefaultDist arbitrary
                      , liftM Dimen arbitrary
                      , liftM Dim arbitrary
                      , liftM Dir arbitrary
                      , liftM DirEdgeConstraints arbitrary
                      , liftM Distortion arbitrary
                      , liftM DPI arbitrary
                      , liftM EdgeURL arbitrary
                      , liftM EdgeTarget arbString
                      , liftM EdgeTooltip arbString
                      , liftM Epsilon arbitrary
                      , liftM ESep arbitrary
                      , liftM FillColor arbitrary
                      , liftM FixedSize arbitrary
                      , liftM FontColor arbitrary
                      , liftM FontName arbString
                      , liftM FontNames arbString
                      , liftM FontPath arbString
                      , liftM FontSize arbitrary
                      , liftM Group arbString
                      , liftM HeadURL arbitrary
                      , liftM HeadClip arbitrary
                      , liftM HeadLabel arbitrary
                      , liftM HeadPort arbitrary
                      , liftM HeadTarget arbString
                      , liftM HeadTooltip arbString
                      , liftM Height arbitrary
                      , liftM ID arbitrary
                      , liftM Image arbString
                      , liftM ImageScale arbitrary
                      , liftM LabelURL arbitrary
                      , liftM LabelAngle arbitrary
                      , liftM LabelDistance arbitrary
                      , liftM LabelFloat arbitrary
                      , liftM LabelFontColor arbitrary
                      , liftM LabelFontName arbString
                      , liftM LabelFontSize arbitrary
                      , liftM LabelJust arbitrary
                      , liftM LabelLoc arbitrary
                      , liftM LabelTarget arbString
                      , liftM LabelTooltip arbString
                      , liftM Label arbitrary
                      , liftM Landscape arbitrary
                      , liftM LayerSep arbString
                      , liftM Layers arbitrary
                      , liftM Layer arbitrary
                      , liftM Layout arbString
                      , liftM Len arbitrary
                      , liftM LevelsGap arbitrary
                      , liftM Levels arbitrary
                      , liftM LHead arbString
                      , liftM LPos arbitrary
                      , liftM LTail arbString
                      , liftM Margin arbitrary
                      , liftM MaxIter arbitrary
                      , liftM MCLimit arbitrary
                      , liftM MinDist arbitrary
                      , liftM MinLen arbitrary
                      , liftM Model arbitrary
                      , liftM Mode arbitrary
                      , liftM Mosek arbitrary
                      , liftM NodeSep arbitrary
                      , liftM NoJustify arbitrary
                      , liftM Normalize arbitrary
                      , liftM Nslimit1 arbitrary
                      , liftM Nslimit arbitrary
                      , liftM Ordering arbString
                      , liftM Orientation arbitrary
                      , liftM OutputOrder arbitrary
                      , liftM OverlapScaling arbitrary
                      , liftM Overlap arbitrary
                      , liftM PackMode arbitrary
                      , liftM Pack arbitrary
                      , liftM Pad arbitrary
                      , liftM PageDir arbitrary
                      , liftM Page arbitrary
                      , liftM PenColor arbitrary
                      , liftM PenWidth arbitrary
                      , liftM Peripheries arbitrary
                      , liftM Pin arbitrary
                      , liftM Pos arbitrary
                      , liftM QuadTree arbitrary
                      , liftM Quantum arbitrary
                      , liftM RankDir arbitrary
                      , liftM RankSep arbitrary
                      , liftM Rank arbitrary
                      , liftM Ratio arbitrary
                      , liftM Rects arbitrary
                      , liftM Regular arbitrary
                      , liftM ReMinCross arbitrary
                      , liftM RepulsiveForce arbitrary
                      , liftM Root arbitrary
                      , liftM Rotate arbitrary
                      , liftM SameHead arbString
                      , liftM SameTail arbString
                      , liftM SamplePoints arbitrary
                      , liftM SearchSize arbitrary
                      , liftM Sep arbitrary
                      , liftM ShapeFile arbString
                      , liftM Shape arbitrary
                      , liftM ShowBoxes arbitrary
                      , liftM Sides arbitrary
                      , liftM Size arbitrary
                      , liftM Skew arbitrary
                      , liftM Smoothing arbitrary
                      , liftM SortV arbitrary
                      , liftM Splines arbitrary
                      , liftM Start arbitrary
                      , liftM StyleSheet arbString
                      , liftM Style arbList
                      , liftM TailURL arbitrary
                      , liftM TailClip arbitrary
                      , liftM TailLabel arbitrary
                      , liftM TailPort arbitrary
                      , liftM TailTarget arbString
                      , liftM TailTooltip arbString
                      , liftM Target arbString
                      , liftM Tooltip arbString
                      , liftM TrueColor arbitrary
                      , liftM Vertices arbList
                      , liftM ViewPort arbitrary
                      , liftM VoroMargin arbitrary
                      , liftM Weight arbitrary
                      , liftM Width arbitrary
                      , liftM Z arbitrary
                      ]

    shrink (Damping v)            = map Damping            $ shrink v
    shrink (K v)                  = map K                  $ shrink v
    shrink (URL v)                = map URL                $ shrink v
    shrink (ArrowHead v)          = map ArrowHead          $ shrink v
    shrink (ArrowSize v)          = map ArrowSize          $ shrink v
    shrink (ArrowTail v)          = map ArrowTail          $ shrink v
    shrink (Aspect v)             = map Aspect             $ shrink v
    shrink (Bb v)                 = map Bb                 $ shrink v
    shrink (BgColor v)            = map BgColor            $ shrink v
    shrink (Center v)             = map Center             $ shrink v
    shrink (Charset v)            = map Charset            $ shrinkString v
    shrink (ClusterRank v)        = map ClusterRank        $ shrink v
    shrink (ColorScheme v)        = map ColorScheme        $ shrink v
    shrink (Color v)              = map Color              $ nonEmptyShrinks v
    shrink (Comment v)            = map Comment            $ shrinkString v
    shrink (Compound v)           = map Compound           $ shrink v
    shrink (Concentrate v)        = map Concentrate        $ shrink v
    shrink (Constraint v)         = map Constraint         $ shrink v
    shrink (Decorate v)           = map Decorate           $ shrink v
    shrink (DefaultDist v)        = map DefaultDist        $ shrink v
    shrink (Dimen v)              = map Dimen              $ shrink v
    shrink (Dim v)                = map Dim                $ shrink v
    shrink (Dir v)                = map Dir                $ shrink v
    shrink (DirEdgeConstraints v) = map DirEdgeConstraints $ shrink v
    shrink (Distortion v)         = map Distortion         $ shrink v
    shrink (DPI v)                = map DPI                $ shrink v
    shrink (EdgeURL v)            = map EdgeURL            $ shrink v
    shrink (EdgeTarget v)         = map EdgeTarget         $ shrinkString v
    shrink (EdgeTooltip v)        = map EdgeTooltip        $ shrinkString v
    shrink (Epsilon v)            = map Epsilon            $ shrink v
    shrink (ESep v)               = map ESep               $ shrink v
    shrink (FillColor v)          = map FillColor          $ shrink v
    shrink (FixedSize v)          = map FixedSize          $ shrink v
    shrink (FontColor v)          = map FontColor          $ shrink v
    shrink (FontName v)           = map FontName           $ shrinkString v
    shrink (FontNames v)          = map FontNames          $ shrinkString v
    shrink (FontPath v)           = map FontPath           $ shrinkString v
    shrink (FontSize v)           = map FontSize           $ shrink v
    shrink (Group v)              = map Group              $ shrinkString v
    shrink (HeadURL v)            = map HeadURL            $ shrink v
    shrink (HeadClip v)           = map HeadClip           $ shrink v
    shrink (HeadLabel v)          = map HeadLabel          $ shrink v
    shrink (HeadPort v)           = map HeadPort           $ shrink v
    shrink (HeadTarget v)         = map HeadTarget         $ shrinkString v
    shrink (HeadTooltip v)        = map HeadTooltip        $ shrinkString v
    shrink (Height v)             = map Height             $ shrink v
    shrink (ID v)                 = map ID                 $ shrink v
    shrink (Image v)              = map Image              $ shrinkString v
    shrink (ImageScale v)         = map ImageScale         $ shrink v
    shrink (LabelURL v)           = map LabelURL           $ shrink v
    shrink (LabelAngle v)         = map LabelAngle         $ shrink v
    shrink (LabelDistance v)      = map LabelDistance      $ shrink v
    shrink (LabelFloat v)         = map LabelFloat         $ shrink v
    shrink (LabelFontColor v)     = map LabelFontColor     $ shrink v
    shrink (LabelFontName v)      = map LabelFontName      $ shrinkString v
    shrink (LabelFontSize v)      = map LabelFontSize      $ shrink v
    shrink (LabelJust v)          = map LabelJust          $ shrink v
    shrink (LabelLoc v)           = map LabelLoc           $ shrink v
    shrink (LabelTarget v)        = map LabelTarget        $ shrinkString v
    shrink (LabelTooltip v)       = map LabelTooltip       $ shrinkString v
    shrink (Label v)              = map Label              $ shrink v
    shrink (Landscape v)          = map Landscape          $ shrink v
    shrink (LayerSep v)           = map LayerSep           $ shrinkString v
    shrink (Layers v)             = map Layers             $ shrink v
    shrink (Layer v)              = map Layer              $ shrink v
    shrink (Layout v)             = map Layout             $ shrinkString v
    shrink (Len v)                = map Len                $ shrink v
    shrink (LevelsGap v)          = map LevelsGap          $ shrink v
    shrink (Levels v)             = map Levels             $ shrink v
    shrink (LHead v)              = map LHead              $ shrinkString v
    shrink (LPos v)               = map LPos               $ shrink v
    shrink (LTail v)              = map LTail              $ shrinkString v
    shrink (Margin v)             = map Margin             $ shrink v
    shrink (MaxIter v)            = map MaxIter            $ shrink v
    shrink (MCLimit v)            = map MCLimit            $ shrink v
    shrink (MinDist v)            = map MinDist            $ shrink v
    shrink (MinLen v)             = map MinLen             $ shrink v
    shrink (Model v)              = map Model              $ shrink v
    shrink (Mode v)               = map Mode               $ shrink v
    shrink (Mosek v)              = map Mosek              $ shrink v
    shrink (NodeSep v)            = map NodeSep            $ shrink v
    shrink (NoJustify v)          = map NoJustify          $ shrink v
    shrink (Normalize v)          = map Normalize          $ shrink v
    shrink (Nslimit1 v)           = map Nslimit1           $ shrink v
    shrink (Nslimit v)            = map Nslimit            $ shrink v
    shrink (Ordering v)           = map Ordering           $ shrinkString v
    shrink (Orientation v)        = map Orientation        $ shrink v
    shrink (OutputOrder v)        = map OutputOrder        $ shrink v
    shrink (OverlapScaling v)     = map OverlapScaling     $ shrink v
    shrink (Overlap v)            = map Overlap            $ shrink v
    shrink (PackMode v)           = map PackMode           $ shrink v
    shrink (Pack v)               = map Pack               $ shrink v
    shrink (Pad v)                = map Pad                $ shrink v
    shrink (PageDir v)            = map PageDir            $ shrink v
    shrink (Page v)               = map Page               $ shrink v
    shrink (PenColor v)           = map PenColor           $ shrink v
    shrink (PenWidth v)           = map PenWidth           $ shrink v
    shrink (Peripheries v)        = map Peripheries        $ shrink v
    shrink (Pin v)                = map Pin                $ shrink v
    shrink (Pos v)                = map Pos                $ shrink v
    shrink (QuadTree v)           = map QuadTree           $ shrink v
    shrink (Quantum v)            = map Quantum            $ shrink v
    shrink (RankDir v)            = map RankDir            $ shrink v
    shrink (RankSep v)            = map RankSep            $ shrink v
    shrink (Rank v)               = map Rank               $ shrink v
    shrink (Ratio v)              = map Ratio              $ shrink v
    shrink (Rects v)              = map Rects              $ shrink v
    shrink (Regular v)            = map Regular            $ shrink v
    shrink (ReMinCross v)         = map ReMinCross         $ shrink v
    shrink (RepulsiveForce v)     = map RepulsiveForce     $ shrink v
    shrink (Root v)               = map Root               $ shrink v
    shrink (Rotate v)             = map Rotate             $ shrink v
    shrink (SameHead v)           = map SameHead           $ shrinkString v
    shrink (SameTail v)           = map SameTail           $ shrinkString v
    shrink (SamplePoints v)       = map SamplePoints       $ shrink v
    shrink (SearchSize v)         = map SearchSize         $ shrink v
    shrink (Sep v)                = map Sep                $ shrink v
    shrink (ShapeFile v)          = map ShapeFile          $ shrinkString v
    shrink (Shape v)              = map Shape              $ shrink v
    shrink (ShowBoxes v)          = map ShowBoxes          $ shrink v
    shrink (Sides v)              = map Sides              $ shrink v
    shrink (Size v)               = map Size               $ shrink v
    shrink (Skew v)               = map Skew               $ shrink v
    shrink (Smoothing v)          = map Smoothing          $ shrink v
    shrink (SortV v)              = map SortV              $ shrink v
    shrink (Splines v)            = map Splines            $ shrink v
    shrink (Start v)              = map Start              $ shrink v
    shrink (StyleSheet v)         = map StyleSheet         $ shrinkString v
    shrink (Style v)              = map Style              $ nonEmptyShrinks v
    shrink (TailURL v)            = map TailURL            $ shrink v
    shrink (TailClip v)           = map TailClip           $ shrink v
    shrink (TailLabel v)          = map TailLabel          $ shrink v
    shrink (TailPort v)           = map TailPort           $ shrink v
    shrink (TailTarget v)         = map TailTarget         $ shrinkString v
    shrink (TailTooltip v)        = map TailTooltip        $ shrinkString v
    shrink (Target v)             = map Target             $ shrinkString v
    shrink (Tooltip v)            = map Tooltip            $ shrinkString v
    shrink (TrueColor v)          = map TrueColor          $ shrink v
    shrink (Vertices v)           = map Vertices           $ nonEmptyShrinks v
    shrink (ViewPort v)           = map ViewPort           $ shrink v
    shrink (VoroMargin v)         = map VoroMargin         $ shrink v
    shrink (Weight v)             = map Weight             $ shrink v
    shrink (Width v)              = map Width              $ shrink v
    shrink (Z v)                  = map Z                  $ shrink v
{- delete to here -}

instance Arbitrary Word8 where
  arbitrary = arbitraryBoundedIntegral
  shrink = shrinkIntegral

instance Arbitrary URL where
  arbitrary = liftM UStr
              $ suchThat arbString (not . null)

  shrink (UStr ustr) = map UStr $ nonEmptyShrinks ustr

instance Arbitrary ArrowType where
  arbitrary = liftM AType
              -- Arrow specifications have between 1 and 4 elements.
              $ resize 4 arbList

  shrink (AType as) = map AType $ nonEmptyShrinks as

instance Arbitrary ArrowShape where
  arbitrary = arbBounded

instance Arbitrary ArrowModifier where
  arbitrary = liftM2 ArrMod arbitrary arbitrary

instance Arbitrary ArrowFill where
  arbitrary = arbBounded

instance Arbitrary ArrowSide where
  arbitrary = arbBounded

instance Arbitrary AspectType where
  arbitrary = oneof [ liftM  RatioOnly arbitrary
                    , liftM2 RatioPassCount arbitrary posArbitrary
                    ]

  shrink (RatioOnly d) = map RatioOnly $ shrink d
  shrink (RatioPassCount d i) = do ds <- shrink d
                                   is <- shrink i
                                   return $ RatioPassCount ds is

instance Arbitrary Rect where
  arbitrary = liftM2 Rect arbitrary arbitrary

  shrink (Rect p1 p2) = do p1s <- shrink p1
                           p2s <- shrink p2
                           return $ Rect p1s p2s

instance Arbitrary Point where
  -- Pretty sure points have to be positive...
  arbitrary = oneof [ liftM2 Point  posArbitrary posArbitrary
                    , liftM (uncurry PointD)
                      $ suchThat (liftM2 (,) posArbitrary posArbitrary)
                                 notBothInt
                    ]

  shrink (Point  v1 v2) = do v1s <- shrink v1
                             v2s <- shrink v2
                             return $ Point v1s v2s
  shrink (PointD v1 v2) = do v1s <- shrink v1
                             v2s <- shrink v2
                             guard $ notBothInt (v1s,v2s)
                             return $ PointD v1s v2s

instance Arbitrary ClusterMode where
  arbitrary = arbBounded

instance Arbitrary DirType where
  arbitrary = arbBounded

instance Arbitrary DEConstraints where
  arbitrary = arbBounded

instance Arbitrary DPoint where
  arbitrary = oneof [ liftM DVal arbitrary
                    , liftM PVal arbitrary
                    ]

  shrink (DVal d) = map DVal $ shrink d
  shrink (PVal p) = map PVal $ shrink p

instance Arbitrary ModeType where
  arbitrary = arbBounded

instance Arbitrary Model where
  arbitrary = arbBounded

instance Arbitrary Label where
  arbitrary = oneof [ liftM StrLabel arbString
                    , liftM URLLabel arbitrary
                    ]

  shrink (StrLabel str) = map StrLabel $ shrinkString str
  shrink (URLLabel url) = map URLLabel $ shrink url

instance Arbitrary Overlap where
  arbitrary = oneof [ simpleOverlap
                    , liftM PrismOverlap arbitrary
                    ]
    where
      -- Have to do this by hand since Overlap can't have Bounded and
      -- Enum instances
      simpleOverlap = elements [ KeepOverlaps
                               , RemoveOverlaps
                               , ScaleOverlaps
                               , ScaleXYOverlaps
                               , CompressOverlap
                               , VpscOverlap
                               , IpsepOverlap
                               ]

  shrink (PrismOverlap mi) = map PrismOverlap $ shrink mi
  shrink _                 = []

instance Arbitrary LayerList where
  arbitrary = do fs <- arbLayerName
                 oths <- listOf $ liftM2 (,) arbLayerSep arbLayerName
                 return $ LL fs oths

  -- This should be improved to try actually shrinking the seps and names.
  -- shrink (LL _ [(_,fs')]) = [LL fs' []]
  -- shrink (LL fs oths)     = map (LL fs) $ shrink oths

instance Arbitrary LayerRange where
  arbitrary = oneof [ liftM  LRID arbitrary
                    , liftM3 LRS arbitrary arbLayerSep arbitrary
                    ]

  shrink (LRID nm)     = map LRID $ shrink nm
  shrink (LRS l1 _ l2) = [LRID l1, LRID l2]

instance Arbitrary LayerID where
  arbitrary = oneof [ return AllLayers
                    , liftM LRInt arbitrary
                    , liftM LRName $ suchThat arbLayerName lrnameCheck
                    ]

  shrink AllLayers   = []
  shrink (LRInt i)   = map LRInt $ shrink i
  shrink (LRName nm) = map LRName
                       . filter lrnameCheck
                       $ shrinkString nm

lrnameCheck :: String -> Bool
lrnameCheck = (/=) "all"

instance Arbitrary OutputMode where
  arbitrary = arbBounded

instance Arbitrary Pack where
  arbitrary = oneof [ return DoPack
                    , return DontPack
                    , liftM PackMargin arbitrary
                    ]

  shrink (PackMargin m) = map PackMargin $ shrink m
  shrink _              = []

instance Arbitrary PackMode where
  arbitrary = oneof [ return PackNode
                    , return PackClust
                    , return PackGraph
                    , liftM3 PackArray arbitrary arbitrary arbitrary
                    ]

  shrink (PackArray c u mi) = map (PackArray c u) $ shrink mi
  shrink _                  = []

instance Arbitrary Pos where
  arbitrary = oneof [ liftM PointPos arbitrary
                      -- A single spline with only one point overall
                      -- is just a point...
                    , liftM SplinePos $ suchThat arbList validSplineList
                    ]
    where

  shrink (PointPos p)   = map PointPos $ shrink p
  shrink (SplinePos ss) = map SplinePos . filter validSplineList
                          $ nonEmptyShrinks ss

validSplineList                              :: [Spline] -> Bool
validSplineList [Spline Nothing Nothing [_]] = False
validSplineList _                            = True

instance Arbitrary Spline where
  arbitrary = liftM3 Spline arbitrary arbitrary
              -- list of points must have length of 1 mod 3
              $ suchThat arbitrary ((==) 1 . flip mod 3 . length)

  shrink (Spline Nothing Nothing [p]) = map (Spline Nothing Nothing . return)
                                        $ shrink p
  -- We're not going to be shrinking the points in the list; just
  -- making sure that its length is === 1 mod 3
  shrink (Spline ms me ps) = do mss <- shrinkM ms
                                mes <- shrinkM me
                                pss <- rem2 ps
                                return $ Spline mss mes pss
    where

      rem1 []     = []
      rem1 (a:as) = as : map (a:) (rem1 as)

      rem2 = nub . concatMap rem1 . rem1

instance Arbitrary EdgeType where
  arbitrary = arbBounded

instance Arbitrary PageDir where
  arbitrary = arbBounded

instance Arbitrary QuadType where
  arbitrary = arbBounded

instance Arbitrary Root where
  arbitrary = oneof [ return IsCentral
                    , return NotCentral
                    , liftM NodeName arbString
                    ]

  shrink (NodeName nm) = map NodeName $ shrinkString nm
  shrink _             = []

instance Arbitrary RankType where
  arbitrary = arbBounded

instance Arbitrary RankDir where
  arbitrary = arbBounded

instance Arbitrary Shape where
  arbitrary = arbBounded

instance Arbitrary SmoothType where
  arbitrary = arbBounded

instance Arbitrary StartType where
  arbitrary = oneof [ liftM  StartStyle arbitrary
                    , liftM  StartSeed arbitrary
                    , liftM2 StartStyleSeed arbitrary arbitrary
                    ]

  shrink StartStyle{} = [] -- No shrinks for STStyle
  shrink (StartSeed ss) = map StartSeed $ shrink ss
  shrink (StartStyleSeed st ss) = map (StartStyleSeed st) $ shrink ss

instance Arbitrary STStyle where
  arbitrary = arbBounded

instance Arbitrary StyleItem where
  arbitrary = liftM2 SItem arbitrary (listOf arbStyleName)

  -- Can't use this because of what shrink on the individual strings
  -- might do.
  -- shrink (SItem sn opts) = map (SItem sn) $ shrink opts

instance Arbitrary StyleName where
  arbitrary = oneof [ defaultStyles
                    , liftM DD $ suchThat arbStyleName notDefault
                    ]
    where
      defaultStyles = elements [ Dashed
                               , Dotted
                               , Bold
                               , Invisible
                               , Filled
                               , Diagonals
                               , Rounded
                               ]
      notDefault = flip notElem [ "dashed"
                                , "dotted"
                                , "solid"
                                , "bold"
                                , "invis"
                                , "filled"
                                , "diagonals"
                                , "rounded"
                                ]

instance Arbitrary PortPos where
  arbitrary = liftM PP arbitrary

instance Arbitrary CompassPoint where
  arbitrary = arbBounded

instance Arbitrary ViewPort where
  arbitrary = liftM4 VP arbitrary arbitrary arbitrary arbitrary

  shrink (VP w h z f) = case sVPs of
                          [_] -> []
                          _   -> sVPs
    where
      sVPs = do ws <- shrink w
                hs <- shrink h
                zs <- shrink z
                fs <- shrinkM f
                return $ VP ws hs zs fs

instance Arbitrary FocusType where
  arbitrary = oneof [ liftM XY arbitrary
                    , liftM NodeFocus $ suchThat arbString (all ((/=) ','))
                    ]

  shrink (XY p)          = map XY $ shrink p
  shrink (NodeFocus str) = map NodeFocus $ shrinkString str

instance Arbitrary VerticalPlacement where
  arbitrary = arbBounded

instance Arbitrary ScaleType where
  arbitrary = arbBounded

instance Arbitrary Justification where
  arbitrary = arbBounded

instance Arbitrary Ratios where
  arbitrary = oneof [ liftM AspectRatio posArbitrary
                    , namedRats
                    ]
    where
      namedRats = elements [ FillRatio
                           , CompressRatio
                           , ExpandRatio
                           , AutoRatio
                           ]

  shrink (AspectRatio r) = map (AspectRatio . fromPositive)
                           . shrink $ Positive r
  shrink _               = []

instance Arbitrary ColorScheme where
  arbitrary = oneof [ return X11
                    , liftM2 BrewerScheme arbitrary arbitrary
                    ]

  shrink (BrewerScheme nm v) = map (BrewerScheme nm) $ shrink v
  shrink _                   = []

instance Arbitrary BrewerName where
  arbitrary = arbBounded

instance Arbitrary Color where
  arbitrary = oneof [ liftM3 RGB  arbitrary arbitrary arbitrary
                    , liftM4 RGBA arbitrary arbitrary arbitrary arbitrary
                    , liftM3 HSV  zeroOne zeroOne zeroOne
                    , liftM X11Color arbitrary
                      -- Not quite right as the values can get too
                      -- high/low, but should suffice for
                      -- printing/parsing purposes.
                    , liftM BrewerColor arbitrary
                    ]
    where
      zeroOne = choose (0,1)

  shrink (RGB r g b)     = do rs <- shrink r
                              gs <- shrink g
                              bs <- shrink b
                              return $ RGB rs gs bs
  shrink (RGBA r g b a)  = RGB r g b
                           : do rs <- shrink r
                                gs <- shrink g
                                bs <- shrink b
                                as <- shrink a
                                return $ RGBA rs gs bs as
  shrink (BrewerColor c) = map BrewerColor $ shrink c
  shrink _               = [] -- Shrinking 0<=h,s,v<=1 does nothing

instance Arbitrary X11Color where
  arbitrary = arbBounded

-- -----------------------------------------------------------------------------
-- Helper Functions

fromPositive              :: Positive a -> a
fromPositive (Positive a) = a

posArbitrary :: (Arbitrary a, Num a, Ord a) => Gen a
posArbitrary = liftM fromPositive arbitrary

arbString :: Gen String
arbString = suchThat (liftM (map toLower) genStr) validString
  where
    genStr = listOf1 $ elements strChr
    strChr = ['a'..'z'] ++ ['0'..'9'] ++ ['\'', '"', ' ', '\t', '(', ')'
                                         , ',', ':', '.']
validString         :: String -> Bool
validString "true"  = False
validString "false" = False
validString str     = notNumStr str

shrinkString :: String -> [String]
shrinkString = filter validString . nonEmptyShrinks

notNumStr :: String -> Bool
notNumStr = not . isNumString

arbBounded :: (Bounded a, Enum a) => Gen a
arbBounded = elements [minBound .. maxBound]

arbLayerSep :: Gen [Char]
arbLayerSep = listOf1 (elements defLayerSep)

arbLayerName :: Gen String
arbLayerName = suchThat arbString (all notLayerSep)

arbStyleName :: Gen String
arbStyleName = suchThat arbString (all notBrackCom)
  where
    notBrackCom = flip notElem ['(', ')', ',', ' ']

arbList :: (Arbitrary a) => Gen [a]
arbList = listOf1 arbitrary

nonEmptyShrinks :: (Arbitrary a) => [a] -> [[a]]
nonEmptyShrinks = filter (not . null) . shrinkList

-- Shrink lists with more than one value only by removing values, not
-- by shrinking individual items.
shrinkList     :: (Arbitrary a) => [a] -> [[a]]
shrinkList [a] = map return $ shrink a
shrinkList as  = rm (length as) as
  where
    rm 0 _  = []
    rm 1 _  = [[]]
    rm n xs = xs1
            : xs2
            : ( [ xs1' ++ xs2 | xs1' <- rm n1 xs1, not (null xs1') ]
                `ilv` [ xs1 ++ xs2' | xs2' <- rm n2 xs2, not (null xs2') ]
              )
     where
      n1  = n `div` 2
      xs1 = take n1 xs
      n2  = n - n1
      xs2 = drop n1 xs

    []     `ilv` ys     = ys
    xs     `ilv` []     = xs
    (x:xs) `ilv` (y:ys) = x : y : (xs `ilv` ys)

-- When a Maybe value is a sub-component, and we need shrink to return
-- a value.
shrinkM         :: (Arbitrary a) => Maybe a -> [Maybe a]
shrinkM Nothing = [Nothing]
shrinkM j       = shrink j

shrinkL    :: (Arbitrary a) => [a] -> [[a]]
shrinkL xs = case shrinkList xs of
               []  -> [xs]
               xs' -> xs'

notInt   :: Double -> Bool
notInt d = fromIntegral (round d :: Int) /= d

notBothInt         :: (Double, Double) -> Bool
notBothInt (p1,p2) = notInt p1 && notInt p2

returnCheck     :: (Eq a) => a -> a -> [a]
returnCheck o n = if o == n
                  then []
                  else [n]