module Graphics.Fig.Printer (pretty) where
import Graphics.Fig.Syntax
import Graphics.Fig.Values
import Text.PrettyPrint.HughesPJ
pretty
:: Fig
-> String
pretty tree = show (fig tree)
fig (Fig h cls objs) =
header h $+$
colors cls $+$
objects objs $+$
text ""
header (Header h1 h2 h3 h4 h5 h6 h7 h8 h9 h10) =
vcat
[ text header_version
, doc h1
, doc h2
, doc h3
, doc h4
, doc h5
, doc h6
, doc h7
, commentStrings h8
, doc h9 <+> doc h10
]
commented doc (Comment cs obj) =
commentStrings cs $+$
doc obj
commentStrings lines = vcat (map commentLine lines)
commentLine line = text ('#' : line)
colors cls = vcat (map (commented color) cls)
color (Color c1 c2) =
hsep
[ text begin_color
, doc c1
, text c2
]
objects objs = vcat (map (commented object) objs)
object o =
case o of
Arc line fw bw ->
arcLine line fw bw $+$
indent (maybeArrow fw) $+$
indent (maybeArrow bw)
Ellipse common e10 e11 e12 e13 e14 e15 e16 e17 e18 e19 ->
hsep
[ text begin_ellipse
, commonLine common
, doc e10
, doc e11
, doc e12
, doc e13
, doc e14
, doc e15
, doc e16
, doc e17
, doc e18
, doc e19
]
Polyline polyline fw bw pic pts ->
polylineLine polyline fw bw pts $+$
indent (maybeArrow fw) $+$
indent (maybeArrow bw) $+$
indent (maybePic pic) $+$
indent (hsep (map point pts))
Spline spline fw bw pts ctrl ->
splineLine spline fw bw pts $+$
indent (maybeArrow fw) $+$
indent (maybeArrow bw) $+$
indent (hsep (map point pts)) $+$
indent (hsep (map doc ctrl))
Text t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12 t13->
hsep
[ text begin_text
, doc t1
, doc t2
, doc t3
, doc t4
, doc t5
, doc t6
, doc t7
, doc (fromFontFlags t5 t8)
, doc t9
, doc t10
, doc t11
, doc t12
, text t13 <> text "\\001"
]
Compound line objs ->
compoundLine line $+$
objects objs $+$
text end_compound
compoundLine (CompoundLine c1 c2 c3 c4) =
hsep
[ text begin_compound
, doc c1
, doc c2
, doc c3
, doc c4
]
arcLine
(ArcLine common a10 a11 a14 a15 a16 a17 a18 a19 a20 a21) fw bw =
hsep
[ text begin_arc
, commonLine common
, doc a10
, doc a11
, arrowFlag fw
, arrowFlag bw
, doc a14
, doc a15
, doc a16
, doc a17
, doc a18
, doc a19
, doc a20
, doc a21
]
splineLine (SplineLine common s10) fw bw npoints =
hsep
[ text begin_spline
, commonLine common
, doc s10
, arrowFlag fw
, arrowFlag bw
, doc (length npoints)
]
polylineLine (PolylineLine common p10 p11 p12) fw bw npoints =
hsep
[ text begin_polyline
, commonLine common
, doc p10
, doc p11
, doc p12
, arrowFlag fw
, arrowFlag bw
, doc (length npoints)
]
point (x, y) = doc x <+> doc y
pic (Pic p1 p2) = doc p1 <+> text p2
maybePic p = maybe empty pic p
arrow (Arrow a1 a2 a3 a4 a5) =
hsep
[ doc a1
, doc a2
, doc a3
, doc a4
, doc a5
]
maybeArrow a = maybe empty arrow a
arrowFlag Nothing = text "0"
arrowFlag (Just _) = text "1"
commonLine (Common p1 p2 p3 p4 p5 p6 p7 p8 p9) =
hsep
[ doc p1
, doc p2
, doc p3
, doc p4
, doc p5
, doc p6
, doc p7
, doc p8
, doc p9
]
indent doc = nest 8 doc
class Docable a where
doc :: a -> Doc
instance Docable Int where doc = text . show
instance Docable Integer where doc = text . show
instance Docable Double where doc = text . show
instance Docable Orientation where doc = text . fromOrientation
instance Docable Units where doc = text . fromUnits
instance Docable PaperSize where doc = text . fromPaperSize
instance Docable MultiplePage where doc = text . fromMultiplePage
instance Docable Justification where
doc Center = text "Center"
doc FlushLeft = text "Flush Left"
instance Docable LineStyle where doc = doc . fromLineStyle
instance Docable JoinStyle where doc = doc . fromJoinStyle
instance Docable CapStyle where doc = doc . fromCapStyle
instance Docable Flipped where doc = doc . fromFlipped
instance Docable ArrowType where doc = doc . fromArrowType
instance Docable ArrowStyle where doc = doc . fromArrowStyle
instance Docable ColorSpec where doc = doc . fromColorSpec
instance Docable AreaFill where doc = doc . fromAreaFill
instance Docable Transparent where doc = doc . fromTransparent
instance Docable CoordinateSystem where doc = doc . fromCoordinateSystem
instance Docable Font where doc = doc . fromFont