{- | Module : Data.GraphViz.Attributes Description : Definition of the GraphViz attributes. Copyright : (c) Matthew Sackman, Ivan Lazar Miljenovic License : 3-Clause BSD-style Maintainer : Ivan.Miljenovic@gmail.com This module defines the various attributes that different parts of a GraphViz graph can have. These attributes are based on the documentation found at: For more information on usage, etc. please see that document. A summary of known current constraints\/limitations\/differences: * Parsing of quoted strings might not always work if they are a sub-part of another Attribute (e.g. a quoted name in 'LayerList'). In fact, parsing with quotes is iffy for everything; specifically when they are and aren't allowed. * 'ColorScheme' is ignored when parsing 'Color' values * ColorList and PointfList are defined as actual lists (but 'LayerList' is not). * A lot of values have a possible value of @"none"@. These now have custom constructors. In fact, most constructors have been expanded upon to give an idea of what they represent rather than using generic terms. * @PointF@ and 'Point' have been combined, and feature support for pure 'Int'-based co-ordinates as well as 'Double' ones (i.e. no floating point-only points for Point). The optional '!' and third value for Point are not available. * 'Rect' uses two 'Point' values to denote the lower-left and top-right corners. * The two 'LabelLoc' attributes have been combined. * The defined 'LayerSep' is not used to parse 'LayerRange' or 'LayerList'; the default (@[' ', ':', '\t']@) is instead used. * @SplineType@ has been replaced with @['Spline']@. * Only polygon-based 'Shape's are available. * Device-dependent 'StyleName' values are not available. * 'PortPos' only has the 'CompassPoint' option, not @PortName[:CompassPoint]@ (since record shapes aren't allowed, and parsing HTML-like labels could be problematic). * Not every 'Attribute' is fully documented/described. In particular, a lot of them are listed as having a 'String' value, when actually only certain Strings are allowed. * Deprecated 'Overlap' algorithms are not defined. -} module Data.GraphViz.Attributes where import Data.GraphViz.ParserCombinators import Data.Char(isDigit, isHexDigit) import Data.Word import Numeric import Control.Monad import Data.Maybe -- ----------------------------------------------------------------------------- {- | These attributes have been implemented in a /permissive/ manner: that is, rather than split them up based on which type of value they are allowed, they have all been included in the one data type, with functions to determine if they are indeed valid for what they're being applied to. To interpret the /Valid for/ listings: [@G@] Valid for Graphs. [@C@] Valid for Clusters. [@S@] Valid for Sub-Graphs (and also Clusters). [@N@] Valid for Nodes. [@E@] Valid for Edges. Note also that the default values are taken from the specification page listed above, and might not correspond fully with the names of the permitted values. -} data Attribute = Damping Double -- ^ /Valid for/: G; /Default/: 0.99; /Minimum/: 0.0; /Notes/: neato only | K Double -- ^ /Valid for/: GC; /Default/: 0.3; /Minimum/: 0; /Notes/: sfdp, fdp only | URL URL -- ^ /Valid for/: ENGC; /Default/: \; /Notes/: svg, postscript, map only | ArrowHead ArrowType -- ^ /Valid for/: E; /Default/: Normal | ArrowSize Double -- ^ /Valid for/: E; /Default/: 1.0; /Minimum/: 0.0 | ArrowTail ArrowType -- ^ /Valid for/: E; /Default/: Normal | Aspect AspectType -- ^ /Valid for/: G; /Notes/: dot only | Bb Rect -- ^ /Valid for/: G; /Notes/: write only | BgColor Color -- ^ /Valid for/: GC; /Default/: \ | Center Bool -- ^ /Valid for/: G; /Default/: false | Charset String -- ^ /Valid for/: G; /Default/: \"UTF-8\" | ClusterRank ClusterMode -- ^ /Valid for/: G; /Default/: local; /Notes/: dot only | Color Color -- ^ /Valid for/: ENC; /Default/: black | ColorScheme String -- ^ /Valid for/: ENCG; /Default/: \"\" | Comment String -- ^ /Valid for/: ENG; /Default/: \"\" | Compound Bool -- ^ /Valid for/: G; /Default/: false; /Notes/: dot only | Concentrate Bool -- ^ /Valid for/: G; /Default/: false | Constraint Bool -- ^ /Valid for/: E; /Default/: true; /Notes/: dot only | Decorate Bool -- ^ /Valid for/: E; /Default/: false | DefaultDist Double -- ^ /Valid for/: G; /Default/: 1+(avg. len)*sqrt(|V|); /Minimum/: epsilon; /Notes/: neato only | Dim Int -- ^ /Valid for/: G; /Default/: 2; /Minimum/: 2; /Notes/: sfdp, fdp, neato only | Dimen Int -- ^ /Valid for/: G; /Default/: 2; /Minimum/: 2; /Notes/: sfdp, fdp, neato only | Dir DirType -- ^ /Valid for/: E; /Default/: forward(directed)/none(undirected) | DirEdgeConstraints DEConstraints -- ^ /Valid for/: G; /Default/: false; /Notes/: neato only | Distortion Double -- ^ /Valid for/: N; /Default/: 0.0; /Minimum/: -100.0 | DPI Double -- ^ /Valid for/: G; /Default/: 96.0 | 0.0; /Notes/: svg, bitmap output only | EdgeURL URL -- ^ /Valid for/: E; /Default/: \"\"; /Notes/: svg, map only | EdgeTarget String -- ^ /Valid for/: E; /Default/: \; /Notes/: svg, map only | EdgeTooltip String -- ^ /Valid for/: E; /Default/: \"\"; /Notes/: svg, cmap only | Epsilon Double -- ^ /Valid for/: G; /Default/: .0001 * # nodes(mode == KK) | .0001(mode == major); /Notes/: neato only | ESep DPoint -- ^ /Valid for/: G; /Default/: +3; /Notes/: not dot | FillColor Color -- ^ /Valid for/: NC; /Default/: lightgrey(nodes) | black(clusters) | FixedSize Bool -- ^ /Valid for/: N; /Default/: false | FontColor Color -- ^ /Valid for/: ENGC; /Default/: black | FontName String -- ^ /Valid for/: ENGC; /Default/: \"Times-Roman\" | FontNames String -- ^ /Valid for/: G; /Default/: \"\"; /Notes/: svg only | FontPath String -- ^ /Valid for/: G; /Default/: system-dependent | FontSize Double -- ^ /Valid for/: ENGC; /Default/: 14.0; /Minimum/: 1.0 | Group String -- ^ /Valid for/: N; /Default/: \"\"; /Notes/: dot only | HeadURL URL -- ^ /Valid for/: E; /Default/: \"\"; /Notes/: svg, map only | HeadClip Bool -- ^ /Valid for/: E; /Default/: true | HeadLabel Label -- ^ /Valid for/: E; /Default/: \"\" | HeadPort PortPos -- ^ /Valid for/: E; /Default/: center | HeadTarget QuotedString -- ^ /Valid for/: E; /Default/: \; /Notes/: svg, map only | HeadTooltip QuotedString -- ^ /Valid for/: E; /Default/: \"\"; /Notes/: svg, cmap only | Height Double -- ^ /Valid for/: N; /Default/: 0.5; /Minimum/: 0.02 | ID Label -- ^ /Valid for/: GNE; /Default/: \"\"; /Notes/: svg, postscript, map only | Image String -- ^ /Valid for/: N; /Default/: \"\" | ImageScale ScaleType -- ^ /Valid for/: N; /Default/: false | Label Label -- ^ /Valid for/: ENGC; /Default/: \"\N\" (nodes) Nothing | \"\" (otherwise) Nothing | LabelURL URL -- ^ /Valid for/: E; /Default/: \"\"; /Notes/: svg, map only | LabelAngle Double -- ^ /Valid for/: E; /Default/: -25.0; /Minimum/: -180.0 | LabelDistance Double -- ^ /Valid for/: E; /Default/: 1.0; /Minimum/: 0.0 | LabelFloat Bool -- ^ /Valid for/: E; /Default/: false | LabelFontColor Color -- ^ /Valid for/: E; /Default/: black | LabelFontName String -- ^ /Valid for/: E; /Default/: \"Times-Roman\" | LabelFontSize Double -- ^ /Valid for/: E; /Default/: 14.0; /Minimum/: 1.0 | LabelJust Justification -- ^ /Valid for/: GC; /Default/: \"c\" | LabelLoc VerticalPlacement -- ^ /Valid for/: GCN; /Default/: \"t\"(clusters) | \"b\"(root graphs) | \"c\"(clusters) | LabelTarget String -- ^ /Valid for/: E; /Default/: \; /Notes/: svg, map only | LabelTooltip String -- ^ /Valid for/: E; /Default/: \"\"; /Notes/: svg, cmap only | Landscape Bool -- ^ /Valid for/: G; /Default/: false | Layer LayerRange -- ^ /Valid for/: EN; /Default/: \"\" | Layers LayerList -- ^ /Valid for/: G; /Default/: \"\" | LayerSep String -- ^ /Valid for/: G; /Default/: \" :\t\" | Layout String -- ^ /Valid for/: G; /Default/: \"\" | Len Double -- ^ /Valid for/: E; /Default/: 1.0(neato)/0.3(fdp); /Notes/: fdp, neato only | Levels Int -- ^ /Valid for/: G; /Default/: MAXINT; /Minimum/: 0.0; /Notes/: sfdp only | LevelsGap Double -- ^ /Valid for/: G; /Default/: 0.0; /Notes/: neato only | LHead String -- ^ /Valid for/: E; /Default/: \"\"; /Notes/: dot only | LP Point -- ^ /Valid for/: EGC; /Notes/: write only | LTail String -- ^ /Valid for/: E; /Default/: \"\"; /Notes/: dot only | Margin DPoint -- ^ /Valid for/: NG; /Default/: \ | MaxIter Int -- ^ /Valid for/: G; /Default/: 100 * # nodes(mode == KK) | 200(mode == major) | 600(fdp); /Notes/: fdp, neato only | MCLimit Double -- ^ /Valid for/: G; /Default/: 1.0; /Notes/: dot only | MinDist Double -- ^ /Valid for/: G; /Default/: 1.0; /Minimum/: 0.0; /Notes/: circo only | MinLen Int -- ^ /Valid for/: E; /Default/: 1; /Minimum/: 0; /Notes/: dot only | Mode String -- ^ /Valid for/: G; /Default/: \"major\"; /Notes/: neato only | Model String -- ^ /Valid for/: G; /Default/: \"shortpath\"; /Notes/: neato only | Mosek Bool -- ^ /Valid for/: G; /Default/: false; /Notes/: neato only; requires the Mosek software | NodeSep Double -- ^ /Valid for/: G; /Default/: 0.25; /Minimum/: 0.02; /Notes/: dot only | NoJustify Bool -- ^ /Valid for/: GCNE; /Default/: false | Normalize Bool -- ^ /Valid for/: G; /Default/: false; /Notes/: not dot | Nslimit Double -- ^ /Valid for/: G; /Notes/: dot only | Nslimit1 Double -- ^ /Valid for/: G; /Notes/: dot only | Ordering String -- ^ /Valid for/: G; /Default/: \"\"; /Notes/: dot only | Orientation Double -- ^ /Valid for/: N; /Default/: 0.0; /Minimum/: 360.0 | OrientationGraph String -- ^ /Valid for/: G; /Default/: \"\"; /Notes/: Landscape if \"[lL]*\" and rotate not defined | OutputOrder OutputMode -- ^ /Valid for/: G; /Default/: breadthfirst | Overlap Overlap -- ^ /Valid for/: G; /Default/: true; /Notes/: not dot | OverlapScaling Double -- ^ /Valid for/: G; /Default/: -4; /Minimum/: -1.0e10; /Notes/: prism only | Pack Pack -- ^ /Valid for/: G; /Default/: false; /Notes/: not dot | PackMode PackMode -- ^ /Valid for/: G; /Default/: node; /Notes/: not dot | Pad DPoint -- ^ /Valid for/: G; /Default/: 0.0555 (4 points) | Page Point -- ^ /Valid for/: G | PageDir PageDir -- ^ /Valid for/: G; /Default/: BL | PenColor Color -- ^ /Valid for/: C; /Default/: black | PenWidth Double -- ^ /Valid for/: CNE; /Default/: 1.0; /Minimum/: 0.0 | Peripheries Int -- ^ /Valid for/: NC; /Default/: shape default(nodes) | 1(clusters); /Minimum/: 0 | Pin Bool -- ^ /Valid for/: N; /Default/: false; /Notes/: fdp, neato only | Pos Pos -- ^ /Valid for/: EN | QuadTree QuadType -- ^ /Valid for/: G; /Default/: \"normal\"; /Notes/: sfdp only | Quantum Double -- ^ /Valid for/: G; /Default/: 0.0; /Minimum/: 0.0 | Rank RankType -- ^ /Valid for/: S; /Notes/: dot only | RankDir RankDir -- ^ /Valid for/: G; /Default/: TB; /Notes/: dot only | Ranksep Double -- ^ /Valid for/: G; /Default/: 0.5(dot) | 1.0(twopi); /Minimum/: 0.02; /Notes/: twopi, dot only | Ratio Ratios -- ^ /Valid for/: G | Rects Rect -- ^ /Valid for/: N; /Notes/: write only | Regular Bool -- ^ /Valid for/: N; /Default/: false | ReMinCross Bool -- ^ /Valid for/: G; /Default/: false; /Notes/: dot only | RepulsiveForce Double -- ^ /Valid for/: G; /Default/: 1.0; /Minimum/: 0.0; /Notes/: sfdp only | Resolution Double -- ^ /Valid for/: G; /Default/: 96.0 | 0.0; /Notes/: svg, bitmap output only | Root Root -- ^ /Valid for/: GN; /Default/: \"\"(graphs) | false(nodes); /Notes/: circo, twopi only | Rotate Int -- ^ /Valid for/: G; /Default/: 0 | SameHead String -- ^ /Valid for/: E; /Default/: \"\"; /Notes/: dot only | SameTail String -- ^ /Valid for/: E; /Default/: \"\"; /Notes/: dot only | SamplePoints Int -- ^ /Valid for/: N; /Default/: 8(output) | 20(overlap and image maps) | SearchSize Int -- ^ /Valid for/: G; /Default/: 30; /Notes/: dot only | Sep DPoint -- ^ /Valid for/: G; /Default/: +4; /Notes/: not dot | Shape Shape -- ^ /Valid for/: N; /Default/: ellipse | ShapeFile String -- ^ /Valid for/: N; /Default/: \"\" | ShowBoxes Int -- ^ /Valid for/: ENG; /Default/: 0; /Minimum/: 0; /Notes/: dot only | Sides Int -- ^ /Valid for/: N; /Default/: 4; /Minimum/: 0 | Size Point -- ^ /Valid for/: G | Skew Double -- ^ /Valid for/: N; /Default/: 0.0; /Minimum/: -100.0 | Smoothing SmoothType -- ^ /Valid for/: G; /Default/: \"none\"; /Notes/: sfdp only | SortV Int -- ^ /Valid for/: GCN; /Default/: 0; /Minimum/: 0 | Splines EdgeType -- ^ /Valid for/: G | Start StartType -- ^ /Valid for/: G; /Default/: \"\"; /Notes/: fdp, neato only | Style Style -- ^ /Valid for/: ENC | StyleSheet String -- ^ /Valid for/: G; /Default/: \"\"; /Notes/: svg only | TailURL URL -- ^ /Valid for/: E; /Default/: \"\"; /Notes/: svg, map only | TailClip Bool -- ^ /Valid for/: E; /Default/: true | TailLabel Label -- ^ /Valid for/: E; /Default/: \"\" | TailPort PortPos -- ^ /Valid for/: E; /Default/: center | TailTarget String -- ^ /Valid for/: E; /Default/: \; /Notes/: svg, map only | TailTooltip String -- ^ /Valid for/: E; /Default/: \"\"; /Notes/: svg, cmap only | Target String -- ^ /Valid for/: ENGC; /Default/: \; /Notes/: svg, map only | Tooltip String -- ^ /Valid for/: NEC; /Default/: \"\"; /Notes/: svg, cmap only | TrueColor Bool -- ^ /Valid for/: G; /Notes/: bitmap output only | Vertices [Point] -- ^ /Valid for/: N; /Notes/: write only | ViewPort ViewPort -- ^ /Valid for/: G; /Default/: \"\" | VoroMargin Double -- ^ /Valid for/: G; /Default/: 0.05; /Minimum/: 0.0; /Notes/: not dot | Weight Double -- ^ /Valid for/: E; /Default/: 1.0; /Minimum/: 0(dot) | 1(neato,fdp,sfdp) | Width Double -- ^ /Valid for/: N; /Default/: 0.75; /Minimum/: 0.01 | Z Double -- ^ /Valid for/: N; /Default/: 0.0; /Minimum/: -MAXFLOAT | -1000 deriving (Eq, Read) instance Show Attribute where show (Damping v) = "Damping=" ++ show v show (K v) = "K=" ++ show v show (URL v) = "URL=" ++ show v show (ArrowHead v) = "arrowhead=" ++ show v show (ArrowSize v) = "arrowsize=" ++ show v show (ArrowTail v) = "arrowtail=" ++ show v show (Aspect v) = "aspect=" ++ show v show (Bb v) = "bb=" ++ show v show (BgColor v) = "bgcolor=" ++ show v show (Center v) = "center=" ++ show v show (Charset v) = "charset=" ++ v show (ClusterRank v) = "clusterrank=" ++ show v show (Color v) = "color=" ++ show v show (ColorScheme v) = "colorscheme=" ++ v show (Comment v) = "comment=" ++ v show (Compound v) = "compound=" ++ show v show (Concentrate v) = "concentrate=" ++ show v show (Constraint v) = "constraint=" ++ show v show (Decorate v) = "decorate=" ++ show v show (DefaultDist v) = "defaultdist=" ++ show v show (Dim v) = "dim=" ++ show v show (Dimen v) = "dimen=" ++ show v show (Dir v) = "dir=" ++ show v show (DirEdgeConstraints v) = "diredgeconstraints=" ++ show v show (Distortion v) = "distortion=" ++ show v show (DPI v) = "dpi=" ++ show v show (EdgeURL v) = "edgeURL=" ++ show v show (EdgeTarget v) = "edgetarget=" ++ v show (EdgeTooltip v) = "edgetooltip=" ++ v show (Epsilon v) = "epsilon=" ++ show v show (ESep v) = "esep=" ++ show v show (FillColor v) = "fillcolor=" ++ show v show (FixedSize v) = "fixedsize=" ++ show v show (FontColor v) = "fontcolor=" ++ show v show (FontName v) = "fontname=" ++ v show (FontNames v) = "fontnames=" ++ v show (FontPath v) = "fontpath=" ++ v show (FontSize v) = "fontsize=" ++ show v show (Group v) = "group=" ++ v show (HeadURL v) = "headURL=" ++ show v show (HeadClip v) = "headclip=" ++ show v show (HeadLabel v) = "headlabel=" ++ show v show (HeadPort v) = "headport=" ++ show v show (HeadTarget v) = "headtarget=" ++ show v show (HeadTooltip v) = "headtooltip=" ++ show v show (Height v) = "height=" ++ show v show (ID v) = "id=" ++ show v show (Image v) = "image=" ++ v show (ImageScale v) = "imagescale=" ++ show v show (Label v) = "label=" ++ show v show (LabelURL v) = "labelURL=" ++ show v show (LabelAngle v) = "labelangle=" ++ show v show (LabelDistance v) = "labeldistance=" ++ show v show (LabelFloat v) = "labelfloat=" ++ show v show (LabelFontColor v) = "labelfontcolor=" ++ show v show (LabelFontName v) = "labelfontname=" ++ v show (LabelFontSize v) = "labelfontsize=" ++ show v show (LabelJust v) = "labeljust=" ++ show v show (LabelLoc v) = "labelloc=" ++ show v show (LabelTarget v) = "labeltarget=" ++ v show (LabelTooltip v) = "labeltooltip=" ++ v show (Landscape v) = "landscape=" ++ show v show (Layer v) = "layer=" ++ show v show (Layers v) = "layers=" ++ show v show (LayerSep v) = "layersep=" ++ v show (Layout v) = "layout=" ++ v show (Len v) = "len=" ++ show v show (Levels v) = "levels=" ++ show v show (LevelsGap v) = "levelsgap=" ++ show v show (LHead v) = "lhead=" ++ v show (LP v) = "lp=" ++ show v show (LTail v) = "ltail=" ++ v show (Margin v) = "margin=" ++ show v show (MaxIter v) = "maxiter=" ++ show v show (MCLimit v) = "mclimit=" ++ show v show (MinDist v) = "mindist=" ++ show v show (MinLen v) = "minlen=" ++ show v show (Mode v) = "mode=" ++ v show (Model v) = "model=" ++ v show (Mosek v) = "mosek=" ++ show v show (NodeSep v) = "nodesep=" ++ show v show (NoJustify v) = "nojustify=" ++ show v show (Normalize v) = "normalize=" ++ show v show (Nslimit v) = "nslimit=" ++ show v show (Nslimit1 v) = "nslimit1=" ++ show v show (Ordering v) = "ordering=" ++ v show (Orientation v) = "orientation=" ++ show v show (OrientationGraph v) = "orientation=" ++ v show (OutputOrder v) = "outputorder=" ++ show v show (Overlap v) = "overlap=" ++ show v show (OverlapScaling v) = "overlap_scaling=" ++ show v show (Pack v) = "pack=" ++ show v show (PackMode v) = "packmode=" ++ show v show (Pad v) = "pad=" ++ show v show (Page v) = "page=" ++ show v show (PageDir v) = "pagedir=" ++ show v show (PenColor v) = "pencolor=" ++ show v show (PenWidth v) = "penwidth=" ++ show v show (Peripheries v) = "peripheries=" ++ show v show (Pin v) = "pin=" ++ show v show (Pos v) = "pos=" ++ show v show (QuadTree v) = "quadtree=" ++ show v show (Quantum v) = "quantum=" ++ show v show (Rank v) = "rank=" ++ show v show (RankDir v) = "rankdir=" ++ show v show (Ranksep v) = "ranksep=" ++ show v show (Ratio v) = "ratio=" ++ show v show (Rects v) = "rects=" ++ show v show (Regular v) = "regular=" ++ show v show (ReMinCross v) = "remincross=" ++ show v show (RepulsiveForce v) = "repulsiveforce=" ++ show v show (Resolution v) = "resolution=" ++ show v show (Root v) = "root=" ++ show v show (Rotate v) = "rotate=" ++ show v show (SameHead v) = "samehead=" ++ v show (SameTail v) = "sametail=" ++ v show (SamplePoints v) = "samplepoints=" ++ show v show (SearchSize v) = "searchsize=" ++ show v show (Sep v) = "sep=" ++ show v show (Shape v) = "shape=" ++ show v show (ShapeFile v) = "shapefile=" ++ v show (ShowBoxes v) = "showboxes=" ++ show v show (Sides v) = "sides=" ++ show v show (Size v) = "size=" ++ show v show (Skew v) = "skew=" ++ show v show (Smoothing v) = "smoothing=" ++ show v show (SortV v) = "sortv=" ++ show v show (Splines v) = "splines=" ++ show v show (Start v) = "start=" ++ show v show (Style v) = "style=" ++ show v show (StyleSheet v) = "stylesheet=" ++ v show (TailURL v) = "tailURL=" ++ show v show (TailClip v) = "tailclip=" ++ show v show (TailLabel v) = "taillabel=" ++ show v show (TailPort v) = "tailport=" ++ show v show (TailTarget v) = "tailtarget=" ++ v show (TailTooltip v) = "tailtooltip=" ++ v show (Target v) = "target=" ++ v show (Tooltip v) = "tooltip=" ++ v show (TrueColor v) = "truecolor=" ++ show v show (Vertices v) = "vertices=" ++ show v show (ViewPort v) = "viewport=" ++ show v show (VoroMargin v) = "voro_margin=" ++ show v show (Weight v) = "weight=" ++ show v show (Width v) = "width=" ++ show v show (Z v) = "z=" ++ show v instance Parseable Attribute where parse = oneOf [ liftM Damping $ parseField "Damping" , liftM K $ parseField "K" , liftM URL $ oneOf (map parseField ["URL", "href"]) , liftM ArrowHead $ parseField "arrowhead" , liftM ArrowSize $ parseField "arrowsize" , liftM ArrowTail $ parseField "arrowtail" , liftM Aspect $ parseField "aspect" , liftM Bb $ parseField "bb" , liftM BgColor $ parseField "bgcolor" , liftM Center $ parseBoolField "center" , liftM Charset $ parseField "charset" , liftM ClusterRank $ parseField "clusterrank" , liftM Color $ parseField "color" , liftM ColorScheme $ parseField "colorscheme" , liftM Comment $ parseField "comment" , liftM Compound $ parseBoolField "compound" , liftM Concentrate $ parseBoolField "concentrate" , liftM Constraint $ parseBoolField "constraint" , liftM Decorate $ parseBoolField "decorate" , liftM DefaultDist $ parseField "defaultdist" , liftM Dim $ parseField "dim" , liftM Dimen $ parseField "dimen" , liftM Dir $ parseField "dir" , liftM DirEdgeConstraints $ parseFieldDef (DEBool True) "diredgeconstraints" , liftM Distortion $ parseField "distortion" , liftM DPI $ parseField "dpi" , liftM EdgeURL $ oneOf (map parseField ["edgeURL", "edgehref"]) , liftM EdgeTarget $ parseField "edgetarget" , liftM EdgeTooltip $ parseField "edgetooltip" , liftM Epsilon $ parseField "epsilon" , liftM ESep $ parseField "esep" , liftM FillColor $ parseField "fillcolor" , liftM FixedSize $ parseBoolField "fixedsize" , liftM FontColor $ parseField "fontcolor" , liftM FontName $ parseField "fontname" , liftM FontNames $ parseField "fontnames" , liftM FontPath $ parseField "fontpath" , liftM FontSize $ parseField "fontsize" , liftM Group $ parseField "group" , liftM HeadURL $ oneOf (map parseField ["headURL", "headhref"]) , liftM HeadClip $ parseBoolField "headclip" , liftM HeadLabel $ parseField "headlabel" , liftM HeadPort $ parseField "headport" , liftM HeadTarget $ parseField "headtarget" , liftM HeadTooltip $ parseField "headtooltip" , liftM Height $ parseField "height" , liftM ID $ parseField "id" , liftM Image $ parseField "image" , liftM ImageScale $ parseFieldDef UniformScale "imagescale" , liftM Label $ parseField "label" , liftM LabelURL $ oneOf (map parseField ["labelURL", "labelhref"]) , liftM LabelAngle $ parseField "labelangle" , liftM LabelDistance $ parseField "labeldistance" , liftM LabelFloat $ parseBoolField "labelfloat" , liftM LabelFontColor $ parseField "labelfontcolor" , liftM LabelFontName $ parseField "labelfontname" , liftM LabelFontSize $ parseField "labelfontsize" , liftM LabelJust $ parseField "labeljust" , liftM LabelLoc $ parseField "labelloc" , liftM LabelTarget $ parseField "labeltarget" , liftM LabelTooltip $ parseField "labeltooltip" , liftM Landscape $ parseBoolField "landscape" , liftM Layer $ parseField "layer" , liftM Layers $ parseField "layers" , liftM LayerSep $ parseField "layersep" , liftM Layout $ parseField "layout" , liftM Len $ parseField "len" , liftM Levels $ parseField "levels" , liftM LevelsGap $ parseField "levelsgap" , liftM LHead $ parseField "lhead" , liftM LP $ parseField "lp" , liftM LTail $ parseField "ltail" , liftM Margin $ parseField "margin" , liftM MaxIter $ parseField "maxiter" , liftM MCLimit $ parseField "mclimit" , liftM MinDist $ parseField "mindist" , liftM MinLen $ parseField "minlen" , liftM Mode $ parseField "mode" , liftM Model $ parseField "model" , liftM Mosek $ parseBoolField "mosek" , liftM NodeSep $ parseField "nodesep" , liftM NoJustify $ parseBoolField "nojustify" , liftM Normalize $ parseBoolField "normalize" , liftM Nslimit $ parseField "nslimit" , liftM Nslimit1 $ parseField "nslimit1" , liftM Ordering $ parseField "ordering" , liftM Orientation $ parseField "orientation" , liftM OrientationGraph $ parseField "orientation" , liftM OutputOrder $ parseField "outputorder" , liftM Overlap $ parseFieldDef KeepOverlaps "overlap" , liftM OverlapScaling $ parseField "overlap_scaling" , liftM Pack $ parseFieldDef DoPack "pack" , liftM PackMode $ parseField "packmode" , liftM Pad $ parseField "pad" , liftM Page $ parseField "page" , liftM PageDir $ parseField "pagedir" , liftM PenColor $ parseField "pencolor" , liftM PenWidth $ parseField "penwidth" , liftM Peripheries $ parseField "peripheries" , liftM Pin $ parseBoolField "pin" , liftM Pos $ parseField "pos" , liftM QuadTree $ parseFieldDef NormalQT "quadtree" , liftM Quantum $ parseField "quantum" , liftM Rank $ parseField "rank" , liftM RankDir $ parseField "rankdir" , liftM Ranksep $ parseField "ranksep" , liftM Ratio $ parseField "ratio" , liftM Rects $ parseField "rects" , liftM Regular $ parseBoolField "regular" , liftM ReMinCross $ parseBoolField "remincross" , liftM RepulsiveForce $ parseField "repulsiveforce" , liftM Resolution $ parseField "resolution" , liftM Root $ parseFieldDef IsCentral "root" , liftM Rotate $ parseField "rotate" , liftM SameHead $ parseField "samehead" , liftM SameTail $ parseField "sametail" , liftM SamplePoints $ parseField "samplepoints" , liftM SearchSize $ parseField "searchsize" , liftM Sep $ parseField "sep" , liftM Shape $ parseField "shape" , liftM ShapeFile $ parseField "shapefile" , liftM ShowBoxes $ parseField "showboxes" , liftM Sides $ parseField "sides" , liftM Size $ parseField "size" , liftM Skew $ parseField "skew" , liftM Smoothing $ parseField "smoothing" , liftM SortV $ parseField "sortv" , liftM Splines $ parseFieldDef SplineEdges "splines" , liftM Start $ parseField "start" , liftM Style $ parseField "style" , liftM StyleSheet $ parseField "stylesheet" , liftM TailURL $ oneOf (map parseField ["tailURL", "tailhref"]) , liftM TailClip $ parseBoolField "tailclip" , liftM TailLabel $ parseField "taillabel" , liftM TailPort $ parseField "tailport" , liftM TailTarget $ parseField "tailtarget" , liftM TailTooltip $ parseField "tailtooltip" , liftM Target $ parseField "target" , liftM Tooltip $ parseField "tooltip" , liftM TrueColor $ parseBoolField "truecolor" , liftM Vertices $ parseField "vertices" , liftM ViewPort $ parseField "viewport" , liftM VoroMargin $ parseField "voro_margin" , liftM Weight $ parseField "weight" , liftM Width $ parseField "width" , liftM Z $ parseField "z" ] -- | Determine if this Attribute is valid for use with Graphs. usedByGraphs :: Attribute -> Bool usedByGraphs Damping{} = True usedByGraphs K{} = True usedByGraphs URL{} = True usedByGraphs Aspect{} = True usedByGraphs Bb{} = True usedByGraphs BgColor{} = True usedByGraphs Center{} = True usedByGraphs Charset{} = True usedByGraphs ClusterRank{} = True usedByGraphs ColorScheme{} = True usedByGraphs Comment{} = True usedByGraphs Compound{} = True usedByGraphs Concentrate{} = True usedByGraphs DefaultDist{} = True usedByGraphs Dim{} = True usedByGraphs Dimen{} = True usedByGraphs DirEdgeConstraints{} = True usedByGraphs DPI{} = True usedByGraphs Epsilon{} = True usedByGraphs ESep{} = True usedByGraphs FontColor{} = True usedByGraphs FontName{} = True usedByGraphs FontNames{} = True usedByGraphs FontPath{} = True usedByGraphs FontSize{} = True usedByGraphs ID{} = True usedByGraphs Label{} = True usedByGraphs LabelJust{} = True usedByGraphs LabelLoc{} = True usedByGraphs Landscape{} = True usedByGraphs Layers{} = True usedByGraphs LayerSep{} = True usedByGraphs Layout{} = True usedByGraphs Levels{} = True usedByGraphs LevelsGap{} = True usedByGraphs LP{} = True usedByGraphs Margin{} = True usedByGraphs MaxIter{} = True usedByGraphs MCLimit{} = True usedByGraphs MinDist{} = True usedByGraphs Mode{} = True usedByGraphs Model{} = True usedByGraphs Mosek{} = True usedByGraphs NodeSep{} = True usedByGraphs NoJustify{} = True usedByGraphs Normalize{} = True usedByGraphs Nslimit{} = True usedByGraphs Nslimit1{} = True usedByGraphs Ordering{} = True usedByGraphs OrientationGraph{} = True usedByGraphs OutputOrder{} = True usedByGraphs Overlap{} = True usedByGraphs OverlapScaling{} = True usedByGraphs Pack{} = True usedByGraphs PackMode{} = True usedByGraphs Pad{} = True usedByGraphs Page{} = True usedByGraphs PageDir{} = True usedByGraphs QuadTree{} = True usedByGraphs Quantum{} = True usedByGraphs RankDir{} = True usedByGraphs Ranksep{} = True usedByGraphs Ratio{} = True usedByGraphs ReMinCross{} = True usedByGraphs RepulsiveForce{} = True usedByGraphs Resolution{} = True usedByGraphs Root{} = True usedByGraphs Rotate{} = True usedByGraphs SearchSize{} = True usedByGraphs Sep{} = True usedByGraphs ShowBoxes{} = True usedByGraphs Size{} = True usedByGraphs Smoothing{} = True usedByGraphs SortV{} = True usedByGraphs Splines{} = True usedByGraphs Start{} = True usedByGraphs StyleSheet{} = True usedByGraphs Target{} = True usedByGraphs TrueColor{} = True usedByGraphs ViewPort{} = True usedByGraphs VoroMargin{} = True usedByGraphs _ = False -- | Determine if this Attribute is valid for use with Clusters. usedByClusters :: Attribute -> Bool usedByClusters K{} = True usedByClusters URL{} = True usedByClusters BgColor{} = True usedByClusters Color{} = True usedByClusters ColorScheme{} = True usedByClusters FillColor{} = True usedByClusters FontColor{} = True usedByClusters FontName{} = True usedByClusters FontSize{} = True usedByClusters Label{} = True usedByClusters LabelJust{} = True usedByClusters LabelLoc{} = True usedByClusters LP{} = True usedByClusters NoJustify{} = True usedByClusters PenColor{} = True usedByClusters PenWidth{} = True usedByClusters Peripheries{} = True usedByClusters Rank{} = True usedByClusters SortV{} = True usedByClusters Style{} = True usedByClusters Target{} = True usedByClusters Tooltip{} = True usedByClusters _ = False -- | Determine if this Attribute is valid for use with SubGraphs. usedBySubGraphs :: Attribute -> Bool usedBySubGraphs Rank{} = True usedBySubGraphs _ = False -- | Determine if this Attribute is valid for use with Nodes. usedByNodes :: Attribute -> Bool usedByNodes URL{} = True usedByNodes Color{} = True usedByNodes ColorScheme{} = True usedByNodes Comment{} = True usedByNodes Distortion{} = True usedByNodes FillColor{} = True usedByNodes FixedSize{} = True usedByNodes FontColor{} = True usedByNodes FontName{} = True usedByNodes FontSize{} = True usedByNodes Group{} = True usedByNodes Height{} = True usedByNodes ID{} = True usedByNodes Image{} = True usedByNodes ImageScale{} = True usedByNodes Label{} = True usedByNodes LabelLoc{} = True usedByNodes Layer{} = True usedByNodes Margin{} = True usedByNodes NoJustify{} = True usedByNodes Orientation{} = True usedByNodes PenWidth{} = True usedByNodes Peripheries{} = True usedByNodes Pin{} = True usedByNodes Pos{} = True usedByNodes Rects{} = True usedByNodes Regular{} = True usedByNodes Root{} = True usedByNodes SamplePoints{} = True usedByNodes Shape{} = True usedByNodes ShapeFile{} = True usedByNodes ShowBoxes{} = True usedByNodes Sides{} = True usedByNodes Skew{} = True usedByNodes SortV{} = True usedByNodes Style{} = True usedByNodes Target{} = True usedByNodes Tooltip{} = True usedByNodes Vertices{} = True usedByNodes Width{} = True usedByNodes Z{} = True usedByNodes _ = False -- | Determine if this Attribute is valid for use with Edges. usedByEdges :: Attribute -> Bool usedByEdges URL{} = True usedByEdges ArrowHead{} = True usedByEdges ArrowSize{} = True usedByEdges ArrowTail{} = True usedByEdges Color{} = True usedByEdges ColorScheme{} = True usedByEdges Comment{} = True usedByEdges Constraint{} = True usedByEdges Decorate{} = True usedByEdges Dir{} = True usedByEdges EdgeURL{} = True usedByEdges EdgeTarget{} = True usedByEdges EdgeTooltip{} = True usedByEdges FontColor{} = True usedByEdges FontName{} = True usedByEdges FontSize{} = True usedByEdges HeadURL{} = True usedByEdges HeadClip{} = True usedByEdges HeadLabel{} = True usedByEdges HeadPort{} = True usedByEdges HeadTarget{} = True usedByEdges HeadTooltip{} = True usedByEdges ID{} = True usedByEdges Label{} = True usedByEdges LabelURL{} = True usedByEdges LabelAngle{} = True usedByEdges LabelDistance{} = True usedByEdges LabelFloat{} = True usedByEdges LabelFontColor{} = True usedByEdges LabelFontName{} = True usedByEdges LabelFontSize{} = True usedByEdges LabelTarget{} = True usedByEdges LabelTooltip{} = True usedByEdges Layer{} = True usedByEdges Len{} = True usedByEdges LHead{} = True usedByEdges LP{} = True usedByEdges LTail{} = True usedByEdges MinLen{} = True usedByEdges NoJustify{} = True usedByEdges PenWidth{} = True usedByEdges Pos{} = True usedByEdges SameHead{} = True usedByEdges SameTail{} = True usedByEdges ShowBoxes{} = True usedByEdges Style{} = True usedByEdges TailURL{} = True usedByEdges TailClip{} = True usedByEdges TailLabel{} = True usedByEdges TailPort{} = True usedByEdges TailTarget{} = True usedByEdges TailTooltip{} = True usedByEdges Target{} = True usedByEdges Tooltip{} = True usedByEdges Weight{} = True usedByEdges _ = False -- ----------------------------------------------------------------------------- newtype URL = UStr { urlString :: String } deriving (Eq, Read) instance Show URL where show u = '<' : urlString u ++ ">" instance Parseable URL where parse = do char open cnt <- many1 $ satisfy ((/=) close) char close return $ UStr cnt where open = '<' close = '>' -- ----------------------------------------------------------------------------- data ArrowType = Normal | Inv | DotArrow | InvDot | ODot | InvODot | NoArrow | Tee | Empty | InvEmpty | Diamond | ODiamond | EDiamond | Crow | Box | OBox | Open | HalfOpen | Vee deriving (Eq, Read) instance Show ArrowType where show Normal = "normal" show Inv = "inv" show DotArrow = "dot" show InvDot = "invdot" show ODot = "odot" show InvODot = "invodot" show NoArrow = "none" show Tee = "tee" show Empty = "empty" show InvEmpty = "invempty" show Diamond = "diamond" show ODiamond = "odiamond" show EDiamond = "ediamond" show Crow = "crow" show Box = "box" show OBox = "obox" show Open = "open" show HalfOpen = "halfopen" show Vee = "vee" instance Parseable ArrowType where parse = optionalQuoted $ oneOf [ string "normal" >> return Normal , string "inv" >> return Inv , string "dot" >> return DotArrow , string "invdot" >> return InvDot , string "odot" >> return ODot , string "invodot" >> return InvODot , string "none" >> return NoArrow , string "tee" >> return Tee , string "empty" >> return Empty , string "invempty" >> return InvEmpty , string "diamond" >> return Diamond , string "odiamond" >> return ODiamond , string "ediamond" >> return EDiamond , string "crow" >> return Crow , string "box" >> return Box , string "obox" >> return OBox , string "open" >> return Open , string "halfopen" >> return HalfOpen , string "vee" >> return Vee ] -- ----------------------------------------------------------------------------- data AspectType = RatioOnly Double | RatioPassCount Double Int deriving (Eq, Read) instance Show AspectType where show (RatioOnly r) = show r show (RatioPassCount r p) = show $ show r ++ ',' : show p instance Parseable AspectType where parse = oneOf [ liftM RatioOnly parse , quotedParse $ do r <- parse char ',' whitespace' p <- parse return $ RatioPassCount r p ] -- ----------------------------------------------------------------------------- data Rect = Rect Point Point deriving (Eq, Read) instance Show Rect where show (Rect p1 p2) = show $ show p1 ++ ',' : show p2 instance Parseable Rect where parse = liftM (uncurry Rect) . quotedParse $ commaSep' parsePoint parsePoint -- ----------------------------------------------------------------------------- data Color = RGB { red :: Word8 , green :: Word8 , blue :: Word8 } | RGBA { red :: Word8 , green :: Word8 , blue :: Word8 , alpha :: Word8 } | HSV { hue :: Int , saturation :: Int , value :: Int } | ColorName String deriving (Eq, Read) instance Show Color where show = show . showColor showList cs s = show $ go cs where go [] = s go [c] = showColor c ++ s go (c:cs') = showColor c ++ ':' : go cs' showColor :: Color -> String showColor (RGB r g b) = show $ '#' : foldr showWord8Pad "" [r,g,b] showColor (RGBA r g b a) = show $ '#' : foldr showWord8Pad "" [r,g,b,a] showColor (HSV h s v) = show $ show h ++ " " ++ show s ++ " " ++ show v showColor (ColorName name) = name showWord8Pad :: Word8 -> String -> String showWord8Pad w s = padding ++ simple ++ s where simple = showHex w "" padding = replicate count '0' count = 2 - findCols 1 w findCols :: Int -> Word8 -> Int findCols c n | n < 16 = c | otherwise = findCols (c+1) (n `div` 16) instance Parseable Color where parse = quotedParse parseColor parseList = quotedParse $ sepBy1 parseColor (char ':') parseColor :: Parse Color parseColor = oneOf [ parseHexBased , parseHSV , liftM ColorName parse -- Should we check it is a colour? ] where parseHexBased = do char '#' cs <- many1 parse2Hex return $ case cs of [r,g,b] -> RGB r g b [r,g,b,a] -> RGBA r g b a _ -> error $ "Not a valid hex Color specification: " ++ show cs parseHSV = do h <- parse parseSep s <- parse parseSep v <- parse return $ HSV h s v parseSep = oneOf [ string "," , whitespace ] parse2Hex = do c1 <- satisfy isHexDigit c2 <- satisfy isHexDigit let [(n, [])] = readHex [c1, c2] return n -- ----------------------------------------------------------------------------- data ClusterMode = Local | Global | NoCluster deriving (Eq, Read) instance Show ClusterMode where show Local = "local" show Global = "global" show NoCluster = "none" instance Parseable ClusterMode where parse = optionalQuoted . oneOf $ [ string "local" >> return Local , string "global" >> return Global , string "none" >> return NoCluster ] -- ----------------------------------------------------------------------------- data DirType = Forward | Back | Both | NoDir deriving (Eq, Read) instance Show DirType where show Forward = "forward" show Back = "back" show Both = "both" show NoDir = "none" instance Parseable DirType where parse = optionalQuoted $ oneOf [ string "forward" >> return Forward , string "back" >> return Back , string "both" >> return Both , string "none" >> return NoDir ] -- ----------------------------------------------------------------------------- -- | Only when @mode=ipsep@. data DEConstraints = DEBool Bool | Hier deriving (Eq, Read) instance Show DEConstraints where show (DEBool b) = show b show Hier = "hier" instance Parseable DEConstraints where parse = optionalQuoted $ oneOf [ liftM DEBool parse , string "hier" >> return Hier ] -- ----------------------------------------------------------------------------- -- | Either a 'Double' or a 'Point'. data DPoint = DVal Double | PVal Point deriving (Eq, Read) instance Show DPoint where show (DVal d) = show d show (PVal p) = show p instance Parseable DPoint where parse = oneOf [ liftM DVal parse , liftM PVal parsePoint ] -- ----------------------------------------------------------------------------- data Label = StrLabel String | URLLabel URL deriving (Eq, Read) instance Show Label where show (StrLabel s) = s show (URLLabel u) = show u instance Parseable Label where parse = oneOf [ liftM StrLabel parse , liftM URLLabel parse ] -- ----------------------------------------------------------------------------- data Point = Point Int Int | PointD Double Double deriving (Eq, Read) instance Show Point where show = show . showPoint showList ps s = unwords (map showPoint ps) ++ s showPoint :: Point -> String showPoint (Point x y) = show x ++ ',' : show y showPoint (PointD x y) = show x ++ ',' : show y instance Parseable Point where parse = quotedParse parsePoint parseList = quotedParse $ sepBy1 parsePoint whitespace parsePoint :: Parse Point parsePoint = oneOf [ liftM (uncurry Point) commaSep , liftM (uncurry PointD) commaSep ] -- ----------------------------------------------------------------------------- data Overlap = KeepOverlaps | RemoveOverlaps | ScaleOverlaps | ScaleXYOverlaps | PrismOverlap (Maybe Int) -- ^ Only when sfdp is available, @Int@ is non-negative | CompressOverlap | VpscOverlap | IpsepOverlap -- ^ Only when @mode="ipsep"@ deriving (Eq, Read) instance Show Overlap where show KeepOverlaps = "true" show RemoveOverlaps = "false" show ScaleOverlaps = "scale" show ScaleXYOverlaps = "scalexy" show (PrismOverlap i) = maybe id (flip (++) . show) i $ "prism" show CompressOverlap = "compress" show VpscOverlap = "vpsc" show IpsepOverlap = "ipsep" instance Parseable Overlap where parse = optionalQuoted $ oneOf [ string "true" >> return KeepOverlaps , string "false" >> return RemoveOverlaps , string "scale" >> return ScaleOverlaps , string "scalexy" >> return ScaleXYOverlaps , string "prism" >> liftM PrismOverlap (optional parse) , string "compress" >> return CompressOverlap , string "vpsc" >> return VpscOverlap , string "ipsep" >> return IpsepOverlap ] -- ----------------------------------------------------------------------------- data LayerRange = LRID LayerID | LRS LayerID String LayerID deriving (Eq, Read) instance Show LayerRange where show (LRID lid) = show lid show (LRS id1 sep id2) = show $ show id1 ++ sep ++ show id2 instance Parseable LayerRange where parse = oneOf [ liftM LRID parse , do id1 <- parse sep <- parseLayerSep id2 <- parse return $ LRS id1 sep id2 ] parseLayerSep :: Parse String parseLayerSep = many1 . oneOf $ map char defLayerSep defLayerSep :: [Char] defLayerSep = [' ', ':', '\t'] parseLayerName :: Parse String parseLayerName = many1 $ satisfy (flip notElem defLayerSep) data LayerID = AllLayers | LRInt Int | LRName String deriving (Eq, Read) instance Show LayerID where show AllLayers = "all" show (LRInt n) = show n show (LRName nm) = nm instance Parseable LayerID where parse = oneOf [ optionalQuotedString "all" >> return AllLayers , liftM LRInt $ optionalQuoted parse , liftM LRName parseLayerName ] -- | The list represent (Separator, Name) data LayerList = LL String [(String, String)] deriving (Eq, Read) instance Show LayerList where show (LL l1 ols) = l1 ++ concatMap (uncurry (++)) ols instance Parseable LayerList where parse = do l1 <- parseLayerName ols <- many $ do sep <- parseLayerSep lnm <- parseLayerName return (sep, lnm) return $ LL l1 ols -- ----------------------------------------------------------------------------- data OutputMode = BreadthFirst | NodesFirst | EdgesFirst deriving (Eq, Read) instance Show OutputMode where show BreadthFirst = "breadthfirst" show NodesFirst = "nodesfirst" show EdgesFirst = "edgesfirst" instance Parseable OutputMode where parse = optionalQuoted $ oneOf [ string "breadthfirst" >> return BreadthFirst , string "nodesfirst" >> return NodesFirst , string "edgesfirst" >> return EdgesFirst ] -- ----------------------------------------------------------------------------- data Pack = DoPack | DontPack | PackMargin Int -- ^ If non-negative, then packs; otherwise doesn't. deriving (Eq, Read) instance Show Pack where show DoPack = "true" show DontPack = "false" show (PackMargin m) = show m instance Parseable Pack where parse = optionalQuoted $ oneOf [ liftM (bool DoPack DontPack) parse , liftM PackMargin parse ] -- ----------------------------------------------------------------------------- data PackMode = PackNode | PackClust | PackGraph | PackArray Bool Bool (Maybe Int) -- ^ Sort by cols, sort -- by user, number of -- rows/cols deriving (Eq, Read) instance Show PackMode where show PackNode = "node" show PackClust = "clust" show PackGraph = "graph" show (PackArray c u mi) = addNum . isU . isC . isUnder $ "array" where addNum = maybe id (flip (++) . show) mi isUnder = if c || u then flip (++) "_" else id isC = if c then flip (++) "c" else id isU = if u then flip (++) "u" else id instance Parseable PackMode where parse = optionalQuoted $ oneOf [ string "node" >> return PackNode , string "clust" >> return PackClust , string "graph" >> return PackGraph , do string "array" mcu <- optional $ do char '_' many1 $ satisfy (not . isDigit) let c = hasChar mcu 'c' u = hasChar mcu 'u' mi <- optional parse return $ PackArray c u mi ] where hasChar ms c = maybe False (elem c) ms -- ----------------------------------------------------------------------------- data Pos = PointPos Point | SplinePos [Spline] deriving (Eq, Read) instance Show Pos where show (PointPos p) = show p show (SplinePos ss) = show ss instance Parseable Pos where -- [Spline] must be quoted, so use the quoted parser for Point as -- well. parse = oneOf [ liftM PointPos parse , liftM SplinePos parse ] -- ----------------------------------------------------------------------------- -- | Controls how (and if) edges are represented. data EdgeType = SplineEdges | LineEdges | NoEdges | PolyLine | CompoundEdge -- ^ fdp only deriving (Eq, Read) instance Show EdgeType where show SplineEdges = "true" show LineEdges = "false" show NoEdges = "\"\"" show PolyLine = "polyline" show CompoundEdge = "compound" instance Parseable EdgeType where parse = optionalQuoted $ oneOf [ liftM (bool SplineEdges LineEdges) parse , string "spline" >> return SplineEdges , string "line" >> return LineEdges , string "\"\"" >> return NoEdges , string "polyline" >> return PolyLine , string "compound" >> return CompoundEdge ] -- ----------------------------------------------------------------------------- -- | Upper-case first character is major order; -- lower-case second character is minor order. data PageDir = Bl | Br | Tl | Tr | Rb | Rt | Lb | Lt deriving (Eq, Read) instance Show PageDir where show Bl = "BL" show Br = "BR" show Tl = "TL" show Tr = "TR" show Rb = "RB" show Rt = "RT" show Lb = "LB" show Lt = "LT" instance Parseable PageDir where parse = optionalQuoted $ oneOf [ string "BL" >> return Bl , string "BR" >> return Br , string "TL" >> return Tl , string "TR" >> return Tr , string "RB" >> return Rb , string "RT" >> return Rt , string "LB" >> return Lb , string "LT" >> return Lt ] -- ----------------------------------------------------------------------------- -- | The number of points in the list must be equivalent to 1 mod 3; -- note that this is not checked. data Spline = Spline (Maybe Point) (Maybe Point) [Point] deriving (Eq, Read) instance Show Spline where show = show . showSpline showList ss o = show $ go ss where go [] = o go [s] = showSpline s ++ o go (s:ss') = showSpline s ++ ';' : go ss' showSpline :: Spline -> String showSpline (Spline ms me ps) = addS . addE . unwords $ map showPoint ps where addP t = maybe id (\p -> (++) $ t : ',' : show p) addS = addP 's' ms addE = addP 'e' me instance Parseable Spline where parse = quotedParse parseSpline parseList = quotedParse $ sepBy1 parseSpline (char ';') parseSpline :: Parse Spline parseSpline = do ms <- parseP 's' whitespace me <- parseP 'e' whitespace ps <- sepBy1 parsePoint whitespace return $ Spline ms me ps where parseP t = optional $ do char t char ';' parse -- ----------------------------------------------------------------------------- data QuadType = NormalQT | FastQT | NoQT deriving (Eq, Read) instance Show QuadType where show NormalQT = "normal" show FastQT = "fast" show NoQT = "none" instance Parseable QuadType where -- Have to take into account the slightly different interpretation -- of Bool used as an option for parsing QuadType parse = optionalQuoted $ oneOf [ string "normal" >> return NormalQT , string "fast" >> return FastQT , string "none" >> return NoQT , char '2' >> return FastQT -- weird bool , liftM (bool NormalQT NoQT) parse ] -- ----------------------------------------------------------------------------- -- | Specify the root node either as a Node attribute or a Graph attribute. data Root = IsCentral -- ^ For Nodes only | NotCentral -- ^ For Nodes only | NodeName String -- ^ For Graphs only deriving (Eq, Read) instance Show Root where show IsCentral = "true" show NotCentral = "false" show (NodeName n) = n instance Parseable Root where parse = optionalQuoted $ oneOf [ liftM (bool IsCentral NotCentral) parse , liftM NodeName parse ] -- ----------------------------------------------------------------------------- data RankType = SameRank | MinRank | SourceRank | MaxRank | SinkRank deriving (Eq, Read) instance Show RankType where show SameRank = "same" show MinRank = "min" show SourceRank = "source" show MaxRank = "max" show SinkRank = "sink" instance Parseable RankType where parse = optionalQuoted $ oneOf [ string "same" >> return SameRank , string "min" >> return MinRank , string "source" >> return SourceRank , string "max" >> return MaxRank , string "sink" >> return SinkRank ] -- ----------------------------------------------------------------------------- data RankDir = FromTop | FromLeft | FromBottom | FromRight deriving (Eq, Read) instance Show RankDir where show FromTop = "TB" show FromLeft = "LR" show FromBottom = "BT" show FromRight = "RL" instance Parseable RankDir where parse = optionalQuoted $ oneOf [ string "TB" >> return FromTop , string "LR" >> return FromLeft , string "BT" >> return FromBottom , string "RL" >> return FromRight ] -- ----------------------------------------------------------------------------- data Shape = BoxShape | Polygon | Ellipse | Circle | PointShape | Egg | Triangle | Plaintext | DiamondShape | Trapezium | Parallelogram | House | Pentagon | Hexagon | Septagon | Octagon | Doublecircle | Doubleoctagon | Tripleoctagon | Invtriangle | Invtrapezium | Invhouse | Mdiamond | Msquare | Mcircle | Rectangle | NoShape | Note | Tab | Folder | Box3d | Component deriving (Eq, Read) instance Show Shape where show BoxShape = "box" show Polygon = "polygon" show Ellipse = "ellipse" show Circle = "circle" show PointShape = "point" show Egg = "egg" show Triangle = "triangle" show Plaintext = "plaintext" show DiamondShape = "diamond" show Trapezium = "trapezium" show Parallelogram = "parallelogram" show House = "house" show Pentagon = "pentagon" show Hexagon = "hexagon" show Septagon = "septagon" show Octagon = "octagon" show Doublecircle = "doublecircle" show Doubleoctagon = "doubleoctagon" show Tripleoctagon = "tripleoctagon" show Invtriangle = "invtriangle" show Invtrapezium = "invtrapezium" show Invhouse = "invhouse" show Mdiamond = "mdiamond" show Msquare = "msquare" show Mcircle = "mcircle" show Rectangle = "rectangle" show NoShape = "none" show Note = "note" show Tab = "tab" show Folder = "folder" show Box3d = "box3d" show Component = "component" instance Parseable Shape where parse = optionalQuoted $ oneOf [ string "box" >> return BoxShape , string "polygon" >> return Polygon , string "ellipse" >> return Ellipse , string "circle" >> return Circle , string "point" >> return PointShape , string "egg" >> return Egg , string "triangle" >> return Triangle , string "plaintext" >> return Plaintext , string "diamond" >> return DiamondShape , string "trapezium" >> return Trapezium , string "parallelogram" >> return Parallelogram , string "house" >> return House , string "pentagon" >> return Pentagon , string "hexagon" >> return Hexagon , string "septagon" >> return Septagon , string "octagon" >> return Octagon , string "doublecircle" >> return Doublecircle , string "doubleoctagon" >> return Doubleoctagon , string "tripleoctagon" >> return Tripleoctagon , string "invtriangle" >> return Invtriangle , string "invtrapezium" >> return Invtrapezium , string "invhouse" >> return Invhouse , string "mdiamond" >> return Mdiamond , string "msquare" >> return Msquare , string "mcircle" >> return Mcircle , string "rectangle" >> return Rectangle , string "none" >> return NoShape , string "note" >> return Note , string "tab" >> return Tab , string "folder" >> return Folder , string "box3d" >> return Box3d , string "component" >> return Component ] -- ----------------------------------------------------------------------------- data SmoothType = NoSmooth | AvgDist | GraphDist | PowerDist | RNG | Spring | TriangleSmooth deriving (Eq, Read) instance Show SmoothType where show NoSmooth = "none" show AvgDist = "avg_dist" show GraphDist = "graph_dist" show PowerDist = "power_dist" show RNG = "rng" show Spring = "spring" show TriangleSmooth = "triangle" instance Parseable SmoothType where parse = optionalQuoted $ oneOf [ string "none" >> return NoSmooth , string "avg_dist" >> return AvgDist , string "graph_dist" >> return GraphDist , string "power_dist" >> return PowerDist , string "rng" >> return RNG , string "spring" >> return Spring , string "triangle" >> return TriangleSmooth ] -- ----------------------------------------------------------------------------- -- | It it assumed that at least one of these is @Just{}@. data StartType = ST (Maybe STStyle) (Maybe Int) -- Use a Word? deriving (Eq, Read) instance Show StartType where show (ST ms mi) = maybe id ((++) . show) ms $ maybe "" show mi instance Parseable StartType where parse = optionalQuoted $ do ms <- optional parse mi <- optional parse return $ ST ms mi data STStyle = RegularStyle | Self | Random deriving (Eq, Read) instance Show STStyle where show RegularStyle = "regular" show Self = "self" show Random = "random" instance Parseable STStyle where parse = oneOf [ string "regular" >> return RegularStyle , string "self" >> return Self , string "random" >> return Random ] -- ----------------------------------------------------------------------------- data Style = Stl StyleName (Maybe String) deriving (Eq, Read) instance Show Style where show (Stl nm marg) = maybe snm (\arg -> show $ snm ++ '(' : arg ++ ")") marg where snm = show nm instance Parseable Style where parse = oneOf [ optionalQuoted $ liftM (\nm -> Stl nm Nothing) parse , quotedParse $ do nm <- parse char '(' arg <- many1 $ satisfy (flip notElem "()") char ')' return $ Stl nm (Just arg) ] data StyleName = Dashed -- ^ Nodes and Edges | Dotted -- ^ Nodes and Edges | Solid -- ^ Nodes and Edges | Bold -- ^ Nodes and Edges | Invisible -- ^ Nodes and Edges | Filled -- ^ Nodes and Clusters | Diagonals -- ^ Nodes only | Rounded -- ^ Nodes and Clusters deriving (Eq, Read) instance Show StyleName where show Filled = "filled" show Invisible = "invis" show Diagonals = "diagonals" show Rounded = "rounded" show Dashed = "dashed" show Dotted = "dotted" show Solid = "solid" show Bold = "bold" instance Parseable StyleName where parse = optionalQuoted $ oneOf [ string "filled" >> return Filled , string "invis" >> return Invisible , string "diagonals" >> return Diagonals , string "rounded" >> return Rounded , string "dashed" >> return Dashed , string "dotted" >> return Dotted , string "solid" >> return Solid , string "bold" >> return Bold ] -- ----------------------------------------------------------------------------- newtype PortPos = PP CompassPoint deriving (Eq, Read) instance Show PortPos where show (PP cp) = show cp instance Parseable PortPos where parse = liftM PP parse data CompassPoint = North | NorthEast | East | SouthEast | South | SouthWest | West | NorthWest | CenterPoint | NoCP deriving (Eq, Read) instance Show CompassPoint where show North = "n" show NorthEast = "ne" show East = "e" show SouthEast = "se" show South = "s" show SouthWest = "sw" show West = "w" show NorthWest = "nw" show CenterPoint = "c" show NoCP = "_" instance Parseable CompassPoint where parse = optionalQuoted $ oneOf [ string "n" >> return North , string "ne" >> return NorthEast , string "e" >> return East , string "se" >> return SouthEast , string "s" >> return South , string "sw" >> return SouthWest , string "w" >> return West , string "nw" >> return NorthWest , string "c" >> return CenterPoint , string "_" >> return NoCP ] -- ----------------------------------------------------------------------------- data ViewPort = VP { wVal :: Double , hVal :: Double , zVal :: Double , focus :: Maybe FocusType } deriving (Eq, Read) instance Show ViewPort where show vp = show . maybe id (flip (++) . show) (focus vp) $ show (wVal vp) ++ ',' : show (hVal vp) ++ ',' : show (zVal vp) instance Parseable ViewPort where parse = quotedParse $ do wv <- parse char ',' hv <- parse char ',' zv <- parse mf <- optional $ char ',' >> parse return $ VP wv hv zv mf data FocusType = XY Point | NodeFocus String deriving (Eq, Read) instance Show FocusType where show (XY p) = showPoint p show (NodeFocus nm) = nm instance Parseable FocusType where parse = oneOf [ liftM XY parsePoint , liftM NodeFocus stringBlock ] -- ----------------------------------------------------------------------------- -- | Note that 'VCenter' is only valid for Nodes. data VerticalPlacement = VTop | VCenter | VBottom deriving (Eq, Read) instance Show VerticalPlacement where show VTop = "t" show VCenter = "c" show VBottom = "b" instance Parseable VerticalPlacement where parse = optionalQuoted $ oneOf [ string "t" >> return VTop , string "c" >> return VCenter , string "b" >> return VBottom ] -- ----------------------------------------------------------------------------- data ScaleType = UniformScale | NoScale | FillWidth | FillHeight | FillBoth deriving (Eq, Read) instance Show ScaleType where show UniformScale = "true" show NoScale = "false" show FillWidth = "width" show FillHeight = "height" show FillBoth = "both" instance Parseable ScaleType where parse = optionalQuoted $ oneOf [ string "true" >> return UniformScale , string "false" >> return NoScale , string "width" >> return FillWidth , string "height" >> return FillHeight , string "both" >> return FillBoth ] -- ----------------------------------------------------------------------------- data Justification = JLeft | JRight | JCenter deriving (Eq, Read) instance Show Justification where show JLeft = "l" show JRight = "r" show JCenter = "c" instance Parseable Justification where parse = optionalQuoted $ oneOf [ string "l" >> return JLeft , string "r" >> return JRight , string "c" >> return JCenter ] -- ----------------------------------------------------------------------------- data Ratios = AspectRatio Double | FillRatio | CompressRatio | ExpandRatio | AutoRatio deriving (Eq, Read) instance Show Ratios where show (AspectRatio r) = show r show FillRatio = "fill" show CompressRatio = "compress" show ExpandRatio = "expand" show AutoRatio = "auto" instance Parseable Ratios where parse = optionalQuoted $ oneOf [ liftM AspectRatio parse , string "fill" >> return FillRatio , string "compress" >> return CompressRatio , string "expand" >> return ExpandRatio , string "auto" >> return AutoRatio ] -- ----------------------------------------------------------------------------- -- | Represents 'String's that definitely have quotes around them. newtype QuotedString = QS { qStr :: String } deriving (Eq, Read) instance Show QuotedString where show = show . qStr instance Parseable QuotedString where parse = liftM (QS . tail . init) quotedString -- ----------------------------------------------------------------------------- -- Utility Functions -- | Fold over 'Bool's. bool :: a -> a -> Bool -> a bool t f b = if b then t else f