diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,14 @@ -*-change-log-*- +v0.11.0.0 + + * Drop support for GHC 7. + * Remove toPoint, isPathArc, isPathWithArc + +v0.10.3.0 September 2020 + + * Generic and Hashable instances. + v0.9.0.0 April 2019 * Performance optimizations. diff --git a/reanimate-svg.cabal b/reanimate-svg.cabal --- a/reanimate-svg.cabal +++ b/reanimate-svg.cabal @@ -1,5 +1,6 @@ +cabal-version: 2.2 name: reanimate-svg -version: 0.10.3.0 +version: 0.11.0.0 synopsis: SVG file loader and serializer description: reanimate-svg provides types representing a SVG document, @@ -10,14 +11,13 @@ look after `lucid-svg`. -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Vincent Berthoux, David Himmelstrup maintainer: David Himmelstrup -- copyright: category: Graphics, Svg build-type: Simple -cabal-version: >=1.10 extra-source-files: changelog.md @@ -27,7 +27,7 @@ library hs-source-dirs: src - Ghc-options: -O3 -Wall + ghc-options: -Wall default-language: Haskell2010 exposed-modules: Graphics.SvgTree , Graphics.SvgTree.CssTypes @@ -41,39 +41,25 @@ , Graphics.SvgTree.CssParser , Graphics.SvgTree.ColorParser , Graphics.SvgTree.Misc - - if impl(ghc >= 8.0) - ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances - else - -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8 - build-depends: fail == 4.9.*, semigroups == 0.18.* + , Graphics.SvgTree.Types.Hashable + , Graphics.SvgTree.Types.Basic + , Graphics.SvgTree.Types.Fold + , Graphics.SvgTree.Types.Internal + , Graphics.SvgTree.Types.Constructors + , Graphics.SvgTree.Types.Instances - build-depends: base >= 4.5 && < 6 - , JuicyPixels >= 3.2 - , attoparsec >= 0.12 - , scientific >= 0.3 - , containers >= 0.4 - , xml >= 1.3 - , bytestring >= 0.10 - , linear >= 1.20 - , vector >= 0.10 - , text >= 1.1 - , transformers >= 0.3 && < 0.6 - , mtl >= 2.1 && < 2.3 - , lens >= 4.6 && < 5 + build-depends: base >= 4.5 && < 6 + , JuicyPixels >= 3.2 + , attoparsec >= 0.12 + , scientific >= 0.3 + , containers >= 0.4 + , xml >= 1.3 + , bytestring >= 0.10 + , linear >= 1.20 + , vector >= 0.10 + , text >= 1.1 + , transformers >= 0.3 && < 0.6 + , mtl >= 2.1 && < 2.3 + , lens >= 4.6 && < 5 , double-conversion >= 2.0.0.0 && < 3.0.0.0 - , hashable >= 1.3.0.0 - -test-suite test - default-language: Haskell2010 - hs-source-dirs: test - main-is: Spec.hs - type: exitcode-stdio-1.0 - build-depends: base - , svg-tree - , attoparsec >= 0.12 - , scientific >= 0.3 - , linear >= 1.20 - , hspec - ghc-options: -Wall -threaded - other-modules: PathParserSpec + , hashable >= 1.3.0.0 diff --git a/src/Graphics/SvgTree.hs b/src/Graphics/SvgTree.hs --- a/src/Graphics/SvgTree.hs +++ b/src/Graphics/SvgTree.hs @@ -1,43 +1,35 @@ -{-# LANGUAGE CPP #-} -- | Module providing basic input/output for the SVG document, -- for document building, please refer to Graphics.Svg.Types. module Graphics.SvgTree ( -- * Saving/Loading functions - loadSvgFile - , parseSvgFile - , unparse - , xmlOfDocument - , xmlOfTree - , saveXmlFile + loadSvgFile, + parseSvgFile, + unparse, + xmlOfDocument, + xmlOfTree, + saveXmlFile, -- * Manipulation functions - , cssApply - , cssRulesOfText - -- , applyCSSRules - -- , resolveUses + cssApply, + cssRulesOfText, + -- , applyCSSRules + -- , resolveUses -- * Type definitions - , module Graphics.SvgTree.Types - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif - -import Control.Lens -import qualified Data.ByteString as B -import Data.List (foldl') --- import qualified Data.Map as M -import qualified Data.Text as T -import Text.XML.Light.Input (parseXMLDoc) -import Text.XML.Light.Output (ppcTopElement, prettyConfigPP) - -import Graphics.SvgTree.CssParser (cssRulesOfText) -import Graphics.SvgTree.CssTypes -import Graphics.SvgTree.Types -import Graphics.SvgTree.XmlParser + module Graphics.SvgTree.Types, + ) +where -{-import Graphics.Svg.CssParser-} +import Control.Lens +import qualified Data.ByteString as B +import Data.List (foldl') +import qualified Data.Text as T +import Graphics.SvgTree.CssParser (cssRulesOfText) +import Graphics.SvgTree.CssTypes +import Graphics.SvgTree.Types +import Graphics.SvgTree.XmlParser +import Text.XML.Light.Input (parseXMLDoc) +import Text.XML.Light.Output (ppcTopElement, prettyConfigPP) -- | Try to load an svg file on disc and parse it as -- a SVG Document. @@ -46,42 +38,49 @@ parseSvgFile filename <$> B.readFile filename -- | Parse an in-memory SVG file -parseSvgFile :: FilePath -- ^ Source path/URL of the document, used - -- to resolve relative links. - -> B.ByteString - -> Maybe Document +parseSvgFile :: + -- | Source path/URL of the document, used + -- to resolve relative links. + FilePath -> + B.ByteString -> + Maybe Document parseSvgFile filename fileContent = parseXMLDoc fileContent >>= unparseDocument filename -- | Save a svg Document on a file on disk. saveXmlFile :: FilePath -> Document -> IO () saveXmlFile filePath = - writeFile filePath . ppcTopElement prettyConfigPP . xmlOfDocument + writeFile filePath . ppcTopElement prettyConfigPP . xmlOfDocument -cssDeclApplyer :: DrawAttributes -> CssDeclaration - -> DrawAttributes +cssDeclApplyer :: + DrawAttributes -> + CssDeclaration -> + DrawAttributes cssDeclApplyer value (CssDeclaration txt elems) = - case lookup txt cssUpdaters of - Nothing -> value - Just f -> f value elems + case lookup txt cssUpdaters of + Nothing -> value + Just f -> f value elems where - cssUpdaters = [(T.pack $ _attributeName n, u) | - (n, u) <- drawAttributesList] + cssUpdaters = + [ (T.pack $ _attributeName n, u) + | (n, u) <- drawAttributesList + ] -- | Rewrite a SVG Tree using some CSS rules. -- -- This action will propagate the definition of the -- css directly in each matched element. cssApply :: [CssRule] -> Tree -> Tree -cssApply rules = zipTree go where - go [] = None - go ([]:_) = None - go context@((t:_):_) = t & drawAttributes .~ attr' - where - matchingDeclarations = - findMatchingDeclarations rules context - attr = view drawAttributes t - attr' = foldl' cssDeclApplyer attr matchingDeclarations +cssApply rules = zipTree go + where + go [] = defaultSvg + go ([] : _) = defaultSvg + go context@((t : _) : _) = t & drawAttributes .~ attr' + where + matchingDeclarations = + findMatchingDeclarations rules context + attr = view drawAttributes t + attr' = foldl' cssDeclApplyer attr matchingDeclarations -- For every 'use' tag, try to resolve the geometry associated -- with it and place it in the scene Tree. It is important to diff --git a/src/Graphics/SvgTree/ColorParser.hs b/src/Graphics/SvgTree/ColorParser.hs --- a/src/Graphics/SvgTree/ColorParser.hs +++ b/src/Graphics/SvgTree/ColorParser.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Graphics.SvgTree.ColorParser ( colorParser @@ -8,26 +7,24 @@ , urlRef ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((*>), (<$), (<$>), (<*), (<*>)) -#endif - -import Control.Applicative ((<|>)) -import Data.Attoparsec.Text (Parser, char, digit, inClass, letter, - many1, option, satisfy, scientific, - skipSpace, string, takeWhile1) -import Data.Bits (unsafeShiftL, (.|.)) +import Control.Applicative ((<|>)) +import Data.Attoparsec.Text (Parser, char, digit, inClass, + letter, many1, option, satisfy, + scientific, skipSpace, string, + takeWhile1) +import Data.Bits (unsafeShiftL, (.|.)) -import Codec.Picture (PixelRGBA8 (..)) -import qualified Data.Map as M -import Data.Scientific (toRealFloat) -import Data.Word (Word8) +import Codec.Picture (PixelRGBA8 (..)) +import Data.Functor +import qualified Data.Map as M +import Data.Scientific (toRealFloat) +import Data.Word (Word8) import Graphics.SvgTree.NamedColors import Graphics.SvgTree.Types -import Text.Printf (printf) +import Text.Printf (printf) commaWsp :: Parser () -commaWsp = skipSpace *> option () (string "," *> return ()) +commaWsp = skipSpace *> option () (string "," $> ()) <* skipSpace diff --git a/src/Graphics/SvgTree/CssParser.hs b/src/Graphics/SvgTree/CssParser.hs --- a/src/Graphics/SvgTree/CssParser.hs +++ b/src/Graphics/SvgTree/CssParser.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} module Graphics.SvgTree.CssParser @@ -13,11 +12,6 @@ , cssRulesOfText ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (pure, (*>), (<$), (<$>), (<*), - (<*>)) -#endif - import Control.Applicative (many, (<|>)) import Data.Attoparsec.Text (Parser, char, digit, double, letter, notChar, parseOnly, sepBy1, @@ -100,7 +94,7 @@ ruleSet = cleanSpace *> rule where rule = CssRule <$> selector `sepBy1` commaWsp - <*> (between '{' '}' styleString) + <*> between '{' '}' styleString "cssrule" styleString :: Parser [CssDeclaration] @@ -119,7 +113,7 @@ combOpt = cleanSpace *> option id ((:) <$> combinator) next :: Parser [CssSelector] - next = id <$> combOpt <*> selector + next = combOpt <*> selector simpleSelector :: Parser [CssDescriptor] simpleSelector = (:) <$> elementName <*> many whole @@ -226,6 +220,6 @@ -- | Parse CSS text into rules. cssRulesOfText :: T.Text -> [CssRule] -cssRulesOfText txt = case parseOnly (many1 ruleSet) $ txt of +cssRulesOfText txt = case parseOnly (many1 ruleSet) txt of Left _ -> [] Right rules -> rules diff --git a/src/Graphics/SvgTree/CssTypes.hs b/src/Graphics/SvgTree/CssTypes.hs --- a/src/Graphics/SvgTree/CssTypes.hs +++ b/src/Graphics/SvgTree/CssTypes.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -- | Define the types used to describes CSS elements module Graphics.SvgTree.CssTypes @@ -22,13 +21,8 @@ , tserialize ) where -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid (mconcat) -#endif - import Data.Hashable (Hashable) import Data.List (intersperse) -import Data.Monoid ((<>)) import qualified Data.Text as T import qualified Data.Text.Lazy.Builder as TB import GHC.Generics (Generic) @@ -214,7 +208,6 @@ Point n -> Point $ f n Inches n -> Inches $ f n --- XXX: Compress unused precision. -- | Encode the number to string which can be used in a -- CSS or a svg attributes. serializeNumber :: Number -> String diff --git a/src/Graphics/SvgTree/Memo.hs b/src/Graphics/SvgTree/Memo.hs --- a/src/Graphics/SvgTree/Memo.hs +++ b/src/Graphics/SvgTree/Memo.hs @@ -1,17 +1,14 @@ module Graphics.SvgTree.Memo ( memo - , preRender ) where -import Control.Lens -import Data.IORef -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe -import Data.Typeable -import Graphics.SvgTree.Printer -import Graphics.SvgTree.Types (Tree, preRendered) -import System.IO.Unsafe +import Data.IORef (IORef, atomicModifyIORef, newIORef) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (catMaybes, listToMaybe) +import Data.Typeable (TypeRep, Typeable, cast, typeOf) +import Graphics.SvgTree.Types (Tree) +import System.IO.Unsafe (unsafePerformIO) {-# NOINLINE intCache #-} intCache :: IORef (Map Int Tree) @@ -37,7 +34,7 @@ memoUsing :: Ord a => IORef (Map a Tree) -> (a -> Tree) -> (a -> Tree) memoUsing cache fn a = unsafePerformIO $ atomicModifyIORef cache $ \m -> - let newVal = preRender $ fn a + let newVal = fn a notFound = (Map.insert a newVal m, newVal) in case Map.lookup a m of @@ -47,15 +44,12 @@ memoAny :: (Typeable a, Show a) => (a -> Tree) -> (a -> Tree) memoAny fn a = unsafePerformIO $ atomicModifyIORef anyCache $ \m -> - let newVal = preRender $ fn a + let newVal = fn a notFound = (Map.insert (typeOf a, show a) newVal m, newVal) in case Map.lookup (typeOf a, show a) m of Nothing -> notFound Just t -> (m, t) - -preRender :: Tree -> Tree -preRender t = t & preRendered .~ Just (ppTree t) -- {-# INLINE memo #-} -- memo :: (a -> b) -> (a -> b) diff --git a/src/Graphics/SvgTree/PathParser.hs b/src/Graphics/SvgTree/PathParser.hs --- a/src/Graphics/SvgTree/PathParser.hs +++ b/src/Graphics/SvgTree/PathParser.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Graphics.SvgTree.PathParser ( transformParser @@ -14,18 +13,14 @@ , serializeViewBox ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((*>), (<$), (<$>), (<*), (<*>)) -#endif - import Control.Applicative ((<|>)) import Data.Attoparsec.Combinator (option, sepBy, sepBy1) import Data.Attoparsec.Text (Parser, char, digit, many1, parseOnly, scientific, skipSpace, string) -import Data.Scientific (toRealFloat) - +import Data.Functor import Data.List +import Data.Scientific (toRealFloat) import qualified Data.Text as T import Graphics.SvgTree.Misc import Graphics.SvgTree.Types @@ -54,7 +49,7 @@ serializeViewBox (a, b, c, d) = printf "%s %s %s %s" (ppD a) (ppD b) (ppD c) (ppD d) commaWsp :: Parser () -commaWsp = skipSpace *> option () (string "," *> return ()) <* skipSpace +commaWsp = skipSpace *> option () (string "," $> ()) <* skipSpace point :: Parser RPoint point = V2 <$> num <* commaWsp <*> num @@ -99,8 +94,8 @@ ellipticalArgs = (,,,,,) <$> numComma <*> numComma <*> numComma - <*> (fmap (/= 0) numComma) - <*> (fmap (/= 0) numComma) + <*> fmap (/= 0) numComma + <*> fmap (/= 0) numComma <*> point unwordsS :: [ShowS] -> ShowS diff --git a/src/Graphics/SvgTree/Printer.hs b/src/Graphics/SvgTree/Printer.hs --- a/src/Graphics/SvgTree/Printer.hs +++ b/src/Graphics/SvgTree/Printer.hs @@ -1,58 +1,55 @@ module Graphics.SvgTree.Printer - ( ppTree - , ppDocument - ) where + ( ppTree, + ppDocument, + ) +where -import Control.Lens ((^.)) -import Data.List -import Graphics.SvgTree.Types (Document (..), - Tree (..), clipPathContent, - groupChildren, markerElements, - maskContent, patternElements, - preRendered) -import Graphics.SvgTree.XmlParser -import Text.XML.Light hiding (showAttr) +import Control.Lens ((^.)) +import Data.List +import Graphics.SvgTree.Types hiding (Element) +import Graphics.SvgTree.XmlParser +import Text.XML.Light hiding (showAttr) ppDocument :: Document -> String ppDocument doc = - ppElementS_ (_elements doc) (xmlOfDocument doc) "" + ppElementS_ (_documentElements doc) (xmlOfDocument doc) "" ppTree :: Tree -> String ppTree t = ppTreeS t "" ppTreeS :: Tree -> ShowS ppTreeS tree = - case tree ^. preRendered of - Nothing -> - case xmlOfTree tree of - Just x -> ppElementS_ (treeChildren tree) x - Nothing -> id - Just s -> showString s + case xmlOfTree tree of + Just x -> ppElementS_ (treeChildren tree) x + Nothing -> id treeChildren :: Tree -> [Tree] -treeChildren (GroupTree g) = g^.groupChildren -treeChildren (SymbolTree g) = g^.groupChildren -treeChildren (DefinitionTree g) = g^.groupChildren -treeChildren (ClipPathTree c) = c^.clipPathContent -treeChildren (PatternTree p) = p^.patternElements -treeChildren (MarkerTree m) = m^.markerElements -treeChildren (MaskTree m) = m^.maskContent -treeChildren _ = [] +treeChildren t = case t of + GroupTree g -> g ^. groupChildren + SymbolTree g -> g ^. groupChildren + DefinitionTree g -> g ^. groupChildren + ClipPathTree c -> c ^. clipPathContent + PatternTree p -> p ^. patternElements + MarkerTree m -> m ^. markerElements + MaskTree m -> m ^. maskContent + _ -> [] -ppElementS_ :: [Tree] -> Element -> ShowS +ppElementS_ :: [Tree] -> Element -> ShowS ppElementS_ [] e xs | not (null (elContent e)) = ppElement e ++ xs ppElementS_ children e xs = tagStart name (elAttribs e) $ case children of - [] | "?" `isPrefixOf` qName name -> showString " ?>" xs - | otherwise -> showString " />" xs + [] + | "?" `isPrefixOf` qName name -> showString " ?>" xs + | otherwise -> showString " />" xs _ -> showChar '>' (foldr ppTreeS (tagEnd name xs) children) where name = elName e -------------------------------------------------------------------------------- -tagStart :: QName -> [Attr] -> ShowS -tagStart qn as rs = '<':showQName qn ++ as_str ++ rs - where as_str = if null as then "" else ' ' : unwords (map showAttr as) +tagStart :: QName -> [Attr] -> ShowS +tagStart qn as rs = '<' : showQName qn ++ as_str ++ rs + where + as_str = if null as then "" else ' ' : unwords (map showAttr as) -showAttr :: Attr -> String +showAttr :: Attr -> String showAttr (Attr qn v) = showQName qn ++ '=' : '"' : v ++ "\"" diff --git a/src/Graphics/SvgTree/Types.hs b/src/Graphics/SvgTree/Types.hs --- a/src/Graphics/SvgTree/Types.hs +++ b/src/Graphics/SvgTree/Types.hs @@ -1,2971 +1,362 @@ -{-# OPTIONS_GHC -Wno-orphans -O0 #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} --- | This module define all the types used in the definition --- of a svg scene. --- --- Most of the types are lensified. -module Graphics.SvgTree.Types - ( -- * Basic building types - Coord - , Origin( .. ) - , Point - , RPoint - , PathCommand( .. ) - , Transformation( .. ) - , ElementRef( .. ) - , CoordinateUnits( .. ) - - -- ** Building helpers - , toPoint - , serializeNumber - , serializeTransformation - , serializeTransformations - - -- * Drawing control types - , Cap( .. ) - , LineJoin( .. ) - , Tree( .. ) - , Number( .. ) - , Spread( .. ) - , Texture( .. ) - , Element( .. ) - , FillRule( .. ) - , FontStyle( .. ) - , Dpi - - , WithDefaultSvg( .. ) - - -- * Main type - , Document( .. ) - , HasDocument( .. ) - , documentSize - - -- * Drawing attributes - , DrawAttributes( .. ) - , HasDrawAttributes( .. ) - - -- * Filters - , FilterElement(..) - , FilterAttributes(..) - , HasFilterAttributes(..) - , FilterSource(..) - , ColorMatrixType(..) - , HasColorMatrix(..) - , ColorMatrix(..) - , HasComposite(..) - , Composite(..) - , CompositeOperator(..) - , EdgeMode(..) - , HasGaussianBlur(..) - , GaussianBlur(..) - , HasTurbulence(..) - , Turbulence(..) - , TurbulenceType(..) - , StitchTiles(..) - , HasDisplacementMap(..) - , DisplacementMap(..) - , ChannelSelector(..) - - -- * SVG drawing primitives - -- ** Rectangle - , Rectangle( .. ) - , HasRectangle( .. ) - - -- ** Line - , Line( .. ) - , HasLine( .. ) - - -- ** Polygon - , Polygon( .. ) - , HasPolygon( .. ) - - -- ** Polyline - , PolyLine( .. ) - , HasPolyLine( .. ) - - -- ** Path - , Path( .. ) - , HasPath( .. ) - - -- ** Circle - , Circle( .. ) - , HasCircle( .. ) - - -- ** Ellipse - , Ellipse( .. ) - , HasEllipse( .. ) - - -- ** Mesh (gradient mesh) - , GradientPathCommand( .. ) - , MeshGradientType( .. ) - - , MeshGradient( .. ) - , HasMeshGradient( .. ) - - , MeshGradientRow( .. ) - , HasMeshGradientRow( .. ) - - , MeshGradientPatch( .. ) - , HasMeshGradientPatch( .. ) - - -- ** Image - , Image( .. ) - , HasImage( .. ) - - -- ** Use - , Use( .. ) - , HasUse( .. ) - - -- * Grouping primitives - -- ** Group - , Group( .. ) - , HasGroup( .. ) - - -- ** Symbol - , Symbol( .. ) - , groupOfSymbol - - -- ** Definitions - , Definitions( .. ) - , groupOfDefinitions - - -- ** Filter - , Filter( .. ) - , filterChildren - - -- * Text related types - -- ** Text - , Text( .. ) - , HasText( .. ) - , TextAnchor( .. ) - , textAt - - -- ** Text path - , TextPath( .. ) - , HasTextPath( .. ) - - , TextPathSpacing( .. ) - , TextPathMethod( .. ) - - -- ** Text span. - , TextSpanContent( .. ) - - , TextSpan( .. ) - , HasTextSpan( .. ) - - , TextInfo( .. ) - , HasTextInfo( .. ) - - , TextAdjust( .. ) - - -- * Marker definition - , Marker( .. ) - , Overflow( .. ) - , MarkerOrientation( .. ) - , MarkerUnit( .. ) - , HasMarker( .. ) - - -- * Gradient definition - , GradientStop( .. ) - , HasGradientStop( .. ) - - -- ** Linear Gradient - , LinearGradient( .. ) - , HasLinearGradient( .. ) - - -- ** Radial Gradient - , RadialGradient( .. ) - , HasRadialGradient( .. ) - - -- * Pattern definition - , Pattern( .. ) - , HasPattern( .. ) - - -- * Mask definition - , Mask( .. ) - , HasMask( .. ) - - -- * Clip path definition - , ClipPath( .. ) - , HasClipPath( .. ) - - -- * Aspect Ratio description - , PreserveAspectRatio( .. ) - , Alignment( .. ) - , MeetSlice( .. ) - , HasPreserveAspectRatio( .. ) - - -- * MISC functions - , isPathArc - , isPathWithArc - , nameOfTree - , zipTree - , mapTree - , foldTree - , toUserUnit - , mapNumber - ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Foldable (Foldable) -import Data.Monoid (Monoid (..)) -#endif - -import Codec.Picture (PixelRGBA8 (..)) -import Control.Lens (Lens, Lens', lens, view, (&), (.~), - (^.)) -import Control.Lens.TH -import qualified Data.Foldable as F -import Data.Function (on) -import Data.Hashable (Hashable) -import Data.List (inits) -import Data.Monoid (Last (..)) -import Data.Semigroup (Semigroup (..)) -import qualified Data.Text as T -import GHC.Generics (Generic) -import Graphics.SvgTree.CssTypes -import Graphics.SvgTree.Misc -import Linear hiding (angle) - -import Text.Printf - - --- Orphan instances :( -instance Hashable a => Hashable (Last a) - -deriving instance Generic PixelRGBA8 -instance Hashable PixelRGBA8 - --- | Basic coordinate type. -type Coord = Double - --- | Real Point, fully determined and not --- dependant of the rendering context. -type RPoint = V2 Coord - --- | Possibly context dependant point. -type Point = (Number, Number) - --- | Tell if a path command is absolute (in the current --- user coordiante) or relative to the previous poitn. -data Origin - = OriginAbsolute -- ^ Next point in absolute coordinate - | OriginRelative -- ^ Next point relative to the previous - deriving (Eq, Show, Generic, Hashable) - - -data MeshGradientType - = GradientBilinear - | GradientBicubic - deriving (Eq, Show, Generic, Hashable) - --- | Path command definition. -data PathCommand - -- | 'M' or 'm' command - = MoveTo !Origin ![RPoint] - -- | Line to, 'L' or 'l' Svg path command. - | LineTo !Origin ![RPoint] - - -- | Equivalent to the 'H' or 'h' svg path command. - | HorizontalTo !Origin ![Coord] - -- | Equivalent to the 'V' or 'v' svg path command. - | VerticalTo !Origin ![Coord] - - -- | Cubic bezier, 'C' or 'c' command - | CurveTo !Origin ![(RPoint, RPoint, RPoint)] - -- | Smooth cubic bezier, equivalent to 'S' or 's' command - | SmoothCurveTo !Origin ![(RPoint, RPoint)] - -- | Quadratic bezier, 'Q' or 'q' command - | QuadraticBezier !Origin ![(RPoint, RPoint)] - -- | Quadratic bezier, 'T' or 't' command - | SmoothQuadraticBezierCurveTo !Origin ![RPoint] - -- | Eliptical arc, 'A' or 'a' command. - | EllipticalArc !Origin ![(Coord, Coord, Coord, Bool, Bool, RPoint)] - -- | Close the path, 'Z' or 'z' svg path command. - | EndPath - deriving (Eq, Show, Generic, Hashable) - --- | Description of path used in meshgradient tag -data GradientPathCommand - -- | Line to, 'L' or 'l' Svg path command. - = GLine !Origin !(Maybe RPoint) - -- | Cubic bezier, 'C' or 'c' command - | GCurve !Origin !RPoint !RPoint !(Maybe RPoint) - -- | 'Z' command - | GClose - deriving (Eq, Show, Generic, Hashable) - --- | Little helper function to build a point. -toPoint :: Number -> Number -> Point -toPoint = (,) - --- | Tell if the path command is an EllipticalArc. -isPathArc :: PathCommand -> Bool -isPathArc (EllipticalArc _ _) = True -isPathArc _ = False - --- | Tell if a full path contain an EllipticalArc. -isPathWithArc :: Foldable f => f PathCommand -> Bool -isPathWithArc = F.any isPathArc - --- | Define the possible values of various *units attributes --- used in the definition of the gradients and masks. -data CoordinateUnits - = CoordUserSpace -- ^ `userSpaceOnUse` value - | CoordBoundingBox -- ^ `objectBoundingBox` value - deriving (Eq, Show, Generic, Hashable) - --- | This type represent the align information of the --- preserveAspectRatio SVGattribute -data Alignment - = AlignNone -- ^ "none" value - | AlignxMinYMin -- "xMinYMin" value - | AlignxMidYMin -- ^ "xMidYMin" value - | AlignxMaxYMin -- ^ "xMaxYMin" value - | AlignxMinYMid -- ^ "xMinYMid" value - | AlignxMidYMid -- ^ "xMidYMid" value - | AlignxMaxYMid -- ^ "xMaxYMid" value - | AlignxMinYMax -- ^ "xMinYMax" value - | AlignxMidYMax -- ^ "xMidYMax" value - | AlignxMaxYMax -- ^ "xMaxYMax" value - deriving (Eq, Show, Generic, Hashable) - --- | This type represent the "meet or slice" information --- of the preserveAspectRatio SVGattribute -data MeetSlice = Meet | Slice - deriving (Eq, Show, Generic, Hashable) - --- | Describe the content of the preserveAspectRatio attribute. -data PreserveAspectRatio = PreserveAspectRatio - { _aspectRatioDefer :: !Bool - , _aspectRatioAlign :: !Alignment - , _aspectRatioMeetSlice :: !(Maybe MeetSlice) - } - deriving (Eq, Show, Generic, Hashable) - -instance WithDefaultSvg PreserveAspectRatio where - defaultSvg = PreserveAspectRatio - { _aspectRatioDefer = False - , _aspectRatioAlign = AlignxMidYMid - , _aspectRatioMeetSlice = Nothing - } - --- | Describe how the line should be terminated --- when stroking them. Describe the values of the --- `stroke-linecap` attribute. --- See `_strokeLineCap` -data Cap - = CapRound -- ^ End with a round (`round` value) - | CapButt -- ^ Define straight just at the end (`butt` value) - | CapSquare -- ^ Straight further of the ends (`square` value) - deriving (Eq, Show, Generic, Hashable) - --- | Define the possible values of the `stroke-linejoin` --- attribute. --- see `_strokeLineJoin` -data LineJoin - = JoinMiter -- ^ `miter` value - | JoinBevel -- ^ `bevel` value - | JoinRound -- ^ `round` value - deriving (Eq, Show, Generic, Hashable) - --- | Describe the different value which can be used --- in the `fill` or `stroke` attributes. -data Texture - = ColorRef PixelRGBA8 -- ^ Direct solid color (#rrggbb, #rgb) - | TextureRef String -- ^ Link to a complex texture (url(#name)) - | FillNone -- ^ Equivalent to the `none` value. - deriving (Eq, Show, Generic, Hashable) - --- | Describe the possile filling algorithms. --- Map the values of the `fill-rule` attributes. -data FillRule - = FillEvenOdd -- ^ Correspond to the `evenodd` value. - | FillNonZero -- ^ Correspond to the `nonzero` value. - deriving (Eq, Show, Generic, Hashable) - --- | Describe the content of the `transformation` attribute. --- see `_transform` and `transform`. -data Transformation - = -- | Directly encode the translation matrix. - TransformMatrix !Coord !Coord !Coord - !Coord !Coord !Coord - -- | Translation along a vector - | Translate !Double !Double - -- | Scaling on both axis or on X axis and Y axis. - | Scale !Double !(Maybe Double) - -- | Rotation around `(0, 0)` or around an optional - -- point. - | Rotate !Double !(Maybe (Double, Double)) - -- | Skew transformation along the X axis. - | SkewX !Double - -- | Skew transformation along the Y axis. - | SkewY !Double - -- | Unkown transformation, like identity. - | TransformUnknown - deriving (Eq, Show, Generic, Hashable) - --- | Convert the Transformation to a string which can be --- directly used in a svg attributes. -serializeTransformation :: Transformation -> String -serializeTransformation t = case t of - TransformUnknown -> "" - TransformMatrix a b c d e f -> - printf "matrix(%s, %s, %s, %s, %s, %s)" - (ppD a) (ppD b) (ppD c) (ppD d) (ppD e) (ppD f) - Translate x y -> printf "translate(%s, %s)" (ppD x) (ppD y) - Scale x Nothing -> printf "scale(%s)" (ppD x) - Scale x (Just y) -> printf "scale(%s, %s)" (ppD x) (ppD y) - Rotate angle Nothing -> printf "rotate(%s)" (ppD angle) - Rotate angle (Just (x, y))-> printf "rotate(%s, %s, %s)" - (ppD angle) (ppD x) (ppD y) - SkewX x -> printf "skewX(%s)" (ppD x) - SkewY y -> printf "skewY(%s)" (ppD y) - --- | Transform a list of transformations to a string for svg --- `transform` attributes. -serializeTransformations :: [Transformation] -> String -serializeTransformations = - unwords . fmap serializeTransformation - --- | Define an empty 'default' element for the SVG tree. --- It is used as base when parsing the element from XML. -class WithDefaultSvg a where - -- | The default element. - defaultSvg :: a - --- | Classify the font style, used to search a matching --- font in the FontCache. -data FontStyle - = FontStyleNormal - | FontStyleItalic - | FontStyleOblique - deriving (Eq, Show, Generic, Hashable) - --- | Tell where to anchor the text, where the position --- given is realative to the text. -data TextAnchor - -- | The text with left aligned, or start at the postion - -- If the point is the '*' then the text will be printed - -- this way: - -- - -- > *THE_TEXT_TO_PRINT - -- - -- Equivalent to the `start` value. - = TextAnchorStart - -- | The text is middle aligned, so the text will be at - -- the left and right of the position: - -- - -- > THE_TEXT*TO_PRINT - -- - -- Equivalent to the `middle` value. - | TextAnchorMiddle - -- | The text is right aligned. - -- - -- > THE_TEXT_TO_PRINT* - -- - -- Equivalent to the `end` value. - | TextAnchorEnd - deriving (Eq, Show, Generic, Hashable) - - --- | Correspond to the possible values of the --- the attributes which are either `none` or --- `url(#elem)` -data ElementRef - = RefNone -- ^ Value for `none` - | Ref String -- ^ Equivalent to `url()` attribute. - deriving (Eq, Show, Generic, Hashable) - -data FilterSource - = SourceGraphic - | SourceAlpha - | BackgroundImage - | BackgroundAlpha - | FillPaint - | StrokePaint - | SourceRef String - deriving (Eq, Show, Generic, Hashable) - -data FilterAttributes = FilterAttributes - { _filterHeight :: !(Last Number) - , _filterResult :: !(Maybe String) - , _filterWidth :: !(Last Number) - , _filterX :: !(Last Number) - , _filterY :: !(Last Number) - } deriving (Eq, Show, Generic, Hashable) - -instance WithDefaultSvg FilterAttributes where - defaultSvg = FilterAttributes - { _filterHeight = Last Nothing - , _filterResult = Nothing - , _filterWidth = Last Nothing - , _filterX = Last Nothing - , _filterY = Last Nothing } - --- | This type define how to draw any primitives, --- which color to use, how to stroke the primitives --- and the potential transformations to use. --- --- All these attributes are propagated to the children. -data DrawAttributes = DrawAttributes - { -- | Attribute corresponding to the `stroke-width` - -- SVG attribute. - _strokeWidth :: !(Last Number) - -- | Correspond to the `stroke` attribute. - , _strokeColor :: !(Last Texture) - -- | Define the `stroke-opacity` attribute, the transparency - -- for the "border". - , _strokeOpacity :: !(Maybe Float) - -- | Correspond to the `stroke-linecap` SVG - -- attribute - , _strokeLineCap :: !(Last Cap) - -- | Correspond to the `stroke-linejoin` SVG - -- attribute - , _strokeLineJoin :: !(Last LineJoin) - -- | Define the distance of the miter join, correspond - -- to the `stroke-miterlimit` attritbue. - , _strokeMiterLimit :: !(Last Double) - -- | Define the filling color of the elements. Corresponding - -- to the `fill` attribute. - , _fillColor :: !(Last Texture) - -- | Define the `fill-opacity` attribute, the transparency - -- for the "content". - , _fillOpacity :: !(Maybe Float) - -- | Define the global or group opacity attribute. - , _groupOpacity :: !(Maybe Float) - -- | Content of the `transform` attribute - , _transform :: !(Maybe [Transformation]) - -- | Define the `fill-rule` used during the rendering. - , _fillRule :: !(Last FillRule) - -- | Define the `mask` attribute. - , _maskRef :: !(Last ElementRef) - -- | Define the `clip-path` attribute. - , _clipPathRef :: !(Last ElementRef) - -- | Define the `clip-rule` attribute. - , _clipRule :: !(Last FillRule) - -- | Map to the `class` attribute. Used for the CSS - -- rewriting. - , _attrClass :: ![T.Text] - -- | Map to the `id` attribute. Used for the CSS - -- rewriting. - , _attrId :: !(Maybe String) - -- | Define the start distance of the dashing pattern. - -- Correspond to the `stroke-dashoffset` attribute. - , _strokeOffset :: !(Last Number) - -- | Define the dashing pattern for the lines. Correspond - -- to the `stroke-dasharray` attribute. - , _strokeDashArray :: !(Last [Number]) - -- | Current size of the text, correspond to the - -- `font-size` SVG attribute. - , _fontSize :: !(Last Number) - -- | Define the possible fonts to be used for text rendering. - -- Map to the `font-family` attribute. - , _fontFamily :: !(Last [String]) - -- | Map to the `font-style` attribute. - , _fontStyle :: !(Last FontStyle) - -- | Define how to interpret the text position, correspond - -- to the `text-anchor` attribute. - , _textAnchor :: !(Last TextAnchor) - -- | Define the marker used for the start of the line. - -- Correspond to the `marker-start` attribute. - , _markerStart :: !(Last ElementRef) - -- | Define the marker used for every point of the - -- polyline/path Correspond to the `marker-mid` - -- attribute. - , _markerMid :: !(Last ElementRef) - -- | Define the marker used for the end of the line. - -- Correspond to the `marker-end` attribute. - , _markerEnd :: !(Last ElementRef) - , _filterRef :: !(Last ElementRef) - , _preRendered :: !(Maybe String) - } - deriving (Eq, Show, Generic, Hashable) - -makeClassy ''DrawAttributes - --- | This primitive describe an unclosed suite of --- segments. Correspond to the `` tag. -data PolyLine = PolyLine - { -- | drawing attributes of the polyline. - _polyLineDrawAttributes :: !DrawAttributes - - -- | Geometry definition of the polyline. - -- correspond to the `points` attribute - , _polyLinePoints :: ![RPoint] - } - deriving (Eq, Show, Generic, Hashable) - - -instance WithDefaultSvg PolyLine where - defaultSvg = PolyLine - { _polyLineDrawAttributes = mempty - , _polyLinePoints = [] - } - --- makeClassy ''PolyLine --- | Lenses for the PolyLine type. -class HasPolyLine a where - polyLine :: Lens' a PolyLine - polyLineDrawAttributes :: Lens' a DrawAttributes - {-# INLINE polyLineDrawAttributes #-} - polyLineDrawAttributes = polyLine . polyLineDrawAttributes - - polyLinePoints :: Lens' a [RPoint] - {-# INLINE polyLinePoints #-} - polyLinePoints = polyLine . polyLinePoints - -instance HasPolyLine PolyLine where - polyLine = id - {-# INLINE polyLineDrawAttributes #-} - polyLineDrawAttributes f p = - fmap (\y -> p { _polyLineDrawAttributes = y }) (f $ _polyLineDrawAttributes p) - {-# INLINE polyLinePoints #-} - polyLinePoints f p = - fmap (\y -> p { _polyLinePoints = y }) (f $ _polyLinePoints p) - -instance HasDrawAttributes PolyLine where - drawAttributes = polyLineDrawAttributes - --- | Primitive decriving polygon composed --- of segements. Correspond to the `` --- tag -data Polygon = Polygon - { -- | Drawing attributes for the polygon. - _polygonDrawAttributes :: !DrawAttributes - -- | Points of the polygon. Correspond to - -- the `points` attributes. - , _polygonPoints :: ![RPoint] - } - deriving (Eq, Show, Generic, Hashable) - --- makeClassy ''Polygon --- | Lenses for the Polygon type -class HasPolygon a where - polygon :: Lens' a Polygon - polygonDrawAttributes :: Lens' a DrawAttributes - {-# INLINE polygonDrawAttributes #-} - polygonPoints :: Lens' a [RPoint] - {-# INLINE polygonPoints #-} - polygonDrawAttributes = polygon . polygonDrawAttributes - polygonPoints = polygon . polygonPoints - -instance HasPolygon Polygon where - polygon = id - {-# INLINE polygonDrawAttributes #-} - polygonDrawAttributes f p = - fmap (\y -> p { _polygonDrawAttributes = y }) (f $ _polygonDrawAttributes p) - {-# INLINE polygonPoints #-} - polygonPoints f p = - fmap (\y -> p { _polygonPoints = y }) (f $ _polygonPoints p) - -instance HasDrawAttributes Polygon where - drawAttributes = polygonDrawAttributes - -instance WithDefaultSvg Polygon where - defaultSvg = Polygon - { _polygonDrawAttributes = mempty - , _polygonPoints = [] - } - --- | Define a simple line. Correspond to the --- `` tag. -data Line = Line - { -- | Drawing attributes of line. - _lineDrawAttributes :: !DrawAttributes - -- | First point of the the line, correspond - -- to the `x1` and `y1` attributes. - , _linePoint1 :: !Point - -- | Second point of the the line, correspond - -- to the `x2` and `y2` attributes. - , _linePoint2 :: !Point - } - deriving (Eq, Show, Generic, Hashable) - --- makeClassy ''Line --- | Lenses for the Line type. -class HasLine a where - line :: Lens' a Line - lineDrawAttributes :: Lens' a DrawAttributes - lineDrawAttributes = line . lineDrawAttributes - {-# INLINE lineDrawAttributes #-} - linePoint1 :: Lens' a Point - linePoint1 = line . linePoint1 - {-# INLINE linePoint1 #-} - linePoint2 :: Lens' a Point - linePoint2 = line . linePoint2 - {-# INLINE linePoint2 #-} - -instance HasLine Line where - line = id - {-# INLINE lineDrawAttributes #-} - lineDrawAttributes f l = - fmap (\y -> l { _lineDrawAttributes = y }) (f (_lineDrawAttributes l)) - {-# INLINE linePoint1 #-} - linePoint1 f l = - fmap (\y -> l { _linePoint1 = y }) (f (_linePoint1 l)) - {-# INLINE linePoint2 #-} - linePoint2 f l = - fmap (\y -> l { _linePoint2 = y }) (f (_linePoint2 l)) - -instance HasDrawAttributes Line where - drawAttributes = lineDrawAttributes - -instance WithDefaultSvg Line where - defaultSvg = Line - { _lineDrawAttributes = mempty - , _linePoint1 = zeroPoint - , _linePoint2 = zeroPoint - } - where zeroPoint = (Num 0, Num 0) - --- | Define a rectangle. Correspond to --- `` svg tag. -data Rectangle = Rectangle - { -- | Rectangle drawing attributes. - _rectDrawAttributes :: !DrawAttributes - -- | Upper left corner of the rectangle, correspond - -- to the attributes `x` and `y`. - , _rectUpperLeftCorner :: !Point - -- | Rectangle width, correspond, strangely, to - -- the `width` attribute. - , _rectWidth :: !(Maybe Number) - -- | Rectangle height, correspond, amazingly, to - -- the `height` attribute. - , _rectHeight :: !(Maybe Number) - -- | Define the rounded corner radius radius - -- of the rectangle. Correspond to the `rx` and - -- `ry` attributes. - , _rectCornerRadius :: !(Maybe Number, Maybe Number) - } - deriving (Eq, Show, Generic, Hashable) - --- makeClassy ''Rectangle --- | Lenses for the Rectangle type. -class HasRectangle a where - rectangle :: Lens' a Rectangle - rectCornerRadius :: Lens' a (Maybe Number, Maybe Number) - {-# INLINE rectCornerRadius #-} - rectCornerRadius = rectangle . rectCornerRadius - - rectDrawAttributes :: Lens' a DrawAttributes - {-# INLINE rectDrawAttributes #-} - rectDrawAttributes = rectangle . rectDrawAttributes - - rectHeight :: Lens' a (Maybe Number) - {-# INLINE rectHeight #-} - rectHeight = rectangle . rectHeight - - rectUpperLeftCorner :: Lens' a Point - {-# INLINE rectUpperLeftCorner #-} - rectUpperLeftCorner = rectangle . rectUpperLeftCorner - - rectWidth :: Lens' a (Maybe Number) - {-# INLINE rectWidth #-} - rectWidth = rectangle . rectWidth - -instance HasRectangle Rectangle where - rectangle = id - {-# INLINE rectCornerRadius #-} - rectCornerRadius f attr = - fmap (\y -> attr { _rectCornerRadius = y }) (f $ _rectCornerRadius attr) - {-# INLINE rectDrawAttributes #-} - rectDrawAttributes f attr = - fmap (\y -> attr { _rectDrawAttributes = y }) (f $ _rectDrawAttributes attr) - {-# INLINE rectHeight #-} - rectHeight f attr = - fmap (\y -> attr { _rectHeight = y }) (f $ _rectHeight attr) - {-# INLINE rectUpperLeftCorner #-} - rectUpperLeftCorner f attr = - fmap (\y -> attr { _rectUpperLeftCorner = y }) (f $ _rectUpperLeftCorner attr) - {-# INLINE rectWidth #-} - rectWidth f attr = - fmap (\y -> attr { _rectWidth = y }) (f $ _rectWidth attr) - -instance HasDrawAttributes Rectangle where - drawAttributes = rectDrawAttributes - -instance WithDefaultSvg Rectangle where - defaultSvg = Rectangle - { _rectDrawAttributes = mempty - , _rectUpperLeftCorner = (Num 0, Num 0) - , _rectWidth = Nothing - , _rectHeight = Nothing - , _rectCornerRadius = (Nothing, Nothing) - } - --- | Type mapping the `` svg tag. -data Path = Path - { -- | Drawing attributes of the path. - _pathDrawAttributes :: !DrawAttributes - -- | Definition of the path, correspond to the - -- `d` attributes. - , _pathDefinition :: ![PathCommand] - } - deriving (Eq, Show, Generic, Hashable) - --- makeClassy ''Path --- | Lenses for the Path type -class HasPath c_alhy where - path :: Lens' c_alhy Path - pathDefinition :: Lens' c_alhy [PathCommand] - {-# INLINE pathDefinition #-} - pathDefinition = path . pathDefinition - - pathDrawAttributes :: Lens' c_alhy DrawAttributes - {-# INLINE pathDrawAttributes #-} - pathDrawAttributes = path . pathDrawAttributes - -instance HasPath Path where - path = id - {-# INLINE pathDefinition #-} - pathDefinition f attr = - fmap (\y -> attr { _pathDefinition = y }) (f $ _pathDefinition attr) - {-# INLINE pathDrawAttributes #-} - pathDrawAttributes f attr = - fmap (\y -> attr { _pathDrawAttributes = y }) (f $ _pathDrawAttributes attr) - -instance HasDrawAttributes Path where - drawAttributes = pathDrawAttributes - -instance WithDefaultSvg Path where - defaultSvg = Path - { _pathDrawAttributes = mempty - , _pathDefinition = [] - } - --- | Define a SVG group, corresponding `` tag. -data Group a = Group - { -- | Group drawing attributes, propagated to all of its - -- children. - _groupDrawAttributes :: !DrawAttributes - -- | Content of the group, corresponding to all the tags - -- inside the `` tag. - , _groupChildren :: ![a] - -- | Mapped to the attribute `viewBox` - , _groupViewBox :: !(Maybe (Double, Double, Double, Double)) - -- | used for symbols only - , _groupAspectRatio :: !PreserveAspectRatio - } - deriving (Eq, Show, Generic, Hashable) - --- makeClassy ''Group --- | Lenses associated to the Group type. -class HasGroup g a | g -> a where - group :: Lens' g (Group a) - groupAspectRatio :: Lens' g PreserveAspectRatio - {-# INLINE groupAspectRatio #-} - groupAspectRatio = group . groupAspectRatio - - groupChildren :: Lens' g [a] - {-# INLINE groupChildren #-} - groupChildren = group . groupChildren - - groupDrawAttributes :: Lens' g DrawAttributes - {-# INLINE groupDrawAttributes #-} - groupDrawAttributes = group . groupDrawAttributes - - groupViewBox :: Lens' g (Maybe (Double, Double, Double, Double)) - {-# INLINE groupViewBox #-} - groupViewBox = group . groupViewBox - -instance HasGroup (Group a) a where - group = id - {-# INLINE groupAspectRatio #-} - groupAspectRatio f attr = - fmap (\y -> attr { _groupAspectRatio = y }) (f $ _groupAspectRatio attr) - - {-# INLINE groupChildren #-} - groupChildren f attr = - fmap (\y -> attr { _groupChildren = y }) (f $ _groupChildren attr) - - {-# INLINE groupDrawAttributes #-} - groupDrawAttributes f attr = - fmap (\y -> attr { _groupDrawAttributes = y }) (f $ _groupDrawAttributes attr) - - {-# INLINE groupViewBox #-} - groupViewBox f attr = - fmap (\y -> attr { _groupViewBox = y }) (f $ _groupViewBox attr) - -instance HasDrawAttributes (Group a) where - drawAttributes = groupDrawAttributes - -instance WithDefaultSvg (Group a) where - defaultSvg = Group - { _groupDrawAttributes = mempty - , _groupChildren = [] - , _groupViewBox = Nothing - , _groupAspectRatio = defaultSvg - } - --- | Define the `` tag, equivalent to --- a hidden named group. -newtype Symbol a = - Symbol { _groupOfSymbol :: Group a } - deriving (Eq, Show, Generic, Hashable) - -instance HasGroup (Symbol a) a where - group = groupOfSymbol - --- makeLenses ''Symbol --- | Lenses associated with the Symbol type. -groupOfSymbol :: Lens (Symbol s) (Symbol t) (Group s) (Group t) -{-# INLINE groupOfSymbol #-} -groupOfSymbol f = fmap Symbol . f . _groupOfSymbol - -instance HasDrawAttributes (Symbol a) where - drawAttributes = groupOfSymbol . drawAttributes - -instance WithDefaultSvg (Symbol a) where - defaultSvg = Symbol defaultSvg - --- | Define the `` tag, equivalent to --- a named symbol. -newtype Definitions a = - Definitions { _groupOfDefinitions :: Group a } - deriving (Eq, Show, Generic, Hashable) - -instance HasGroup (Definitions a) a where - group = groupOfDefinitions - --- makeLenses ''Definitions --- | Lenses associated with the Definitions type. -groupOfDefinitions :: Lens (Definitions s) (Definitions t) (Group s) (Group t) -{-# INLINE groupOfDefinitions #-} -groupOfDefinitions f = fmap Definitions . f . _groupOfDefinitions - -instance HasDrawAttributes (Definitions a) where - drawAttributes = groupOfDefinitions . drawAttributes - -instance WithDefaultSvg (Definitions a) where - defaultSvg = Definitions defaultSvg - --- | Define the `` tag. -data Filter = Filter - { _filterDrawAttributes :: !DrawAttributes - , _filterSelfAttributes :: !FilterAttributes - , _filterChildren :: ![FilterElement] - } - deriving (Eq, Show, Generic, Hashable) - -instance WithDefaultSvg Filter where - defaultSvg = Filter - { _filterDrawAttributes = defaultSvg - , _filterSelfAttributes = defaultSvg - , _filterChildren = [] - } - --- | Define a ``. -data Circle = Circle - { -- | Drawing attributes of the circle. - _circleDrawAttributes :: !DrawAttributes - -- | Define the center of the circle, describe - -- the `cx` and `cy` attributes. - , _circleCenter :: !Point - -- | Radius of the circle, equivalent to the `r` - -- attribute. - , _circleRadius :: !Number - } - deriving (Eq, Show, Generic, Hashable) - --- makeClassy ''Circle --- | Lenses for the Circle type. -class HasCircle a where - circle :: Lens' a Circle - circleCenter :: Lens' a Point - {-# INLINE circleCenter #-} - circleCenter = circle . circleCenter - - circleDrawAttributes :: Lens' a DrawAttributes - {-# INLINE circleDrawAttributes #-} - circleDrawAttributes = circle . circleDrawAttributes - - circleRadius :: Lens' a Number - {-# INLINE circleRadius #-} - circleRadius = circle . circleRadius - -instance HasCircle Circle where - circle = id - {-# INLINE circleCenter #-} - circleCenter f attr = - fmap (\y -> attr { _circleCenter = y }) (f $ _circleCenter attr) - {-# INLINE circleDrawAttributes #-} - circleDrawAttributes f attr = - fmap (\y -> attr { _circleDrawAttributes = y }) (f $ _circleDrawAttributes attr) - {-# INLINE circleRadius #-} - circleRadius f attr = - fmap (\y -> attr { _circleRadius = y }) (f $ _circleRadius attr) - -instance HasDrawAttributes Circle where - drawAttributes = circleDrawAttributes - -instance WithDefaultSvg Circle where - defaultSvg = Circle - { _circleDrawAttributes = mempty - , _circleCenter = (Num 0, Num 0) - , _circleRadius = Num 0 - } - --- | Define an `` -data Ellipse = Ellipse - { -- | Drawing attributes of the ellipse. - _ellipseDrawAttributes :: !DrawAttributes - -- | Center of the ellipse, map to the `cx` - -- and `cy` attributes. - , _ellipseCenter :: !Point - -- | Radius along the X axis, map the - -- `rx` attribute. - , _ellipseXRadius :: !Number - -- | Radius along the Y axis, map the - -- `ry` attribute. - , _ellipseYRadius :: !Number - } - deriving (Eq, Show, Generic, Hashable) - --- makeClassy ''Ellipse --- | Lenses for the ellipse type. -class HasEllipse c_amWt where - ellipse :: Lens' c_amWt Ellipse - ellipseCenter :: Lens' c_amWt Point - {-# INLINE ellipseCenter #-} - ellipseDrawAttributes :: Lens' c_amWt DrawAttributes - {-# INLINE ellipseDrawAttributes #-} - ellipseXRadius :: Lens' c_amWt Number - {-# INLINE ellipseXRadius #-} - ellipseYRadius :: Lens' c_amWt Number - {-# INLINE ellipseYRadius #-} - ellipseCenter = ((.) ellipse) ellipseCenter - ellipseDrawAttributes = ((.) ellipse) ellipseDrawAttributes - ellipseXRadius = ((.) ellipse) ellipseXRadius - ellipseYRadius = ((.) ellipse) ellipseYRadius - -instance HasEllipse Ellipse where - {-# INLINE ellipseCenter #-} - {-# INLINE ellipseDrawAttributes #-} - {-# INLINE ellipseXRadius #-} - {-# INLINE ellipseYRadius #-} - ellipse = id - ellipseCenter f attr = - fmap (\y -> attr { _ellipseCenter = y }) (f $ _ellipseCenter attr) - ellipseDrawAttributes f attr = - fmap (\y -> attr { _ellipseDrawAttributes = y }) (f $ _ellipseDrawAttributes attr) - ellipseXRadius f attr = - fmap (\y -> attr { _ellipseXRadius = y }) (f $ _ellipseXRadius attr) - ellipseYRadius f attr = - fmap (\y -> attr { _ellipseYRadius = y }) (f $ _ellipseYRadius attr) - -instance HasDrawAttributes Ellipse where - drawAttributes = ellipseDrawAttributes - -instance WithDefaultSvg Ellipse where - defaultSvg = Ellipse - { _ellipseDrawAttributes = mempty - , _ellipseCenter = (Num 0, Num 0) - , _ellipseXRadius = Num 0 - , _ellipseYRadius = Num 0 - } - --- | Define a color stop for the gradients. Represent --- the `` SVG tag. -data GradientStop = GradientStop - { -- | Gradient offset between 0 and 1, correspond - -- to the `offset` attribute. - _gradientOffset :: !Float - -- | Color of the gradient stop. Correspond - -- to the `stop-color` attribute. - , _gradientColor :: !PixelRGBA8 - -- | Path command used in mesh patch - , _gradientPath :: !(Maybe GradientPathCommand) - -- | Stop color opacity - , _gradientOpacity :: !(Maybe Float) - } - deriving (Eq, Show, Generic, Hashable) - --- makeClassy ''GradientStop --- | Lenses for the GradientStop type. -class HasGradientStop c_anhM where - gradientStop :: Lens' c_anhM GradientStop - gradientColor :: Lens' c_anhM PixelRGBA8 - {-# INLINE gradientColor #-} - gradientOffset :: Lens' c_anhM Float - {-# INLINE gradientOffset #-} - gradientOpacity :: Lens' c_anhM (Maybe Float) - {-# INLINE gradientOpacity #-} - gradientPath :: Lens' c_anhM (Maybe GradientPathCommand) - {-# INLINE gradientPath #-} - gradientColor = ((.) gradientStop) gradientColor - gradientOffset = ((.) gradientStop) gradientOffset - gradientOpacity = ((.) gradientStop) gradientOpacity - gradientPath = ((.) gradientStop) gradientPath - -instance HasGradientStop GradientStop where - {-# INLINE gradientColor #-} - {-# INLINE gradientOffset #-} - {-# INLINE gradientOpacity #-} - {-# INLINE gradientPath #-} - gradientStop = id - gradientColor f attr = - fmap (\y -> attr { _gradientColor = y }) (f $ _gradientColor attr) - gradientOffset f attr = - fmap (\y -> attr { _gradientOffset = y }) (f $ _gradientOffset attr) - gradientOpacity f attr = - fmap (\y -> attr { _gradientOpacity = y }) (f $ _gradientOpacity attr) - gradientPath f attr = - fmap (\y -> attr { _gradientPath = y }) (f $ _gradientPath attr) - -instance WithDefaultSvg GradientStop where - defaultSvg = GradientStop - { _gradientOffset = 0.0 - , _gradientColor = PixelRGBA8 0 0 0 255 - , _gradientPath = Nothing - , _gradientOpacity = Nothing - } - - --- | Define `` SVG tag -data MeshGradientPatch = MeshGradientPatch - { -- | List of stop, from 2 to 4 in a patch - _meshGradientPatchStops :: ![GradientStop] - } - deriving (Eq, Show, Generic, Hashable) - --- makeClassy ''MeshGradientPatch -class HasMeshGradientPatch c_annx where - meshGradientPatch :: Lens' c_annx MeshGradientPatch - meshGradientPatchStops :: Lens' c_annx [GradientStop] - {-# INLINE meshGradientPatchStops #-} - meshGradientPatchStops = meshGradientPatch . meshGradientPatchStops - -instance HasMeshGradientPatch MeshGradientPatch where - {-# INLINE meshGradientPatchStops #-} - meshGradientPatch = id - meshGradientPatchStops f m = - fmap (\y -> m { _meshGradientPatchStops = y }) . f $ _meshGradientPatchStops m - -instance WithDefaultSvg MeshGradientPatch where - defaultSvg = MeshGradientPatch [] - --- | Define a `` tag. -data MeshGradientRow = MeshGradientRow - { -- | List of patch in a row - _meshGradientRowPatches :: ![MeshGradientPatch] - } - deriving (Eq, Show, Generic, Hashable) - --- makeClassy ''MeshGradientRow -class HasMeshGradientRow c_antr where - meshGradientRow :: Lens' c_antr MeshGradientRow - meshGradientRowPatches :: Lens' c_antr [MeshGradientPatch] - {-# INLINE meshGradientRowPatches #-} - meshGradientRowPatches = meshGradientRow . meshGradientRowPatches - -instance HasMeshGradientRow MeshGradientRow where - {-# INLINE meshGradientRowPatches #-} - meshGradientRow = id - meshGradientRowPatches f m = - fmap (\y -> m { _meshGradientRowPatches = y }) . f $ _meshGradientRowPatches m - -instance WithDefaultSvg MeshGradientRow where - defaultSvg = MeshGradientRow [] - - --- | Define a `` tag. -data MeshGradient = MeshGradient - { _meshGradientDrawAttributes :: !DrawAttributes - -- | Original x coordinate of the mesh gradient - , _meshGradientX :: !Number - -- | Original y coordinate of the mesh gradient - , _meshGradientY :: !Number - -- | Type of color interpolation to use - , _meshGradientType :: !MeshGradientType - -- | Coordiante system to use - , _meshGradientUnits :: !CoordinateUnits - -- | Optional transform - , _meshGradientTransform :: ![Transformation] - -- | List of patch rows in the the mesh. - , _meshGradientRows :: ![MeshGradientRow] - } - deriving (Eq, Show, Generic, Hashable) - --- makeClassy ''MeshGradient -class HasMeshGradient c_anxG where - meshGradient :: Lens' c_anxG MeshGradient - meshGradientDrawAttributes :: Lens' c_anxG DrawAttributes - {-# INLINE meshGradientDrawAttributes #-} - meshGradientRows :: Lens' c_anxG [MeshGradientRow] - {-# INLINE meshGradientRows #-} - meshGradientTransform :: Lens' c_anxG [Transformation] - {-# INLINE meshGradientTransform #-} - meshGradientType :: Lens' c_anxG MeshGradientType - {-# INLINE meshGradientType #-} - meshGradientUnits :: Lens' c_anxG CoordinateUnits - {-# INLINE meshGradientUnits #-} - meshGradientX :: Lens' c_anxG Number - {-# INLINE meshGradientX #-} - meshGradientY :: Lens' c_anxG Number - {-# INLINE meshGradientY #-} - meshGradientDrawAttributes - = ((.) meshGradient) meshGradientDrawAttributes - meshGradientRows = ((.) meshGradient) meshGradientRows - meshGradientTransform = ((.) meshGradient) meshGradientTransform - meshGradientType = ((.) meshGradient) meshGradientType - meshGradientUnits = ((.) meshGradient) meshGradientUnits - meshGradientX = ((.) meshGradient) meshGradientX - meshGradientY = ((.) meshGradient) meshGradientY -instance HasMeshGradient MeshGradient where - {-# INLINE meshGradientDrawAttributes #-} - {-# INLINE meshGradientRows #-} - {-# INLINE meshGradientTransform #-} - {-# INLINE meshGradientType #-} - {-# INLINE meshGradientUnits #-} - {-# INLINE meshGradientX #-} - {-# INLINE meshGradientY #-} - meshGradient = id - meshGradientDrawAttributes f attr = - fmap (\y -> attr { _meshGradientDrawAttributes = y }) (f $ _meshGradientDrawAttributes attr) - meshGradientRows f attr = - fmap (\y -> attr { _meshGradientRows = y }) (f $ _meshGradientRows attr) - meshGradientTransform f attr = - fmap (\y -> attr { _meshGradientTransform = y }) (f $ _meshGradientTransform attr) - meshGradientType f attr = - fmap (\y -> attr { _meshGradientType = y }) (f $ _meshGradientType attr) - meshGradientUnits f attr = - fmap (\y -> attr { _meshGradientUnits = y }) (f $ _meshGradientUnits attr) - meshGradientX f attr = - fmap (\y -> attr { _meshGradientX = y }) (f $ _meshGradientX attr) - meshGradientY f attr = - fmap (\y -> attr { _meshGradientY = y }) (f $ _meshGradientY attr) - - -instance HasDrawAttributes MeshGradient where - drawAttributes = meshGradientDrawAttributes - -instance WithDefaultSvg MeshGradient where - defaultSvg = MeshGradient - { _meshGradientDrawAttributes = mempty - , _meshGradientX = Percent 0 - , _meshGradientY = Percent 0 - , _meshGradientType = GradientBilinear - , _meshGradientUnits = CoordBoundingBox - , _meshGradientTransform = mempty - , _meshGradientRows = mempty - } - - --- | Define an `` tag. -data Image = Image - { -- | Drawing attributes of the image - _imageDrawAttributes :: !DrawAttributes - -- | Position of the image referenced by its - -- upper left corner. - , _imageCornerUpperLeft :: !Point - -- | Image width - , _imageWidth :: !Number - -- | Image Height - , _imageHeight :: !Number - -- | Image href, pointing to the real image. - , _imageHref :: !String - -- | preserveAspectRatio attribute - , _imageAspectRatio :: !PreserveAspectRatio - } - deriving (Eq, Show, Generic, Hashable) - --- makeClassy ''Image --- | Lenses for the Image type. -class HasImage c_anI7 where - image :: Lens' c_anI7 Image - imageAspectRatio :: Lens' c_anI7 PreserveAspectRatio - {-# INLINE imageAspectRatio #-} - imageCornerUpperLeft :: Lens' c_anI7 Point - {-# INLINE imageCornerUpperLeft #-} - imageDrawAttributes :: Lens' c_anI7 DrawAttributes - {-# INLINE imageDrawAttributes #-} - imageHeight :: Lens' c_anI7 Number - {-# INLINE imageHeight #-} - imageHref :: Lens' c_anI7 String - {-# INLINE imageHref #-} - imageWidth :: Lens' c_anI7 Number - {-# INLINE imageWidth #-} - imageAspectRatio = ((.) image) imageAspectRatio - imageCornerUpperLeft = ((.) image) imageCornerUpperLeft - imageDrawAttributes = ((.) image) imageDrawAttributes - imageHeight = ((.) image) imageHeight - imageHref = ((.) image) imageHref - imageWidth = ((.) image) imageWidth -instance HasImage Image where - {-# INLINE imageAspectRatio #-} - {-# INLINE imageCornerUpperLeft #-} - {-# INLINE imageDrawAttributes #-} - {-# INLINE imageHeight #-} - {-# INLINE imageHref #-} - {-# INLINE imageWidth #-} - image = id - imageAspectRatio f attr = - fmap (\y -> attr { _imageAspectRatio = y }) (f $ _imageAspectRatio attr) - imageCornerUpperLeft f attr = - fmap (\y -> attr { _imageCornerUpperLeft = y }) (f $ _imageCornerUpperLeft attr) - imageDrawAttributes f attr = - fmap (\y -> attr { _imageDrawAttributes = y }) (f $ _imageDrawAttributes attr) - imageHeight f attr = - fmap (\y -> attr { _imageHeight = y }) (f $ _imageHeight attr) - imageHref f attr = - fmap (\y -> attr { _imageHref = y }) (f $ _imageHref attr) - imageWidth f attr = - fmap (\y -> attr { _imageWidth = y }) (f $ _imageWidth attr) - - -instance HasDrawAttributes Image where - drawAttributes = imageDrawAttributes - -instance WithDefaultSvg Image where - defaultSvg = Image - { _imageDrawAttributes = mempty - , _imageCornerUpperLeft = (Num 0, Num 0) - , _imageWidth = Num 0 - , _imageHeight = Num 0 - , _imageHref = "" - , _imageAspectRatio = defaultSvg - } - --- | Define an `` for a named content. --- Every named content can be reused in the --- document using this element. -data Use = Use - { -- | Position where to draw the "used" element. - -- Correspond to the `x` and `y` attributes. - _useBase :: Point - -- | Referenced name, correspond to `xlink:href` - -- attribute. - , _useName :: String - -- | Define the width of the region where - -- to place the element. Map to the `width` - -- attribute. - , _useWidth :: Maybe Number - -- | Define the height of the region where - -- to place the element. Map to the `height` - -- attribute. - , _useHeight :: Maybe Number - -- | Use draw attributes. - , _useDrawAttributes :: DrawAttributes - } - deriving (Eq, Show, Generic, Hashable) - --- makeClassy ''Use --- | Lenses for the Use type. -class HasUse c_anR3 where - use :: Lens' c_anR3 Use - useBase :: Lens' c_anR3 Point - {-# INLINE useBase #-} - useDrawAttributes :: Lens' c_anR3 DrawAttributes - {-# INLINE useDrawAttributes #-} - useHeight :: Lens' c_anR3 (Maybe Number) - {-# INLINE useHeight #-} - useName :: Lens' c_anR3 String - {-# INLINE useName #-} - useWidth :: Lens' c_anR3 (Maybe Number) - {-# INLINE useWidth #-} - useBase = ((.) use) useBase - useDrawAttributes = ((.) use) useDrawAttributes - useHeight = ((.) use) useHeight - useName = ((.) use) useName - useWidth = ((.) use) useWidth -instance HasUse Use where - {-# INLINE useBase #-} - {-# INLINE useDrawAttributes #-} - {-# INLINE useHeight #-} - {-# INLINE useName #-} - {-# INLINE useWidth #-} - use = id - useBase f attr = - fmap (\y -> attr { _useBase = y }) (f $ _useBase attr) - useDrawAttributes f attr = - fmap (\y -> attr { _useDrawAttributes = y }) (f $ _useDrawAttributes attr) - useHeight f attr = - fmap (\y -> attr { _useHeight = y }) (f $ _useHeight attr) - useName f attr = - fmap (\y -> attr { _useName = y }) (f $ _useName attr) - useWidth f attr = - fmap (\y -> attr { _useWidth = y }) (f $ _useWidth attr) - -instance HasDrawAttributes Use where - drawAttributes = useDrawAttributes - -instance WithDefaultSvg Use where - defaultSvg = Use - { _useBase = (Num 0, Num 0) - , _useName = "" - , _useWidth = Nothing - , _useHeight = Nothing - , _useDrawAttributes = mempty - } - --- | Define position information associated to --- `` or `` svg tag. -data TextInfo = TextInfo - { _textInfoX :: ![Number] -- ^ `x` attribute. - , _textInfoY :: ![Number] -- ^ `y` attribute. - , _textInfoDX :: ![Number] -- ^ `dx` attribute. - , _textInfoDY :: ![Number] -- ^ `dy` attribute. - , _textInfoRotate :: ![Double] -- ^ `rotate` attribute. - , _textInfoLength :: !(Maybe Number) -- ^ `textLength` attribute. - } - deriving (Eq, Show, Generic, Hashable) - -instance Semigroup TextInfo where - (<>) (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) - -instance Monoid TextInfo where - mempty = TextInfo [] [] [] [] [] Nothing - mappend = (<>) - --- makeClassy ''TextInfo --- | Lenses for the TextInfo type. -class HasTextInfo c_ao0m where - textInfo :: Lens' c_ao0m TextInfo - textInfoDX :: Lens' c_ao0m [Number] - {-# INLINE textInfoDX #-} - textInfoDY :: Lens' c_ao0m [Number] - {-# INLINE textInfoDY #-} - textInfoLength :: Lens' c_ao0m (Maybe Number) - {-# INLINE textInfoLength #-} - textInfoRotate :: Lens' c_ao0m [Double] - {-# INLINE textInfoRotate #-} - textInfoX :: Lens' c_ao0m [Number] - {-# INLINE textInfoX #-} - textInfoY :: Lens' c_ao0m [Number] - {-# INLINE textInfoY #-} - textInfoDX = ((.) textInfo) textInfoDX - textInfoDY = ((.) textInfo) textInfoDY - textInfoLength = ((.) textInfo) textInfoLength - textInfoRotate = ((.) textInfo) textInfoRotate - textInfoX = ((.) textInfo) textInfoX - textInfoY = ((.) textInfo) textInfoY -instance HasTextInfo TextInfo where - {-# INLINE textInfoDX #-} - {-# INLINE textInfoDY #-} - {-# INLINE textInfoLength #-} - {-# INLINE textInfoRotate #-} - {-# INLINE textInfoX #-} - {-# INLINE textInfoY #-} - textInfo = id - textInfoDX f attr = - fmap (\y -> attr { _textInfoDX = y }) (f $ _textInfoDX attr) - textInfoDY f attr = - fmap (\y -> attr { _textInfoDY = y }) (f $ _textInfoDY attr) - textInfoLength f attr = - fmap (\y -> attr { _textInfoLength = y }) (f $ _textInfoLength attr) - textInfoRotate f attr = - fmap (\y -> attr { _textInfoRotate = y }) (f $ _textInfoRotate attr) - textInfoX f attr = - fmap (\y -> attr { _textInfoX = y }) (f $ _textInfoX attr) - textInfoY f attr = - fmap (\y -> attr { _textInfoY = y }) (f $ _textInfoY attr) - -instance WithDefaultSvg TextInfo where - defaultSvg = mempty - --- | Define the content of a `` tag. -data TextSpanContent - = SpanText !T.Text -- ^ Raw text - | SpanTextRef !String -- ^ Equivalent to a `` - | SpanSub !TextSpan -- ^ Define a `` - deriving (Eq, Show, Generic, Hashable) - --- | Define a `` tag. -data TextSpan = TextSpan - { -- | Placing information for the text. - _spanInfo :: !TextInfo - -- | Drawing attributes for the text span. - , _spanDrawAttributes :: !DrawAttributes - -- | Content of the span. - , _spanContent :: ![TextSpanContent] - } - deriving (Eq, Show, Generic, Hashable) - --- makeClassy ''TextSpan --- | Lenses for the TextSpan type. -class HasTextSpan c_aobD where - textSpan :: Lens' c_aobD TextSpan - spanContent :: Lens' c_aobD [TextSpanContent] - {-# INLINE spanContent #-} - spanDrawAttributes :: Lens' c_aobD DrawAttributes - {-# INLINE spanDrawAttributes #-} - spanInfo :: Lens' c_aobD TextInfo - {-# INLINE spanInfo #-} - spanContent = ((.) textSpan) spanContent - spanDrawAttributes = ((.) textSpan) spanDrawAttributes - spanInfo = ((.) textSpan) spanInfo -instance HasTextSpan TextSpan where - {-# INLINE spanContent #-} - {-# INLINE spanDrawAttributes #-} - {-# INLINE spanInfo #-} - textSpan = id - spanContent f attr = - fmap (\y -> attr { _spanContent = y }) (f $ _spanContent attr) - spanDrawAttributes f attr = - fmap (\y -> attr { _spanDrawAttributes = y }) (f $ _spanDrawAttributes attr) - spanInfo f attr = - fmap (\y -> attr { _spanInfo = y }) (f $ _spanInfo attr) - -instance WithDefaultSvg TextSpan where - defaultSvg = TextSpan - { _spanInfo = defaultSvg - , _spanDrawAttributes = mempty - , _spanContent = mempty - } - --- | Describe the content of the `method` attribute on --- text path. -data TextPathMethod - = TextPathAlign -- ^ Map to the `align` value. - | TextPathStretch -- ^ Map to the `stretch` value. - deriving (Eq, Show, Generic, Hashable) - --- | Describe the content of the `spacing` text path --- attribute. -data TextPathSpacing - = TextPathSpacingExact -- ^ Map to the `exact` value. - | TextPathSpacingAuto -- ^ Map to the `auto` value. - deriving (Eq, Show, Generic, Hashable) - --- | Describe the `` SVG tag. -data TextPath = TextPath - { -- | Define the beginning offset on the path, - -- the `startOffset` attribute. - _textPathStartOffset :: !Number - -- | Define the `xlink:href` attribute. - , _textPathName :: !String - -- | Correspond to the `method` attribute. - , _textPathMethod :: !TextPathMethod - -- | Correspond to the `spacing` attribute. - , _textPathSpacing :: !TextPathSpacing - } - deriving (Eq, Show, Generic, Hashable) - --- -- | Lenses for the TextPath type. - -instance WithDefaultSvg TextPath where - defaultSvg = TextPath - { _textPathStartOffset = Num 0 - , _textPathName = mempty - , _textPathMethod = TextPathAlign - , _textPathSpacing = TextPathSpacingExact - } - --- | Define the possible values of the `lengthAdjust` --- attribute. -data TextAdjust - = TextAdjustSpacing -- ^ Value `spacing` - | TextAdjustSpacingAndGlyphs -- ^ Value `spacingAndGlyphs` - deriving (Eq, Show, Generic, Hashable) - --- | Define the global `` SVG tag. -data Text = Text - { -- | Define the `lengthAdjust` attribute. - _textAdjust :: !TextAdjust - -- | Root of the text content. - , _textRoot :: !TextSpan - } - deriving (Eq, Show, Generic, Hashable) - --- makeClassy ''Text --- | Lenses for the Text type. -class HasText c_aorD where - text :: Lens' c_aorD Text - textAdjust :: Lens' c_aorD TextAdjust - {-# INLINE textAdjust #-} - textRoot :: Lens' c_aorD TextSpan - {-# INLINE textRoot #-} - textAdjust = ((.) text) textAdjust - textRoot = ((.) text) textRoot -instance HasText Text where - {-# INLINE textAdjust #-} - {-# INLINE textRoot #-} - text = id - textAdjust f attr = - fmap (\y -> attr { _textAdjust = y }) (f $ _textAdjust attr) - textRoot f attr = - fmap (\y -> attr { _textRoot = y }) (f $ _textRoot attr) - --- | Little helper to create a SVG text at a given --- baseline position. -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 HasDrawAttributes Text where - drawAttributes = textRoot . spanDrawAttributes - -instance WithDefaultSvg Text where - defaultSvg = Text - { _textRoot = defaultSvg - , _textAdjust = TextAdjustSpacing - } - --- | Main type for the scene description, reorient to --- specific type describing each tag. -data Tree - = None - | UseTree { useInformation :: !Use - , useSubTree :: !(Maybe Tree) } - | GroupTree !(Group Tree) - | SymbolTree !(Symbol Tree) - | DefinitionTree !(Definitions Tree) - | FilterTree !Filter - | PathTree !Path - | CircleTree !Circle - | PolyLineTree !PolyLine - | PolygonTree !Polygon - | EllipseTree !Ellipse - | LineTree !Line - | RectangleTree !Rectangle - | TextTree !(Maybe TextPath) !Text - | ImageTree !Image - | LinearGradientTree !LinearGradient - | RadialGradientTree !RadialGradient - | MeshGradientTree !MeshGradient - | PatternTree !Pattern - | MarkerTree !Marker - | MaskTree !Mask - | ClipPathTree !ClipPath - | SvgTree !Document - deriving (Eq, Show, Generic, Hashable) - -data FilterElement - = FEBlend - | FEColorMatrix ColorMatrix - | FEComponentTransfer -- Need - | FEComposite Composite - | FEConvolveMatrix - | FEDiffuseLighting - | FEDisplacementMap DisplacementMap - | FEDropShadow - | FEFlood - | FEFuncA -- Need - | FEFuncB - | FEFuncG - | FEFuncR - | FEGaussianBlur GaussianBlur - | FEImage - | FEMerge - | FEMergeNode - | FEMorphology - | FEOffset - | FESpecularLighting - | FETile - | FETurbulence Turbulence - | FENone - deriving (Eq,Show, Generic, Hashable) - -instance WithDefaultSvg FilterElement where - defaultSvg = FENone - -data TransferFunctionType - = TFIdentity - | TFTable - | TFDiscrete - | TFLinear - | TFGamma - deriving (Eq, Show, Generic, Hashable) - -data TransferFunction = TransferFunction - { _transferFunctionDrawAttributes :: !DrawAttributes - , _transferFunctionFilterAttr :: !FilterAttributes - , _transferFunctionType :: TransferFunctionType - , _transferFunctionTableValues :: [Double] - , _transferFunctionSlope :: Double - , _transferFunctionIntercept :: Double - , _transferFunctionAmplitude :: Double - , _transferFunctionExponent :: Double - , _transferFunctionOffset :: Double - } deriving (Eq, Show, Generic, Hashable) - -data ChannelSelector - = ChannelR - | ChannelG - | ChannelB - | ChannelA - deriving (Eq, Show, Generic, Hashable) - -data DisplacementMap = DisplacementMap - { _displacementMapDrawAttributes :: !DrawAttributes - , _displacementMapFilterAttr :: !FilterAttributes - , _displacementMapIn :: !(Last FilterSource) - , _displacementMapIn2 :: !(Last FilterSource) - , _displacementMapScale :: !(Last Double) - , _displacementMapXChannelSelector :: ChannelSelector - , _displacementMapYChannelSelector :: ChannelSelector - } deriving (Eq, Show, Generic, Hashable) - -instance WithDefaultSvg DisplacementMap where - defaultSvg = DisplacementMap - { _displacementMapDrawAttributes = defaultSvg - , _displacementMapFilterAttr = defaultSvg - , _displacementMapIn = Last Nothing - , _displacementMapIn2 = Last Nothing - , _displacementMapScale = Last Nothing - , _displacementMapXChannelSelector = ChannelA - , _displacementMapYChannelSelector = ChannelA - } - -data ColorMatrixType - = Matrix - | Saturate - | HueRotate - | LuminanceToAlpha - deriving (Eq,Show, Generic, Hashable) - -data ColorMatrix = ColorMatrix - { _colorMatrixDrawAttributes :: !DrawAttributes - , _colorMatrixFilterAttr :: !FilterAttributes - , _colorMatrixIn :: !(Last FilterSource) - , _colorMatrixType :: !ColorMatrixType - , _colorMatrixValues :: !String - } deriving (Eq,Show, Generic, Hashable) - -instance WithDefaultSvg ColorMatrix where - defaultSvg = ColorMatrix - { _colorMatrixDrawAttributes = defaultSvg - , _colorMatrixFilterAttr = defaultSvg - , _colorMatrixIn = Last Nothing - , _colorMatrixType = Matrix - , _colorMatrixValues = "" - } - -data CompositeOperator - = CompositeOver -- this is default - | CompositeIn - | CompositeOut - | CompositeAtop - | CompositeXor - | CompositeArithmetic - deriving (Eq, Show, Generic, Hashable) - -data Composite = Composite - { _compositeDrawAttributes :: DrawAttributes - , _compositeFilterAttr :: !FilterAttributes - , _compositeIn :: Last FilterSource - , _compositeIn2 :: Last FilterSource - , _compositeOperator :: CompositeOperator - , _compositeK1 :: Number - , _compositeK2 :: Number - , _compositeK3 :: Number - , _compositeK4 :: Number - } deriving (Eq, Show, Generic, Hashable) - -instance WithDefaultSvg Composite where - defaultSvg = Composite - { _compositeDrawAttributes = defaultSvg - , _compositeFilterAttr = defaultSvg - , _compositeIn = Last Nothing - , _compositeIn2 = Last Nothing - , _compositeOperator = CompositeOver - , _compositeK1 = Num 0 - , _compositeK2 = Num 0 - , _compositeK3 = Num 0 - , _compositeK4 = Num 0 - } - -data Turbulence = Turbulence - { _turbulenceDrawAttributes :: !DrawAttributes - , _turbulenceFilterAttr :: !FilterAttributes - , _turbulenceBaseFrequency :: !(Double, Last Double) -- Not negative - , _turbulenceNumOctaves :: Int -- Not negative - , _turbulenceSeed :: Double - , _turbulenceStitchTiles :: StitchTiles - , _turbulenceType :: TurbulenceType - } deriving (Eq, Show, Generic, Hashable) - -data StitchTiles - = NoStitch - | Stitch - deriving (Eq, Show, Generic, Hashable) - -data TurbulenceType - = FractalNoiseType - | TurbulenceType - deriving (Eq, Show, Generic, Hashable) - -instance WithDefaultSvg Turbulence where - defaultSvg = Turbulence - { _turbulenceDrawAttributes = defaultSvg - , _turbulenceFilterAttr = defaultSvg - , _turbulenceBaseFrequency = (0, Last Nothing) - , _turbulenceNumOctaves = 1 - , _turbulenceSeed = 0 - , _turbulenceStitchTiles = NoStitch - , _turbulenceType = TurbulenceType - } - -data EdgeMode - = EdgeDuplicate - | EdgeWrap - | EdgeNone - deriving (Eq,Show, Generic, Hashable) - -data GaussianBlur = GaussianBlur - { _gaussianBlurDrawAttributes :: DrawAttributes - , _gaussianBlurFilterAttr :: !FilterAttributes - , _gaussianBlurIn :: Last FilterSource - , _gaussianBlurStdDeviationX :: Number - , _gaussianBlurStdDeviationY :: Last Number - , _gaussianBlurEdgeMode :: EdgeMode - } deriving (Eq,Show, Generic, Hashable) - -instance WithDefaultSvg GaussianBlur where - defaultSvg = GaussianBlur - { _gaussianBlurDrawAttributes = defaultSvg - , _gaussianBlurFilterAttr = defaultSvg - , _gaussianBlurIn = Last Nothing - , _gaussianBlurStdDeviationX = Num 0 - , _gaussianBlurStdDeviationY = Last Nothing - , _gaussianBlurEdgeMode = EdgeDuplicate - } - --- | Define the orientation, associated to the --- `orient` attribute on the Marker -data MarkerOrientation - = OrientationAuto -- ^ Auto value - | OrientationAngle Coord -- ^ Specific angle. - deriving (Eq, Show, Generic, Hashable) - --- | Define the content of the `markerUnits` attribute --- on the Marker. -data MarkerUnit - = MarkerUnitStrokeWidth -- ^ Value `strokeWidth` - | MarkerUnitUserSpaceOnUse -- ^ Value `userSpaceOnUse` - deriving (Eq, Show, Generic, Hashable) - --- | Define the content of the `markerUnits` attribute --- on the Marker. -data Overflow - = OverflowVisible -- ^ Value `visible` - | OverflowHidden -- ^ Value `hidden` - deriving (Eq, Show, Generic, Hashable) - --- | Define the `` tag. -data Marker = Marker - { -- | Draw attributes of the marker. - _markerDrawAttributes :: DrawAttributes - -- | Define the reference point of the marker. - -- correspond to the `refX` and `refY` attributes. - , _markerRefPoint :: !(Number, Number) - -- | Define the width of the marker. Correspond to - -- the `markerWidth` attribute. - , _markerWidth :: !(Maybe Number) - -- | Define the height of the marker. Correspond to - -- the `markerHeight` attribute. - , _markerHeight :: !(Maybe Number) - -- | Correspond to the `orient` attribute. - , _markerOrient :: !(Maybe MarkerOrientation) - -- | Map the `markerUnits` attribute. - , _markerUnits :: !(Maybe MarkerUnit) - -- | Optional viewbox - , _markerViewBox :: !(Maybe (Double, Double, Double, Double)) - -- | Elements defining the marker. - , _markerOverflow :: !(Maybe Overflow) - -- | preserveAspectRatio attribute - , _markerAspectRatio :: !PreserveAspectRatio - -- | Elements defining the marker. - , _markerElements :: [Tree] - } - deriving (Eq, Show, Generic, Hashable) - --- makeClassy ''Marker --- | Lenses for the Marker type. -class HasMarker c_aoKc where - marker :: Lens' c_aoKc Marker - markerAspectRatio :: Lens' c_aoKc PreserveAspectRatio - {-# INLINE markerAspectRatio #-} - markerDrawAttributes :: Lens' c_aoKc DrawAttributes - {-# INLINE markerDrawAttributes #-} - markerElements :: Lens' c_aoKc [Tree] - {-# INLINE markerElements #-} - markerHeight :: Lens' c_aoKc (Maybe Number) - {-# INLINE markerHeight #-} - markerOrient :: Lens' c_aoKc (Maybe MarkerOrientation) - {-# INLINE markerOrient #-} - markerOverflow :: Lens' c_aoKc (Maybe Overflow) - {-# INLINE markerOverflow #-} - markerRefPoint :: Lens' c_aoKc (Number, Number) - {-# INLINE markerRefPoint #-} - markerUnits :: Lens' c_aoKc (Maybe MarkerUnit) - {-# INLINE markerUnits #-} - markerViewBox :: - Lens' c_aoKc (Maybe (Double, Double, Double, Double)) - {-# INLINE markerViewBox #-} - markerWidth :: Lens' c_aoKc (Maybe Number) - {-# INLINE markerWidth #-} - markerAspectRatio = ((.) marker) markerAspectRatio - markerDrawAttributes = ((.) marker) markerDrawAttributes - markerElements = ((.) marker) markerElements - markerHeight = ((.) marker) markerHeight - markerOrient = ((.) marker) markerOrient - markerOverflow = ((.) marker) markerOverflow - markerRefPoint = ((.) marker) markerRefPoint - markerUnits = ((.) marker) markerUnits - markerViewBox = ((.) marker) markerViewBox - markerWidth = ((.) marker) markerWidth -instance HasMarker Marker where - {-# INLINE markerAspectRatio #-} - {-# INLINE markerDrawAttributes #-} - {-# INLINE markerElements #-} - {-# INLINE markerHeight #-} - {-# INLINE markerOrient #-} - {-# INLINE markerOverflow #-} - {-# INLINE markerRefPoint #-} - {-# INLINE markerUnits #-} - {-# INLINE markerViewBox #-} - {-# INLINE markerWidth #-} - marker = id - markerAspectRatio f attr = - fmap (\y -> attr { _markerAspectRatio = y }) (f $ _markerAspectRatio attr) - markerDrawAttributes f attr = - fmap (\y -> attr { _markerDrawAttributes = y }) (f $ _markerDrawAttributes attr) - markerElements f attr = - fmap (\y -> attr { _markerElements = y }) (f $ _markerElements attr) - markerHeight f attr = - fmap (\y -> attr { _markerHeight = y }) (f $ _markerHeight attr) - markerOrient f attr = - fmap (\y -> attr { _markerOrient = y }) (f $ _markerOrient attr) - markerOverflow f attr = - fmap (\y -> attr { _markerOverflow = y }) (f $ _markerOverflow attr) - markerRefPoint f attr = - fmap (\y -> attr { _markerRefPoint = y }) (f $ _markerRefPoint attr) - markerUnits f attr = - fmap (\y -> attr { _markerUnits = y }) (f $ _markerUnits attr) - markerViewBox f attr = - fmap (\y -> attr { _markerViewBox = y }) (f $ _markerViewBox attr) - markerWidth f attr = - fmap (\y -> attr { _markerWidth = y }) (f $ _markerWidth attr) - -instance HasDrawAttributes Marker where - drawAttributes = markerDrawAttributes - -instance WithDefaultSvg Marker where - defaultSvg = Marker - { _markerDrawAttributes = mempty - , _markerRefPoint = (Num 0, Num 0) - , _markerWidth = Just (Num 3) - , _markerHeight = Just (Num 3) - , _markerOrient = Nothing -- MarkerOrientation - , _markerUnits = Nothing -- MarkerUnitStrokeWidth - , _markerViewBox = Nothing - , _markerOverflow = Nothing - , _markerElements = mempty - , _markerAspectRatio = defaultSvg - } - --- | Insert element in the first sublist in the list of list. -appNode :: [[a]] -> a -> [[a]] -appNode [] e = [[e]] -appNode (curr:above) e = (e:curr) : above - --- | Map a tree while propagating context information. --- The function passed in parameter receive a list --- representing the the path used to go arrive to the --- current node. -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@(DefinitionTree g) = - f . appNode prev . DefinitionTree . Definitions . - zipGroup (appNode prev e) $ _groupOfDefinitions g - dig prev e@(FilterTree _) = f $ appNode prev e - 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 - dig prev e@(MeshGradientTree _) = f $ appNode prev e - dig prev e@(LinearGradientTree _) = f $ appNode prev e - dig prev e@(RadialGradientTree _) = f $ appNode prev e - dig prev e@(PatternTree _) = f $ appNode prev e - dig prev e@(MarkerTree _) = f $ appNode prev e - dig prev e@(MaskTree _) = f $ appNode prev e - dig prev e@(ClipPathTree _) = f $ appNode prev e - dig prev e@(SvgTree _) = 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] - --- | Fold all nodes of a SVG tree. -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 - LinearGradientTree _ -> f acc e - RadialGradientTree _ -> f acc e - MeshGradientTree _ -> f acc e - PatternTree _ -> f acc e - MarkerTree _ -> f acc e - MaskTree _ -> f acc e - ClipPathTree _ -> f acc e - DefinitionTree g -> foldGroup (_groupOfDefinitions g) - FilterTree _ -> f acc e - GroupTree g -> foldGroup g - SymbolTree s -> foldGroup (_groupOfSymbol s) - SvgTree{} -> f acc e - where - foldGroup g = - let subAcc = F.foldl' go acc $ _groupChildren g in - f subAcc e - --- | Helper function mapping every tree element. -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 (DefinitionTree defs) = - f . DefinitionTree . Definitions . mapGroup $ _groupOfDefinitions defs - go e@(FilterTree _) = f e - 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 - go e@(LinearGradientTree _) = f e - go e@(RadialGradientTree _) = f e - go e@(MeshGradientTree _) = f e - go e@(PatternTree _) = f e - go e@(MarkerTree _) = f e - go e@(MaskTree _) = f e - go e@(ClipPathTree _) = f e - go e@SvgTree{} = f e - - mapGroup g = - g { _groupChildren = map go $ _groupChildren g } - --- | For every element of a svg tree, associate --- it's SVG tag name. -nameOfTree :: Tree -> T.Text -nameOfTree v = - case v of - None -> "" - UseTree _ _ -> "use" - GroupTree _ -> "g" - SymbolTree _ -> "symbol" - DefinitionTree _ -> "defs" - FilterTree _ -> "filter" - PathTree _ -> "path" - CircleTree _ -> "circle" - PolyLineTree _ -> "polyline" - PolygonTree _ -> "polygon" - EllipseTree _ -> "ellipse" - LineTree _ -> "line" - RectangleTree _ -> "rectangle" - TextTree _ _ -> "text" - ImageTree _ -> "image" - LinearGradientTree _ -> "lineargradient" - RadialGradientTree _ -> "radialgradient" - MeshGradientTree _ -> "meshgradient" - PatternTree _ -> "pattern" - MarkerTree _ -> "marker" - MaskTree _ -> "mask" - ClipPathTree _ -> "clipPath" - SvgTree{} -> "svg" - -drawAttrOfTree :: Tree -> DrawAttributes -drawAttrOfTree v = case v of - None -> mempty - UseTree e _ -> e ^. drawAttributes - GroupTree e -> e ^. drawAttributes - SymbolTree e -> e ^. drawAttributes - DefinitionTree e -> e ^. drawAttributes - FilterTree e -> e ^. drawAttributes - PathTree e -> e ^. drawAttributes - CircleTree e -> e ^. drawAttributes - PolyLineTree e -> e ^. drawAttributes - PolygonTree e -> e ^. drawAttributes - EllipseTree e -> e ^. drawAttributes - LineTree e -> e ^. drawAttributes - RectangleTree e -> e ^. drawAttributes - TextTree _ e -> e ^. drawAttributes - ImageTree e -> e ^. drawAttributes - LinearGradientTree e -> e ^. drawAttributes - RadialGradientTree e -> e ^. drawAttributes - MeshGradientTree e -> e ^. drawAttributes - PatternTree e -> e ^. drawAttributes - MarkerTree e -> e ^. drawAttributes - MaskTree e -> e ^. drawAttributes - ClipPathTree e -> e ^. drawAttributes - SvgTree _ -> mempty -- FIXME - -setDrawAttrOfTree :: Tree -> DrawAttributes -> Tree -setDrawAttrOfTree v attr' = case v of - None -> None - UseTree e m -> UseTree (e & drawAttributes .~ attr) m - GroupTree e -> GroupTree $ e & drawAttributes .~ attr - SymbolTree e -> SymbolTree $ e & drawAttributes .~ attr - DefinitionTree e -> DefinitionTree $ e & drawAttributes .~ attr - FilterTree e -> FilterTree $ e & drawAttributes .~ attr - PathTree e -> PathTree $ e & drawAttributes .~ attr - CircleTree e -> CircleTree $ e & drawAttributes .~ attr - PolyLineTree e -> PolyLineTree $ e & drawAttributes .~ attr - PolygonTree e -> PolygonTree $ e & drawAttributes .~ attr - EllipseTree e -> EllipseTree $ e & drawAttributes .~ attr - LineTree e -> LineTree $ e & drawAttributes .~ attr - RectangleTree e -> RectangleTree $ e & drawAttributes .~ attr - TextTree a e -> TextTree a $ e & drawAttributes .~ attr - ImageTree e -> ImageTree $ e & drawAttributes .~ attr - LinearGradientTree e -> LinearGradientTree $ e & drawAttributes .~ attr - RadialGradientTree e -> RadialGradientTree $ e & drawAttributes .~ attr - MeshGradientTree e -> MeshGradientTree $ e & drawAttributes .~ attr - PatternTree e -> PatternTree $ e & drawAttributes .~ attr - MarkerTree e -> MarkerTree $ e & drawAttributes .~ attr - MaskTree e -> MaskTree $ e & drawAttributes .~ attr - ClipPathTree e -> ClipPathTree $ e & drawAttributes .~ attr - SvgTree e -> SvgTree e - where - attr = attr'{_preRendered = Nothing} - -instance HasDrawAttributes Tree where - drawAttributes = lens drawAttrOfTree setDrawAttrOfTree - -instance WithDefaultSvg Tree where - defaultSvg = None - --- | Define the possible values for the `spreadMethod` --- values used for the gradient definitions. -data Spread - = SpreadRepeat -- ^ `reapeat` value - | SpreadPad -- ^ `pad` value - | SpreadReflect -- ^ `reflect value` - deriving (Eq, Show, Generic, Hashable) - --- | Define a `` tag. -data LinearGradient = LinearGradient - { -- | Drawing attributes of the RadialGradient - _linearGradientDrawAttributes :: DrawAttributes - -- | Define coordinate system of the gradient, - -- associated to the `gradientUnits` attribute. - , _linearGradientUnits :: CoordinateUnits - -- | Point defining the beginning of the line gradient. - -- Associated to the `x1` and `y1` attribute. - , _linearGradientStart :: Point - -- | Point defining the end of the line gradient. - -- Associated to the `x2` and `y2` attribute. - , _linearGradientStop :: Point - -- | Define how to handle the values outside - -- the gradient start and stop. Associated to the - -- `spreadMethod` attribute. - , _linearGradientSpread :: Spread - -- | Define the transformation to apply to the - -- gradient points. Associated to the `gradientTransform` - -- attribute. - , _linearGradientTransform :: [Transformation] - -- | List of color stops of the linear gradient. - , _linearGradientStops :: [GradientStop] - } - deriving (Eq, Show, Generic, Hashable) - --- makeClassy ''LinearGradient --- | Lenses for the LinearGradient type. -class HasLinearGradient c_apmJ where - linearGradient :: Lens' c_apmJ LinearGradient - linearGradientDrawAttributes :: Lens' c_apmJ DrawAttributes - linearGradientSpread :: Lens' c_apmJ Spread - {-# INLINE linearGradientSpread #-} - linearGradientStart :: Lens' c_apmJ Point - {-# INLINE linearGradientStart #-} - linearGradientStop :: Lens' c_apmJ Point - {-# INLINE linearGradientStop #-} - linearGradientStops :: Lens' c_apmJ [GradientStop] - {-# INLINE linearGradientStops #-} - linearGradientTransform :: Lens' c_apmJ [Transformation] - {-# INLINE linearGradientTransform #-} - linearGradientUnits :: Lens' c_apmJ CoordinateUnits - {-# INLINE linearGradientUnits #-} - linearGradientDrawAttributes = ((.) linearGradient) linearGradientDrawAttributes - linearGradientSpread = ((.) linearGradient) linearGradientSpread - linearGradientStart = ((.) linearGradient) linearGradientStart - linearGradientStop = ((.) linearGradient) linearGradientStop - linearGradientStops = ((.) linearGradient) linearGradientStops - linearGradientTransform - = ((.) linearGradient) linearGradientTransform - linearGradientUnits = ((.) linearGradient) linearGradientUnits - -instance HasLinearGradient LinearGradient where - {-# INLINE linearGradientSpread #-} - {-# INLINE linearGradientStart #-} - {-# INLINE linearGradientStop #-} - {-# INLINE linearGradientStops #-} - {-# INLINE linearGradientTransform #-} - {-# INLINE linearGradientUnits #-} - linearGradient = id - linearGradientSpread f attr = - fmap (\y -> attr { _linearGradientSpread = y }) (f $ _linearGradientSpread attr) - linearGradientStart f attr = - fmap (\y -> attr { _linearGradientStart = y }) (f $ _linearGradientStart attr) - linearGradientStop f attr = - fmap (\y -> attr { _linearGradientStop = y }) (f $ _linearGradientStop attr) - linearGradientStops f attr = - fmap (\y -> attr { _linearGradientStops = y }) (f $ _linearGradientStops attr) - linearGradientTransform f attr = - fmap (\y -> attr { _linearGradientTransform = y }) (f $ _linearGradientTransform attr) - linearGradientUnits f attr = - fmap (\y -> attr { _linearGradientUnits = y }) (f $ _linearGradientUnits attr) - - -instance HasDrawAttributes LinearGradient where - drawAttributes = linearGradientDrawAttributes - -instance WithDefaultSvg LinearGradient where - defaultSvg = LinearGradient - { _linearGradientDrawAttributes = mempty - , _linearGradientUnits = CoordBoundingBox - , _linearGradientStart = (Percent 0, Percent 0) - , _linearGradientStop = (Percent 1, Percent 0) - , _linearGradientSpread = SpreadPad - , _linearGradientTransform = [] - , _linearGradientStops = [] - } - --- | Define a `` tag. -data RadialGradient = RadialGradient - { -- | Drawing attributes of the RadialGradient - _radialGradientDrawAttributes :: DrawAttributes - -- | Define coordinate system of the gradient, - -- associated to the `gradientUnits` attribute. - , _radialGradientUnits :: CoordinateUnits - -- | Center of the radial gradient. Associated to - -- the `cx` and `cy` attributes. - , _radialGradientCenter :: Point - -- | Radius of the radial gradient. Associated to - -- the `r` attribute. - , _radialGradientRadius :: Number - -- | X coordinate of the focus point of the radial - -- gradient. Associated to the `fx` attribute. - , _radialGradientFocusX :: Maybe Number - -- | Y coordinate of the focus point of the radial - -- gradient. Associated to the `fy` attribute. - , _radialGradientFocusY :: Maybe Number - -- | Define how to handle the values outside - -- the gradient start and stop. Associated to the - -- `spreadMethod` attribute. - , _radialGradientSpread :: Spread - -- | Define the transformation to apply to the - -- gradient points. Associated to the `gradientTransform` - -- attribute. - , _radialGradientTransform :: [Transformation] - -- | List of color stops of the radial gradient. - , _radialGradientStops :: [GradientStop] - } - deriving (Eq, Show, Generic, Hashable) - --- makeClassy ''RadialGradient --- | Lenses for the RadialGradient type. - -class HasRadialGradient c_apwt where - radialGradient :: Lens' c_apwt RadialGradient - radialGradientDrawAttributes :: Lens' c_apwt DrawAttributes - radialGradientCenter :: Lens' c_apwt Point - {-# INLINE radialGradientCenter #-} - radialGradientFocusX :: Lens' c_apwt (Maybe Number) - {-# INLINE radialGradientFocusX #-} - radialGradientFocusY :: Lens' c_apwt (Maybe Number) - {-# INLINE radialGradientFocusY #-} - radialGradientRadius :: Lens' c_apwt Number - {-# INLINE radialGradientRadius #-} - radialGradientSpread :: Lens' c_apwt Spread - {-# INLINE radialGradientSpread #-} - radialGradientStops :: Lens' c_apwt [GradientStop] - {-# INLINE radialGradientStops #-} - radialGradientTransform :: Lens' c_apwt [Transformation] - {-# INLINE radialGradientTransform #-} - radialGradientUnits :: Lens' c_apwt CoordinateUnits - {-# INLINE radialGradientUnits #-} - radialGradientDrawAttributes = ((.) radialGradient) radialGradientDrawAttributes - radialGradientCenter = ((.) radialGradient) radialGradientCenter - radialGradientFocusX = ((.) radialGradient) radialGradientFocusX - radialGradientFocusY = ((.) radialGradient) radialGradientFocusY - radialGradientRadius = ((.) radialGradient) radialGradientRadius - radialGradientSpread = ((.) radialGradient) radialGradientSpread - radialGradientStops = ((.) radialGradient) radialGradientStops - radialGradientTransform - = ((.) radialGradient) radialGradientTransform - radialGradientUnits = ((.) radialGradient) radialGradientUnits - -instance HasRadialGradient RadialGradient where - {-# INLINE radialGradientCenter #-} - {-# INLINE radialGradientFocusX #-} - {-# INLINE radialGradientFocusY #-} - {-# INLINE radialGradientRadius #-} - {-# INLINE radialGradientSpread #-} - {-# INLINE radialGradientStops #-} - {-# INLINE radialGradientTransform #-} - {-# INLINE radialGradientUnits #-} - radialGradient = id - radialGradientCenter f attr = - fmap (\y -> attr { _radialGradientCenter = y }) (f $ _radialGradientCenter attr) - radialGradientFocusX f attr = - fmap (\y -> attr { _radialGradientFocusX = y }) (f $ _radialGradientFocusX attr) - radialGradientFocusY f attr = - fmap (\y -> attr { _radialGradientFocusY = y }) (f $ _radialGradientFocusY attr) - radialGradientRadius f attr = - fmap (\y -> attr { _radialGradientRadius = y }) (f $ _radialGradientRadius attr) - radialGradientSpread f attr = - fmap (\y -> attr { _radialGradientSpread = y }) (f $ _radialGradientSpread attr) - radialGradientStops f attr = - fmap (\y -> attr { _radialGradientStops = y }) (f $ _radialGradientStops attr) - radialGradientTransform f attr = - fmap (\y -> attr { _radialGradientTransform = y }) (f $ _radialGradientTransform attr) - radialGradientUnits f attr = - fmap (\y -> attr { _radialGradientUnits = y }) (f $ _radialGradientUnits attr) - - -instance HasDrawAttributes RadialGradient where - drawAttributes = radialGradientDrawAttributes - -instance WithDefaultSvg RadialGradient where - defaultSvg = RadialGradient - { _radialGradientDrawAttributes = mempty - , _radialGradientUnits = CoordBoundingBox - , _radialGradientCenter = (Percent 0.5, Percent 0.5) - , _radialGradientRadius = Percent 0.5 - , _radialGradientFocusX = Nothing - , _radialGradientFocusY = Nothing - , _radialGradientSpread = SpreadPad - , _radialGradientTransform = [] - , _radialGradientStops = [] - } - --- | Define a SVG `` tag. -data Mask = Mask - { -- | Drawing attributes of the Mask - _maskDrawAttributes :: DrawAttributes - -- | Correspond to the `maskContentUnits` attributes. - , _maskContentUnits :: CoordinateUnits - -- | Mapping to the `maskUnits` attribute. - , _maskUnits :: CoordinateUnits - -- | Map to the `x` and `y` attributes. - , _maskPosition :: Point - -- | Map to the `width` attribute - , _maskWidth :: Number - -- | Map to the `height` attribute. - , _maskHeight :: Number - -- | Children of the `` tag. - , _maskContent :: [Tree] - } - deriving (Eq, Show, Generic, Hashable) - --- makeClassy ''Mask --- | Lenses for the Mask type. -class HasMask c_apHI where - mask :: Lens' c_apHI Mask - maskContent :: Lens' c_apHI [Tree] - {-# INLINE maskContent #-} - maskContentUnits :: Lens' c_apHI CoordinateUnits - {-# INLINE maskContentUnits #-} - maskDrawAttributes :: Lens' c_apHI DrawAttributes - {-# INLINE maskDrawAttributes #-} - maskHeight :: Lens' c_apHI Number - {-# INLINE maskHeight #-} - maskPosition :: Lens' c_apHI Point - {-# INLINE maskPosition #-} - maskUnits :: Lens' c_apHI CoordinateUnits - {-# INLINE maskUnits #-} - maskWidth :: Lens' c_apHI Number - {-# INLINE maskWidth #-} - maskContent = ((.) mask) maskContent - maskContentUnits = ((.) mask) maskContentUnits - maskDrawAttributes = ((.) mask) maskDrawAttributes - maskHeight = ((.) mask) maskHeight - maskPosition = ((.) mask) maskPosition - maskUnits = ((.) mask) maskUnits - maskWidth = ((.) mask) maskWidth - -instance HasMask Mask where - {-# INLINE maskContent #-} - {-# INLINE maskContentUnits #-} - {-# INLINE maskDrawAttributes #-} - {-# INLINE maskHeight #-} - {-# INLINE maskPosition #-} - {-# INLINE maskUnits #-} - {-# INLINE maskWidth #-} - mask = id - maskContent f attr = - fmap (\y -> attr { _maskContent = y }) (f $ _maskContent attr) - maskContentUnits f attr = - fmap (\y -> attr { _maskContentUnits = y }) (f $ _maskContentUnits attr) - maskDrawAttributes f attr = - fmap (\y -> attr { _maskDrawAttributes = y }) (f $ _maskDrawAttributes attr) - maskHeight f attr = - fmap (\y -> attr { _maskHeight = y }) (f $ _maskHeight attr) - maskPosition f attr = - fmap (\y -> attr { _maskPosition = y }) (f $ _maskPosition attr) - maskUnits f attr = - fmap (\y -> attr { _maskUnits = y }) (f $ _maskUnits attr) - maskWidth f attr = - fmap (\y -> attr { _maskWidth = y }) (f $ _maskWidth attr) - - -instance HasDrawAttributes Mask where - drawAttributes = 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 = [] - } - --- | Define a `` tag. -data ClipPath = ClipPath - { _clipPathDrawAttributes :: DrawAttributes - -- | Maps to the `clipPathUnits` attribute - , _clipPathUnits :: CoordinateUnits - -- | Maps to the content of the tree - , _clipPathContent :: [Tree] - } - deriving (Eq, Show, Generic, Hashable) - --- makeClassy ''ClipPath --- | Lenses for the ClipPath type. -class HasClipPath c_apZq where - clipPath :: Lens' c_apZq ClipPath - clipPathContent :: Lens' c_apZq [Tree] - {-# INLINE clipPathContent #-} - clipPathDrawAttributes :: Lens' c_apZq DrawAttributes - {-# INLINE clipPathDrawAttributes #-} - clipPathUnits :: Lens' c_apZq CoordinateUnits - {-# INLINE clipPathUnits #-} - clipPathContent = ((.) clipPath) clipPathContent - clipPathDrawAttributes = ((.) clipPath) clipPathDrawAttributes - clipPathUnits = ((.) clipPath) clipPathUnits -instance HasClipPath ClipPath where - {-# INLINE clipPathContent #-} - {-# INLINE clipPathDrawAttributes #-} - {-# INLINE clipPathUnits #-} - clipPath = id - clipPathContent f attr = - fmap (\y -> attr { _clipPathContent = y }) (f $ _clipPathContent attr) - clipPathDrawAttributes f attr = - fmap (\y -> attr { _clipPathDrawAttributes = y }) (f $ _clipPathDrawAttributes attr) - clipPathUnits f attr = - fmap (\y -> attr { _clipPathUnits = y }) (f $ _clipPathUnits attr) - - -instance HasDrawAttributes ClipPath where - drawAttributes = clipPathDrawAttributes - -instance WithDefaultSvg ClipPath where - defaultSvg = ClipPath - { _clipPathDrawAttributes = mempty - , _clipPathUnits = CoordUserSpace - , _clipPathContent = mempty - } - --- | Define a `` tag. -data Pattern = Pattern - { -- | Pattern drawing attributes. - _patternDrawAttributes :: !DrawAttributes - -- | Possible `viewBox`. - , _patternViewBox :: !(Maybe (Double, Double, Double, Double)) - -- | Width of the pattern tile, mapped to the - -- `width` attribute - , _patternWidth :: !Number - -- | Height of the pattern tile, mapped to the - -- `height` attribute - , _patternHeight :: !Number - -- | Pattern tile base, mapped to the `x` and - -- `y` attributes. - , _patternPos :: !Point - -- | Patterns can be chained, so this is a potential - -- reference to another pattern - , _patternHref :: !String - -- | Elements used in the pattern. - , _patternElements :: ![Tree] - -- | Define the cordinate system to use for - -- the pattern. Mapped to the `patternUnits` - -- attribute. - , _patternUnit :: !CoordinateUnits - -- | Value of the "preserveAspectRatio" attribute - , _patternAspectRatio :: !PreserveAspectRatio - -- | Value of "patternTransform" attribute - , _patternTransform :: !(Maybe [Transformation]) - } - deriving (Eq, Show, Generic, Hashable) - --- makeClassy ''Pattern --- | Lenses for the Patter type. -class HasPattern c_aq6G where - pattern :: Lens' c_aq6G Pattern - patternAspectRatio :: Lens' c_aq6G PreserveAspectRatio - {-# INLINE patternAspectRatio #-} - patternDrawAttributes :: Lens' c_aq6G DrawAttributes - {-# INLINE patternDrawAttributes #-} - patternElements :: Lens' c_aq6G [Tree] - {-# INLINE patternElements #-} - patternHeight :: Lens' c_aq6G Number - {-# INLINE patternHeight #-} - patternHref :: Lens' c_aq6G String - {-# INLINE patternHref #-} - patternPos :: Lens' c_aq6G Point - {-# INLINE patternPos #-} - patternTransform :: Lens' c_aq6G (Maybe [Transformation]) - {-# INLINE patternTransform #-} - patternUnit :: Lens' c_aq6G CoordinateUnits - {-# INLINE patternUnit #-} - patternViewBox :: - Lens' c_aq6G (Maybe (Double, Double, Double, Double)) - {-# INLINE patternViewBox #-} - patternWidth :: Lens' c_aq6G Number - {-# INLINE patternWidth #-} - patternAspectRatio = ((.) pattern) patternAspectRatio - patternDrawAttributes = ((.) pattern) patternDrawAttributes - patternElements = ((.) pattern) patternElements - patternHeight = ((.) pattern) patternHeight - patternHref = ((.) pattern) patternHref - patternPos = ((.) pattern) patternPos - patternTransform = ((.) pattern) patternTransform - patternUnit = ((.) pattern) patternUnit - patternViewBox = ((.) pattern) patternViewBox - patternWidth = ((.) pattern) patternWidth - -instance HasPattern Pattern where - {-# INLINE patternAspectRatio #-} - {-# INLINE patternDrawAttributes #-} - {-# INLINE patternElements #-} - {-# INLINE patternHeight #-} - {-# INLINE patternHref #-} - {-# INLINE patternPos #-} - {-# INLINE patternTransform #-} - {-# INLINE patternUnit #-} - {-# INLINE patternViewBox #-} - {-# INLINE patternWidth #-} - pattern = id - patternAspectRatio f attr = - fmap (\y -> attr { _patternAspectRatio = y }) (f $ _patternAspectRatio attr) - patternDrawAttributes f attr = - fmap (\y -> attr { _patternDrawAttributes = y }) (f $ _patternDrawAttributes attr) - patternElements f attr = - fmap (\y -> attr { _patternElements = y }) (f $ _patternElements attr) - patternHeight f attr = - fmap (\y -> attr { _patternHeight = y }) (f $ _patternHeight attr) - patternHref f attr = - fmap (\y -> attr { _patternHref = y }) (f $ _patternHref attr) - patternPos f attr = - fmap (\y -> attr { _patternPos = y }) (f $ _patternPos attr) - patternTransform f attr = - fmap (\y -> attr { _patternTransform = y }) (f $ _patternTransform attr) - patternUnit f attr = - fmap (\y -> attr { _patternUnit = y }) (f $ _patternUnit attr) - patternViewBox f attr = - fmap (\y -> attr { _patternViewBox = y }) (f $ _patternViewBox attr) - patternWidth f attr = - fmap (\y -> attr { _patternWidth = y }) (f $ _patternWidth attr) - -instance HasDrawAttributes Pattern where - drawAttributes = 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 - , _patternAspectRatio = defaultSvg - , _patternHref = "" - , _patternTransform = mempty - } - --- | Sum types helping keeping track of all the namable --- elemens in a SVG document. -data Element - = ElementLinearGradient LinearGradient - | ElementRadialGradient RadialGradient - | ElementMeshGradient MeshGradient - | ElementGeometry Tree - | ElementPattern Pattern - | ElementMarker Marker - | ElementMask Mask - | ElementClipPath ClipPath - deriving (Eq, Show, Generic, Hashable) - --- | Represent a full svg document with style, --- geometry and named elements. -data Document = Document - { _viewBox :: Maybe (Double, Double, Double, Double) - , _width :: Maybe Number - , _height :: Maybe Number - , _elements :: [Tree] - , _description :: String - , _documentLocation :: FilePath - , _documentAspectRatio :: PreserveAspectRatio - } - deriving (Show, Eq, Generic, Hashable) - - --- | Lenses associated to a SVG document. -makeClassy ''Document - --- | Calculate the document size in function of the --- different available attributes in the 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 = abs $ x2 - x1 - dy = 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) } = - (floor . abs $ x2 - x1, floor . 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 Semigroup DrawAttributes where - (<>) 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 - , _filterRef = (mappend `on` _filterRef) a b - , _preRendered = Nothing - } - 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 Monoid DrawAttributes where - mappend = (<>) - 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 - , _filterRef = Last Nothing - , _preRendered = Nothing - } - -instance WithDefaultSvg DrawAttributes where - defaultSvg = mempty - -instance CssMatcheable Tree where - cssAttribOf _ _ = Nothing - cssClassOf = view (drawAttributes . attrClass) - cssIdOf = fmap T.pack . view (drawAttributes . attrId) - cssNameOf = nameOfTree - --------------------------------------------------------------------------- ---- Dumped --------------------------------------------------------------------------- --- makeClassy ''PreserveAspectRatio --- --- | Lenses for the PreserveAspectRatio type -class HasPreserveAspectRatio a where - preserveAspectRatio :: Lens' a PreserveAspectRatio - aspectRatioAlign :: Lens' a Alignment - {-# INLINE aspectRatioAlign #-} - aspectRatioAlign = preserveAspectRatio . aspectRatioAlign - - aspectRatioDefer :: Lens' a Bool - {-# INLINE aspectRatioDefer #-} - aspectRatioDefer = preserveAspectRatio . aspectRatioDefer - - aspectRatioMeetSlice :: Lens' a (Maybe MeetSlice) - {-# INLINE aspectRatioMeetSlice #-} - aspectRatioMeetSlice = preserveAspectRatio . aspectRatioMeetSlice - -instance HasPreserveAspectRatio PreserveAspectRatio where - preserveAspectRatio = id - {-# INLINE aspectRatioAlign #-} - aspectRatioAlign f attr = - fmap (\y -> attr { _aspectRatioAlign = y }) (f $ _aspectRatioAlign attr) - - {-# INLINE aspectRatioDefer #-} - aspectRatioDefer f attr = - fmap (\y -> attr { _aspectRatioDefer = y }) (f $ _aspectRatioDefer attr) - - {-# INLINE aspectRatioMeetSlice #-} - aspectRatioMeetSlice f attr = - fmap (\y -> attr { _aspectRatioMeetSlice = y }) (f $ _aspectRatioMeetSlice attr) - --- makeClassy ''FilterAttributes --- | Lenses for the FilterAttributes type. -class HasFilterAttributes c_asYk where - filterAttributes :: Lens' c_asYk FilterAttributes - filterHeight :: Lens' c_asYk (Last Number) - {-# INLINE filterHeight #-} - filterResult :: Lens' c_asYk (Maybe String) - {-# INLINE filterResult #-} - filterWidth :: Lens' c_asYk (Last Number) - {-# INLINE filterWidth #-} - filterX :: Lens' c_asYk (Last Number) - {-# INLINE filterX #-} - filterY :: Lens' c_asYk (Last Number) - {-# INLINE filterY #-} - filterHeight = ((.) filterAttributes) filterHeight - filterResult = ((.) filterAttributes) filterResult - filterWidth = ((.) filterAttributes) filterWidth - filterX = ((.) filterAttributes) filterX - filterY = ((.) filterAttributes) filterY -instance HasFilterAttributes FilterAttributes where - {-# INLINE filterHeight #-} - {-# INLINE filterResult #-} - {-# INLINE filterWidth #-} - {-# INLINE filterX #-} - {-# INLINE filterY #-} - filterAttributes = id - filterHeight - f_asYl - (FilterAttributes x1_asYm x2_asYn x3_asYo x4_asYp x5_asYq) - = (fmap - (\ y1_asYr - -> ((((FilterAttributes y1_asYr) x2_asYn) x3_asYo) x4_asYp) - x5_asYq)) - (f_asYl x1_asYm) - filterResult - f_asYs - (FilterAttributes x1_asYt x2_asYu x3_asYv x4_asYw x5_asYx) - = (fmap - (\ y1_asYy - -> ((((FilterAttributes x1_asYt) y1_asYy) x3_asYv) x4_asYw) - x5_asYx)) - (f_asYs x2_asYu) - filterWidth - f_asYz - (FilterAttributes x1_asYA x2_asYB x3_asYC x4_asYD x5_asYE) - = (fmap - (\ y1_asYF - -> ((((FilterAttributes x1_asYA) x2_asYB) y1_asYF) x4_asYD) - x5_asYE)) - (f_asYz x3_asYC) - filterX - f_asYG - (FilterAttributes x1_asYH x2_asYI x3_asYJ x4_asYK x5_asYL) - = (fmap - (\ y1_asYM - -> ((((FilterAttributes x1_asYH) x2_asYI) x3_asYJ) y1_asYM) - x5_asYL)) - (f_asYG x4_asYK) - filterY - f_asYN - (FilterAttributes x1_asYO x2_asYP x3_asYQ x4_asYR x5_asYS) - = (fmap - (\ y1_asYT - -> ((((FilterAttributes x1_asYO) x2_asYP) x3_asYQ) x4_asYR) - y1_asYT)) - (f_asYN x5_asYS) - - -makeClassy ''TextPath - --- | Lenses for the DrawAttributes type. --- makeClassy ''DrawAttributes - -makeLenses ''Filter - -instance HasDrawAttributes Filter where - drawAttributes = filterDrawAttributes - -instance HasFilterAttributes Filter where - filterAttributes = filterSelfAttributes - -makeClassy ''Composite -makeClassy ''ColorMatrix -makeClassy ''GaussianBlur -makeClassy ''Turbulence -makeClassy ''DisplacementMap - -instance HasDrawAttributes Composite where - drawAttributes = compositeDrawAttributes - - -instance HasDrawAttributes ColorMatrix where - drawAttributes = colorMatrixDrawAttributes - -instance HasDrawAttributes GaussianBlur where - drawAttributes = gaussianBlurDrawAttributes - -instance HasDrawAttributes Turbulence where - drawAttributes = turbulenceDrawAttributes - -instance HasDrawAttributes DisplacementMap where - drawAttributes = displacementMapDrawAttributes - -instance HasFilterAttributes Composite where - filterAttributes = compositeFilterAttr - -instance HasFilterAttributes ColorMatrix where - filterAttributes = colorMatrixFilterAttr - -instance HasFilterAttributes GaussianBlur where - filterAttributes = gaussianBlurFilterAttr - -instance HasFilterAttributes Turbulence where - filterAttributes = turbulenceFilterAttr - -instance HasFilterAttributes DisplacementMap where - filterAttributes = displacementMapFilterAttr - -instance HasFilterAttributes FilterElement where - filterAttributes = lens getter setter - where - getter fe = case fe of - FEBlend -> defaultSvg - FEColorMatrix m -> m ^. filterAttributes - FEComponentTransfer -> defaultSvg - FEComposite c -> c ^. filterAttributes - FEConvolveMatrix -> defaultSvg - FEDiffuseLighting -> defaultSvg - FEDisplacementMap d -> d ^. filterAttributes - FEDropShadow -> defaultSvg - FEFlood -> defaultSvg - FEFuncA -> defaultSvg - FEFuncB -> defaultSvg - FEFuncG -> defaultSvg - FEFuncR -> defaultSvg - FEGaussianBlur g -> g ^. filterAttributes - FEImage -> defaultSvg - FEMerge -> defaultSvg - FEMergeNode -> defaultSvg - FEMorphology -> defaultSvg - FEOffset -> defaultSvg - FESpecularLighting -> defaultSvg - FETile -> defaultSvg - FETurbulence t -> t ^. filterAttributes - FENone -> defaultSvg - setter fe attr = case fe of - FEBlend -> fe - FEColorMatrix m -> FEColorMatrix $ m & filterAttributes .~ attr - FEComponentTransfer -> fe - FEComposite c -> FEComposite $ c & filterAttributes .~ attr - FEConvolveMatrix -> fe - FEDiffuseLighting -> fe - FEDisplacementMap d -> FEDisplacementMap $ d & filterAttributes .~ attr - FEDropShadow -> fe - FEFlood -> fe - FEFuncA -> fe - FEFuncB -> fe - FEFuncG -> fe - FEFuncR -> fe - FEGaussianBlur g -> FEGaussianBlur $ g & filterAttributes .~ attr - FEImage -> fe - FEMerge -> fe - FEMergeNode -> fe - FEMorphology -> fe - FEOffset -> fe - FESpecularLighting -> fe - FETile -> fe - FETurbulence t -> FETurbulence $ t & filterAttributes .~ attr - FENone -> fe +{-# LANGUAGE PatternSynonyms #-} +-- | This module define all the types used in the definition +-- of a svg scene. +-- +-- Most of the types are lensified. +module Graphics.SvgTree.Types + ( -- * Basic building types + Coord + , Origin( .. ) + , Point + , RPoint + , PathCommand( .. ) + , Transformation( .. ) + , ElementRef( .. ) + , CoordinateUnits( .. ) + + -- ** Building helpers + , serializeNumber + , serializeTransformation + , serializeTransformations + + -- * Drawing control types + , Cap( .. ) + , LineJoin( .. ) + , Tree + , pattern Tree + , pattern None + , treeBranch + , TreeBranch(..) + , Number( .. ) + , Spread( .. ) + , Texture( .. ) + , Element( .. ) + , FillRule( .. ) + , FontStyle( .. ) + , Dpi + + , WithDefaultSvg( .. ) + + -- * Main type + , Document( .. ) + , pattern SvgTree + , svgTree + ,documentViewBox, + documentWidth, + documentHeight, + documentElements, + documentDescription, + documentLocation, + documentAspectRatio, + documentSize + + -- * Drawing attributes + , DrawAttributes( .. ) + , HasDrawAttributes( .. ) + + -- * Filters + , FilterElement(..) + , FilterAttributes(..) + , HasFilterAttributes(..) + , FilterSource(..) + , ColorMatrixType(..) + , colorMatrixDrawAttributes + , colorMatrixFilterAttr + , colorMatrixIn + , colorMatrixType + , colorMatrixValues + , ColorMatrix(..) + , compositeDrawAttributes + , compositeFilterAttr + , compositeIn + , compositeIn2 + , compositeOperator + , compositeK1 + , compositeK2 + , compositeK3 + , compositeK4 + , Composite(..) + , CompositeOperator(..) + , EdgeMode(..) + , gaussianBlurDrawAttributes + , gaussianBlurFilterAttr + , gaussianBlurIn + , gaussianBlurStdDeviationX + , gaussianBlurStdDeviationY + , gaussianBlurEdgeMode + , GaussianBlur(..) + , turbulenceDrawAttributes + , turbulenceFilterAttr + , turbulenceBaseFrequency + , turbulenceNumOctaves + , turbulenceSeed + , turbulenceStitchTiles + , turbulenceType + , Turbulence(..) + , TurbulenceType(..) + , StitchTiles(..) + , DisplacementMap(..) + , displacementMapDrawAttributes + , displacementMapFilterAttr + , displacementMapIn + , displacementMapIn2 + , displacementMapScale + , displacementMapXChannelSelector + , displacementMapYChannelSelector + , ChannelSelector(..) + + -- * SVG drawing primitives + -- ** Rectangle + , Rectangle( .. ) + , pattern RectangleTree + , rectangleTree + , rectUpperLeftCorner + , rectWidth + , rectHeight + , rectCornerRadius + + -- ** Line + , Line( .. ) + , pattern LineTree + , lineTree + , linePoint1 + , linePoint2 + + -- ** Polygon + , Polygon( .. ) + , pattern PolygonTree + , polygonTree + , polygonPoints + + -- ** Polyline + , PolyLine( .. ) + , pattern PolyLineTree + , polyLineTree + , polyLinePoints + + -- ** Path + , Path( .. ) + , pattern PathTree + , pathTree + , pathDefinition + + -- ** Circle + , Circle( .. ) + , pattern CircleTree + , circleTree + , circleCenter + , circleRadius + + + -- ** Ellipse + , Ellipse( .. ) + , pattern EllipseTree + , ellipseTree + , ellipseCenter + , ellipseXRadius + , ellipseYRadius + + -- ** Mesh (gradient mesh) + , GradientPathCommand( .. ) + , MeshGradientType( .. ) + + , MeshGradient( .. ) + , pattern MeshGradientTree + , meshGradientTree + , meshGradientX + , meshGradientY + , meshGradientType + , meshGradientUnits + , meshGradientTransform + , meshGradientRows + + , MeshGradientRow( .. ) + , meshGradientRowPatches + + , MeshGradientPatch( .. ) + , meshGradientPatchStops + + -- ** Image + , Image( .. ) + , pattern ImageTree + , imageTree + , imageCornerUpperLeft + , imageWidth + , imageHeight + , imageHref + , imageAspectRatio + + -- ** Use + , Use( .. ) + , pattern UseTree + , useTree + , useBase + , useName + , useWidth + , useHeight + + -- * Grouping primitives + -- ** Group + , Group( .. ) + , pattern GroupTree + , groupTree + , groupDrawAttributes + , groupChildren + , groupViewBox + , groupAspectRatio + + -- ** Symbol + , pattern SymbolTree + , symbolTree + + -- ** Definitions + , pattern DefinitionTree + , definitionTree + + -- ** Filter + , Filter( .. ) + , pattern FilterTree + , filterTree + , filterChildren + + -- * Text related types + -- ** Text + , Text( .. ) + , pattern TextTree + , textTree + , textAdjust + , textRoot + , TextAnchor( .. ) + , textAt + + -- ** Text path + , TextPath( .. ) + , textPathStartOffset + , textPathName + , textPathMethod + , textPathSpacing + + , TextPathSpacing( .. ) + , TextPathMethod( .. ) + + -- ** Text span. + , TextSpanContent( .. ) + + , TextSpan( .. ) + , spanInfo + , spanDrawAttributes + , spanContent + + , TextInfo( .. ) + , textInfoX + , textInfoY + , textInfoDX + , textInfoDY + , textInfoRotate + , textInfoLength + + , TextAdjust( .. ) + + -- * Marker definition + , Marker( .. ) + , pattern MarkerTree + , markerTree + , Overflow( .. ) + , MarkerOrientation( .. ) + , MarkerUnit( .. ) + , markerRefPoint + , markerWidth + , markerHeight + , markerOrient + , markerUnits + , markerViewBox + , markerOverflow + , markerAspectRatio + , markerElements + + -- * Gradient definition + , GradientStop( .. ) + , gradientOffset + , gradientColor + , gradientPath + , gradientOpacity + + -- ** Linear Gradient + , LinearGradient( .. ) + , pattern LinearGradientTree + , linearGradientTree + , linearGradientUnits + , linearGradientStart + , linearGradientStop + , linearGradientSpread + , linearGradientTransform + , linearGradientStops + + -- ** Radial Gradient + , RadialGradient( .. ) + , pattern RadialGradientTree + , radialGradientTree + , radialGradientUnits + , radialGradientCenter + , radialGradientRadius + , radialGradientFocusX + , radialGradientFocusY + , radialGradientSpread + , radialGradientTransform + , radialGradientStops + + -- * Pattern definition + , Pattern( .. ) + , pattern PatternTree + , patternTree + , patternViewBox + , patternWidth + , patternHeight + , patternPos + , patternHref + , patternElements + , patternUnit + , patternAspectRatio + , patternTransform + + -- * Mask definition + , Mask( .. ) + , pattern MaskTree + , maskTree + , maskContentUnits + , maskUnits + , maskPosition + , maskWidth + , maskHeight + , maskContent + + -- * Clip path definition + , ClipPath( .. ) + , pattern ClipPathTree + , clipPathTree + , clipPathUnits + , clipPathContent + + -- * Aspect Ratio description + , PreserveAspectRatio( .. ) + , Alignment( .. ) + , MeetSlice( .. ) + , aspectRatioDefer + , aspectRatioAlign + , aspectRatioMeetSlice + + -- * MISC functions + , zipTree + , foldTree + , mapTree + , mapBranch + , nameOfTree + , toUserUnit + , mapNumber + ) where + +import Graphics.SvgTree.Types.Internal +import Graphics.SvgTree.Types.Hashable +import Graphics.SvgTree.Types.Fold +import Graphics.SvgTree.Types.Constructors +import Graphics.SvgTree.Types.Instances () diff --git a/src/Graphics/SvgTree/Types/Basic.hs b/src/Graphics/SvgTree/Types/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/SvgTree/Types/Basic.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE DeriveGeneric #-} +{- + Home of basic types without fields. +-} +module Graphics.SvgTree.Types.Basic where + +import Codec.Picture (PixelRGBA8 (..)) +import GHC.Generics (Generic) +import Graphics.SvgTree.CssTypes (Number) +import Linear (V2) + +-- | Basic coordinate type. +type Coord = Double + +-- | Real Point, fully determined and not +-- dependant of the rendering context. +type RPoint = V2 Coord + +-- FIXME: Use 'V2 Number' instead of tuple +-- | Possibly context dependant point. +type Point = (Number, Number) + +-- | Tell if a path command is absolute (in the current +-- user coordiante) or relative to the previous poitn. +data Origin + = OriginAbsolute -- ^ Next point in absolute coordinate + | OriginRelative -- ^ Next point relative to the previous + deriving (Eq, Show, Generic) + + +data MeshGradientType + = GradientBilinear + | GradientBicubic + deriving (Eq, Show, Generic) + +-- | Define the possible values of various *units attributes +-- used in the definition of the gradients and masks. +data CoordinateUnits + = CoordUserSpace -- ^ `userSpaceOnUse` value + | CoordBoundingBox -- ^ `objectBoundingBox` value + deriving (Eq, Show, Generic) + +-- | This type represent the align information of the +-- preserveAspectRatio SVGattribute +data Alignment + = AlignNone -- ^ "none" value + | AlignxMinYMin -- "xMinYMin" value + | AlignxMidYMin -- ^ "xMidYMin" value + | AlignxMaxYMin -- ^ "xMaxYMin" value + | AlignxMinYMid -- ^ "xMinYMid" value + | AlignxMidYMid -- ^ "xMidYMid" value + | AlignxMaxYMid -- ^ "xMaxYMid" value + | AlignxMinYMax -- ^ "xMinYMax" value + | AlignxMidYMax -- ^ "xMidYMax" value + | AlignxMaxYMax -- ^ "xMaxYMax" value + deriving (Eq, Show, Generic) + +-- | This type represent the "meet or slice" information +-- of the preserveAspectRatio SVGattribute +data MeetSlice = Meet | Slice + deriving (Eq, Show, Generic) + +-- | Describe how the line should be terminated +-- when stroking them. Describe the values of the +-- `stroke-linecap` attribute. +-- See `_strokeLineCap` +data Cap + = CapRound -- ^ End with a round (`round` value) + | CapButt -- ^ Define straight just at the end (`butt` value) + | CapSquare -- ^ Straight further of the ends (`square` value) + deriving (Eq, Show, Generic) + +-- | Define the possible values of the `stroke-linejoin` +-- attribute. +-- see `_strokeLineJoin` +data LineJoin + = JoinMiter -- ^ `miter` value + | JoinBevel -- ^ `bevel` value + | JoinRound -- ^ `round` value + deriving (Eq, Show, Generic) + +-- | Describe the different value which can be used +-- in the `fill` or `stroke` attributes. +data Texture + = ColorRef PixelRGBA8 -- ^ Direct solid color (#rrggbb, #rgb) + | TextureRef String -- ^ Link to a complex texture (url(#name)) + | FillNone -- ^ Equivalent to the `none` value. + deriving (Eq, Show, Generic) + +-- | Describe the possile filling algorithms. +-- Map the values of the `fill-rule` attributes. +data FillRule + = FillEvenOdd -- ^ Correspond to the `evenodd` value. + | FillNonZero -- ^ Correspond to the `nonzero` value. + deriving (Eq, Show, Generic) diff --git a/src/Graphics/SvgTree/Types/Constructors.hs b/src/Graphics/SvgTree/Types/Constructors.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/SvgTree/Types/Constructors.hs @@ -0,0 +1,70 @@ +module Graphics.SvgTree.Types.Constructors where + +import Graphics.SvgTree.Types.Internal +import Graphics.SvgTree.Types.Hashable + +useTree :: Use -> Tree +useTree u = UseTree u Nothing + +groupTree :: Group -> Tree +groupTree = GroupTree + +symbolTree :: Group -> Tree +symbolTree = SymbolTree + +definitionTree :: Group -> Tree +definitionTree = DefinitionTree + +filterTree :: Filter -> Tree +filterTree = FilterTree + +pathTree :: Path -> Tree +pathTree = PathTree + +circleTree :: Circle -> Tree +circleTree = CircleTree + +polyLineTree :: PolyLine -> Tree +polyLineTree = PolyLineTree + +polygonTree :: Polygon -> Tree +polygonTree = PolygonTree + +ellipseTree :: Ellipse -> Tree +ellipseTree = EllipseTree + +lineTree :: Line -> Tree +lineTree = LineTree + +rectangleTree :: Rectangle -> Tree +rectangleTree = RectangleTree + +textTree :: Maybe TextPath -> Text -> Tree +textTree = TextTree + +imageTree :: Image -> Tree +imageTree = ImageTree + +linearGradientTree :: LinearGradient -> Tree +linearGradientTree = LinearGradientTree + +radialGradientTree :: RadialGradient -> Tree +radialGradientTree = RadialGradientTree + +meshGradientTree :: MeshGradient -> Tree +meshGradientTree = MeshGradientTree + +patternTree :: Pattern -> Tree +patternTree = PatternTree + +markerTree :: Marker -> Tree +markerTree = MarkerTree + +maskTree :: Mask -> Tree +maskTree = MaskTree + +clipPathTree :: ClipPath -> Tree +clipPathTree = ClipPathTree + +svgTree :: Document -> Tree +svgTree = SvgTree diff --git a/src/Graphics/SvgTree/Types/Fold.hs b/src/Graphics/SvgTree/Types/Fold.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/SvgTree/Types/Fold.hs @@ -0,0 +1,105 @@ +module Graphics.SvgTree.Types.Fold where + +import Control.Lens ((%~), (&), (^.)) +import qualified Data.Foldable as F +import Data.List (inits) +import Graphics.SvgTree.Types.Internal +import Graphics.SvgTree.Types.Hashable + +-- | Insert element in the first sublist in the list of list. +appNode :: [[a]] -> a -> [[a]] +appNode [] e = [[e]] +appNode (curr:above) e = (e:curr) : above + +-- | Map a tree while propagating context information. +-- The function passed in parameter receive a list +-- representing the the path used to go arrive to the +-- current node. +zipTree :: ([[Tree]] -> Tree) -> Tree -> Tree +zipTree f = dig [] where + dig prev e = case e ^. treeBranch of + NoNode -> f $ appNode prev e + UseNode _ Nothing -> f $ appNode prev e + UseNode nfo (Just u) -> + f $ appNode prev $ UseTree nfo (Just $ dig ([] : appNode prev e) u) + GroupNode g -> + f $ appNode prev $ GroupTree $ zipGroup (appNode prev e) g + SymbolNode g -> + f $ appNode prev $ SymbolTree $ zipGroup (appNode prev e) g + DefinitionNode g -> + f $ appNode prev $ DefinitionTree $ zipGroup (appNode prev e) g + FilterNode{} -> f $ appNode prev e + PathNode{} -> f $ appNode prev e + CircleNode{} -> f $ appNode prev e + PolyLineNode{} -> f $ appNode prev e + PolygonNode{} -> f $ appNode prev e + EllipseNode{} -> f $ appNode prev e + LineNode{} -> f $ appNode prev e + RectangleNode{} -> f $ appNode prev e + TextNode{} -> f $ appNode prev e + ImageNode{} -> f $ appNode prev e + MeshGradientNode{} -> f $ appNode prev e + LinearGradientNode{} -> f $ appNode prev e + RadialGradientNode{} -> f $ appNode prev e + PatternNode{} -> f $ appNode prev e + MarkerNode{} -> f $ appNode prev e + MaskNode{} -> f $ appNode prev e + ClipPathNode{} -> f $ appNode prev e + SvgNode{} -> 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] + +-- | Fold all nodes of a SVG tree. +foldTree :: (a -> Tree -> a) -> a -> Tree -> a +foldTree f = go where + go acc e = case e of + DefinitionTree g -> foldGroup g + GroupTree g -> foldGroup g + SymbolTree g -> foldGroup g + _ -> f acc e + where + foldGroup g = + let subAcc = F.foldl' go acc $ _groupChildren g in + f subAcc e + +-- | Helper function mapping every tree element. +mapTree :: (Tree -> Tree) -> Tree -> Tree +mapTree f = worker where + worker t = f $ t & treeBranch %~ go + go e = case e of + NoNode -> e + UseNode{} -> e + GroupNode g -> GroupNode $ mapGroup g + SymbolNode g -> + SymbolNode $ mapGroup g + DefinitionNode g -> + DefinitionNode $ mapGroup g + FilterNode{} -> e + PathNode{} -> e + CircleNode{} -> e + PolyLineNode{} -> e + PolygonNode{} -> e + EllipseNode{} -> e + LineNode{} -> e + RectangleNode{} -> e + TextNode{} -> e + ImageNode{} -> e + LinearGradientNode{} -> e + RadialGradientNode{} -> e + MeshGradientNode{} -> e + PatternNode{} -> e + MarkerNode{} -> e + MaskNode{} -> e + ClipPathNode{} -> e + SvgNode{} -> e + + mapGroup g = + g { _groupChildren = map worker $ _groupChildren g } + +mapBranch :: (TreeBranch -> TreeBranch) -> Tree -> Tree +mapBranch f = mapTree (treeBranch %~ f) diff --git a/src/Graphics/SvgTree/Types/Hashable.hs b/src/Graphics/SvgTree/Types/Hashable.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/SvgTree/Types/Hashable.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans -O0 #-} + +module Graphics.SvgTree.Types.Hashable where + +import Codec.Picture (PixelRGBA8 (..)) +import Control.Lens +import Data.Hashable +import Data.Monoid +import GHC.Generics (Generic) +import Graphics.SvgTree.Types.Internal + +-- Orphan instances :( +instance Hashable a => Hashable (Last a) + +deriving instance Generic PixelRGBA8 + +instance Hashable PixelRGBA8 + +deriving instance Hashable DrawAttributes + +deriving instance Hashable Pattern + +deriving instance Hashable Element + +deriving instance Hashable ClipPath + +deriving instance Hashable Mask + +deriving instance Hashable CoordinateUnits + +deriving instance Hashable TreeBranch + +deriving instance Hashable Group + +deriving instance Hashable PreserveAspectRatio + +deriving instance Hashable Alignment + +deriving instance Hashable MeetSlice + +deriving instance Hashable LinearGradient + +deriving instance Hashable Spread + +deriving instance Hashable Transformation + +deriving instance Hashable GradientStop + +deriving instance Hashable GradientPathCommand + +deriving instance Hashable Origin + +deriving instance Hashable Use + +deriving instance Hashable Filter + +deriving instance Hashable FilterAttributes + +deriving instance Hashable FilterElement + +deriving instance Hashable ColorMatrix + +deriving instance Hashable FilterSource + +deriving instance Hashable ColorMatrixType + +deriving instance Hashable Composite + +deriving instance Hashable CompositeOperator + +deriving instance Hashable DisplacementMap + +deriving instance Hashable ChannelSelector + +deriving instance Hashable GaussianBlur + +deriving instance Hashable EdgeMode + +deriving instance Hashable Turbulence + +deriving instance Hashable StitchTiles + +deriving instance Hashable TurbulenceType + +deriving instance Hashable Path + +deriving instance Hashable PathCommand + +deriving instance Hashable Circle + +deriving instance Hashable PolyLine + +deriving instance Hashable Polygon + +deriving instance Hashable Ellipse + +deriving instance Hashable Line + +deriving instance Hashable Rectangle + +deriving instance Hashable TextPath + +deriving instance Hashable TextPathMethod + +deriving instance Hashable TextPathSpacing + +deriving instance Hashable Text + +deriving instance Hashable TextAdjust + +deriving instance Hashable TextSpan + +deriving instance Hashable TextInfo + +deriving instance Hashable TextSpanContent + +deriving instance Hashable Image + +deriving instance Hashable RadialGradient + +deriving instance Hashable MeshGradient + +deriving instance Hashable MeshGradientType + +deriving instance Hashable MeshGradientRow + +deriving instance Hashable MeshGradientPatch + +deriving instance Hashable Marker + +deriving instance Hashable MarkerOrientation + +deriving instance Hashable MarkerUnit + +deriving instance Hashable Overflow + +deriving instance Hashable Document + +deriving instance Hashable Texture + +deriving instance Hashable Cap + +deriving instance Hashable LineJoin + +deriving instance Hashable FillRule + +deriving instance Hashable ElementRef + +deriving instance Hashable FontStyle + +deriving instance Hashable TextAnchor + +instance Hashable Tree where + hashWithSalt s = hashWithSalt s . _treeHash + +treeBranch :: Lens' Tree TreeBranch +treeBranch = lens _treeBranch $ const Tree + +instance WithDefaultSvg Tree where + defaultSvg = Tree NoNode + +unpack :: Tree -> TreeBranch +unpack t = (_treeBranch t) + +pattern Tree :: TreeBranch -> Tree +pattern Tree branch <- + CachedTree {_treeBranch = branch} + where + Tree branch = + CachedTree + { _treeBranch = branch, + _treeHash = hash branch + } + +pattern GroupTree :: Group -> Tree +pattern GroupTree g = Tree (GroupNode g) + +pattern SymbolTree :: Group -> Tree +pattern SymbolTree g = Tree (SymbolNode g) + +pattern DefinitionTree :: Group -> Tree +pattern DefinitionTree g = Tree (DefinitionNode g) + +pattern None :: Tree +pattern None = Tree NoNode + +pattern UseTree :: Use -> Maybe Tree -> Tree +pattern UseTree info sub = Tree (UseNode info sub) + +pattern FilterTree :: Filter -> Tree +pattern FilterTree f = Tree (FilterNode f) + +pattern PathTree :: Path -> Tree +pattern PathTree f = Tree (PathNode f) + +pattern CircleTree :: Circle -> Tree +pattern CircleTree f = Tree (CircleNode f) + +pattern PolyLineTree :: PolyLine -> Tree +pattern PolyLineTree f = Tree (PolyLineNode f) + +pattern PolygonTree :: Polygon -> Tree +pattern PolygonTree f = Tree (PolygonNode f) + +pattern EllipseTree :: Ellipse -> Tree +pattern EllipseTree f = Tree (EllipseNode f) + +pattern LineTree :: Line -> Tree +pattern LineTree f = Tree (LineNode f) + +pattern RectangleTree :: Rectangle -> Tree +pattern RectangleTree f = Tree (RectangleNode f) + +pattern TextTree :: Maybe TextPath -> Text -> Tree +pattern TextTree p t = Tree (TextNode p t) + +pattern ImageTree :: Image -> Tree +pattern ImageTree n = Tree (ImageNode n) + +pattern LinearGradientTree :: LinearGradient -> Tree +pattern LinearGradientTree n = Tree (LinearGradientNode n) + +pattern RadialGradientTree :: RadialGradient -> Tree +pattern RadialGradientTree n = Tree (RadialGradientNode n) + +pattern MeshGradientTree :: MeshGradient -> Tree +pattern MeshGradientTree n = Tree (MeshGradientNode n) + +pattern PatternTree :: Pattern -> Tree +pattern PatternTree n = Tree (PatternNode n) + +pattern MarkerTree :: Marker -> Tree +pattern MarkerTree n = Tree (MarkerNode n) + +pattern MaskTree :: Mask -> Tree +pattern MaskTree n = Tree (MaskNode n) + +pattern ClipPathTree :: ClipPath -> Tree +pattern ClipPathTree n = Tree (ClipPathNode n) + +pattern SvgTree :: Document -> Tree +pattern SvgTree n = Tree (SvgNode n) diff --git a/src/Graphics/SvgTree/Types/Instances.hs b/src/Graphics/SvgTree/Types/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/SvgTree/Types/Instances.hs @@ -0,0 +1,211 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module Graphics.SvgTree.Types.Instances where + +import Control.Lens ((&), (.~), (^.), lens, view) +import qualified Data.Text as T +import Graphics.SvgTree.CssTypes (CssMatcheable (..)) +import Graphics.SvgTree.Types.Hashable +import Graphics.SvgTree.Types.Internal + +instance CssMatcheable Tree where + cssAttribOf _ _ = Nothing + cssClassOf = view (drawAttributes . attrClass) + cssIdOf = fmap T.pack . view (drawAttributes . attrId) + cssNameOf = nameOfTree + +instance HasDrawAttributes Tree where + drawAttributes = treeBranch . drawAttributes + +instance HasDrawAttributes Filter where + drawAttributes = filterDrawAttributes + +instance HasDrawAttributes Use where + drawAttributes = useDrawAttributes + +instance HasDrawAttributes Group where + drawAttributes = groupDrawAttributes + +instance HasDrawAttributes Rectangle where + drawAttributes = rectangleDrawAttributes + +instance HasDrawAttributes Line where + drawAttributes = lineDrawAttributes + +instance HasDrawAttributes Ellipse where + drawAttributes = ellipseDrawAttributes + +instance HasDrawAttributes Polygon where + drawAttributes = polygonDrawAttributes + +instance HasDrawAttributes PolyLine where + drawAttributes = polyLineDrawAttributes + +instance HasDrawAttributes Circle where + drawAttributes = circleDrawAttributes + +instance HasDrawAttributes Path where + drawAttributes = pathDrawAttributes + +instance HasDrawAttributes ClipPath where + drawAttributes = clipPathDrawAttributes + +instance HasDrawAttributes Mask where + drawAttributes = maskDrawAttributes + +instance HasDrawAttributes Marker where + drawAttributes = markerDrawAttributes + +instance HasDrawAttributes Image where + drawAttributes = imageDrawAttributes + +instance HasDrawAttributes Pattern where + drawAttributes = patternDrawAttributes + +instance HasDrawAttributes MeshGradient where + drawAttributes = meshGradientDrawAttributes + +instance HasDrawAttributes RadialGradient where + drawAttributes = radialGradientDrawAttributes + +instance HasDrawAttributes LinearGradient where + drawAttributes = linearGradientDrawAttributes + +instance HasDrawAttributes Composite where + drawAttributes = compositeDrawAttributes + +instance HasDrawAttributes ColorMatrix where + drawAttributes = colorMatrixDrawAttributes + +instance HasDrawAttributes GaussianBlur where + drawAttributes = gaussianBlurDrawAttributes + +instance HasDrawAttributes Turbulence where + drawAttributes = turbulenceDrawAttributes + +instance HasDrawAttributes DisplacementMap where + drawAttributes = displacementMapDrawAttributes + +instance HasDrawAttributes Text where + drawAttributes = textRoot . spanDrawAttributes + +instance HasFilterAttributes Filter where + filterAttributes = filterSelfAttributes + +instance HasFilterAttributes Composite where + filterAttributes = compositeFilterAttr + +instance HasFilterAttributes ColorMatrix where + filterAttributes = colorMatrixFilterAttr + +instance HasFilterAttributes GaussianBlur where + filterAttributes = gaussianBlurFilterAttr + +instance HasFilterAttributes Turbulence where + filterAttributes = turbulenceFilterAttr + +instance HasFilterAttributes DisplacementMap where + filterAttributes = displacementMapFilterAttr + +instance HasFilterAttributes FilterElement where + filterAttributes = lens getter setter + where + getter fe = case fe of + FEBlend -> defaultSvg + FEColorMatrix m -> m ^. filterAttributes + FEComponentTransfer -> defaultSvg + FEComposite c -> c ^. filterAttributes + FEConvolveMatrix -> defaultSvg + FEDiffuseLighting -> defaultSvg + FEDisplacementMap d -> d ^. filterAttributes + FEDropShadow -> defaultSvg + FEFlood -> defaultSvg + FEFuncA -> defaultSvg + FEFuncB -> defaultSvg + FEFuncG -> defaultSvg + FEFuncR -> defaultSvg + FEGaussianBlur g -> g ^. filterAttributes + FEImage -> defaultSvg + FEMerge -> defaultSvg + FEMergeNode -> defaultSvg + FEMorphology -> defaultSvg + FEOffset -> defaultSvg + FESpecularLighting -> defaultSvg + FETile -> defaultSvg + FETurbulence t -> t ^. filterAttributes + FENone -> defaultSvg + setter fe attr = case fe of + FEBlend -> fe + FEColorMatrix m -> FEColorMatrix $ m & filterAttributes .~ attr + FEComponentTransfer -> fe + FEComposite c -> FEComposite $ c & filterAttributes .~ attr + FEConvolveMatrix -> fe + FEDiffuseLighting -> fe + FEDisplacementMap d -> FEDisplacementMap $ d & filterAttributes .~ attr + FEDropShadow -> fe + FEFlood -> fe + FEFuncA -> fe + FEFuncB -> fe + FEFuncG -> fe + FEFuncR -> fe + FEGaussianBlur g -> FEGaussianBlur $ g & filterAttributes .~ attr + FEImage -> fe + FEMerge -> fe + FEMergeNode -> fe + FEMorphology -> fe + FEOffset -> fe + FESpecularLighting -> fe + FETile -> fe + FETurbulence t -> FETurbulence $ t & filterAttributes .~ attr + FENone -> fe + +instance HasDrawAttributes TreeBranch where + drawAttributes = lens getter setter + where + getter b = case b of + NoNode -> defaultSvg + UseNode use _subNode -> use ^. drawAttributes + GroupNode t -> t ^. drawAttributes + SymbolNode t -> t ^. drawAttributes + DefinitionNode t -> t ^. drawAttributes + FilterNode t -> t ^. drawAttributes + PathNode t -> t ^. drawAttributes + CircleNode t -> t ^. drawAttributes + PolyLineNode t -> t ^. drawAttributes + PolygonNode t -> t ^. drawAttributes + EllipseNode t -> t ^. drawAttributes + LineNode t -> t ^. drawAttributes + RectangleNode t -> t ^. drawAttributes + TextNode _ t -> t ^. drawAttributes + ImageNode t -> t ^. drawAttributes + LinearGradientNode t -> t ^. drawAttributes + RadialGradientNode t -> t ^. drawAttributes + MeshGradientNode t -> t ^. drawAttributes + PatternNode t -> t ^. drawAttributes + MarkerNode t -> t ^. drawAttributes + MaskNode t -> t ^. drawAttributes + ClipPathNode t -> t ^. drawAttributes + SvgNode{} -> defaultSvg + setter b attr = case b of + NoNode -> b + UseNode use subNode -> UseNode (use & drawAttributes .~ attr) subNode + GroupNode t -> GroupNode $ t & drawAttributes .~ attr + SymbolNode t -> SymbolNode $ t & drawAttributes .~ attr + DefinitionNode t -> DefinitionNode $ t & drawAttributes .~ attr + FilterNode t -> FilterNode $ t & drawAttributes .~ attr + PathNode t -> PathNode $ t & drawAttributes .~ attr + CircleNode t -> CircleNode $ t & drawAttributes .~ attr + PolyLineNode t -> PolyLineNode $ t & drawAttributes .~ attr + PolygonNode t -> PolygonNode $ t & drawAttributes .~ attr + EllipseNode t -> EllipseNode $ t & drawAttributes .~ attr + LineNode t -> LineNode $ t & drawAttributes .~ attr + RectangleNode t -> RectangleNode $ t & drawAttributes .~ attr + TextNode path t -> TextNode path $ t & drawAttributes .~ attr + ImageNode t -> ImageNode $ t & drawAttributes .~ attr + LinearGradientNode t -> LinearGradientNode $ t & drawAttributes .~ attr + RadialGradientNode t -> RadialGradientNode $ t & drawAttributes .~ attr + MeshGradientNode t -> MeshGradientNode $ t & drawAttributes .~ attr + PatternNode t -> PatternNode $ t & drawAttributes .~ attr + MarkerNode t -> MarkerNode $ t & drawAttributes .~ attr + MaskNode t -> MaskNode $ t & drawAttributes .~ attr + ClipPathNode t -> ClipPathNode $ t & drawAttributes .~ attr + SvgNode {} -> GroupNode $ defaultSvg & groupChildren .~ [Tree b] & drawAttributes .~ attr diff --git a/src/Graphics/SvgTree/Types/Internal.hs b/src/Graphics/SvgTree/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/SvgTree/Types/Internal.hs @@ -0,0 +1,1767 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | This module define all the types used in the definition +-- of a svg scene. +-- +-- Most of the types are lensified. +module Graphics.SvgTree.Types.Internal + ( -- * Basic building types + Coord, + Origin (..), + Point, + RPoint, + PathCommand (..), + Transformation (..), + ElementRef (..), + CoordinateUnits (..), + + -- ** Building helpers + serializeNumber, + serializeTransformation, + serializeTransformations, + + -- * Drawing control types + Cap (..), + LineJoin (..), + Tree (..), + TreeBranch (..), + Number (..), + Spread (..), + Texture (..), + Element (..), + FillRule (..), + FontStyle (..), + Dpi, + WithDefaultSvg (..), + + -- * Main type + Document (..), + documentViewBox, + documentWidth, + documentHeight, + documentElements, + documentDescription, + documentLocation, + documentAspectRatio, + documentSize, + + -- * Drawing attributes + DrawAttributes (..), + HasDrawAttributes (..), + + -- * Filters + FilterElement (..), + FilterAttributes (..), + HasFilterAttributes (..), + FilterSource (..), + ColorMatrixType (..), + colorMatrixDrawAttributes, + colorMatrixFilterAttr, + colorMatrixIn, + colorMatrixType, + colorMatrixValues, + ColorMatrix (..), + compositeDrawAttributes, + compositeFilterAttr, + compositeIn, + compositeIn2, + compositeOperator, + compositeK1, + compositeK2, + compositeK3, + compositeK4, + Composite (..), + CompositeOperator (..), + EdgeMode (..), + gaussianBlurDrawAttributes, + gaussianBlurFilterAttr, + gaussianBlurIn, + gaussianBlurStdDeviationX, + gaussianBlurStdDeviationY, + gaussianBlurEdgeMode, + GaussianBlur (..), + turbulenceDrawAttributes, + turbulenceFilterAttr, + turbulenceBaseFrequency, + turbulenceNumOctaves, + turbulenceSeed, + turbulenceStitchTiles, + turbulenceType, + Turbulence (..), + TurbulenceType (..), + StitchTiles (..), + DisplacementMap (..), + displacementMapDrawAttributes, + displacementMapFilterAttr, + displacementMapIn, + displacementMapIn2, + displacementMapScale, + displacementMapXChannelSelector, + displacementMapYChannelSelector, + ChannelSelector (..), + + -- * SVG drawing primitives + + -- ** Rectangle + Rectangle (..), + rectangleDrawAttributes, + rectUpperLeftCorner, + rectWidth, + rectHeight, + rectCornerRadius, + + -- ** Line + Line (..), + lineDrawAttributes, + linePoint1, + linePoint2, + + -- ** Polygon + Polygon (..), + polygonDrawAttributes, + polygonPoints, + + -- ** Polyline + PolyLine (..), + polyLineDrawAttributes, + polyLinePoints, + + -- ** Path + Path (..), + pathDrawAttributes, + pathDefinition, + + -- ** Circle + Circle (..), + circleDrawAttributes, + circleCenter, + circleRadius, + + -- ** Ellipse + Ellipse (..), + ellipseDrawAttributes, + ellipseCenter, + ellipseXRadius, + ellipseYRadius, + + -- ** Mesh (gradient mesh) + GradientPathCommand (..), + MeshGradientType (..), + MeshGradient (..), + meshGradientDrawAttributes, + meshGradientX, + meshGradientY, + meshGradientType, + meshGradientUnits, + meshGradientTransform, + meshGradientRows, + MeshGradientRow (..), + meshGradientRowPatches, + MeshGradientPatch (..), + meshGradientPatchStops, + + -- ** Image + Image (..), + imageDrawAttributes, + imageCornerUpperLeft, + imageWidth, + imageHeight, + imageHref, + imageAspectRatio, + + -- ** Use + Use (..), + useDrawAttributes, + useBase, + useName, + useWidth, + useHeight, + + -- * Grouping primitives + + -- ** Group + Group (..), + groupDrawAttributes, + groupChildren, + groupViewBox, + groupAspectRatio, + + -- ** Filter + Filter (..), + filterDrawAttributes, + filterSelfAttributes, + filterChildren, + + -- * Text related types + + -- ** Text + Text (..), + textAdjust, + textRoot, + TextAnchor (..), + textAt, + + -- ** Text path + TextPath (..), + textPathStartOffset, + textPathName, + textPathMethod, + textPathSpacing, + TextPathSpacing (..), + TextPathMethod (..), + + -- ** Text span. + TextSpanContent (..), + TextSpan (..), + spanInfo, + spanDrawAttributes, + spanContent, + TextInfo (..), + textInfoX, + textInfoY, + textInfoDX, + textInfoDY, + textInfoRotate, + textInfoLength, + TextAdjust (..), + + -- * Marker definition + Marker (..), + Overflow (..), + MarkerOrientation (..), + MarkerUnit (..), + markerDrawAttributes, + markerRefPoint, + markerWidth, + markerHeight, + markerOrient, + markerUnits, + markerViewBox, + markerOverflow, + markerAspectRatio, + markerElements, + + -- * Gradient definition + GradientStop (..), + gradientOffset, + gradientColor, + gradientPath, + gradientOpacity, + + -- ** Linear Gradient + LinearGradient (..), + linearGradientDrawAttributes, + linearGradientUnits, + linearGradientStart, + linearGradientStop, + linearGradientSpread, + linearGradientTransform, + linearGradientStops, + + -- ** Radial Gradient + RadialGradient (..), + radialGradientDrawAttributes, + radialGradientUnits, + radialGradientCenter, + radialGradientRadius, + radialGradientFocusX, + radialGradientFocusY, + radialGradientSpread, + radialGradientTransform, + radialGradientStops, + + -- * Pattern definition + Pattern (..), + patternDrawAttributes, + patternViewBox, + patternWidth, + patternHeight, + patternPos, + patternHref, + patternElements, + patternUnit, + patternAspectRatio, + patternTransform, + + -- * Mask definition + Mask (..), + maskDrawAttributes, + maskContentUnits, + maskUnits, + maskPosition, + maskWidth, + maskHeight, + maskContent, + + -- * Clip path definition + ClipPath (..), + clipPathDrawAttributes, + clipPathUnits, + clipPathContent, + + -- * Aspect Ratio description + PreserveAspectRatio (..), + Alignment (..), + MeetSlice (..), + aspectRatioDefer, + aspectRatioAlign, + aspectRatioMeetSlice, + + -- * MISC functions + nameOfTree, + toUserUnit, + mapNumber, + ) +where + +import Codec.Picture (PixelRGBA8 (..)) +import Control.Lens.TH (makeClassy, makeLenses) +import Data.Function (on) +import Data.Monoid (Last (..)) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Graphics.SvgTree.CssTypes + ( Dpi, + Number (..), + mapNumber, + serializeNumber, + toUserUnit, + ) +import Graphics.SvgTree.Misc (ppD) +import Graphics.SvgTree.Types.Basic +import Text.Printf (printf) + +-- | Path command definition. +data PathCommand + = -- | 'M' or 'm' command + MoveTo !Origin ![RPoint] + | -- | Line to, 'L' or 'l' Svg path command. + LineTo !Origin ![RPoint] + | -- | Equivalent to the 'H' or 'h' svg path command. + HorizontalTo !Origin ![Coord] + | -- | Equivalent to the 'V' or 'v' svg path command. + VerticalTo !Origin ![Coord] + | -- | Cubic bezier, 'C' or 'c' command + CurveTo !Origin ![(RPoint, RPoint, RPoint)] + | -- | Smooth cubic bezier, equivalent to 'S' or 's' command + SmoothCurveTo !Origin ![(RPoint, RPoint)] + | -- | Quadratic bezier, 'Q' or 'q' command + QuadraticBezier !Origin ![(RPoint, RPoint)] + | -- | Quadratic bezier, 'T' or 't' command + SmoothQuadraticBezierCurveTo !Origin ![RPoint] + | -- | Eliptical arc, 'A' or 'a' command. + EllipticalArc !Origin ![(Coord, Coord, Coord, Bool, Bool, RPoint)] + | -- | Close the path, 'Z' or 'z' svg path command. + EndPath + deriving (Eq, Show, Generic) + +-- | Description of path used in meshgradient tag +data GradientPathCommand + = -- | Line to, 'L' or 'l' Svg path command. + GLine !Origin !(Maybe RPoint) + | -- | Cubic bezier, 'C' or 'c' command + GCurve !Origin !RPoint !RPoint !(Maybe RPoint) + | -- | 'Z' command + GClose + deriving (Eq, Show, Generic) + +-- | Describe the content of the preserveAspectRatio attribute. +data PreserveAspectRatio = PreserveAspectRatio + { _aspectRatioDefer :: !Bool, + _aspectRatioAlign :: !Alignment, + _aspectRatioMeetSlice :: !(Maybe MeetSlice) + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg PreserveAspectRatio where + defaultSvg = + PreserveAspectRatio + { _aspectRatioDefer = False, + _aspectRatioAlign = AlignxMidYMid, + _aspectRatioMeetSlice = Nothing + } + +-- | Describe the content of the `transformation` attribute. +-- see `_transform` and `transform`. +data Transformation + = -- | Directly encode the translation matrix. + TransformMatrix + !Coord + !Coord + !Coord + !Coord + !Coord + !Coord + | -- | Translation along a vector + Translate !Double !Double + | -- | Scaling on both axis or on X axis and Y axis. + Scale !Double !(Maybe Double) + | -- | Rotation around `(0, 0)` or around an optional + -- point. + Rotate !Double !(Maybe (Double, Double)) + | -- | Skew transformation along the X axis. + SkewX !Double + | -- | Skew transformation along the Y axis. + SkewY !Double + | -- | Unkown transformation, like identity. + TransformUnknown + deriving (Eq, Show, Generic) + +-- | Convert the Transformation to a string which can be +-- directly used in a svg attributes. +serializeTransformation :: Transformation -> String +serializeTransformation t = case t of + TransformUnknown -> "" + TransformMatrix a b c d e f -> + printf + "matrix(%s, %s, %s, %s, %s, %s)" + (ppD a) + (ppD b) + (ppD c) + (ppD d) + (ppD e) + (ppD f) + Translate x y -> printf "translate(%s, %s)" (ppD x) (ppD y) + Scale x Nothing -> printf "scale(%s)" (ppD x) + Scale x (Just y) -> printf "scale(%s, %s)" (ppD x) (ppD y) + Rotate angle Nothing -> printf "rotate(%s)" (ppD angle) + Rotate angle (Just (x, y)) -> + printf + "rotate(%s, %s, %s)" + (ppD angle) + (ppD x) + (ppD y) + SkewX x -> printf "skewX(%s)" (ppD x) + SkewY y -> printf "skewY(%s)" (ppD y) + +-- | Transform a list of transformations to a string for svg +-- `transform` attributes. +serializeTransformations :: [Transformation] -> String +serializeTransformations = + unwords . fmap serializeTransformation + +-- | Define an empty 'default' element for the SVG tree. +-- It is used as base when parsing the element from XML. +class WithDefaultSvg a where + -- | The default element. + defaultSvg :: a + +-- | Classify the font style, used to search a matching +-- font in the FontCache. +data FontStyle + = FontStyleNormal + | FontStyleItalic + | FontStyleOblique + deriving (Eq, Show, Generic) + +-- | Tell where to anchor the text, where the position +-- given is realative to the text. +data TextAnchor + = -- | The text with left aligned, or start at the postion + -- If the point is the '*' then the text will be printed + -- this way: + -- + -- > *THE_TEXT_TO_PRINT + -- + -- Equivalent to the `start` value. + TextAnchorStart + | -- | The text is middle aligned, so the text will be at + -- the left and right of the position: + -- + -- > THE_TEXT*TO_PRINT + -- + -- Equivalent to the `middle` value. + TextAnchorMiddle + | -- | The text is right aligned. + -- + -- > THE_TEXT_TO_PRINT* + -- + -- Equivalent to the `end` value. + TextAnchorEnd + deriving (Eq, Show, Generic) + +-- | Correspond to the possible values of the +-- the attributes which are either `none` or +-- `url(#elem)` +data ElementRef + = -- | Value for `none` + RefNone + | -- | Equivalent to `url()` attribute. + Ref String + deriving (Eq, Show, Generic) + +data FilterSource + = SourceGraphic + | SourceAlpha + | BackgroundImage + | BackgroundAlpha + | FillPaint + | StrokePaint + | SourceRef String + deriving (Eq, Show, Generic) + +data FilterAttributes = FilterAttributes + { _filterHeight :: !(Last Number), + _filterResult :: !(Maybe String), + _filterWidth :: !(Last Number), + _filterX :: !(Last Number), + _filterY :: !(Last Number) + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg FilterAttributes where + defaultSvg = + FilterAttributes + { _filterHeight = Last Nothing, + _filterResult = Nothing, + _filterWidth = Last Nothing, + _filterX = Last Nothing, + _filterY = Last Nothing + } + +-- | This type define how to draw any primitives, +-- which color to use, how to stroke the primitives +-- and the potential transformations to use. +-- +-- All these attributes are propagated to the children. +data DrawAttributes = DrawAttributes + { -- | Attribute corresponding to the `stroke-width` + -- SVG attribute. + _strokeWidth :: !(Last Number), + -- | Correspond to the `stroke` attribute. + _strokeColor :: !(Last Texture), + -- | Define the `stroke-opacity` attribute, the transparency + -- for the "border". + _strokeOpacity :: !(Maybe Float), + -- | Correspond to the `stroke-linecap` SVG + -- attribute + _strokeLineCap :: !(Last Cap), + -- | Correspond to the `stroke-linejoin` SVG + -- attribute + _strokeLineJoin :: !(Last LineJoin), + -- | Define the distance of the miter join, correspond + -- to the `stroke-miterlimit` attritbue. + _strokeMiterLimit :: !(Last Double), + -- | Define the filling color of the elements. Corresponding + -- to the `fill` attribute. + _fillColor :: !(Last Texture), + -- | Define the `fill-opacity` attribute, the transparency + -- for the "content". + _fillOpacity :: !(Maybe Float), + -- | Define the global or group opacity attribute. + _groupOpacity :: !(Maybe Float), + -- | Content of the `transform` attribute + _transform :: !(Maybe [Transformation]), + -- | Define the `fill-rule` used during the rendering. + _fillRule :: !(Last FillRule), + -- | Define the `mask` attribute. + _maskRef :: !(Last ElementRef), + -- | Define the `clip-path` attribute. + _clipPathRef :: !(Last ElementRef), + -- | Define the `clip-rule` attribute. + _clipRule :: !(Last FillRule), + -- | Map to the `class` attribute. Used for the CSS + -- rewriting. + _attrClass :: ![T.Text], + -- | Map to the `id` attribute. Used for the CSS + -- rewriting. + _attrId :: !(Maybe String), + -- | Define the start distance of the dashing pattern. + -- Correspond to the `stroke-dashoffset` attribute. + _strokeOffset :: !(Last Number), + -- | Define the dashing pattern for the lines. Correspond + -- to the `stroke-dasharray` attribute. + _strokeDashArray :: !(Last [Number]), + -- | Current size of the text, correspond to the + -- `font-size` SVG attribute. + _fontSize :: !(Last Number), + -- | Define the possible fonts to be used for text rendering. + -- Map to the `font-family` attribute. + _fontFamily :: !(Last [String]), + -- | Map to the `font-style` attribute. + _fontStyle :: !(Last FontStyle), + -- | Define how to interpret the text position, correspond + -- to the `text-anchor` attribute. + _textAnchor :: !(Last TextAnchor), + -- | Define the marker used for the start of the line. + -- Correspond to the `marker-start` attribute. + _markerStart :: !(Last ElementRef), + -- | Define the marker used for every point of the + -- polyline/path Correspond to the `marker-mid` + -- attribute. + _markerMid :: !(Last ElementRef), + -- | Define the marker used for the end of the line. + -- Correspond to the `marker-end` attribute. + _markerEnd :: !(Last ElementRef), + _filterRef :: !(Last ElementRef) + } + deriving (Eq, Show, Generic) + +makeClassy ''DrawAttributes + +-- | This primitive describe an unclosed suite of +-- segments. Correspond to the `` tag. +data PolyLine = PolyLine + { _polyLineDrawAttributes :: DrawAttributes, + -- | Geometry definition of the polyline. + -- correspond to the `points` attribute + _polyLinePoints :: [RPoint] + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg PolyLine where + defaultSvg = PolyLine mempty mempty + +-- | Primitive decriving polygon composed +-- of segements. Correspond to the `` +-- tag +data Polygon = Polygon + { _polygonDrawAttributes :: DrawAttributes, + -- | Points of the polygon. Correspond to + -- the `points` attributes. + _polygonPoints :: [RPoint] + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg Polygon where + defaultSvg = Polygon mempty mempty + +-- | Define a simple line. Correspond to the +-- `` tag. +data Line = Line + { _lineDrawAttributes :: DrawAttributes, + -- | First point of the the line, correspond + -- to the `x1` and `y1` attributes. + _linePoint1 :: !Point, + -- | Second point of the the line, correspond + -- to the `x2` and `y2` attributes. + _linePoint2 :: !Point + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg Line where + defaultSvg = + Line + { _lineDrawAttributes = mempty, + _linePoint1 = zeroPoint, + _linePoint2 = zeroPoint + } + where + zeroPoint = (Num 0, Num 0) + +-- | Define a rectangle. Correspond to +-- `` svg tag. +data Rectangle = Rectangle + { _rectangleDrawAttributes :: DrawAttributes, + -- | Upper left corner of the rectangle, correspond + -- to the attributes `x` and `y`. + _rectUpperLeftCorner :: !Point, + -- | Rectangle width, correspond, strangely, to + -- the `width` attribute. + _rectWidth :: !(Maybe Number), + -- | Rectangle height, correspond, amazingly, to + -- the `height` attribute. + _rectHeight :: !(Maybe Number), + -- | Define the rounded corner radius radius + -- of the rectangle. Correspond to the `rx` and + -- `ry` attributes. + _rectCornerRadius :: !(Maybe Number, Maybe Number) + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg Rectangle where + defaultSvg = + Rectangle + { _rectangleDrawAttributes = mempty, + _rectUpperLeftCorner = (Num 0, Num 0), + _rectWidth = Nothing, + _rectHeight = Nothing, + _rectCornerRadius = (Nothing, Nothing) + } + +-- | Type mapping the `` svg tag. +data Path = Path + { _pathDrawAttributes :: DrawAttributes, + -- | Definition of the path, correspond to the + -- `d` attributes. + _pathDefinition :: [PathCommand] + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg Path where + defaultSvg = Path mempty mempty + +-- | Define a SVG group, corresponding `` tag. +data Group = Group + { _groupDrawAttributes :: DrawAttributes, + -- | Content of the group, corresponding to all the tags + -- inside the `` tag. + _groupChildren :: ![Tree], + -- | Mapped to the attribute `viewBox` + _groupViewBox :: !(Maybe (Double, Double, Double, Double)), + -- | used for symbols only + _groupAspectRatio :: !PreserveAspectRatio + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg Group where + defaultSvg = + Group + { _groupDrawAttributes = mempty, + _groupChildren = [], + _groupViewBox = Nothing, + _groupAspectRatio = defaultSvg + } + +-- | Define the `` tag. +data Filter = Filter + { _filterDrawAttributes :: DrawAttributes, + _filterSelfAttributes :: !FilterAttributes, + _filterChildren :: ![FilterElement] + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg Filter where + defaultSvg = + Filter + { _filterDrawAttributes = mempty, + _filterSelfAttributes = defaultSvg, + _filterChildren = [] + } + +-- | Define a ``. +data Circle = Circle + { _circleDrawAttributes :: DrawAttributes, + -- | Define the center of the circle, describe + -- the `cx` and `cy` attributes. + _circleCenter :: !Point, + -- | Radius of the circle, equivalent to the `r` + -- attribute. + _circleRadius :: !Number + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg Circle where + defaultSvg = + Circle + { _circleDrawAttributes = mempty, + _circleCenter = (Num 0, Num 0), + _circleRadius = Num 0 + } + +-- | Define an `` +data Ellipse = Ellipse + { _ellipseDrawAttributes :: DrawAttributes, + -- | Center of the ellipse, map to the `cx` + -- and `cy` attributes. + _ellipseCenter :: !Point, + -- | Radius along the X axis, map the + -- `rx` attribute. + _ellipseXRadius :: !Number, + -- | Radius along the Y axis, map the + -- `ry` attribute. + _ellipseYRadius :: !Number + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg Ellipse where + defaultSvg = + Ellipse + { _ellipseDrawAttributes = mempty, + _ellipseCenter = (Num 0, Num 0), + _ellipseXRadius = Num 0, + _ellipseYRadius = Num 0 + } + +-- | Define a color stop for the gradients. Represent +-- the `` SVG tag. +data GradientStop = GradientStop + { -- | Gradient offset between 0 and 1, correspond + -- to the `offset` attribute. + _gradientOffset :: !Float, + -- | Color of the gradient stop. Correspond + -- to the `stop-color` attribute. + _gradientColor :: !PixelRGBA8, + -- | Path command used in mesh patch + _gradientPath :: !(Maybe GradientPathCommand), + -- | Stop color opacity + _gradientOpacity :: !(Maybe Float) + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg GradientStop where + defaultSvg = + GradientStop + { _gradientOffset = 0.0, + _gradientColor = PixelRGBA8 0 0 0 255, + _gradientPath = Nothing, + _gradientOpacity = Nothing + } + +-- | Define `` SVG tag +data MeshGradientPatch = MeshGradientPatch + { -- | List of stop, from 2 to 4 in a patch + _meshGradientPatchStops :: ![GradientStop] + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg MeshGradientPatch where + defaultSvg = MeshGradientPatch [] + +-- | Define a `` tag. +data MeshGradientRow = MeshGradientRow + { -- | List of patch in a row + _meshGradientRowPatches :: ![MeshGradientPatch] + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg MeshGradientRow where + defaultSvg = MeshGradientRow [] + +-- | Define a `` tag. +data MeshGradient = MeshGradient + { _meshGradientDrawAttributes :: DrawAttributes, + -- | Original x coordinate of the mesh gradient + _meshGradientX :: !Number, + -- | Original y coordinate of the mesh gradient + _meshGradientY :: !Number, + -- | Type of color interpolation to use + _meshGradientType :: !MeshGradientType, + -- | Coordiante system to use + _meshGradientUnits :: !CoordinateUnits, + -- | Optional transform + _meshGradientTransform :: ![Transformation], + -- | List of patch rows in the the mesh. + _meshGradientRows :: ![MeshGradientRow] + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg MeshGradient where + defaultSvg = + MeshGradient + { _meshGradientDrawAttributes = mempty, + _meshGradientX = Percent 0, + _meshGradientY = Percent 0, + _meshGradientType = GradientBilinear, + _meshGradientUnits = CoordBoundingBox, + _meshGradientTransform = mempty, + _meshGradientRows = mempty + } + +-- | Define an `` tag. +data Image = Image + { _imageDrawAttributes :: DrawAttributes, + -- | Position of the image referenced by its + -- upper left corner. + _imageCornerUpperLeft :: !Point, + -- | Image width + _imageWidth :: !Number, + -- | Image Height + _imageHeight :: !Number, + -- | Image href, pointing to the real image. + _imageHref :: !String, + -- | preserveAspectRatio attribute + _imageAspectRatio :: !PreserveAspectRatio + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg Image where + defaultSvg = + Image + { _imageDrawAttributes = mempty, + _imageCornerUpperLeft = (Num 0, Num 0), + _imageWidth = Num 0, + _imageHeight = Num 0, + _imageHref = "", + _imageAspectRatio = defaultSvg + } + +-- | Define an `` for a named content. +-- Every named content can be reused in the +-- document using this element. +data Use = Use + { _useDrawAttributes :: DrawAttributes, + -- | Position where to draw the "used" element. + -- Correspond to the `x` and `y` attributes. + _useBase :: Point, + -- | Referenced name, correspond to `xlink:href` + -- attribute. + _useName :: String, + -- | Define the width of the region where + -- to place the element. Map to the `width` + -- attribute. + _useWidth :: Maybe Number, + -- | Define the height of the region where + -- to place the element. Map to the `height` + -- attribute. + _useHeight :: Maybe Number + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg Use where + defaultSvg = + Use + { _useDrawAttributes = mempty, + _useBase = (Num 0, Num 0), + _useName = "", + _useWidth = Nothing, + _useHeight = Nothing + } + +-- | Define position information associated to +-- `` or `` svg tag. +data TextInfo = TextInfo + { -- | `x` attribute. + _textInfoX :: ![Number], + -- | `y` attribute. + _textInfoY :: ![Number], + -- | `dx` attribute. + _textInfoDX :: ![Number], + -- | `dy` attribute. + _textInfoDY :: ![Number], + -- | `rotate` attribute. + _textInfoRotate :: ![Double], + -- | `textLength` attribute. + _textInfoLength :: !(Maybe Number) + } + deriving (Eq, Show, Generic) + +instance Semigroup TextInfo where + (<>) + (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) + +instance Monoid TextInfo where + mempty = TextInfo [] [] [] [] [] Nothing + mappend = (<>) + +instance WithDefaultSvg TextInfo where + defaultSvg = mempty + +-- | Define the content of a `` tag. +data TextSpanContent + = -- | Raw text + SpanText !T.Text + | -- | Equivalent to a `` + SpanTextRef !String + | -- | Define a `` + SpanSub !TextSpan + deriving (Eq, Show, Generic) + +-- | Define a `` tag. +data TextSpan = TextSpan + { -- | Placing information for the text. + _spanInfo :: !TextInfo, + -- | Drawing attributes for the text span. + _spanDrawAttributes :: !DrawAttributes, + -- | Content of the span. + _spanContent :: ![TextSpanContent] + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg TextSpan where + defaultSvg = + TextSpan + { _spanInfo = defaultSvg, + _spanDrawAttributes = mempty, + _spanContent = mempty + } + +-- | Describe the content of the `method` attribute on +-- text path. +data TextPathMethod + = -- | Map to the `align` value. + TextPathAlign + | -- | Map to the `stretch` value. + TextPathStretch + deriving (Eq, Show, Generic) + +-- | Describe the content of the `spacing` text path +-- attribute. +data TextPathSpacing + = -- | Map to the `exact` value. + TextPathSpacingExact + | -- | Map to the `auto` value. + TextPathSpacingAuto + deriving (Eq, Show, Generic) + +-- | Describe the `` SVG tag. +data TextPath = TextPath + { -- | Define the beginning offset on the path, + -- the `startOffset` attribute. + _textPathStartOffset :: !Number, + -- | Define the `xlink:href` attribute. + _textPathName :: !String, + -- | Correspond to the `method` attribute. + _textPathMethod :: !TextPathMethod, + -- | Correspond to the `spacing` attribute. + _textPathSpacing :: !TextPathSpacing + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg TextPath where + defaultSvg = + TextPath + { _textPathStartOffset = Num 0, + _textPathName = mempty, + _textPathMethod = TextPathAlign, + _textPathSpacing = TextPathSpacingExact + } + +-- | Define the possible values of the `lengthAdjust` +-- attribute. +data TextAdjust + = -- | Value `spacing` + TextAdjustSpacing + | -- | Value `spacingAndGlyphs` + TextAdjustSpacingAndGlyphs + deriving (Eq, Show, Generic) + +-- | Define the global `` SVG tag. +data Text = Text + { -- | Define the `lengthAdjust` attribute. + _textAdjust :: !TextAdjust, + -- | Root of the text content. + _textRoot :: !TextSpan + } + deriving (Eq, Show, Generic) + +-- | Little helper to create a SVG text at a given +-- baseline position. +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 WithDefaultSvg Text where + defaultSvg = + Text + { _textRoot = defaultSvg, + _textAdjust = TextAdjustSpacing + } + +-- | Main type for the scene description, reorient to +-- specific type describing each tag. +data Tree = CachedTree + { _treeBranch :: TreeBranch, + _treeHash :: Int + } + deriving (Eq, Show, Generic) + +data TreeBranch + = NoNode + | UseNode + { useInformation :: !Use, + useSubTree :: !(Maybe Tree) + } + | GroupNode !Group + | SymbolNode !Group + | DefinitionNode !Group + | FilterNode !Filter + | PathNode !Path + | CircleNode !Circle + | PolyLineNode !PolyLine + | PolygonNode !Polygon + | EllipseNode !Ellipse + | LineNode !Line + | RectangleNode !Rectangle + | TextNode !(Maybe TextPath) !Text + | ImageNode !Image + | LinearGradientNode !LinearGradient + | RadialGradientNode !RadialGradient + | MeshGradientNode !MeshGradient + | PatternNode !Pattern + | MarkerNode !Marker + | MaskNode !Mask + | ClipPathNode !ClipPath + | SvgNode !Document + deriving (Eq, Show, Generic) + +instance WithDefaultSvg TreeBranch where + defaultSvg = NoNode + +data FilterElement + = FEBlend + | FEColorMatrix ColorMatrix + | FEComponentTransfer -- Need + | FEComposite Composite + | FEConvolveMatrix + | FEDiffuseLighting + | FEDisplacementMap DisplacementMap + | FEDropShadow + | FEFlood + | FEFuncA -- Need + | FEFuncB + | FEFuncG + | FEFuncR + | FEGaussianBlur GaussianBlur + | FEImage + | FEMerge + | FEMergeNode + | FEMorphology + | FEOffset + | FESpecularLighting + | FETile + | FETurbulence Turbulence + | FENone + deriving (Eq, Show, Generic) + +instance WithDefaultSvg FilterElement where + defaultSvg = FENone + +data TransferFunctionType + = TFIdentity + | TFTable + | TFDiscrete + | TFLinear + | TFGamma + deriving (Eq, Show, Generic) + +data TransferFunction = TransferFunction + { _transferFunctionDrawAttributes :: !DrawAttributes, + _transferFunctionFilterAttr :: !FilterAttributes, + _transferFunctionType :: TransferFunctionType, + _transferFunctionTableValues :: [Double], + _transferFunctionSlope :: Double, + _transferFunctionIntercept :: Double, + _transferFunctionAmplitude :: Double, + _transferFunctionExponent :: Double, + _transferFunctionOffset :: Double + } + deriving (Eq, Show, Generic) + +data ChannelSelector + = ChannelR + | ChannelG + | ChannelB + | ChannelA + deriving (Eq, Show, Generic) + +data DisplacementMap = DisplacementMap + { _displacementMapDrawAttributes :: !DrawAttributes, + _displacementMapFilterAttr :: !FilterAttributes, + _displacementMapIn :: !(Last FilterSource), + _displacementMapIn2 :: !(Last FilterSource), + _displacementMapScale :: !(Last Double), + _displacementMapXChannelSelector :: ChannelSelector, + _displacementMapYChannelSelector :: ChannelSelector + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg DisplacementMap where + defaultSvg = + DisplacementMap + { _displacementMapDrawAttributes = defaultSvg, + _displacementMapFilterAttr = defaultSvg, + _displacementMapIn = Last Nothing, + _displacementMapIn2 = Last Nothing, + _displacementMapScale = Last Nothing, + _displacementMapXChannelSelector = ChannelA, + _displacementMapYChannelSelector = ChannelA + } + +data ColorMatrixType + = Matrix + | Saturate + | HueRotate + | LuminanceToAlpha + deriving (Eq, Show, Generic) + +data ColorMatrix = ColorMatrix + { _colorMatrixDrawAttributes :: !DrawAttributes, + _colorMatrixFilterAttr :: !FilterAttributes, + _colorMatrixIn :: !(Last FilterSource), + _colorMatrixType :: !ColorMatrixType, + _colorMatrixValues :: !String + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg ColorMatrix where + defaultSvg = + ColorMatrix + { _colorMatrixDrawAttributes = defaultSvg, + _colorMatrixFilterAttr = defaultSvg, + _colorMatrixIn = Last Nothing, + _colorMatrixType = Matrix, + _colorMatrixValues = "" + } + +data CompositeOperator + = CompositeOver -- this is default + | CompositeIn + | CompositeOut + | CompositeAtop + | CompositeXor + | CompositeArithmetic + deriving (Eq, Show, Generic) + +data Composite = Composite + { _compositeDrawAttributes :: DrawAttributes, + _compositeFilterAttr :: !FilterAttributes, + _compositeIn :: Last FilterSource, + _compositeIn2 :: Last FilterSource, + _compositeOperator :: CompositeOperator, + _compositeK1 :: Number, + _compositeK2 :: Number, + _compositeK3 :: Number, + _compositeK4 :: Number + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg Composite where + defaultSvg = + Composite + { _compositeDrawAttributes = defaultSvg, + _compositeFilterAttr = defaultSvg, + _compositeIn = Last Nothing, + _compositeIn2 = Last Nothing, + _compositeOperator = CompositeOver, + _compositeK1 = Num 0, + _compositeK2 = Num 0, + _compositeK3 = Num 0, + _compositeK4 = Num 0 + } + +data Turbulence = Turbulence + { _turbulenceDrawAttributes :: !DrawAttributes, + _turbulenceFilterAttr :: !FilterAttributes, + _turbulenceBaseFrequency :: !(Double, Last Double), -- Not negative + _turbulenceNumOctaves :: Int, -- Not negative + _turbulenceSeed :: Double, + _turbulenceStitchTiles :: StitchTiles, + _turbulenceType :: TurbulenceType + } + deriving (Eq, Show, Generic) + +data StitchTiles + = NoStitch + | Stitch + deriving (Eq, Show, Generic) + +data TurbulenceType + = FractalNoiseType + | TurbulenceType + deriving (Eq, Show, Generic) + +instance WithDefaultSvg Turbulence where + defaultSvg = + Turbulence + { _turbulenceDrawAttributes = defaultSvg, + _turbulenceFilterAttr = defaultSvg, + _turbulenceBaseFrequency = (0, Last Nothing), + _turbulenceNumOctaves = 1, + _turbulenceSeed = 0, + _turbulenceStitchTiles = NoStitch, + _turbulenceType = TurbulenceType + } + +data EdgeMode + = EdgeDuplicate + | EdgeWrap + | EdgeNone + deriving (Eq, Show, Generic) + +data GaussianBlur = GaussianBlur + { _gaussianBlurDrawAttributes :: DrawAttributes, + _gaussianBlurFilterAttr :: !FilterAttributes, + _gaussianBlurIn :: Last FilterSource, + _gaussianBlurStdDeviationX :: Number, + _gaussianBlurStdDeviationY :: Last Number, + _gaussianBlurEdgeMode :: EdgeMode + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg GaussianBlur where + defaultSvg = + GaussianBlur + { _gaussianBlurDrawAttributes = defaultSvg, + _gaussianBlurFilterAttr = defaultSvg, + _gaussianBlurIn = Last Nothing, + _gaussianBlurStdDeviationX = Num 0, + _gaussianBlurStdDeviationY = Last Nothing, + _gaussianBlurEdgeMode = EdgeDuplicate + } + +-- | Define the orientation, associated to the +-- `orient` attribute on the Marker +data MarkerOrientation + = -- | Auto value + OrientationAuto + | -- | Specific angle. + OrientationAngle Coord + deriving (Eq, Show, Generic) + +-- | Define the content of the `markerUnits` attribute +-- on the Marker. +data MarkerUnit + = -- | Value `strokeWidth` + MarkerUnitStrokeWidth + | -- | Value `userSpaceOnUse` + MarkerUnitUserSpaceOnUse + deriving (Eq, Show, Generic) + +-- | Define the content of the `markerUnits` attribute +-- on the Marker. +data Overflow + = -- | Value `visible` + OverflowVisible + | -- | Value `hidden` + OverflowHidden + deriving (Eq, Show, Generic) + +-- | Define the `` tag. +data Marker = Marker + { _markerDrawAttributes :: DrawAttributes, + -- | Define the reference point of the marker. + -- correspond to the `refX` and `refY` attributes. + _markerRefPoint :: !(Number, Number), + -- | Define the width of the marker. Correspond to + -- the `markerWidth` attribute. + _markerWidth :: !(Maybe Number), + -- | Define the height of the marker. Correspond to + -- the `markerHeight` attribute. + _markerHeight :: !(Maybe Number), + -- | Correspond to the `orient` attribute. + _markerOrient :: !(Maybe MarkerOrientation), + -- | Map the `markerUnits` attribute. + _markerUnits :: !(Maybe MarkerUnit), + -- | Optional viewbox + _markerViewBox :: !(Maybe (Double, Double, Double, Double)), + -- | Elements defining the marker. + _markerOverflow :: !(Maybe Overflow), + -- | preserveAspectRatio attribute + _markerAspectRatio :: !PreserveAspectRatio, + -- | Elements defining the marker. + _markerElements :: [Tree] + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg Marker where + defaultSvg = + Marker + { _markerDrawAttributes = mempty, + _markerRefPoint = (Num 0, Num 0), + _markerWidth = Just (Num 3), + _markerHeight = Just (Num 3), + _markerOrient = Nothing, -- MarkerOrientation + _markerUnits = Nothing, -- MarkerUnitStrokeWidth + _markerViewBox = Nothing, + _markerOverflow = Nothing, + _markerElements = mempty, + _markerAspectRatio = defaultSvg + } + +-- | For every element of a svg tree, associate +-- it's SVG tag name. +nameOfTree :: Tree -> T.Text +nameOfTree v = + case _treeBranch v of + NoNode -> "" + UseNode _ _ -> "use" + GroupNode _ -> "g" + SymbolNode _ -> "symbol" + DefinitionNode _ -> "defs" + FilterNode _ -> "filter" + PathNode _ -> "path" + CircleNode _ -> "circle" + PolyLineNode _ -> "polyline" + PolygonNode _ -> "polygon" + EllipseNode _ -> "ellipse" + LineNode _ -> "line" + RectangleNode _ -> "rectangle" + TextNode _ _ -> "text" + ImageNode _ -> "image" + LinearGradientNode _ -> "lineargradient" + RadialGradientNode _ -> "radialgradient" + MeshGradientNode _ -> "meshgradient" + PatternNode _ -> "pattern" + MarkerNode _ -> "marker" + MaskNode _ -> "mask" + ClipPathNode _ -> "clipPath" + SvgNode {} -> "svg" + +-- | Define the possible values for the `spreadMethod` +-- values used for the gradient definitions. +data Spread + = -- | `reapeat` value + SpreadRepeat + | -- | `pad` value + SpreadPad + | -- | `reflect value` + SpreadReflect + deriving (Eq, Show, Generic) + +-- | Define a `` tag. +data LinearGradient = LinearGradient + { _linearGradientDrawAttributes :: DrawAttributes, + -- | Define coordinate system of the gradient, + -- associated to the `gradientUnits` attribute. + _linearGradientUnits :: CoordinateUnits, + -- | Point defining the beginning of the line gradient. + -- Associated to the `x1` and `y1` attribute. + _linearGradientStart :: Point, + -- | Point defining the end of the line gradient. + -- Associated to the `x2` and `y2` attribute. + _linearGradientStop :: Point, + -- | Define how to handle the values outside + -- the gradient start and stop. Associated to the + -- `spreadMethod` attribute. + _linearGradientSpread :: Spread, + -- | Define the transformation to apply to the + -- gradient points. Associated to the `gradientTransform` + -- attribute. + _linearGradientTransform :: [Transformation], + -- | List of color stops of the linear gradient. + _linearGradientStops :: [GradientStop] + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg LinearGradient where + defaultSvg = + LinearGradient + { _linearGradientDrawAttributes = mempty, + _linearGradientUnits = CoordBoundingBox, + _linearGradientStart = (Percent 0, Percent 0), + _linearGradientStop = (Percent 1, Percent 0), + _linearGradientSpread = SpreadPad, + _linearGradientTransform = [], + _linearGradientStops = [] + } + +-- | Define a `` tag. +data RadialGradient = RadialGradient + { _radialGradientDrawAttributes :: DrawAttributes, + -- | Define coordinate system of the gradient, + -- associated to the `gradientUnits` attribute. + _radialGradientUnits :: CoordinateUnits, + -- | Center of the radial gradient. Associated to + -- the `cx` and `cy` attributes. + _radialGradientCenter :: Point, + -- | Radius of the radial gradient. Associated to + -- the `r` attribute. + _radialGradientRadius :: Number, + -- | X coordinate of the focus point of the radial + -- gradient. Associated to the `fx` attribute. + _radialGradientFocusX :: Maybe Number, + -- | Y coordinate of the focus point of the radial + -- gradient. Associated to the `fy` attribute. + _radialGradientFocusY :: Maybe Number, + -- | Define how to handle the values outside + -- the gradient start and stop. Associated to the + -- `spreadMethod` attribute. + _radialGradientSpread :: Spread, + -- | Define the transformation to apply to the + -- gradient points. Associated to the `gradientTransform` + -- attribute. + _radialGradientTransform :: [Transformation], + -- | List of color stops of the radial gradient. + _radialGradientStops :: [GradientStop] + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg RadialGradient where + defaultSvg = + RadialGradient + { _radialGradientDrawAttributes = mempty, + _radialGradientUnits = CoordBoundingBox, + _radialGradientCenter = (Percent 0.5, Percent 0.5), + _radialGradientRadius = Percent 0.5, + _radialGradientFocusX = Nothing, + _radialGradientFocusY = Nothing, + _radialGradientSpread = SpreadPad, + _radialGradientTransform = [], + _radialGradientStops = [] + } + +-- | Define a SVG `` tag. +data Mask = Mask + { _maskDrawAttributes :: DrawAttributes, + -- | Correspond to the `maskContentUnits` attributes. + _maskContentUnits :: CoordinateUnits, + -- | Mapping to the `maskUnits` attribute. + _maskUnits :: CoordinateUnits, + -- | Map to the `x` and `y` attributes. + _maskPosition :: Point, + -- | Map to the `width` attribute + _maskWidth :: Number, + -- | Map to the `height` attribute. + _maskHeight :: Number, + -- | Children of the `` tag. + _maskContent :: [Tree] + } + deriving (Eq, Show, Generic) + +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 = [] + } + +-- | Define a `` tag. +data ClipPath = ClipPath + { _clipPathDrawAttributes :: DrawAttributes, + -- | Maps to the `clipPathUnits` attribute + _clipPathUnits :: CoordinateUnits, + -- | Maps to the content of the tree + _clipPathContent :: [Tree] + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg ClipPath where + defaultSvg = + ClipPath + { _clipPathDrawAttributes = mempty, + _clipPathUnits = CoordUserSpace, + _clipPathContent = mempty + } + +-- | Define a `` tag. +data Pattern = Pattern + { _patternDrawAttributes :: DrawAttributes, + -- | Possible `viewBox`. + _patternViewBox :: !(Maybe (Double, Double, Double, Double)), + -- | Width of the pattern tile, mapped to the + -- `width` attribute + _patternWidth :: !Number, + -- | Height of the pattern tile, mapped to the + -- `height` attribute + _patternHeight :: !Number, + -- | Pattern tile base, mapped to the `x` and + -- `y` attributes. + _patternPos :: !Point, + -- | Patterns can be chained, so this is a potential + -- reference to another pattern + _patternHref :: !String, + -- | Elements used in the pattern. + _patternElements :: ![Tree], + -- | Define the cordinate system to use for + -- the pattern. Mapped to the `patternUnits` + -- attribute. + _patternUnit :: !CoordinateUnits, + -- | Value of the "preserveAspectRatio" attribute + _patternAspectRatio :: !PreserveAspectRatio, + -- | Value of "patternTransform" attribute + _patternTransform :: !(Maybe [Transformation]) + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg Pattern where + defaultSvg = + Pattern + { _patternDrawAttributes = mempty, + _patternViewBox = Nothing, + _patternWidth = Num 0, + _patternHeight = Num 0, + _patternPos = (Num 0, Num 0), + _patternElements = [], + _patternUnit = CoordBoundingBox, + _patternAspectRatio = defaultSvg, + _patternHref = "", + _patternTransform = mempty + } + +-- | Sum types helping keeping track of all the namable +-- elemens in a SVG document. +data Element + = ElementLinearGradient LinearGradient + | ElementRadialGradient RadialGradient + | ElementMeshGradient MeshGradient + | ElementGeometry Tree + | ElementPattern Pattern + | ElementMarker Marker + | ElementMask Mask + | ElementClipPath ClipPath + deriving (Eq, Show, Generic) + +-- | Represent a full svg document with style, +-- geometry and named elements. +data Document = Document + { _documentViewBox :: Maybe (Double, Double, Double, Double), + _documentWidth :: Maybe Number, + _documentHeight :: Maybe Number, + _documentElements :: [Tree], + _documentDescription :: String, + _documentLocation :: FilePath, + _documentAspectRatio :: PreserveAspectRatio + } + deriving (Show, Eq, Generic) + +-- | Calculate the document size in function of the +-- different available attributes in the document. +documentSize :: Dpi -> Document -> (Int, Int) +documentSize + _ + Document + { _documentViewBox = Just (x1, y1, x2, y2), + _documentWidth = Just (Percent pw), + _documentHeight = Just (Percent ph) + } = + (floor $ dx * pw, floor $ dy * ph) + where + dx = abs $ x2 - x1 + dy = abs $ y2 - y1 +documentSize + _ + Document + { _documentWidth = Just (Num w), + _documentHeight = Just (Num h) + } = (floor w, floor h) +documentSize + dpi + doc@( Document + { _documentWidth = Just w, + _documentHeight = Just h + } + ) = + documentSize dpi $ + doc + { _documentWidth = Just $ toUserUnit dpi w, + _documentHeight = Just $ toUserUnit dpi h + } +documentSize _ Document {_documentViewBox = Just (x1, y1, x2, y2)} = + (floor . abs $ x2 - x1, floor . 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 Semigroup DrawAttributes where + (<>) 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, + _filterRef = (mappend `on` _filterRef) 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 Monoid DrawAttributes where + mappend = (<>) + 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, + _filterRef = Last Nothing + } + +instance WithDefaultSvg DrawAttributes where + defaultSvg = mempty + +-------------------------------------------------------------------------- +--- Template Haskell and HasDrawAttributes instances +-------------------------------------------------------------------------- + +makeLenses ''Rectangle +makeLenses ''Pattern +makeLenses ''Document +makeLenses ''Filter +makeLenses ''Line +makeLenses ''Polygon +makeLenses ''PolyLine +makeLenses ''PreserveAspectRatio +makeLenses ''Path +makeLenses ''Circle +makeLenses ''Text +makeLenses ''TextPath +makeLenses ''Ellipse +makeLenses ''MeshGradientPatch +makeLenses ''MeshGradientRow +makeLenses ''MeshGradient +makeLenses ''Image +makeLenses ''Use +makeLenses ''TextSpan +makeLenses ''TextInfo +makeLenses ''Marker +makeLenses ''GradientStop +makeLenses ''LinearGradient +makeLenses ''RadialGradient +makeLenses ''Mask +makeLenses ''ClipPath +makeLenses ''ColorMatrix +makeLenses ''Composite +makeLenses ''GaussianBlur +makeLenses ''Turbulence +makeLenses ''DisplacementMap +makeLenses ''Group + +makeClassy ''FilterAttributes diff --git a/src/Graphics/SvgTree/XmlParser.hs b/src/Graphics/SvgTree/XmlParser.hs --- a/src/Graphics/SvgTree/XmlParser.hs +++ b/src/Graphics/SvgTree/XmlParser.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -15,18 +14,8 @@ ) where -#if !MIN_VERSION_base(4,6,0) -import Text.Read (reads) -#else import Text.Read (readMaybe) -#endif -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (pure, (<$), (<$>), (<*>)) -import Data.Foldable (foldMap) -import Data.Monoid (mempty) -#endif - import Control.Applicative (many, (<|>)) import Codec.Picture (PixelRGBA8 (..)) @@ -36,16 +25,16 @@ import Data.Attoparsec.Text (Parser, parseOnly, string) import Data.List (foldl', intercalate) import Data.Maybe (catMaybes, fromMaybe) -import Data.Monoid (Last (Last), getLast, (<>)) +import Data.Monoid import qualified Data.Text as T import Graphics.SvgTree.ColorParser import Graphics.SvgTree.CssParser (complexNumber, dashArray, num, numberList, styleString) import Graphics.SvgTree.CssTypes (CssDeclaration (..), CssElement (..)) +import Graphics.SvgTree.Misc import Graphics.SvgTree.PathParser import Graphics.SvgTree.Types -import Graphics.SvgTree.Misc import qualified Text.XML.Light as X import Text.XML.Light.Proc (elChildren, findAttrBy) @@ -53,16 +42,12 @@ {-import Debug.Trace-} -#if !MIN_VERSION_base(4,6,0) -readMaybe :: Read a => String -> Maybe a -readMaybe str = case reads str of - [] -> Nothing - (x, _):_ -> Just x -#endif - nodeName :: X.Element -> String nodeName = X.qName . X.elName +setName :: String -> X.Element -> X.Element +setName name elt = elt{ X.elName = X.unqual name } + attributeFinder :: String -> X.Element -> Maybe String attributeFinder str = findAttrBy (\a -> X.qName a == str) @@ -546,7 +531,7 @@ serializer a = printf "%s" . ppF <$> a ^. elLens updater el str = case parseMayStartDot num str of Nothing -> el - Just v -> el & elLens .~ Just (realToFrac v) + Just v -> el & elLens ?~ realToFrac v type Serializer e = e -> Maybe String @@ -592,7 +577,7 @@ classSetter = SvgAttributeLens "class" updater serializer where updater el str = - el & attrClass .~ (T.split (== ' ') $ T.pack str) + el & attrClass .~ T.split (== ' ') (T.pack str) serializer a = case a ^. attrClass of [] -> Nothing @@ -609,7 +594,7 @@ => ASetter el el a (Maybe n) -> CssUpdater el cssUniqueFloat setter attr ((CssNumber (Num n):_):_) = - attr & setter .~ Just (realToFrac n) + attr & setter ?~ realToFrac n cssUniqueFloat _ attr _ = attr cssUniqueMayFloat :: ASetter el el a (Last Double) @@ -660,9 +645,9 @@ cssMayStringSetter :: ASetter el el a (Maybe String) -> CssUpdater el cssMayStringSetter setter attr ((CssIdent i:_):_) = - attr & setter .~ Just (T.unpack i) + attr & setter ?~ T.unpack i cssMayStringSetter setter attr ((CssString i:_):_) = - attr & setter .~ Just (T.unpack i) + attr & setter ?~ T.unpack i cssMayStringSetter _ attr _ = attr cssNullSetter :: CssUpdater a @@ -874,66 +859,49 @@ instance XMLUpdatable Tree where xmlTagName _ = "TREE" attributes = [] - serializeTreeNode e = case e of - None -> Nothing - UseTree u _ -> serializeTreeNode u - GroupTree g -> serializeTreeNode g - SymbolTree s -> serializeTreeNode s - DefinitionTree d -> serializeTreeNode d - FilterTree g -> serializeTreeNode g - PathTree p -> serializeTreeNode p - CircleTree c -> serializeTreeNode c - PolyLineTree p -> serializeTreeNode p - PolygonTree p -> serializeTreeNode p - EllipseTree el -> serializeTreeNode el - LineTree l -> serializeTreeNode l - RectangleTree r -> serializeTreeNode r - TextTree Nothing t -> serializeTreeNode t - ImageTree i -> serializeTreeNode i - LinearGradientTree l -> serializeTreeNode l - RadialGradientTree r -> serializeTreeNode r - MeshGradientTree m -> serializeTreeNode m - PatternTree p -> serializeTreeNode p - MarkerTree m -> serializeTreeNode m - MaskTree m -> serializeTreeNode m - ClipPathTree c -> serializeTreeNode c - TextTree (Just p) t -> do + serializeTreeNode e = case e ^. treeBranch of + NoNode -> Nothing + UseNode u _ -> serializeTreeNode u + GroupNode g -> serializeTreeNode g + SymbolNode s -> setName "symbol" <$> serializeTreeNode s + DefinitionNode d -> setName "defs" <$> serializeTreeNode d + FilterNode g -> serializeTreeNode g + PathNode p -> serializeTreeNode p + CircleNode c -> serializeTreeNode c + PolyLineNode p -> serializeTreeNode p + PolygonNode p -> serializeTreeNode p + EllipseNode el -> serializeTreeNode el + LineNode l -> serializeTreeNode l + RectangleNode r -> serializeTreeNode r + TextNode Nothing t -> serializeTreeNode t + ImageNode i -> serializeTreeNode i + LinearGradientNode l -> serializeTreeNode l + RadialGradientNode r -> serializeTreeNode r + MeshGradientNode m -> serializeTreeNode m + PatternNode p -> serializeTreeNode p + MarkerNode m -> serializeTreeNode m + MaskNode m -> serializeTreeNode m + ClipPathNode c -> serializeTreeNode c + TextNode (Just p) t -> do textNode <- serializeTreeNode t pathNode <- serializeTreeNode p let sub = [X.Elem . setChildren pathNode $ X.elContent textNode] return $ setChildren textNode sub - SvgTree doc -> Just $ xmlOfDocument doc + SvgNode doc -> Just $ xmlOfDocument doc isNotNone :: Tree -> Bool isNotNone None = False -isNotNone _ = True +isNotNone _ = True -instance XMLUpdatable (Group Tree) where +instance XMLUpdatable Group where xmlTagName _ = "g" serializeTreeNode node = updateWithAccessor (filter isNotNone . _groupChildren) node $ genericSerializeWithDrawAttr node - attributes = [] - -instance XMLUpdatable (Symbol Tree) where - xmlTagName _ = "symbol" - serializeTreeNode node = - updateWithAccessor (filter isNotNone . _groupChildren . _groupOfSymbol) node $ - genericSerializeWithDrawAttr node attributes = - ["viewBox" `parseIn` (groupOfSymbol . groupViewBox) - ,"preserveAspectRatio" `parseIn` (groupOfSymbol . groupAspectRatio) - ] - -instance XMLUpdatable (Definitions Tree) where - xmlTagName _ = "defs" - serializeTreeNode node = - updateWithAccessor (filter isNotNone . _groupChildren . _groupOfDefinitions) node $ - genericSerializeWithDrawAttr node - attributes = - ["viewBox" `parseIn` (groupOfDefinitions . groupViewBox) - ,"preserveAspectRatio" `parseIn` (groupOfDefinitions . groupAspectRatio) + ["viewBox" `parseIn` groupViewBox + ,"preserveAspectRatio" `parseIn` groupAspectRatio ] instance XMLUpdatable Filter where @@ -949,7 +917,7 @@ instance XMLUpdatable FilterElement where xmlTagName _ = "FilterElement" - serializeTreeNode fe = flip mergeAttributes <$> (genericSerializeNode fe) <*> + serializeTreeNode fe = flip mergeAttributes <$> genericSerializeNode fe <*> case fe of FEColorMatrix m -> serializeTreeNode m FEComposite c -> serializeTreeNode c @@ -1211,7 +1179,7 @@ attributes = styleAttribute cssAvailable : fmap fst cssAvailable ++ lst where cssAvailable :: [(SvgAttributeLens GradientStop, CssUpdater GradientStop)] cssAvailable = - [(opacitySetter "stop-opacity" gradientOpacity, (cssUniqueFloat gradientOpacity)) + [(opacitySetter "stop-opacity" gradientOpacity, cssUniqueFloat gradientOpacity) ,("stop-color" `parseIn` gradientColor, cssUniqueColor gradientColor) ] @@ -1251,23 +1219,15 @@ ClipPathTree $ xmlUnparseWithDrawAttr e & clipPathContent .~ map unparse (elChildren e) unparse (nodeName -> "style") = None -- XXX: Create a style node? unparse e@(nodeName -> "defs") = - DefinitionTree . Definitions $ groupNode & groupChildren .~ map unparse (elChildren e) - where - groupNode :: Group Tree - groupNode = _groupOfSymbol $ xmlUnparseWithDrawAttr e + DefinitionTree $ xmlUnparseWithDrawAttr e & groupChildren .~ map unparse (elChildren e) unparse e@(nodeName -> "filter") = FilterTree $ xmlUnparseWithDrawAttr e & filterChildren .~ map unparseFE (elChildren e) unparse e@(nodeName -> "symbol") = - SymbolTree . Symbol $ groupNode & groupChildren .~ map unparse (elChildren e) - where - groupNode :: Group Tree - groupNode = _groupOfSymbol $ xmlUnparseWithDrawAttr e + SymbolTree $ xmlUnparseWithDrawAttr e & groupChildren .~ map unparse (elChildren e) unparse e@(nodeName -> "g") = GroupTree $ xmlUnparseWithDrawAttr e & groupChildren .~ map unparse (elChildren e) unparse e@(nodeName -> "svg") = - case unparseDocument "" e of - Nothing -> None - Just doc -> SvgTree doc + maybe None SvgTree $ unparseDocument "" e unparse e@(nodeName -> "text") = TextTree tPath $ xmlUnparse e & textRoot .~ root where @@ -1302,12 +1262,12 @@ unparseDocument :: FilePath -> X.Element -> Maybe Document unparseDocument rootLocation e@(nodeName -> "svg") = Just Document - { _viewBox = + { _documentViewBox = attributeFinder "viewBox" e >>= parse viewBoxParser - , _elements = parsedElements - , _width = lengthFind "width" - , _height = lengthFind "height" - , _description = "" + , _documentElements = parsedElements + , _documentWidth = lengthFind "width" + , _documentHeight = lengthFind "height" + , _documentDescription = "" , _documentLocation = rootLocation , _documentAspectRatio = fromMaybe defaultSvg $ @@ -1325,13 +1285,13 @@ X.node (X.unqual "svg") (attrs, descTag ++ children) where attr name = X.Attr (X.unqual name) - children = catMaybes [serializeTreeNode el | el <- _elements doc] + children = catMaybes [serializeTreeNode el | el <- _documentElements doc] - docViewBox = case _viewBox doc of + docViewBox = case _documentViewBox doc of Nothing -> [] Just b -> [attr "viewBox" $ serializeViewBox b] - descTag = case _description doc of + descTag = case _documentDescription doc of "" -> [] txt -> [X.node (X.unqual "desc") txt] @@ -1340,8 +1300,8 @@ [attr "xmlns" "http://www.w3.org/2000/svg" ,attr "xmlns:xlink" "http://www.w3.org/1999/xlink" ,attr "version" "1.1"] ++ - catMaybes [attr "width" . serializeNumber <$> _width doc - ,attr "height" . serializeNumber <$> _height doc + catMaybes [attr "width" . serializeNumber <$> _documentWidth doc + ,attr "height" . serializeNumber <$> _documentHeight doc ] ++ catMaybes [attr "preserveAspectRatio" <$> aserialize (_documentAspectRatio doc) | _documentAspectRatio doc /= defaultSvg ] diff --git a/test/PathParserSpec.hs b/test/PathParserSpec.hs deleted file mode 100644 --- a/test/PathParserSpec.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module PathParserSpec where - -import Data.Attoparsec.Text -import Graphics.Svg.PathParser -import Graphics.Svg.Types -import Linear -import Test.Hspec - - -spec :: Spec -spec = do - describe "num" $ do - it "support shorthand number" $ do - parseOnly command d `shouldBe` Right p - where - d = "M-.10 .10z" - p = MoveTo OriginAbsolute [V2 (-0.1) 0.10] diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-}