module Graphics.Svg.Types
(
Coord
, Origin( .. )
, Point
, RPoint
, PathCommand( .. )
, Transformation( .. )
, ElementRef( .. )
, CoordinateUnits( .. )
, toPoint
, serializeNumber
, serializeTransformation
, serializeTransformations
, Cap( .. )
, LineJoin( .. )
, Tree( .. )
, Number( .. )
, Spread( .. )
, Texture( .. )
, Element( .. )
, FillRule( .. )
, FontStyle( .. )
, Dpi
, WithDefaultSvg( .. )
, Document( .. )
, HasDocument( .. )
, documentSize
, DrawAttributes( .. )
, HasDrawAttributes( .. )
, WithDrawAttributes( .. )
, Rectangle( .. )
, HasRectangle( .. )
, Line( .. )
, HasLine( .. )
, Polygon( .. )
, HasPolygon( .. )
, PolyLine( .. )
, HasPolyLine( .. )
, Path( .. )
, HasPath( .. )
, Circle( .. )
, HasCircle( .. )
, Ellipse( .. )
, HasEllipse( .. )
, Image( .. )
, HasImage( .. )
, Use( .. )
, HasUse( .. )
, Group( .. )
, HasGroup( .. )
, Symbol( .. )
, groupOfSymbol
, Text( .. )
, HasText( .. )
, TextAnchor( .. )
, textAt
, TextPath( .. )
, HasTextPath( .. )
, TextPathSpacing( .. )
, TextPathMethod( .. )
, TextSpanContent( .. )
, TextSpan( .. )
, HasTextSpan( .. )
, TextInfo( .. )
, HasTextInfo( .. )
, TextAdjust( .. )
, Marker( .. )
, MarkerOrientation( .. )
, MarkerUnit( .. )
, HasMarker( .. )
, GradientStop( .. )
, HasGradientStop( .. )
, LinearGradient( .. )
, HasLinearGradient( .. )
, RadialGradient( .. )
, HasRadialGradient( .. )
, Pattern( .. )
, HasPattern( .. )
, Mask( .. )
, HasMask( .. )
, ClipPath( .. )
, HasClipPath( .. )
, isPathArc
, isPathWithArc
, nameOfTree
, zipTree
, mapTree
, foldTree
, toUserUnit
, mapNumber
) where
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid( Monoid( .. ) )
import Data.Foldable( Foldable )
#endif
import Data.Function( on )
import Data.List( inits )
import qualified Data.Map as M
import Data.Monoid( Last( .. ), (<>) )
import qualified Data.Foldable as F
import qualified Data.Text as T
import Codec.Picture( PixelRGBA8( .. ) )
import Control.Lens( Lens'
, lens
, makeClassy
, makeLenses
, view
, (^.)
, (&)
, (.~)
)
import Graphics.Svg.CssTypes
import Linear hiding ( angle )
import Text.Printf
type Coord = Float
type RPoint = V2 Coord
type Point = (Number, Number)
data Origin
= OriginAbsolute
| OriginRelative
deriving (Eq, Show)
data PathCommand
= MoveTo Origin [RPoint]
| LineTo Origin [RPoint]
| HorizontalTo Origin [Coord]
| VerticalTo Origin [Coord]
| CurveTo Origin [(RPoint, RPoint, RPoint)]
| SmoothCurveTo Origin [(RPoint, RPoint)]
| QuadraticBezier Origin [(RPoint, RPoint)]
| SmoothQuadraticBezierCurveTo Origin [RPoint]
| ElipticalArc Origin [(Coord, Coord, Coord, Coord, Coord, RPoint)]
| EndPath
deriving (Eq, Show)
toPoint :: Number -> Number -> Point
toPoint = (,)
isPathArc :: PathCommand -> Bool
isPathArc (ElipticalArc _ _) = True
isPathArc _ = False
isPathWithArc :: Foldable f => f PathCommand -> Bool
isPathWithArc = F.any isPathArc
data Cap
= CapRound
| CapButt
| CapSquare
deriving (Eq, Show)
data LineJoin
= JoinMiter
| JoinBevel
| JoinRound
deriving (Eq, Show)
data Texture
= ColorRef PixelRGBA8
| TextureRef String
| FillNone
deriving (Eq, Show)
data FillRule
= FillEvenOdd
| FillNonZero
deriving (Eq, Show)
data Transformation
=
TransformMatrix Coord Coord Coord
Coord Coord Coord
| Translate Float Float
| Scale Float (Maybe Float)
| Rotate Float (Maybe (Float, Float))
| SkewX Float
| SkewY Float
| TransformUnknown
deriving (Eq, Show)
serializeTransformation :: Transformation -> String
serializeTransformation t = case t of
TransformUnknown -> ""
TransformMatrix a b c d e f ->
printf "matrix(%g, %g, %g, %g, %g, %g)" a b c d e f
Translate x y -> printf "translate(%g, %g)" x y
Scale x Nothing -> printf "scale(%g)" x
Scale x (Just y) -> printf "scale(%g, %g)" x y
Rotate angle Nothing -> printf "rotate(%g)" angle
Rotate angle (Just (x, y))-> printf "rotate(%g, %g, %g)" angle x y
SkewX x -> printf "skewX(%g)" x
SkewY y -> printf "skewY(%g)" y
serializeTransformations :: [Transformation] -> String
serializeTransformations =
unwords . fmap serializeTransformation
class WithDrawAttributes a where
drawAttr :: Lens' a DrawAttributes
class WithDefaultSvg a where
defaultSvg :: a
data FontStyle
= FontStyleNormal
| FontStyleItalic
| FontStyleOblique
deriving (Eq, Show)
data TextAnchor
= TextAnchorStart
| TextAnchorMiddle
| TextAnchorEnd
deriving (Eq, Show)
data ElementRef
= RefNone
| Ref String
deriving (Eq, Show)
data DrawAttributes = DrawAttributes
{
_strokeWidth :: !(Last Number)
, _strokeColor :: !(Last Texture)
, _strokeOpacity :: !(Maybe Float)
, _strokeLineCap :: !(Last Cap)
, _strokeLineJoin :: !(Last LineJoin)
, _strokeMiterLimit :: !(Last Float)
, _fillColor :: !(Last Texture)
, _fillOpacity :: !(Maybe Float)
, _groupOpacity :: !(Maybe Float)
, _transform :: !(Maybe [Transformation])
, _fillRule :: !(Last FillRule)
, _maskRef :: !(Last ElementRef)
, _clipPathRef :: !(Last ElementRef)
, _clipRule :: !(Last FillRule)
, _attrClass :: ![T.Text]
, _attrId :: !(Maybe String)
, _strokeOffset :: !(Last Number)
, _strokeDashArray :: !(Last [Number])
, _fontSize :: !(Last Number)
, _fontFamily :: !(Last [String])
, _fontStyle :: !(Last FontStyle)
, _textAnchor :: !(Last TextAnchor)
, _markerStart :: !(Last ElementRef)
, _markerMid :: !(Last ElementRef)
, _markerEnd :: !(Last ElementRef)
}
deriving (Eq, Show)
makeClassy ''DrawAttributes
data PolyLine = PolyLine
{
_polyLineDrawAttributes :: DrawAttributes
, _polyLinePoints :: [RPoint]
}
deriving (Eq, Show)
makeClassy ''PolyLine
instance WithDefaultSvg PolyLine where
defaultSvg = PolyLine
{ _polyLineDrawAttributes = mempty
, _polyLinePoints = []
}
instance WithDrawAttributes PolyLine where
drawAttr = polyLineDrawAttributes
data Polygon = Polygon
{
_polygonDrawAttributes :: DrawAttributes
, _polygonPoints :: [RPoint]
}
deriving (Eq, Show)
makeClassy ''Polygon
instance WithDrawAttributes Polygon where
drawAttr = polygonDrawAttributes
instance WithDefaultSvg Polygon where
defaultSvg = Polygon
{ _polygonDrawAttributes = mempty
, _polygonPoints = []
}
data Line = Line
{
_lineDrawAttributes :: DrawAttributes
, _linePoint1 :: Point
, _linePoint2 :: Point
}
deriving (Eq, Show)
makeClassy ''Line
instance WithDrawAttributes Line where
drawAttr = lineDrawAttributes
instance WithDefaultSvg Line where
defaultSvg = Line
{ _lineDrawAttributes = mempty
, _linePoint1 = zeroPoint
, _linePoint2 = zeroPoint
}
where zeroPoint = (Num 0, Num 0)
data Rectangle = Rectangle
{
_rectDrawAttributes :: DrawAttributes
, _rectUpperLeftCorner :: Point
, _rectWidth :: Number
, _rectHeight :: Number
, _rectCornerRadius :: (Number, Number)
}
deriving (Eq, Show)
makeClassy ''Rectangle
instance WithDrawAttributes Rectangle where
drawAttr = rectDrawAttributes
instance WithDefaultSvg Rectangle where
defaultSvg = Rectangle
{ _rectDrawAttributes = mempty
, _rectUpperLeftCorner = (Num 0, Num 0)
, _rectWidth = Num 0
, _rectHeight = Num 0
, _rectCornerRadius = (Num 0, Num 0)
}
data Path = Path
{
_pathDrawAttributes :: DrawAttributes
, _pathDefinition :: [PathCommand]
}
deriving (Eq, Show)
makeClassy ''Path
instance WithDrawAttributes Path where
drawAttr = pathDrawAttributes
instance WithDefaultSvg Path where
defaultSvg = Path
{ _pathDrawAttributes = mempty
, _pathDefinition = []
}
data Group a = Group
{
_groupDrawAttributes :: !DrawAttributes
, _groupChildren :: ![a]
, _groupViewBox :: !(Maybe (Int, Int, Int, Int))
}
deriving (Eq, Show)
makeClassy ''Group
instance WithDrawAttributes (Group a) where
drawAttr = groupDrawAttributes
instance WithDefaultSvg (Group a) where
defaultSvg = Group
{ _groupDrawAttributes = mempty
, _groupChildren = []
, _groupViewBox = Nothing
}
newtype Symbol a =
Symbol { _groupOfSymbol :: Group a }
deriving (Eq, Show)
makeLenses ''Symbol
instance WithDrawAttributes (Symbol a) where
drawAttr = groupOfSymbol . drawAttr
instance WithDefaultSvg (Symbol a) where
defaultSvg = Symbol defaultSvg
data Circle = Circle
{
_circleDrawAttributes :: DrawAttributes
, _circleCenter :: Point
, _circleRadius :: Number
}
deriving (Eq, Show)
makeClassy ''Circle
instance WithDrawAttributes Circle where
drawAttr = circleDrawAttributes
instance WithDefaultSvg Circle where
defaultSvg = Circle
{ _circleDrawAttributes = mempty
, _circleCenter = (Num 0, Num 0)
, _circleRadius = Num 0
}
data Ellipse = Ellipse
{
_ellipseDrawAttributes :: DrawAttributes
, _ellipseCenter :: Point
, _ellipseXRadius :: Number
, _ellipseYRadius :: Number
}
deriving (Eq, Show)
makeClassy ''Ellipse
instance WithDrawAttributes Ellipse where
drawAttr = ellipseDrawAttributes
instance WithDefaultSvg Ellipse where
defaultSvg = Ellipse
{ _ellipseDrawAttributes = mempty
, _ellipseCenter = (Num 0, Num 0)
, _ellipseXRadius = Num 0
, _ellipseYRadius = Num 0
}
data Image = Image
{
_imageDrawAttributes :: DrawAttributes
, _imageCornerUpperLeft :: Point
, _imageWidth :: Number
, _imageHeight :: Number
, _imageHref :: String
}
deriving (Eq, Show)
makeClassy ''Image
instance WithDrawAttributes Image where
drawAttr = imageDrawAttributes
instance WithDefaultSvg Image where
defaultSvg = Image
{ _imageDrawAttributes = mempty
, _imageCornerUpperLeft = (Num 0, Num 0)
, _imageWidth = Num 0
, _imageHeight = Num 0
, _imageHref = ""
}
data Use = Use
{
_useBase :: Point
, _useName :: String
, _useWidth :: Maybe Number
, _useHeight :: Maybe Number
, _useDrawAttributes :: DrawAttributes
}
deriving (Eq, Show)
makeClassy ''Use
instance WithDrawAttributes Use where
drawAttr = useDrawAttributes
instance WithDefaultSvg Use where
defaultSvg = Use
{ _useBase = (Num 0, Num 0)
, _useName = ""
, _useWidth = Nothing
, _useHeight = Nothing
, _useDrawAttributes = mempty
}
data TextInfo = TextInfo
{ _textInfoX :: ![Number]
, _textInfoY :: ![Number]
, _textInfoDX :: ![Number]
, _textInfoDY :: ![Number]
, _textInfoRotate :: ![Float]
, _textInfoLength :: !(Maybe Number)
}
deriving (Eq, Show)
instance Monoid TextInfo where
mempty = TextInfo [] [] [] [] [] Nothing
mappend (TextInfo x1 y1 dx1 dy1 r1 l1)
(TextInfo x2 y2 dx2 dy2 r2 l2) =
TextInfo (x1 <> x2) (y1 <> y2)
(dx1 <> dx2) (dy1 <> dy2)
(r1 <> r2)
(getLast $ Last l1 <> Last l2)
makeClassy ''TextInfo
instance WithDefaultSvg TextInfo where
defaultSvg = mempty
data TextSpanContent
= SpanText !T.Text
| SpanTextRef !String
| SpanSub !TextSpan
deriving (Eq, Show)
data TextSpan = TextSpan
{
_spanInfo :: !TextInfo
, _spanDrawAttributes :: !DrawAttributes
, _spanContent :: ![TextSpanContent]
}
deriving (Eq, Show)
makeClassy ''TextSpan
instance WithDefaultSvg TextSpan where
defaultSvg = TextSpan
{ _spanInfo = defaultSvg
, _spanDrawAttributes = mempty
, _spanContent = mempty
}
data TextPathMethod
= TextPathAlign
| TextPathStretch
deriving (Eq, Show)
data TextPathSpacing
= TextPathSpacingExact
| TextPathSpacingAuto
deriving (Eq, Show)
data TextPath = TextPath
{
_textPathStartOffset :: !Number
, _textPathName :: !String
, _textPathMethod :: !TextPathMethod
, _textPathSpacing :: !TextPathSpacing
, _textPathData :: ![PathCommand]
}
deriving (Eq, Show)
makeClassy ''TextPath
instance WithDefaultSvg TextPath where
defaultSvg = TextPath
{ _textPathStartOffset = Num 0
, _textPathName = mempty
, _textPathMethod = TextPathAlign
, _textPathSpacing = TextPathSpacingExact
, _textPathData = []
}
data TextAdjust
= TextAdjustSpacing
| TextAdjustSpacingAndGlyphs
deriving (Eq, Show)
data Text = Text
{
_textAdjust :: !TextAdjust
, _textRoot :: !TextSpan
}
deriving (Eq, Show)
makeClassy ''Text
textAt :: Point -> T.Text -> Text
textAt (x, y) txt = Text TextAdjustSpacing tspan where
tspan = defaultSvg
{ _spanContent = [SpanText txt]
, _spanInfo = defaultSvg
{ _textInfoX = [x]
, _textInfoY = [y]
}
}
instance WithDrawAttributes Text where
drawAttr = textRoot . spanDrawAttributes
instance WithDefaultSvg Text where
defaultSvg = Text
{ _textRoot = defaultSvg
, _textAdjust = TextAdjustSpacing
}
data Tree
= None
| UseTree { useInformation :: !Use
, useSubTree :: !(Maybe Tree) }
| GroupTree !(Group Tree)
| SymbolTree !(Symbol Tree)
| PathTree !Path
| CircleTree !Circle
| PolyLineTree !PolyLine
| PolygonTree !Polygon
| EllipseTree !Ellipse
| LineTree !Line
| RectangleTree !Rectangle
| TextTree !(Maybe TextPath) !Text
| ImageTree !Image
deriving (Eq, Show)
data MarkerOrientation
= OrientationAuto
| OrientationAngle Coord
deriving (Eq, Show)
data MarkerUnit
= MarkerUnitStrokeWidth
| MarkerUnitUserSpaceOnUse
deriving (Eq, Show)
data Marker = Marker
{
_markerDrawAttributes :: DrawAttributes
, _markerRefPoint :: (Number, Number)
, _markerWidth :: Maybe Number
, _markerHeight :: Maybe Number
, _markerOrient :: Maybe MarkerOrientation
, _markerUnits :: Maybe MarkerUnit
, _markerViewBox :: !(Maybe (Int, Int, Int, Int))
, _markerElements :: [Tree]
}
deriving (Eq, Show)
makeClassy ''Marker
instance WithDrawAttributes Marker where
drawAttr = markerDrawAttributes
instance WithDefaultSvg Marker where
defaultSvg = Marker
{ _markerDrawAttributes = mempty
, _markerRefPoint = (Num 0, Num 0)
, _markerWidth = Just (Num 3)
, _markerHeight = Just (Num 3)
, _markerOrient = Nothing
, _markerUnits = Nothing
, _markerViewBox = Nothing
, _markerElements = mempty
}
appNode :: [[a]] -> a -> [[a]]
appNode [] e = [[e]]
appNode (curr:above) e = (e:curr) : above
zipTree :: ([[Tree]] -> Tree) -> Tree -> Tree
zipTree f = dig [] where
dig prev e@None = f $ appNode prev e
dig prev e@(UseTree _ Nothing) = f $ appNode prev e
dig prev e@(UseTree nfo (Just u)) =
f . appNode prev . UseTree nfo . Just $ dig ([] : appNode prev e) u
dig prev e@(GroupTree g) =
f . appNode prev . GroupTree $ zipGroup (appNode prev e) g
dig prev e@(SymbolTree g) =
f . appNode prev . SymbolTree . Symbol .
zipGroup (appNode prev e) $ _groupOfSymbol g
dig prev e@(PathTree _) = f $ appNode prev e
dig prev e@(CircleTree _) = f $ appNode prev e
dig prev e@(PolyLineTree _) = f $ appNode prev e
dig prev e@(PolygonTree _) = f $ appNode prev e
dig prev e@(EllipseTree _) = f $ appNode prev e
dig prev e@(LineTree _) = f $ appNode prev e
dig prev e@(RectangleTree _) = f $ appNode prev e
dig prev e@(TextTree _ _) = f $ appNode prev e
dig prev e@(ImageTree _) = f $ appNode prev e
zipGroup prev g = g { _groupChildren = updatedChildren }
where
groupChild = _groupChildren g
updatedChildren =
[dig (c:prev) child
| (child, c) <- zip groupChild $ inits groupChild]
foldTree :: (a -> Tree -> a) -> a -> Tree -> a
foldTree f = go where
go acc e = case e of
None -> f acc e
UseTree _ _ -> f acc e
PathTree _ -> f acc e
CircleTree _ -> f acc e
PolyLineTree _ -> f acc e
PolygonTree _ -> f acc e
EllipseTree _ -> f acc e
LineTree _ -> f acc e
RectangleTree _ -> f acc e
TextTree _ _ -> f acc e
ImageTree _ -> f acc e
GroupTree g ->
let subAcc = F.foldl' go acc $ _groupChildren g in
f subAcc e
SymbolTree s ->
let subAcc =
F.foldl' go acc . _groupChildren $ _groupOfSymbol s in
f subAcc e
mapTree :: (Tree -> Tree) -> Tree -> Tree
mapTree f = go where
go e@None = f e
go e@(UseTree _ _) = f e
go (GroupTree g) = f . GroupTree $ mapGroup g
go (SymbolTree g) =
f . SymbolTree . Symbol . mapGroup $ _groupOfSymbol g
go e@(PathTree _) = f e
go e@(CircleTree _) = f e
go e@(PolyLineTree _) = f e
go e@(PolygonTree _) = f e
go e@(EllipseTree _) = f e
go e@(LineTree _) = f e
go e@(RectangleTree _) = f e
go e@(TextTree _ _) = f e
go e@(ImageTree _) = f e
mapGroup g =
g { _groupChildren = map go $ _groupChildren g }
nameOfTree :: Tree -> T.Text
nameOfTree v =
case v of
None -> ""
UseTree _ _ -> "use"
GroupTree _ -> "g"
SymbolTree _ -> "symbol"
PathTree _ -> "path"
CircleTree _ -> "circle"
PolyLineTree _ -> "polyline"
PolygonTree _ -> "polygon"
EllipseTree _ -> "ellipse"
LineTree _ -> "line"
RectangleTree _ -> "rectangle"
TextTree _ _ -> "text"
ImageTree _ -> "image"
drawAttrOfTree :: Tree -> DrawAttributes
drawAttrOfTree v = case v of
None -> mempty
UseTree e _ -> e ^. drawAttr
GroupTree e -> e ^. drawAttr
SymbolTree e -> e ^. drawAttr
PathTree e -> e ^. drawAttr
CircleTree e -> e ^. drawAttr
PolyLineTree e -> e ^. drawAttr
PolygonTree e -> e ^. drawAttr
EllipseTree e -> e ^. drawAttr
LineTree e -> e ^. drawAttr
RectangleTree e -> e ^. drawAttr
TextTree _ e -> e ^. drawAttr
ImageTree e -> e ^. drawAttr
setDrawAttrOfTree :: Tree -> DrawAttributes -> Tree
setDrawAttrOfTree v attr = case v of
None -> None
UseTree e m -> UseTree (e & drawAttr .~ attr) m
GroupTree e -> GroupTree $ e & drawAttr .~ attr
SymbolTree e -> SymbolTree $ e & drawAttr .~ attr
PathTree e -> PathTree $ e & drawAttr .~ attr
CircleTree e -> CircleTree $ e & drawAttr .~ attr
PolyLineTree e -> PolyLineTree $ e & drawAttr .~ attr
PolygonTree e -> PolygonTree $ e & drawAttr .~ attr
EllipseTree e -> EllipseTree $ e & drawAttr .~ attr
LineTree e -> LineTree $ e & drawAttr .~ attr
RectangleTree e -> RectangleTree $ e & drawAttr .~ attr
TextTree a e -> TextTree a $ e & drawAttr .~ attr
ImageTree e -> ImageTree $ e & drawAttr .~ attr
instance WithDrawAttributes Tree where
drawAttr = lens drawAttrOfTree setDrawAttrOfTree
instance WithDefaultSvg Tree where
defaultSvg = None
data CoordinateUnits
= CoordUserSpace
| CoordBoundingBox
deriving (Eq, Show)
data Spread
= SpreadRepeat
| SpreadPad
| SpreadReflect
deriving (Eq, Show)
data GradientStop = GradientStop
{
_gradientOffset :: Float
, _gradientColor :: PixelRGBA8
}
deriving (Eq, Show)
makeClassy ''GradientStop
instance WithDefaultSvg GradientStop where
defaultSvg = GradientStop
{ _gradientOffset = 0.0
, _gradientColor = PixelRGBA8 0 0 0 255
}
data LinearGradient = LinearGradient
{
_linearGradientUnits :: CoordinateUnits
, _linearGradientStart :: Point
, _linearGradientStop :: Point
, _linearGradientSpread :: Spread
, _linearGradientTransform :: [Transformation]
, _linearGradientStops :: [GradientStop]
}
deriving (Eq, Show)
makeClassy ''LinearGradient
instance WithDefaultSvg LinearGradient where
defaultSvg = LinearGradient
{ _linearGradientUnits = CoordBoundingBox
, _linearGradientStart = (Percent 0, Percent 0)
, _linearGradientStop = (Percent 1, Percent 0)
, _linearGradientSpread = SpreadPad
, _linearGradientTransform = []
, _linearGradientStops = []
}
data RadialGradient = RadialGradient
{
_radialGradientUnits :: CoordinateUnits
, _radialGradientCenter :: Point
, _radialGradientRadius :: Number
, _radialGradientFocusX :: Maybe Number
, _radialGradientFocusY :: Maybe Number
, _radialGradientSpread :: Spread
, _radialGradientTransform :: [Transformation]
, _radialGradientStops :: [GradientStop]
}
deriving (Eq, Show)
makeClassy ''RadialGradient
instance WithDefaultSvg RadialGradient where
defaultSvg = RadialGradient
{ _radialGradientUnits = CoordBoundingBox
, _radialGradientCenter = (Percent 0.5, Percent 0.5)
, _radialGradientRadius = Percent 0.5
, _radialGradientFocusX = Nothing
, _radialGradientFocusY = Nothing
, _radialGradientSpread = SpreadPad
, _radialGradientTransform = []
, _radialGradientStops = []
}
data Mask = Mask
{
_maskDrawAttributes :: DrawAttributes
, _maskContentUnits :: CoordinateUnits
, _maskUnits :: CoordinateUnits
, _maskPosition :: Point
, _maskWidth :: Number
, _maskHeight :: Number
, _maskContent :: [Tree]
}
deriving (Eq, Show)
makeClassy ''Mask
instance WithDrawAttributes Mask where
drawAttr = maskDrawAttributes
instance WithDefaultSvg Mask where
defaultSvg = Mask
{ _maskDrawAttributes = mempty
, _maskContentUnits = CoordUserSpace
, _maskUnits = CoordBoundingBox
, _maskPosition = (Percent (0.1), Percent (0.1))
, _maskWidth = Percent 1.2
, _maskHeight = Percent 1.2
, _maskContent = []
}
data ClipPath = ClipPath
{ _clipPathDrawAttributes :: DrawAttributes
, _clipPathUnits :: CoordinateUnits
, _clipPathContent :: [Tree]
}
deriving (Eq, Show)
makeClassy ''ClipPath
instance WithDrawAttributes ClipPath where
drawAttr = clipPathDrawAttributes
instance WithDefaultSvg ClipPath where
defaultSvg = ClipPath
{ _clipPathDrawAttributes = mempty
, _clipPathUnits = CoordUserSpace
, _clipPathContent = mempty
}
data Pattern = Pattern
{
_patternDrawAttributes :: DrawAttributes
, _patternViewBox :: Maybe (Int, Int, Int, Int)
, _patternWidth :: Number
, _patternHeight :: Number
, _patternPos :: Point
, _patternElements :: [Tree]
, _patternUnit :: CoordinateUnits
}
deriving Show
makeClassy ''Pattern
instance WithDrawAttributes Pattern where
drawAttr = patternDrawAttributes
instance WithDefaultSvg Pattern where
defaultSvg = Pattern
{ _patternViewBox = Nothing
, _patternWidth = Num 0
, _patternHeight = Num 0
, _patternPos = (Num 0, Num 0)
, _patternElements = []
, _patternUnit = CoordBoundingBox
, _patternDrawAttributes = mempty
}
data Element
= ElementLinearGradient LinearGradient
| ElementRadialGradient RadialGradient
| ElementGeometry Tree
| ElementPattern Pattern
| ElementMarker Marker
| ElementMask Mask
| ElementClipPath ClipPath
deriving Show
data Document = Document
{ _viewBox :: Maybe (Int, Int, Int, Int)
, _width :: Maybe Number
, _height :: Maybe Number
, _elements :: [Tree]
, _definitions :: M.Map String Element
, _description :: String
, _styleRules :: [CssRule]
, _documentLocation :: FilePath
}
deriving Show
makeClassy ''Document
documentSize :: Dpi -> Document -> (Int, Int)
documentSize _ Document { _viewBox = Just (x1, y1, x2, y2)
, _width = Just (Percent pw)
, _height = Just (Percent ph)
} =
(floor $ dx * pw, floor $ dy * ph)
where
dx = fromIntegral . abs $ x2 x1
dy = fromIntegral . abs $ y2 y1
documentSize _ Document { _width = Just (Num w)
, _height = Just (Num h) } = (floor w, floor h)
documentSize dpi doc@(Document { _width = Just w
, _height = Just h }) =
documentSize dpi $ doc
{ _width = Just $ toUserUnit dpi w
, _height = Just $ toUserUnit dpi h }
documentSize _ Document { _viewBox = Just (x1, y1, x2, y2) } =
(abs $ x2 x1, abs $ y2 y1)
documentSize _ _ = (1, 1)
mayMerge :: Monoid a => Maybe a -> Maybe a -> Maybe a
mayMerge (Just a) (Just b) = Just $ mappend a b
mayMerge _ b@(Just _) = b
mayMerge a Nothing = a
instance Monoid DrawAttributes where
mempty = DrawAttributes
{ _strokeWidth = Last Nothing
, _strokeColor = Last Nothing
, _strokeOpacity = Nothing
, _strokeLineCap = Last Nothing
, _strokeLineJoin = Last Nothing
, _strokeMiterLimit = Last Nothing
, _fillColor = Last Nothing
, _groupOpacity = Nothing
, _fillOpacity = Nothing
, _fontSize = Last Nothing
, _fontFamily = Last Nothing
, _fontStyle = Last Nothing
, _transform = Nothing
, _fillRule = Last Nothing
, _attrClass = mempty
, _attrId = Nothing
, _strokeOffset = Last Nothing
, _strokeDashArray = Last Nothing
, _textAnchor = Last Nothing
, _maskRef = Last Nothing
, _clipPathRef = Last Nothing
, _clipRule = Last Nothing
, _markerStart = Last Nothing
, _markerMid = Last Nothing
, _markerEnd = Last Nothing
}
mappend a b = DrawAttributes
{ _strokeWidth = (mappend `on` _strokeWidth) a b
, _strokeColor = (mappend `on` _strokeColor) a b
, _strokeLineCap = (mappend `on` _strokeLineCap) a b
, _strokeOpacity = (opacityMappend `on` _strokeOpacity) a b
, _strokeLineJoin = (mappend `on` _strokeLineJoin) a b
, _strokeMiterLimit = (mappend `on` _strokeMiterLimit) a b
, _fillColor = (mappend `on` _fillColor) a b
, _fillOpacity = (opacityMappend `on` _fillOpacity) a b
, _fontSize = (mappend `on` _fontSize) a b
, _transform = (mayMerge `on` _transform) a b
, _fillRule = (mappend `on` _fillRule) a b
, _attrClass = _attrClass b
, _attrId = _attrId b
, _groupOpacity = _groupOpacity b
, _strokeOffset = (mappend `on` _strokeOffset) a b
, _strokeDashArray = (mappend `on` _strokeDashArray) a b
, _fontFamily = (mappend `on` _fontFamily) a b
, _fontStyle = (mappend `on` _fontStyle) a b
, _textAnchor = (mappend `on` _textAnchor) a b
, _maskRef = (mappend `on` _maskRef) a b
, _clipPathRef = (mappend `on` _clipPathRef) a b
, _clipRule = (mappend `on` _clipRule) a b
, _markerStart = (mappend `on` _markerStart) a b
, _markerMid = (mappend `on` _markerMid) a b
, _markerEnd = (mappend `on` _markerEnd) a b
}
where
opacityMappend Nothing Nothing = Nothing
opacityMappend (Just v) Nothing = Just v
opacityMappend Nothing (Just v) = Just v
opacityMappend (Just v) (Just v2) = Just $ v * v2
instance WithDefaultSvg DrawAttributes where
defaultSvg = mempty
instance CssMatcheable Tree where
cssAttribOf _ _ = Nothing
cssClassOf = view (drawAttr . attrClass)
cssIdOf = fmap T.pack . view (drawAttr . attrId)
cssNameOf = nameOfTree