graphviz-2999.12.0.0: Data/GraphViz/Testing/Instances/Attributes.hs
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : Data.GraphViz.Testing.Instances.Attributes
Description : Attribute instances for Arbitrary.
Copyright : (c) Ivan Lazar Miljenovic
License : 3-Clause BSD-style
Maintainer : Ivan.Miljenovic@gmail.com
-}
module Data.GraphViz.Testing.Instances.Attributes
( arbGraphAttrs
, arbSubGraphAttrs
, arbClusterAttrs
, arbNodeAttrs
, arbEdgeAttrs
) where
import Data.GraphViz.Testing.Instances.Helpers
import Data.GraphViz.Attributes.Complete
import Data.GraphViz.Attributes.Internal(compassLookup)
import Data.GraphViz.State(initialState, layerSep)
import Data.GraphViz.Util(bool)
import Test.QuickCheck
import Data.List(nub, delete, groupBy)
import qualified Data.Map as Map
import qualified Data.Text.Lazy as T
import Data.Text.Lazy(Text)
import Control.Monad(liftM, liftM2, liftM3, liftM4)
-- -----------------------------------------------------------------------------
-- Defining Arbitrary instances for Attributes
arbGraphAttrs :: Gen Attributes
arbGraphAttrs = arbAttrs usedByGraphs
arbSubGraphAttrs :: Gen Attributes
arbSubGraphAttrs = arbAttrs usedBySubGraphs
arbClusterAttrs :: Gen Attributes
arbClusterAttrs = arbAttrs usedByClusters
arbNodeAttrs :: Gen Attributes
arbNodeAttrs = arbAttrs usedByNodes
arbEdgeAttrs :: Gen Attributes
arbEdgeAttrs = arbAttrs usedByEdges
arbAttrs :: (Attribute -> Bool) -> Gen Attributes
arbAttrs p = liftM (filter p) arbList
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 ClusterRank arbitrary
, liftM ColorScheme arbitrary
, liftM Color arbList
, liftM Comment arbitrary
, 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 arbitrary
, liftM EdgeTooltip arbitrary
, liftM Epsilon arbitrary
, liftM ESep arbitrary
, liftM FillColor arbitrary
, liftM FixedSize arbitrary
, liftM FontColor arbitrary
, liftM FontName arbitrary
, liftM FontNames arbitrary
, liftM FontPath arbitrary
, liftM FontSize arbitrary
, liftM Group arbitrary
, liftM HeadURL arbitrary
, liftM HeadClip arbitrary
, liftM HeadLabel arbitrary
, liftM HeadPort arbitrary
, liftM HeadTarget arbitrary
, liftM HeadTooltip arbitrary
, liftM Height arbitrary
, liftM ID arbitrary
, liftM Image arbitrary
, liftM ImageScale arbitrary
, liftM LabelURL arbitrary
, liftM LabelAngle arbitrary
, liftM LabelDistance arbitrary
, liftM LabelFloat arbitrary
, liftM LabelFontColor arbitrary
, liftM LabelFontName arbitrary
, liftM LabelFontSize arbitrary
, liftM LabelJust arbitrary
, liftM LabelLoc arbitrary
, liftM LabelTarget arbitrary
, liftM LabelTooltip arbitrary
, liftM Label arbitrary
, liftM Landscape arbitrary
, liftM LayerSep arbitrary
, liftM Layers arbitrary
, liftM Layer arbitrary
, liftM Layout arbitrary
, liftM Len arbitrary
, liftM LevelsGap arbitrary
, liftM Levels arbitrary
, liftM LHead arbitrary
, liftM LPos arbitrary
, liftM LTail arbitrary
, 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 arbitrary
, 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 arbList
, liftM Regular arbitrary
, liftM ReMinCross arbitrary
, liftM RepulsiveForce arbitrary
, liftM Root arbitrary
, liftM Rotate arbitrary
, liftM SameHead arbitrary
, liftM SameTail arbitrary
, liftM SamplePoints arbitrary
, liftM SearchSize arbitrary
, liftM Sep arbitrary
, liftM ShapeFile arbitrary
, 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 arbitrary
, liftM Style arbList
, liftM TailURL arbitrary
, liftM TailClip arbitrary
, liftM TailLabel arbitrary
, liftM TailPort arbitrary
, liftM TailTarget arbitrary
, liftM TailTooltip arbitrary
, liftM Target arbitrary
, liftM Tooltip arbitrary
, 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) 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 (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 $ shrink 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 $ shrink v
shrink (EdgeTooltip v) = map EdgeTooltip $ shrink 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 $ shrink v
shrink (FontNames v) = map FontNames $ shrink v
shrink (FontPath v) = map FontPath $ shrink v
shrink (FontSize v) = map FontSize $ shrink v
shrink (Group v) = map Group $ shrink 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 $ shrink v
shrink (HeadTooltip v) = map HeadTooltip $ shrink v
shrink (Height v) = map Height $ shrink v
shrink (ID v) = map ID $ shrink v
shrink (Image v) = map Image $ shrink 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 $ shrink 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 $ shrink v
shrink (LabelTooltip v) = map LabelTooltip $ shrink v
shrink (Label v) = map Label $ shrink v
shrink (Landscape v) = map Landscape $ shrink v
shrink (LayerSep v) = map LayerSep $ shrink v
shrink (Layers v) = map Layers $ shrink v
shrink (Layer v) = map Layer $ shrink v
shrink (Layout v) = map Layout $ shrink 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 $ shrink v
shrink (LPos v) = map LPos $ shrink v
shrink (LTail v) = map LTail $ shrink 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 $ shrink 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 $ nonEmptyShrinks 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 $ shrink v
shrink (SameTail v) = map SameTail $ shrink 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 $ shrink 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 $ shrink 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 $ shrink v
shrink (TailTooltip v) = map TailTooltip $ shrink v
shrink (Target v) = map Target $ shrink v
shrink (Tooltip v) = map Tooltip $ shrink 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) shrink a) (shrink v)
{- delete to here -}
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 point2D point2D
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 = liftM4 Point posArbitrary posArbitrary posZ arbitrary
where
posZ = frequency [(1, return Nothing), (3, liftM Just posArbitrary)]
shrink p = do x' <- shrink $ xCoord p
y' <- shrink $ yCoord p
z' <- shrinkM $ zCoord p
return $ Point x' y' z' False
point2D :: Gen Point
point2D = liftM2 createPoint posArbitrary posArbitrary
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 point2D
]
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 arbitrary
, liftM HtmlLabel arbitrary
, liftM RecordLabel $ suchThat arbList notStr
]
shrink (StrLabel str) = map StrLabel $ shrink 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 arbitrary
, liftM PortName arbitrary
, liftM FieldLabel arbitrary
]
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 $ shrink 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 LayerSep where
-- Since Arbitrary isn't stateful, we can't generate an arbitrary
-- one because of arbLayerName
arbitrary = return . LSep . T.pack $ layerSep initialState
instance Arbitrary LayerList where
arbitrary = liftM LL $ listOf1 arbName
where
arbName = suchThat arbitrary isLayerName
isLayerName LRName{} = True
isLayerName _ = False
shrink (LL ll) = map LL $ nonEmptyShrinks ll
instance Arbitrary LayerRange where
arbitrary = oneof [ liftM LRID arbitrary
, liftM2 LRS arbitrary 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
$ shrink nm
lrnameCheck :: Text -> 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 arbitrary
]
shrink (NodeName nm) = map NodeName $ shrink 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 arbitrary (T.all ((/=) ','))
]
shrink (XY p) = map XY $ shrink p
shrink (NodeFocus str) = map NodeFocus $ shrink 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
, liftM Brewer arbitrary
]
shrink (Brewer bs) = map Brewer $ shrink bs
shrink _ = []
instance Arbitrary BrewerScheme where
arbitrary = liftM2 BScheme arbitrary arbitrary -- Not /quite/ right, but close enough
shrink (BScheme nm l) = map (BScheme nm) $ shrink l
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.
, liftM2 BrewerColor arbitrary 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 s c) = map (BrewerColor s) $ 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 $ shrink 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 arbitrary)
, (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 arbitrary
, liftM HtmlFixedSize arbitrary
, liftM HtmlHeight arbitrary
, liftM HtmlHRef arbitrary
, liftM HtmlPointSize arbitrary
, liftM HtmlPort arbitrary
, liftM HtmlRowSpan arbitrary
, liftM HtmlScale arbitrary
, liftM HtmlSrc arbString
, liftM HtmlTarget arbitrary
, liftM HtmlTitle arbitrary
, 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 $ shrinkString 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
$ suchThat arbitrary (liftM2 (&&) (T.all (/=':')) notCP)
shrink = map PN . filter notCP . shrink . portName
notCP :: Text -> Bool
notCP = flip Map.notMember compassLookup