graphviz-2999.10.0.1: Data/GraphViz/Testing/Instances.hs
{-# 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.Attributes.Internal(compassLookup)
import Data.GraphViz.Types
import Data.GraphViz.Types.Generalised
import Data.GraphViz.Util(bool)
import Test.QuickCheck
import Data.List(nub, delete, groupBy)
import qualified Data.Sequence as Seq
import qualified Data.Map as Map
import Control.Monad(liftM, liftM2, liftM3, liftM4)
import Data.Word(Word8, Word16)
-- -----------------------------------------------------------------------------
-- 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
]
shrink (Str s) = map Str $ shrinkString s
shrink (Int i) = map Int $ shrink i
shrink (Dbl d) = map Dbl $ filter notInt $ shrink d
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 arbString
, 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 arbString
, 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 arbString
, 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 arbString
, 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 arbList
, 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 arbString
, 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
, liftM2 UnknownAttribute (suchThat arbIDString validUnknown) arbString
]
shrink (Damping v) = map Damping $ shrink v
shrink (K v) = map K $ shrink v
shrink (URL v) = map URL $ shrinkString 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 $ shrinkString 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 $ shrinkString 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 $ shrinkString 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 $ nonEmptyShrinks 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 $ shrinkString 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
shrink (UnknownAttribute a v) = liftM2 UnknownAttribute (liftM (filter validUnknown) shrinkString a) (shrinkString v)
validUnknown :: String -> Bool
validUnknown "Damping" = False
validUnknown "K" = False
validUnknown "URL" = False
validUnknown "href" = False
validUnknown "arrowhead" = False
validUnknown "arrowsize" = False
validUnknown "arrowtail" = False
validUnknown "aspect" = False
validUnknown "bb" = False
validUnknown "bgcolor" = False
validUnknown "center" = False
validUnknown "charset" = False
validUnknown "clusterrank" = False
validUnknown "colorscheme" = False
validUnknown "color" = False
validUnknown "comment" = False
validUnknown "compound" = False
validUnknown "concentrate" = False
validUnknown "constraint" = False
validUnknown "decorate" = False
validUnknown "defaultdist" = False
validUnknown "dimen" = False
validUnknown "dim" = False
validUnknown "dir" = False
validUnknown "diredgeconstraints" = False
validUnknown "distortion" = False
validUnknown "dpi" = False
validUnknown "resolution" = False
validUnknown "edgeURL" = False
validUnknown "edgehref" = False
validUnknown "edgetarget" = False
validUnknown "edgetooltip" = False
validUnknown "epsilon" = False
validUnknown "esep" = False
validUnknown "fillcolor" = False
validUnknown "fixedsize" = False
validUnknown "fontcolor" = False
validUnknown "fontname" = False
validUnknown "fontnames" = False
validUnknown "fontpath" = False
validUnknown "fontsize" = False
validUnknown "group" = False
validUnknown "headURL" = False
validUnknown "headhref" = False
validUnknown "headclip" = False
validUnknown "headlabel" = False
validUnknown "headport" = False
validUnknown "headtarget" = False
validUnknown "headtooltip" = False
validUnknown "height" = False
validUnknown "id" = False
validUnknown "image" = False
validUnknown "imagescale" = False
validUnknown "labelURL" = False
validUnknown "labelhref" = False
validUnknown "labelangle" = False
validUnknown "labeldistance" = False
validUnknown "labelfloat" = False
validUnknown "labelfontcolor" = False
validUnknown "labelfontname" = False
validUnknown "labelfontsize" = False
validUnknown "labeljust" = False
validUnknown "labelloc" = False
validUnknown "labeltarget" = False
validUnknown "labeltooltip" = False
validUnknown "label" = False
validUnknown "landscape" = False
validUnknown "layersep" = False
validUnknown "layers" = False
validUnknown "layer" = False
validUnknown "layout" = False
validUnknown "len" = False
validUnknown "levelsgap" = False
validUnknown "levels" = False
validUnknown "lhead" = False
validUnknown "lp" = False
validUnknown "ltail" = False
validUnknown "margin" = False
validUnknown "maxiter" = False
validUnknown "mclimit" = False
validUnknown "mindist" = False
validUnknown "minlen" = False
validUnknown "model" = False
validUnknown "mode" = False
validUnknown "mosek" = False
validUnknown "nodesep" = False
validUnknown "nojustify" = False
validUnknown "normalize" = False
validUnknown "nslimit1" = False
validUnknown "nslimit" = False
validUnknown "ordering" = False
validUnknown "orientation" = False
validUnknown "outputorder" = False
validUnknown "overlap_scaling" = False
validUnknown "overlap" = False
validUnknown "packmode" = False
validUnknown "pack" = False
validUnknown "pad" = False
validUnknown "pagedir" = False
validUnknown "page" = False
validUnknown "pencolor" = False
validUnknown "penwidth" = False
validUnknown "peripheries" = False
validUnknown "pin" = False
validUnknown "pos" = False
validUnknown "quadtree" = False
validUnknown "quantum" = False
validUnknown "rankdir" = False
validUnknown "ranksep" = False
validUnknown "rank" = False
validUnknown "ratio" = False
validUnknown "rects" = False
validUnknown "regular" = False
validUnknown "remincross" = False
validUnknown "repulsiveforce" = False
validUnknown "root" = False
validUnknown "rotate" = False
validUnknown "samehead" = False
validUnknown "sametail" = False
validUnknown "samplepoints" = False
validUnknown "searchsize" = False
validUnknown "sep" = False
validUnknown "shapefile" = False
validUnknown "shape" = False
validUnknown "showboxes" = False
validUnknown "sides" = False
validUnknown "size" = False
validUnknown "skew" = False
validUnknown "smoothing" = False
validUnknown "sortv" = False
validUnknown "splines" = False
validUnknown "start" = False
validUnknown "stylesheet" = False
validUnknown "style" = False
validUnknown "tailURL" = False
validUnknown "tailhref" = False
validUnknown "tailclip" = False
validUnknown "taillabel" = False
validUnknown "tailport" = False
validUnknown "tailtarget" = False
validUnknown "tailtooltip" = False
validUnknown "target" = False
validUnknown "tooltip" = False
validUnknown "truecolor" = False
validUnknown "vertices" = False
validUnknown "viewport" = False
validUnknown "voro_margin" = False
validUnknown "weight" = False
validUnknown "width" = False
validUnknown "z" = False
validUnknown _ = True
{- delete to here -}
instance Arbitrary Word8 where
arbitrary = arbitraryBoundedIntegral
shrink = shrinkIntegral
instance Arbitrary Word16 where
arbitrary = arbitraryBoundedIntegral
shrink = shrinkIntegral
instance Arbitrary ArrowType where
arbitrary = liftM AType
-- Arrow specifications have between 1 and 4 elements.
$ sized (\ s -> resize (min s 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 = liftM2 Point posArbitrary posArbitrary
shrink (Point v1 v2) = do v1s <- shrink v1
v2s <- shrink v2
return $ Point 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 HtmlLabel arbitrary
, liftM RecordLabel $ suchThat arbList notStr
]
shrink (StrLabel str) = map StrLabel $ shrinkString str
shrink (HtmlLabel html) = map HtmlLabel $ shrink html
shrink (RecordLabel fs) = map RecordLabel . filter notStr $ shrinkList fs
notStr :: RecordFields -> Bool
notStr [FieldLabel{}] = False -- Just in case
notStr _ = True
arbField :: Bool -> Int -> Gen RecordField
arbField b s = resize s'
. oneof
. bool id ((:) genFlipped) b
$ [ liftM2 LabelledTarget arbitrary arbString
, liftM PortName arbitrary
, liftM FieldLabel arbString
]
where
genFlipped = liftM FlipFields
$ listOf1 (sized $ arbField False)
s' = min 3 s
instance Arbitrary RecordField where
arbitrary = sized (arbField True)
shrink (LabelledTarget f l) = [PortName f, FieldLabel l]
shrink (PortName f) = map PortName $ shrink f
shrink (FieldLabel l) = map FieldLabel $ shrinkString l
shrink (FlipFields fs) = map FlipFields $ shrinkList fs
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
]
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 = oneof [ liftM2 LabelledPort arbitrary arbitrary
, liftM CompassPoint arbitrary
]
shrink (LabelledPort pn mc) = map (flip LabelledPort mc) $ shrink pn
shrink _ = []
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
instance Arbitrary HtmlLabel where
arbitrary = sized $ arbHtml True
shrink ht@(HtmlText txts) = delete ht . map HtmlText $ shrinkL txts
shrink (HtmlTable tbl) = map HtmlTable $ shrink tbl
-- Note: for the most part, HtmlLabel values are very repetitive (and
-- furthermore, they end up chewing a large amount of memory). As
-- such, use resize to limit how large the actual HtmlLabel values
-- become.
arbHtml :: Bool -> Int -> Gen HtmlLabel
arbHtml table s = resize' $ frequency options
where
s' = min 2 s
resize' = if not table
then resize s'
else id
allowTable = if table
then (:) (1, arbTbl)
else id
arbTbl = liftM HtmlTable arbitrary
options = allowTable [ (20, liftM HtmlText . sized $ arbHtmlTexts table) ]
arbHtmlTexts :: Bool -> Int -> Gen HtmlText
arbHtmlTexts fnt s = liftM simplifyHtmlText
. resize s'
. listOf1
. sized
$ arbHtmlText fnt
where
s' = min s 10
-- When parsing, all textual characters are parsed together; thus,
-- make sure we generate them like that.
simplifyHtmlText :: HtmlText -> HtmlText
simplifyHtmlText = map head . groupBy sameType
where
sameType HtmlStr{} HtmlStr{} = True
sameType HtmlNewline{} HtmlNewline{} = True
sameType HtmlFont{} HtmlFont{} = True
sameType _ _ = False
instance Arbitrary HtmlTextItem where
arbitrary = sized $ arbHtmlText True
shrink (HtmlStr str) = map HtmlStr $ shrinkString str
shrink (HtmlNewline as) = map HtmlNewline $ shrink as
shrink hf@(HtmlFont as txt) = do as' <- shrink as
txt' <- shrinkL txt
returnCheck hf $ HtmlFont as' txt'
arbHtmlText :: Bool -> Int -> Gen HtmlTextItem
arbHtmlText font s = frequency options
where
allowFonts = if font
then (:) (1, arbFont)
else id
s' = min 2 s
arbFont = liftM2 HtmlFont arbitrary . resize s' . sized $ arbHtmlTexts False
options = allowFonts [ (10, liftM HtmlStr arbString)
, (10, liftM HtmlNewline arbitrary)
]
instance Arbitrary HtmlTable where
arbitrary = liftM3 HTable arbitrary arbitrary (sized arbRows)
where
arbRows s = resize (min s 10) arbList
shrink (HTable fas as rs) = map (HTable fas as) $ shrinkL rs
instance Arbitrary HtmlRow where
arbitrary = liftM HtmlRow arbList
shrink hr@(HtmlRow cs) = delete hr . map HtmlRow $ shrinkL cs
instance Arbitrary HtmlCell where
arbitrary = oneof [ liftM2 HtmlLabelCell arbitrary . sized $ arbHtml False
, liftM2 HtmlImgCell arbitrary arbitrary
]
shrink lc@(HtmlLabelCell as h) = do as' <- shrink as
h' <- shrink h
returnCheck lc $ HtmlLabelCell as' h'
shrink (HtmlImgCell as ic) = map (HtmlImgCell as) $ shrink ic
instance Arbitrary HtmlImg where
arbitrary = liftM HtmlImg arbitrary
instance Arbitrary HtmlAttribute where
arbitrary = oneof [ liftM HtmlAlign arbitrary
, liftM HtmlBAlign arbitrary
, liftM HtmlBGColor arbitrary
, liftM HtmlBorder arbitrary
, liftM HtmlCellBorder arbitrary
, liftM HtmlCellPadding arbitrary
, liftM HtmlCellSpacing arbitrary
, liftM HtmlColor arbitrary
, liftM HtmlColSpan arbitrary
, liftM HtmlFace arbString
, liftM HtmlFixedSize arbitrary
, liftM HtmlHeight arbitrary
, liftM HtmlHRef arbString
, liftM HtmlPointSize arbitrary
, liftM HtmlPort arbitrary
, liftM HtmlRowSpan arbitrary
, liftM HtmlScale arbitrary
, liftM HtmlSrc arbString
, liftM HtmlTarget arbString
, liftM HtmlTitle arbString
, liftM HtmlVAlign arbitrary
, liftM HtmlWidth arbitrary
]
shrink (HtmlAlign v) = map HtmlAlign $ shrink v
shrink (HtmlBAlign v) = map HtmlBAlign $ shrink v
shrink (HtmlBGColor v) = map HtmlBGColor $ shrink v
shrink (HtmlBorder v) = map HtmlBorder $ shrink v
shrink (HtmlCellBorder v) = map HtmlCellBorder $ shrink v
shrink (HtmlCellPadding v) = map HtmlCellPadding $ shrink v
shrink (HtmlCellSpacing v) = map HtmlCellSpacing $ shrink v
shrink (HtmlColor v) = map HtmlColor $ shrink v
shrink (HtmlColSpan v) = map HtmlColSpan $ shrink v
shrink (HtmlFace v) = map HtmlFace $ shrink v
shrink (HtmlFixedSize v) = map HtmlFixedSize $ shrink v
shrink (HtmlHeight v) = map HtmlHeight $ shrink v
shrink (HtmlHRef v) = map HtmlHRef $ shrink v
shrink (HtmlPointSize v) = map HtmlPointSize $ shrink v
shrink (HtmlPort v) = map HtmlPort $ shrink v
shrink (HtmlRowSpan v) = map HtmlRowSpan $ shrink v
shrink (HtmlScale v) = map HtmlScale $ shrink v
shrink (HtmlSrc v) = map HtmlSrc $ shrink v
shrink (HtmlTarget v) = map HtmlTarget $ shrink v
shrink (HtmlTitle v) = map HtmlTitle $ shrink v
shrink (HtmlVAlign v) = map HtmlVAlign $ shrink v
shrink (HtmlWidth v) = map HtmlWidth $ shrink v
instance Arbitrary HtmlScale where
arbitrary = arbBounded
instance Arbitrary HtmlAlign where
arbitrary = arbBounded
instance Arbitrary HtmlVAlign where
arbitrary = arbBounded
instance Arbitrary PortName where
arbitrary = liftM PN . flip suchThat (liftM2 (&&) (not . null) notCP)
$ liftM (filter (/= ':')) arbString
shrink = map PN . filter notCP . shrinkString . portName
notCP :: String -> Bool
notCP = flip Map.notMember compassLookup
-- -----------------------------------------------------------------------------
-- 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 genStr validString
where
genStr = listOf1 $ elements strChr
strChr = ['a'..'z'] ++ ['0'..'9'] ++ ['\'', '"', ' ', '(', ')'
, ',', ':', '.']
arbIDString :: Gen String
arbIDString = suchThat genStr validString
where
genStr = liftM2 (:) (elements frst) $ listOf (elements rest)
frst = ['a'..'z'] ++ ['_']
rest = frst ++ ['0'.. '9']
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
returnCheck :: (Eq a) => a -> a -> [a]
returnCheck o n = if o == n
then []
else [n]