{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, TypeFamilies, FlexibleContexts #-}

--------------------------------------------------------------------
-- |
-- Module    : Diagrams.SVG.Attributes
-- Copyright : (c) 2015 Tillmann Vogt <tillk.vogt@googlemail.com>
-- License   : BSD3
--
-- Maintainer: diagrams-discuss@googlegroups.com
-- Stability : stable
-- Portability: portable

module Diagrams.SVG.Attributes 
    (
      initialStyles
    -- * Classes of attributes
    , CoreAttributes(..)
    , ConditionalProcessingAttributes(..)
    , DocumentEventAttributes(..)
    , GraphicalEventAttributes(..)
    , XlinkAttributes(..)
    , FilterPrimitiveAttributes(..)
    , NameSpaces(..)
    -- * General Parsing Functions
    , separatedBy
    , parseOne
    , parseOne'
    , compose
    , parseDouble
    , parseToDouble
    , parsePoints
    , parseTempl
    , parseIRI
    -- * Transformations
    , applyTr
    , parseTr
    -- * Parsing the style attribute
    , applyStyleSVG
    , parseStyles
    , parseLengths
    , parseViewBox
    , parsePA
    , cssStylesFromMap
    , fragment
    , p
    , parseSpread
    -- * Parsing Colors
    -- * Parsing preserve aspect ratio
    , parsePreserveAR
    , PreserveAR(..)
    , AlignSVG(..)
    , Place(..)
    , MeetOrSlice(..)
    , SVGStyle(..)
    , PresentationAttributes(..)
    )
where

import           Data.Attoparsec.Combinator
import           Data.Attoparsec.Text
import qualified Data.Attoparsec.Text as AT
import           Data.Char (isAlpha, isHexDigit, digitToInt)
import           Data.Colour
import           Data.Colour.Names (readColourName)
import           Data.Colour.SRGB
import           Data.Colour.RGBSpace.HSL (hsl)
import qualified Data.HashMap.Strict as H
import           Data.Maybe (fromMaybe, fromJust, isJust, isNothing, maybeToList, catMaybes)
import qualified Data.Text as T
import           Data.Text(Text(..), pack, unpack, empty, cons, snoc, append)
import           Data.Typeable
import           Data.Word (Word8)
import           Diagrams.Prelude hiding (fillOpacity, strokeOpacity)
import           Diagrams.SVG.Path
import           Diagrams.SVG.Tree
import           Text.CSS.Parse
import           Diagrams.Core.Transform
import           Data.Digits

---------------------------------------------------

data CoreAttributes =
   CA { CoreAttributes -> Maybe Text
id1      :: Maybe Text
      , CoreAttributes -> Maybe Text
xmlbase  :: Maybe Text
      , CoreAttributes -> Maybe Text
xmllang  :: Maybe Text
      , CoreAttributes -> Maybe Text
xmlspace :: Maybe Text
      }

data ConditionalProcessingAttributes =
  CPA { ConditionalProcessingAttributes -> Maybe Text
requiredFeatures   :: Maybe Text
      , ConditionalProcessingAttributes -> Maybe Text
requiredExtensions :: Maybe Text
      , ConditionalProcessingAttributes -> Maybe Text
systemLanguage     :: Maybe Text
      }

data DocumentEventAttributes =
   DEA { DocumentEventAttributes -> Maybe Text
onunload :: Maybe Text
       , DocumentEventAttributes -> Maybe Text
onabort  :: Maybe Text
       , DocumentEventAttributes -> Maybe Text
onerror  :: Maybe Text
       , DocumentEventAttributes -> Maybe Text
onresize :: Maybe Text
       , DocumentEventAttributes -> Maybe Text
onscroll :: Maybe Text
       , DocumentEventAttributes -> Maybe Text
onzoom   :: Maybe Text
       }

data GraphicalEventAttributes =
   GEA { GraphicalEventAttributes -> Maybe Text
onfocusin   :: Maybe Text
       , GraphicalEventAttributes -> Maybe Text
onfocusout  :: Maybe Text
       , GraphicalEventAttributes -> Maybe Text
onactivate  :: Maybe Text
       , GraphicalEventAttributes -> Maybe Text
onclick     :: Maybe Text
       , GraphicalEventAttributes -> Maybe Text
onmousedown :: Maybe Text
       , GraphicalEventAttributes -> Maybe Text
onmouseup   :: Maybe Text
       , GraphicalEventAttributes -> Maybe Text
onmouseover :: Maybe Text
       , GraphicalEventAttributes -> Maybe Text
onmousemove :: Maybe Text
       , GraphicalEventAttributes -> Maybe Text
onmouseout  :: Maybe Text
       , GraphicalEventAttributes -> Maybe Text
onload      :: Maybe Text
       }

data XlinkAttributes =
   XLA { XlinkAttributes -> Maybe Text
xlinkHref    :: Maybe Text
       , XlinkAttributes -> Maybe Text
xlinkShow    :: Maybe Text
       , XlinkAttributes -> Maybe Text
xlinkActuate :: Maybe Text
       , XlinkAttributes -> Maybe Text
xlinkType    :: Maybe Text
       , XlinkAttributes -> Maybe Text
xlinkRole    :: Maybe Text
       , XlinkAttributes -> Maybe Text
xlinkArcrole :: Maybe Text
       , XlinkAttributes -> Maybe Text
xlinkTitle   :: Maybe Text
       }

data FilterPrimitiveAttributes = 
   FPA { FilterPrimitiveAttributes -> Maybe Text
x      :: Maybe Text
       , FilterPrimitiveAttributes -> Maybe Text
y      :: Maybe Text
       , FilterPrimitiveAttributes -> Maybe Text
width  :: Maybe Text
       , FilterPrimitiveAttributes -> Maybe Text
height :: Maybe Text
       , FilterPrimitiveAttributes -> Maybe Text
result :: Maybe Text
       }

data NameSpaces =
   NSP { NameSpaces -> Maybe Text
xlink    :: Maybe Text
       , NameSpaces -> Maybe Text
dc       :: Maybe Text
       , NameSpaces -> Maybe Text
cc       :: Maybe Text
       , NameSpaces -> Maybe Text
rdf      :: Maybe Text
       , NameSpaces -> Maybe Text
svg      :: Maybe Text
       , NameSpaces -> Maybe Text
sodipodi :: Maybe Text
       , NameSpaces -> Maybe Text
inkscape :: Maybe Text
       } deriving Int -> NameSpaces -> ShowS
[NameSpaces] -> ShowS
NameSpaces -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NameSpaces] -> ShowS
$cshowList :: [NameSpaces] -> ShowS
show :: NameSpaces -> String
$cshow :: NameSpaces -> String
showsPrec :: Int -> NameSpaces -> ShowS
$cshowsPrec :: Int -> NameSpaces -> ShowS
Show

--------------------------------------------------------------------------------
-- General parsing functions
--------------------------------------------------------------------------------

-- | Parsing content separated by something, e.g. ";"  like in: "a;b;c;d;" or "a;b;c;d"
separatedBy :: Parser Text a -> Text -> Parser Text [a]
separatedBy Parser Text a
parse Text
sep = do [a]
ls <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 (forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice [forall {b}. Parser Text b -> Text -> Parser Text b
parseOne Parser Text a
parse Text
sep, forall {b}. Parser Text b -> Parser Text b
parseOne' Parser Text a
parse])
                           forall (m :: * -> *) a. Monad m => a -> m a
return [a]
ls

parseOne :: Parser Text b -> Text -> Parser Text b
parseOne Parser Text b
parse Text
sep = do Parser ()
AT.skipSpace
                        b
s <- Parser Text b
parse
                        Text -> Parser Text
AT.string Text
sep
                        forall (m :: * -> *) a. Monad m => a -> m a
return b
s

parseOne' :: Parser Text b -> Parser Text b
parseOne' Parser Text b
parse = do Parser ()
AT.skipSpace
                     b
s <- Parser Text b
parse
                     forall (m :: * -> *) a. Monad m => a -> m a
return b
s

-- | See <http://www.haskell.org/haskellwiki/Compose>
compose :: [a -> a] -> a -> a
compose :: forall a. [a -> a] -> a -> a
compose [a -> a]
fs a
v = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Prelude.foldl (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)) forall a. a -> a
id [a -> a]
fs forall a b. (a -> b) -> a -> b
$ a
v

parseDouble :: RealFloat n => Text -> n
parseDouble :: forall n. RealFloat n => Text -> n
parseDouble Text
l = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const n
0) (forall a. Fractional a => Rational -> a
fromRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => a -> Rational
toRational) (forall a. Parser a -> Text -> Either String a
AT.parseOnly Parser Text Double
myDouble Text
l)

parseToDouble :: RealFloat n => Maybe Text -> Maybe n
parseToDouble :: forall n. RealFloat n => Maybe Text -> Maybe n
parseToDouble Maybe Text
l | forall a. Maybe a -> Bool
isJust Maybe Text
l = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Fractional a => Rational -> a
fromRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => a -> Rational
toRational) (forall a. Parser a -> Text -> Either String a
AT.parseOnly Parser Text Double
myDouble (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
l))
                | Bool
otherwise = forall a. Maybe a
Nothing
pp :: String -> c
pp = forall n. RealFloat n => Text -> n
parseDouble forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack

myDouble :: Parser Text Double
myDouble = forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [forall {b}. Fractional b => Parser Text b
dotDouble, Parser Text Double
double]

dotDouble :: Parser Text b
dotDouble =
   do Parser ()
AT.skipSpace
      Char -> Parser Char
AT.char Char
'.'
      Integer
frac <- forall a. Integral a => Parser a
AT.decimal
      let denominator :: b
denominator = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
10forall a b. (Num a, Integral b) => a -> b -> a
^(forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall n. Integral n => n -> n -> [n]
digits Integer
10 Integer
frac))
      forall (m :: * -> *) a. Monad m => a -> m a
return ((forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
frac) forall a. Fractional a => a -> a -> a
/ b
denominator)

parsePoints :: RealFloat n => Text -> [(n, n)]
parsePoints :: forall n. RealFloat n => Text -> [(n, n)]
parsePoints Text
t = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const []) forall a. a -> a
id (forall a. Parser a -> Text -> Either String a
AT.parseOnly (forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' forall n. RealFloat n => Parser (n, n)
parsePoint) Text
t)

parsePoint :: RealFloat n => Parser (n, n)
parsePoint :: forall n. RealFloat n => Parser (n, n)
parsePoint =
   do Parser ()
AT.skipSpace
      Double
a <- Parser Text Double
double
      Char -> Parser Char
AT.char Char
','
      Double
b <- Parser Text Double
double
      forall (m :: * -> *) a. Monad m => a -> m a
return ( (forall a. Fractional a => Rational -> a
fromRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => a -> Rational
toRational) Double
a, (forall a. Fractional a => Rational -> a
fromRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => a -> Rational
toRational) Double
b)

parseUntil :: Char -> Parser Text String
parseUntil Char
c = forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
AT.manyTill Parser Char
AT.anyChar (Char -> Parser Char
AT.char Char
c)

data Tup n = TS1 Text | TS2 Text Text | TS3 Text Text Text 
         | T1  n | T2  n n | T3 n n n 
         deriving Int -> Tup n -> ShowS
forall n. Show n => Int -> Tup n -> ShowS
forall n. Show n => [Tup n] -> ShowS
forall n. Show n => Tup n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tup n] -> ShowS
$cshowList :: forall n. Show n => [Tup n] -> ShowS
show :: Tup n -> String
$cshow :: forall n. Show n => Tup n -> String
showsPrec :: Int -> Tup n -> ShowS
$cshowsPrec :: forall n. Show n => Int -> Tup n -> ShowS
Show

parse1 :: Parser Text (Tup n)
parse1 =
  do Parser ()
AT.skipSpace
     Char -> Parser Char
AT.char Char
'('
     Text
a <- (Char -> Bool) -> Parser Text
AT.takeTill (forall a. Eq a => a -> a -> Bool
== Char
')')
     Char -> Parser Char
AT.char Char
')'
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n. Text -> Tup n
TS1 Text
a)

parse2 :: Parser Text (Tup n)
parse2 =
  do Parser ()
AT.skipSpace
     Char -> Parser Char
AT.char Char
'('
     Text
a <- (Char -> Bool) -> Parser Text
AT.takeTill (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
',' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
' ')
     forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Char -> Parser Char
AT.char Char
',', Char -> Parser Char
AT.char Char
' ']
     Parser ()
AT.skipSpace
     Text
b <- (Char -> Bool) -> Parser Text
AT.takeTill (forall a. Eq a => a -> a -> Bool
== Char
')')
     Char -> Parser Char
AT.char Char
')'
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n. Text -> Text -> Tup n
TS2 Text
a Text
b)

parse3 :: Parser Text (Tup n)
parse3 =
  do Parser ()
AT.skipSpace
     Char -> Parser Char
AT.char Char
'('
     Text
a <- (Char -> Bool) -> Parser Text
AT.takeTill (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
',' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
' ')
     forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Char -> Parser Char
AT.char Char
',', Char -> Parser Char
AT.char Char
' ']
     Text
b <- (Char -> Bool) -> Parser Text
AT.takeTill (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
',' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
' ')
     forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Char -> Parser Char
AT.char Char
',', Char -> Parser Char
AT.char Char
' ']
     Text
c <- (Char -> Bool) -> Parser Text
AT.takeTill (forall a. Eq a => a -> a -> Bool
== Char
')')
     Char -> Parser Char
AT.char Char
')'
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n. Text -> Text -> Text -> Tup n
TS3 Text
a Text
b Text
c)

-----------------------------------------------------------------------------------------------------------------
-- Transformations, see <http://www.w3.org/TR/SVG11/coords.html#TransformAttribute>
--    
-- Example: transform="translate(-121.1511,-167.6958) matrix(4.675013,0,0,4.675013,-1353.75,-678.4329)"
-----------------------------------------------------------------------------------------------------------------

data Transform n = Tr (Tup n)
               | Matrix n n n n n n
               | Rotate (Tup n)
               | Scale (Tup n)
               | SkewX (Tup n)
               | SkewY (Tup n) deriving Int -> Transform n -> ShowS
forall n. Show n => Int -> Transform n -> ShowS
forall n. Show n => [Transform n] -> ShowS
forall n. Show n => Transform n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Transform n] -> ShowS
$cshowList :: forall n. Show n => [Transform n] -> ShowS
show :: Transform n -> String
$cshow :: forall n. Show n => Transform n -> String
showsPrec :: Int -> Transform n -> ShowS
$cshowsPrec :: forall n. Show n => Int -> Transform n -> ShowS
Show

parseTr :: RealFloat n => Maybe Text -> [Transform n]
parseTr :: forall n. RealFloat n => Maybe Text -> [Transform n]
parseTr =  forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
.
           forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
.
           (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const []) forall a. a -> a
id) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
           ( forall a. Parser a -> Text -> Either String a
AT.parseOnly (forall (f :: * -> *) a. Alternative f => f a -> f [a]
AT.many1 forall {n}. RealFloat n => Parser Text (Maybe (Transform n))
parseTransform)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
           (forall a. a -> Maybe a -> a
fromMaybe Text
empty)

parseTransform :: Parser Text (Maybe (Transform n))
parseTransform = forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [forall {n}. RealFloat n => Parser Text (Maybe (Transform n))
matr, forall {n}. RealFloat n => Parser Text (Maybe (Transform n))
trans, forall {n}. RealFloat n => Parser Text (Maybe (Transform n))
scle, forall {n}. RealFloat n => Parser Text (Maybe (Transform n))
rot, forall {n}. RealFloat n => Parser Text (Maybe (Transform n))
skewX, forall {n}. RealFloat n => Parser Text (Maybe (Transform n))
skewY]

applyTr :: [Transform (N a)] -> a -> a
applyTr [Transform (N a)]
trs = forall a. [a -> a] -> a -> a
compose (forall a b. (a -> b) -> [a] -> [b]
map forall {t}.
(V t ~ V2, Transformable t, RealFloat (N t), Additive (V t),
 R2 (V t)) =>
Transform (N t) -> t -> t
getTransformations [Transform (N a)]
trs)

getTransformations :: Transform (N t) -> t -> t
getTransformations (Tr (T1 N t
x))   =  forall (v :: * -> *) n t.
(InSpace v n t, R1 v, Transformable t) =>
n -> t -> t
translateX N t
x
getTransformations (Tr (T2 N t
x N t
y)) = (forall (v :: * -> *) n t.
(InSpace v n t, R1 v, Transformable t) =>
n -> t -> t
translateX N t
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Transformable t) =>
n -> t -> t
translateY N t
y)

-- | See <http://www.w3.org/TR/SVG11/coords.html#TransformMatrixDefined>
getTransformations (Matrix N t
a N t
b N t
c N t
d N t
e N t
f)
   = (forall (v :: * -> *) n t.
(InSpace v n t, R1 v, Transformable t) =>
n -> t -> t
translateX N t
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Transformable t) =>
n -> t -> t
translateY N t
y) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
n -> t -> t
rotateBy N t
angle) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Fractional n, Transformable t) =>
n -> t -> t
scaleX N t
scX) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Fractional n, Transformable t) =>
n -> t -> t
scaleY N t
scY)
  where (N t
angle, N t
scX, N t
scY, N t
x, N t
y) = forall {e}. RealFloat e => Transform e -> (e, e, e, e, e)
matrixDecompose (forall n. n -> n -> n -> n -> n -> n -> Transform n
Matrix N t
a N t
b N t
c N t
d N t
e N t
f)


-- matrix(0.70710678,-0.70710678,0.70710678,0.70710678,0,0)

getTransformations (Rotate (T1 N t
angle)) = forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
n -> t -> t
rotateBy N t
angle
getTransformations (Rotate (T3 N t
angle N t
x N t
y)) = forall a. a -> a
id -- rotationAbout (p2 (x,y)) (angle)
getTransformations (Scale (T1 N t
x))   = forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Fractional n, Transformable t) =>
n -> t -> t
scaleX N t
x
getTransformations (Scale (T2 N t
x N t
y)) = (forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Fractional n, Transformable t) =>
n -> t -> t
scaleX N t
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Fractional n, Transformable t) =>
n -> t -> t
scaleY N t
y)
getTransformations (SkewX (T1 N t
x)) = forall a. a -> a
id
getTransformations (SkewY (T1 N t
y)) = forall a. a -> a
id

-- | See <http://math.stackexchange.com/questions/13150/extracting-rotation-scale-values-from-2d-transformation-matrix/13165#13165>
matrixDecompose :: Transform e -> (e, e, e, e, e)
matrixDecompose (Matrix e
m11 e
m12 e
m21 e
m22 e
m31 e
m32) = (e
rotation, e
scX, e
scY, e
transX, e
transY)
  where
    rotation :: e
rotation = (forall a. RealFloat a => a -> a -> a
atan2 e
m12 e
m22) forall a. Fractional a => a -> a -> a
/ (e
2forall a. Num a => a -> a -> a
*forall a. Floating a => a
pi)
    scX :: e
scX | e
m11 forall a. Ord a => a -> a -> Bool
>= e
0  =   forall a. Floating a => a -> a
sqrt (e
m11forall a. Num a => a -> a -> a
*e
m11 forall a. Num a => a -> a -> a
+ e
m21forall a. Num a => a -> a -> a
*e
m21)
        | Bool
otherwise = - forall a. Floating a => a -> a
sqrt (e
m11forall a. Num a => a -> a -> a
*e
m11 forall a. Num a => a -> a -> a
+ e
m21forall a. Num a => a -> a -> a
*e
m21)
    scY :: e
scY | e
m22 forall a. Ord a => a -> a -> Bool
>= e
0  =   forall a. Floating a => a -> a
sqrt (e
m12forall a. Num a => a -> a -> a
*e
m12 forall a. Num a => a -> a -> a
+ e
m22forall a. Num a => a -> a -> a
*e
m22)
        | Bool
otherwise = - forall a. Floating a => a -> a
sqrt (e
m12forall a. Num a => a -> a -> a
*e
m12 forall a. Num a => a -> a -> a
+ e
m22forall a. Num a => a -> a -> a
*e
m22)
    (e
transX, e
transY) = (e
m31, e
m32)

matr :: Parser Text (Maybe (Transform n))
matr =
   do Parser ()
AT.skipSpace
      Text -> Parser Text
AT.string Text
"matrix"
      Parser ()
AT.skipSpace
      Char -> Parser Char
AT.char Char
'('
      String
a <- Char -> Parser Text String
parseUntil Char
','
      String
b <- Char -> Parser Text String
parseUntil Char
','
      String
c <- Char -> Parser Text String
parseUntil Char
','
      String
d <- Char -> Parser Text String
parseUntil Char
','
      String
e <- Char -> Parser Text String
parseUntil Char
','
      String
f <- Char -> Parser Text String
parseUntil Char
')'
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall n. n -> n -> n -> n -> n -> n -> Transform n
Matrix (forall {c}. RealFloat c => String -> c
pp String
a) (forall {c}. RealFloat c => String -> c
pp String
b) (forall {c}. RealFloat c => String -> c
pp String
c) (forall {c}. RealFloat c => String -> c
pp String
d) (forall {c}. RealFloat c => String -> c
pp String
e) (forall {c}. RealFloat c => String -> c
pp String
f) )

evalTup :: Tup n -> Tup n
evalTup (TS1 Text
x)     = forall n. n -> Tup n
T1 (forall n. RealFloat n => Text -> n
parseDouble Text
x)
evalTup (TS2 Text
x Text
y)   = forall n. n -> n -> Tup n
T2 (forall n. RealFloat n => Text -> n
parseDouble Text
x) (forall n. RealFloat n => Text -> n
parseDouble Text
y)
evalTup (TS3 Text
x Text
y Text
z) = forall n. n -> n -> n -> Tup n
T3 (forall n. RealFloat n => Text -> n
parseDouble Text
x) (forall n. RealFloat n => Text -> n
parseDouble Text
y) (forall n. RealFloat n => Text -> n
parseDouble Text
z)

trans :: Parser Text (Maybe (Transform n))
trans =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"translate" 
     Tup Any
tup <- forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [forall {n}. Parser Text (Tup n)
parse2, forall {n}. Parser Text (Tup n)
parse1]
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall n. Tup n -> Transform n
Tr (forall {n} {n}. RealFloat n => Tup n -> Tup n
evalTup Tup Any
tup))

scle :: Parser Text (Maybe (Transform n))
scle =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"scale"
     Tup Any
tup <- forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [forall {n}. Parser Text (Tup n)
parse2, forall {n}. Parser Text (Tup n)
parse1]
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall n. Tup n -> Transform n
Scale (forall {n} {n}. RealFloat n => Tup n -> Tup n
evalTup Tup Any
tup))

rot :: Parser Text (Maybe (Transform n))
rot =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"rotate"
     Tup Any
tup <- forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [forall {n}. Parser Text (Tup n)
parse1, forall {n}. Parser Text (Tup n)
parse3]
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall n. Tup n -> Transform n
Rotate (forall {n} {n}. RealFloat n => Tup n -> Tup n
evalTup Tup Any
tup))

skewX :: Parser Text (Maybe (Transform n))
skewX =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"skewX"
     Tup Any
angle <- forall {n}. Parser Text (Tup n)
parse1
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall n. Tup n -> Transform n
SkewX (forall {n} {n}. RealFloat n => Tup n -> Tup n
evalTup Tup Any
angle))

skewY :: Parser Text (Maybe (Transform n))
skewY =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"skewY"
     Tup Any
angle <- forall {n}. Parser Text (Tup n)
parse1
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall n. Tup n -> Transform n
SkewY (forall {n} {n}. RealFloat n => Tup n -> Tup n
evalTup Tup Any
angle))

------------------------------------------------------------------------------------------------
-- Parse the styles of various presentation attributes.
-- Example: <path fill="#FFFFFF" ...
-- Alternative way to writing everything into style="
------------------------------------------------------------------------------------------------

parsePA :: (RealFloat n, RealFloat a, Read a) => PresentationAttributes -> HashMaps b n -> [(SVGStyle n a)]
parsePA :: forall n a b.
(RealFloat n, RealFloat a, Read a) =>
PresentationAttributes -> HashMaps b n -> [SVGStyle n a]
parsePA PresentationAttributes
pa (NodesMap b n
nodes,CSSMap
css,GradientsMap n
grad) = [SVGStyle n a]
l
  where l :: [SVGStyle n a]
l = forall a. [Maybe a] -> [a]
catMaybes
         [(forall a. Parser a -> Maybe Text -> Maybe a
parseTempl (forall {a} {n}.
(Floating a, RealFrac a, Num n) =>
CSSMap -> HashMap Text (Gr n) -> Parser Text (SVGStyle n a)
styleFillVal CSSMap
css GradientsMap n
grad))   (PresentationAttributes -> Maybe Text
fill PresentationAttributes
pa),
          (forall a. Parser a -> Maybe Text -> Maybe a
parseTempl forall {n} {a}. Parser Text (SVGStyle n a)
styleFillRuleVal)          (PresentationAttributes -> Maybe Text
fillRuleSVG PresentationAttributes
pa),
          (forall a. Parser a -> Maybe Text -> Maybe a
parseTempl forall {n} {a}. Parser Text (SVGStyle n a)
styleFillOpacityVal)       (PresentationAttributes -> Maybe Text
fillOpacity PresentationAttributes
pa),
          (forall a. Parser a -> Maybe Text -> Maybe a
parseTempl forall {n} {a}. Parser Text (SVGStyle n a)
styleOpacityVal)           (PresentationAttributes -> Maybe Text
Diagrams.SVG.Tree.opacity PresentationAttributes
pa),
          (forall a. Parser a -> Maybe Text -> Maybe a
parseTempl forall {n} {a}. Parser Text (SVGStyle n a)
styleStrokeOpacityVal)     (PresentationAttributes -> Maybe Text
strokeOpacity PresentationAttributes
pa),
          (forall a. Parser a -> Maybe Text -> Maybe a
parseTempl (forall {a} {n}.
(Floating a, RealFrac a, Num n) =>
CSSMap -> HashMap Text (Gr n) -> Parser Text (SVGStyle n a)
styleStrokeVal CSSMap
css GradientsMap n
grad)) (PresentationAttributes -> Maybe Text
strokeSVG PresentationAttributes
pa),
          (forall a. Parser a -> Maybe Text -> Maybe a
parseTempl forall {n} {a}. Fractional n => Parser Text (SVGStyle n a)
styleStrokeWidthVal)       (PresentationAttributes -> Maybe Text
strokeWidth PresentationAttributes
pa),
          (forall a. Parser a -> Maybe Text -> Maybe a
parseTempl forall {n} {a}. Parser Text (SVGStyle n a)
styleStrokeLineCapVal)     (PresentationAttributes -> Maybe Text
strokeLinecap PresentationAttributes
pa),
          (forall a. Parser a -> Maybe Text -> Maybe a
parseTempl forall {n} {a}. Parser Text (SVGStyle n a)
styleStrokeLineJoinVal)    (PresentationAttributes -> Maybe Text
strokeLinejoin PresentationAttributes
pa),
          (forall a. Parser a -> Maybe Text -> Maybe a
parseTempl forall {n} {a}. Fractional n => Parser Text (SVGStyle n a)
styleStrokeMiterLimitVal)  (PresentationAttributes -> Maybe Text
strokeMiterlimit PresentationAttributes
pa),
          (forall a. Parser a -> Maybe Text -> Maybe a
parseTempl forall {n} {a}. Parser Text (SVGStyle n a)
styleFontFamily)           (PresentationAttributes -> Maybe Text
fontFamily PresentationAttributes
pa),
          (forall a. Parser a -> Maybe Text -> Maybe a
parseTempl forall {n} {a}. Fractional n => Parser Text (SVGStyle n a)
styleFontSize)             (PresentationAttributes -> Maybe Text
fntSize PresentationAttributes
pa),
          (forall a. Parser a -> Maybe Text -> Maybe a
parseTempl (forall {n} {b} {a}.
RealFloat n =>
HashMap Text (Tag b n) -> Parser Text (SVGStyle n a)
styleClipPathVal NodesMap b n
nodes))  (PresentationAttributes -> Maybe Text
clipPath PresentationAttributes
pa),
          (forall a. Parser a -> Maybe Text -> Maybe a
parseTempl forall {n} {a}. Fractional n => Parser Text (SVGStyle n a)
styleStrokeDashArrayVal)   (PresentationAttributes -> Maybe Text
strokeDasharray PresentationAttributes
pa) ]

--------------------------------------------------------------------------------------------
-- Parse the style attribute, see <http://www.w3.org/TR/SVG/painting.html>
--                            and <http://www.w3.org/TR/SVG/styling.html>
-- Example: style="fill:white;stroke:black;stroke-width:0.503546"
--------------------------------------------------------------------------------------------

data SVGStyle n a = Fill (AlphaColour a) | FillTex (Texture n) | FillOpacity Double | FillRule FR | Opacity Double
                  | Stroke (AlphaColour a) | StrokeTex (Texture n) | StrokeWidth (LenPercent n) | StrokeLineCap LineCap
                  | StrokeLineJoin LineJoin | StrokeMiterLimit n | StrokeDasharray [LenPercent n] | StrokeOpacity Double
                  | FontFamily String | FontStyle FStyle | FontVariant FVariant | FontWeight FWeight | FontStretch FStretch
                  | FontSize (LenPercent n)
                  | ClipPath (Path V2 n)
                  | EmptyStyle


-- "font-style:normal;text-align:start;letter-spacing:0px;word-spacing:0px;writing-mode:lr-tb;text-anchor:start"
-- fontStyle letterSpacing wordSpacing writingMode textAnchor

data Unit = EM | EX | PX | IN | CM | MM | PT | PC deriving Int -> Unit -> ShowS
[Unit] -> ShowS
Unit -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Unit] -> ShowS
$cshowList :: [Unit] -> ShowS
show :: Unit -> String
$cshow :: Unit -> String
showsPrec :: Int -> Unit -> ShowS
$cshowsPrec :: Int -> Unit -> ShowS
Show
data FR = Even_Odd | Nonzero | Inherit  deriving Int -> FR -> ShowS
[FR] -> ShowS
FR -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FR] -> ShowS
$cshowList :: [FR] -> ShowS
show :: FR -> String
$cshow :: FR -> String
showsPrec :: Int -> FR -> ShowS
$cshowsPrec :: Int -> FR -> ShowS
Show
data LenPercent n = Len n | Percent n

instance Show (SVGStyle n a) where
  show :: SVGStyle n a -> String
show (Fill AlphaColour a
c) = String
"Fill"
  show (FillTex Texture n
t) = String
"Filltex"
  show (FillRule FR
r) = String
"FillRule"
  show (FillOpacity Double
d) = String
"FillOpacity"
  show (FontFamily String
f) = String
"FontFamily"
  show (FontStyle FStyle
f) = String
"FontStyle"
  show (FontVariant FVariant
f) = String
"FontVariant"
  show (FontWeight FWeight
f) = String
"FontWeight"
  show (FontStretch FStretch
f) = String
"FontStretch"
  show (FontSize LenPercent n
f) = String
"FontSize"
  show (Diagrams.SVG.Attributes.Opacity Double
d) = String
"Opacity"
  show (StrokeOpacity Double
o) = String
"StrokeOpacity"
  show (Stroke AlphaColour a
s) = String
"Stroke"
  show (StrokeTex Texture n
s) = String
"StrokeTex"
  show (StrokeWidth LenPercent n
w) = String
"StrokeWidth"
  show (StrokeLineCap LineCap
l) = String
"StrokeLineCap"
  show (StrokeLineJoin LineJoin
l) = String
"StrokeLineJoin"
  show (StrokeMiterLimit n
l) = String
"StrokeMiterLimit"
  show (StrokeDasharray [LenPercent n]
l) = String
"StrokeDasharray"
  show (ClipPath Path V2 n
path) = String
"ClipPath"
  show (SVGStyle n a
EmptyStyle) = String
""

instance Show (LenPercent n) where
  show :: LenPercent n -> String
show (Len n
x) = String
"" -- show x
  show (Percent n
x) = String
"" -- show x

-- parseStyles :: (Read a, RealFloat a, RealFloat n) => Maybe Text -> HashMaps b n -> [(SVGStyle n a)]
parseStyles :: Maybe Text
-> (HashMap Text (Tag b n), CSSMap, HashMap Text (Gr n))
-> [SVGStyle n a]
parseStyles Maybe Text
text (HashMap Text (Tag b n), CSSMap, HashMap Text (Gr n))
hmaps = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const []) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
                         forall a. Parser a -> Text -> Either String a
AT.parseOnly (forall {a}. Parser Text a -> Text -> Parser Text [a]
separatedBy (forall {n} {a} {b}.
(RealFloat n, RealFrac a, Floating a) =>
(HashMap Text (Tag b n), CSSMap, HashMap Text (Gr n))
-> Parser Text (SVGStyle n a)
parseStyleAttr (HashMap Text (Tag b n), CSSMap, HashMap Text (Gr n))
hmaps) Text
";") (forall a. a -> Maybe a -> a
fromMaybe Text
empty Maybe Text
text)

-- parseStyleAttr :: (Read a, RealFloat a, RealFloat n) => HashMaps b n -> Parser (SVGStyle n a)
parseStyleAttr :: (HashMap Text (Tag b n), CSSMap, HashMap Text (Gr n))
-> Parser Text (SVGStyle n a)
parseStyleAttr (HashMap Text (Tag b n)
ns,CSSMap
css,HashMap Text (Gr n)
grad) =
  forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [forall {n} {a}. Parser Text (SVGStyle n a)
styleFillRule, forall {n} {a}. Fractional n => Parser Text (SVGStyle n a)
styleStrokeWidth, forall {n} {a}. Fractional n => Parser Text (SVGStyle n a)
styleStrokeDashArray, forall {a} {n}.
(Floating a, RealFrac a, Num n) =>
CSSMap -> HashMap Text (Gr n) -> Parser Text (SVGStyle n a)
styleFill CSSMap
css HashMap Text (Gr n)
grad, forall {a} {n}.
(Floating a, RealFrac a, Num n) =>
CSSMap -> HashMap Text (Gr n) -> Parser Text (SVGStyle n a)
styleStroke CSSMap
css HashMap Text (Gr n)
grad, forall {a} {n}.
(Floating a, RealFrac a) =>
Parser Text (SVGStyle n a)
styleStopColor,
             forall {n} {a}. Parser Text (SVGStyle n a)
styleStopOpacity, forall {n} {a}. Parser Text (SVGStyle n a)
styleFillOpacity, forall {n} {a}. Parser Text (SVGStyle n a)
styleStrokeOpacity, forall {n} {a}. Parser Text (SVGStyle n a)
styleOpacity,
             forall {n} {a}. Parser Text (SVGStyle n a)
styleFontFamily, forall {n} {a}. Parser Text (SVGStyle n a)
styleFontStyle, forall {n} {a}. Parser Text (SVGStyle n a)
styleFontVariant, forall {n} {a}. Parser Text (SVGStyle n a)
styleFontWeight, forall {n} {a}. Parser Text (SVGStyle n a)
styleFontStretch, forall {n} {a}. Fractional n => Parser Text (SVGStyle n a)
styleFontSize,
             forall {n} {a}. Parser Text (SVGStyle n a)
styleStrokeLineCap, forall {n} {a}. Parser Text (SVGStyle n a)
styleStrokeLineJoin, forall {n} {a}. Fractional n => Parser Text (SVGStyle n a)
styleStrokeMiterLimit, forall {n} {b} {a}.
RealFloat n =>
HashMap Text (Tag b n) -> Parser Text (SVGStyle n a)
styleClipPath HashMap Text (Tag b n)
ns, forall {n} {a}. Parser Text (SVGStyle n a)
skipOne]

skipOne :: Parser Text (SVGStyle n a)
skipOne = do String
str <- forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
AT.manyTill Parser Char
AT.anyChar (Char -> Parser Char
AT.char Char
';') -- TODO end of input ?
             forall (m :: * -> *) a. Monad m => a -> m a
return forall n a. SVGStyle n a
EmptyStyle

-- | This function is called on every tag and returns a list of style-attributes to apply 
--   (if there is a rule that matches)
-- TO DO: CSS2 + CSS3 selectors
-- cssStylesFromMap :: (Read a, RealFloat a, RealFloat n) =>
--                    HashMaps b n -> Text -> Maybe Text ->  Maybe Text -> [(SVGStyle n a)]
cssStylesFromMap :: (HashMap Text (Tag b n), CSSMap, HashMap Text (Gr n))
-> Text -> Maybe Text -> Maybe Text -> [SVGStyle n a]
cssStylesFromMap (HashMap Text (Tag b n)
ns,CSSMap
css,HashMap Text (Gr n)
grad) Text
tagName Maybe Text
id_ Maybe Text
class_ = forall {n} {a} {b}.
(RealFloat n, RealFrac a, Floating a) =>
Maybe Text
-> (HashMap Text (Tag b n), CSSMap, HashMap Text (Gr n))
-> [SVGStyle n a]
parseStyles ( forall a. a -> Maybe a
Just ( [Text] -> Text
T.concat ( forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Text
f [(Text, Text)]
attributes ) ) ) (HashMap Text (Tag b n)
ns,CSSMap
css,HashMap Text (Gr n)
grad)
  where f :: (Text, Text) -> Text
f (Text
attr, Text
val) = (Text
attr Text -> Char -> Text
`Data.Text.snoc` Char
':') Text -> Text -> Text
`append` (Text
val Text -> Char -> Text
`Data.Text.snoc` Char
';')
        styleFromClass :: Text -> [Maybe [(Text, Text)]]
styleFromClass Text
cl = [forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup (Char
'.' Char -> Text -> Text
`Data.Text.cons` Text
cl) CSSMap
css] forall a. [a] -> [a] -> [a]
++ [forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup (Text
tagName Text -> Text -> Text
`append` (Char
'.' Char -> Text -> Text
`Data.Text.cons` Text
cl)) CSSMap
css]
        attributes :: [(Text, Text)]
attributes = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes
                   ( [forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
"*" CSSMap
css] forall a. [a] -> [a] -> [a]
++    -- apply this style to every element
                     (if forall a. Maybe a -> Bool
isJust Maybe Text
id_ then [forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup (Char
'#' Char -> Text -> Text
`Data.Text.cons` (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
id_)) CSSMap
css] else []) forall a. [a] -> [a] -> [a]
++
                     (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b. (a -> b) -> [a] -> [b]
map Text -> [Maybe [(Text, Text)]]
styleFromClass (if forall a. Maybe a -> Bool
isJust Maybe Text
class_ then Text -> [Text]
T.words forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
class_ else [])))
                   )

-- | a template that deals with the common parser errors
parseTempl :: Parser a -> Maybe Text -> Maybe a
parseTempl :: forall a. Parser a -> Maybe Text -> Maybe a
parseTempl Parser a
p = (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
               (forall a. Parser a -> Text -> Either String a
AT.parseOnly Parser a
p)forall b c a. (b -> c) -> (a -> b) -> a -> c
.
               (forall a. a -> Maybe a -> a
fromMaybe Text
empty)

-- | Given a minimum and maximum value of a viewbox (x or y-direction) and a maybe a Text value
--   Parse this Text value as a length (with a unit) or a percentage relative to the viewbox (minx,maxx)
--   If parsers fails return def
p :: RealFloat n => (n,n) -> n -> Maybe Text -> n
p :: forall n. RealFloat n => (n, n) -> n -> Maybe Text -> n
p (n
minx,n
maxx) n
def Maybe Text
x = LenPercent n -> n
unL forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (forall n. n -> LenPercent n
Len n
def) forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Maybe Text -> Maybe a
parseTempl forall {n}. Fractional n => Parser Text (LenPercent n)
styleLength Maybe Text
x
  where unL :: LenPercent n -> n
unL (Len n
x) = n
x
        unL (Percent n
x) = n
xforall a. Fractional a => a -> a -> a
/n
100 forall a. Num a => a -> a -> a
* (n
maxxforall a. Num a => a -> a -> a
-n
minx)

parseIRI :: Parser Text (Text, Text)
parseIRI = do forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [ Parser Text (Text, Text)
funcIRI, Parser Text (Text, Text)
absoluteOrRelativeIRI ]

funcIRI :: Parser Text (Text, Text)
funcIRI =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"url("
     String
absrel <- Char -> Parser Text String
parseUntil Char
'#'
     String
frag <- Char -> Parser Text String
parseUntil Char
')'
     forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Text
T.pack String
absrel, String -> Text
T.pack String
frag)

absoluteOrRelativeIRI :: Parser Text (Text, Text)
absoluteOrRelativeIRI =
  do Parser ()
AT.skipSpace
     String
absrel <- Char -> Parser Text String
parseUntil Char
'#'
     Text
frag <- Parser Text
takeText
     forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Text
T.pack String
absrel, Text
frag)

fragment :: Maybe Text -> Maybe Text
fragment Maybe Text
x = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd (forall a. Parser a -> Maybe Text -> Maybe a
parseTempl Parser Text (Text, Text)
parseIRI Maybe Text
x) -- look only for the text after "#"

-- | Inital styles, see: <http://www.w3.org/TR/SVG/painting.html#FillProperty>
initialStyles :: c -> c
initialStyles = forall a n. (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a
lwL N c
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n a.
(InSpace V2 n a, Floating n, Typeable n, HasStyle a) =>
Colour Double -> a -> a
fc forall a. Num a => Colour a
black forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasStyle a => LineCap -> a -> a
lineCap LineCap
LineCapButt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasStyle a => LineJoin -> a -> a
lineJoin LineJoin
LineJoinMiter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasStyle a => Double -> a -> a
lineMiterLimit Double
4 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
AlphaColour Double -> a -> a
lcA forall a. Num a => AlphaColour a
transparent
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a n.
(N a ~ n, Typeable n, HasStyle a) =>
Measure n -> a -> a
fontSize forall n. OrderedField n => Measure n
medium
               -- fillRule nonzero -- TODO
               -- fillOpcacity 1 -- TODO
               -- stroke-opacity 1 #
               -- stroke-dasharray none
               -- stroke-dashoffset 0 #
               -- display inline

applyStyleSVG :: (t -> [SVGStyle (N a) Double]) -> t -> a -> a
applyStyleSVG t -> [SVGStyle (N a) Double]
stylesFromMap t
hmap = forall a. [a -> a] -> a -> a
compose (forall a b. (a -> b) -> [a] -> [b]
map forall {a}.
(V a ~ V2, HasStyle a, Typeable (N a), RealFloat (N a)) =>
SVGStyle (N a) Double -> a -> a
getStyles (t -> [SVGStyle (N a) Double]
stylesFromMap t
hmap))

getStyles :: SVGStyle (N a) Double -> a -> a
getStyles (Fill AlphaColour Double
c) = forall n a.
(InSpace V2 n a, Floating n, Typeable n, HasStyle a) =>
AlphaColour Double -> a -> a
fcA AlphaColour Double
c
getStyles (FillTex Texture (N a)
x) = forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Texture n -> a -> a
fillTexture Texture (N a)
x
getStyles (FillRule FR
Even_Odd) = forall a. HasStyle a => FillRule -> a -> a
fillRule FillRule
EvenOdd
getStyles (FillRule FR
Nonzero) = forall a. a -> a
id
getStyles (FillRule FR
Inherit) = forall a. a -> a
id
getStyles (FillOpacity Double
x) = forall a. HasStyle a => Double -> a -> a
Diagrams.Prelude.opacity Double
x
getStyles (FontFamily String
str) = forall a. HasStyle a => String -> a -> a
font String
str
getStyles (FontStyle FStyle
s) = forall a. a -> a
id
getStyles (FontVariant FVariant
s) = forall a. a -> a
id
getStyles (FontWeight FWeight
s) = forall a. a -> a
id
getStyles (FontStretch FStretch
s) = forall a. a -> a
id
getStyles (FontSize (Len N a
len)) = forall a n.
(N a ~ n, Typeable n, HasStyle a) =>
Measure n -> a -> a
fontSize (forall n. Num n => n -> Measure n
local N a
len)
-- getStyles (FontSize (Percent len)) = fontSize (local len)
getStyles (Diagrams.SVG.Attributes.Opacity Double
x) = forall a. HasStyle a => Double -> a -> a
Diagrams.Prelude.opacity Double
x
getStyles (StrokeOpacity Double
x) | Double
x forall a. Eq a => a -> a -> Bool
== Double
0    = forall a n. (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a
lwL N a
0
                            | Bool
otherwise = forall a. HasStyle a => Double -> a -> a
Diagrams.Prelude.opacity Double
x -- we currently don't differentiate between fill opacity and stroke opacity
getStyles (Stroke AlphaColour Double
x) = forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
AlphaColour Double -> a -> a
lcA AlphaColour Double
x
getStyles (StrokeTex Texture (N a)
x) = forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Texture n -> a -> a
lineTexture Texture (N a)
x
getStyles (StrokeWidth (Len N a
x)) = forall a n. (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a
lwL forall a b. (a -> b) -> a -> b
$ forall a. Fractional a => Rational -> a
fromRational forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> Rational
toRational N a
x
getStyles (StrokeWidth (Percent N a
x)) = forall a n. (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a
lwG N a
x
getStyles (StrokeLineCap LineCap
x) = forall a. HasStyle a => LineCap -> a -> a
lineCap LineCap
x
getStyles (StrokeLineJoin LineJoin
x) = forall a. HasStyle a => LineJoin -> a -> a
lineJoin LineJoin
x
getStyles (StrokeMiterLimit N a
x) = forall a. a -> a
id
getStyles (StrokeDasharray [LenPercent (N a)]
array) = forall a n.
(N a ~ n, HasStyle a, Typeable n, Num n) =>
[n] -> n -> a -> a
dashingL (forall a b. (a -> b) -> [a] -> [b]
map forall {n}. LenPercent n -> n
dash [LenPercent (N a)]
array) N a
0
   where dash :: LenPercent n -> n
dash (Len n
x) = n
x
         dash (Percent n
x) = n
x -- TODO implement percent length
getStyles (ClipPath Path V2 (N a)
path) = forall a n.
(HasStyle a, V a ~ V2, N a ~ n, TypeableFloat n) =>
Path V2 n -> a -> a
clipBy Path V2 (N a)
path
getStyles SVGStyle (N a) Double
_ = forall a. a -> a
id

-- | Example: style="fill:#ffb13b" style="fill:red"
styleFill :: CSSMap -> HashMap Text (Gr n) -> Parser Text (SVGStyle n a)
styleFill CSSMap
css HashMap Text (Gr n)
hmap =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"fill:"
     Parser ()
AT.skipSpace
     forall {a} {n}.
(Floating a, RealFrac a, Num n) =>
CSSMap -> HashMap Text (Gr n) -> Parser Text (SVGStyle n a)
styleFillVal CSSMap
css HashMap Text (Gr n)
hmap

styleFillVal :: CSSMap -> HashMap Text (Gr n) -> Parser Text (SVGStyle n a)
styleFillVal CSSMap
css HashMap Text (Gr n)
gradients = forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [ forall {a} {n}.
(Floating a, RealFrac a) =>
Parser Text (SVGStyle n a)
styleFillColourVal, forall {n} {a}.
Num n =>
CSSMap -> HashMap Text (Gr n) -> Parser Text (SVGStyle n a)
styleFillTexURL CSSMap
css HashMap Text (Gr n)
gradients ]

styleFillColourVal :: Parser Text (SVGStyle n a)
styleFillColourVal =
  do AlphaColour a
c <- forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [forall {a}. (Ord a, Floating a) => Parser Text (AlphaColour a)
colorRRGGBB, forall {a}. (Ord a, Floating a) => Parser Text (AlphaColour a)
colorRGB, forall {a}. (Ord a, Floating a) => Parser Text (AlphaColour a)
colorString, forall {a}. (Floating a, Ord a) => Parser Text (AlphaColour a)
colorRGBPercent, forall {a}. (RealFrac a, Floating a) => Parser Text (AlphaColour a)
colorHSLPercent, forall {a}. Num a => Parser Text (AlphaColour a)
colorNone, forall {a}. (Floating a, Ord a) => Parser Text (AlphaColour a)
colorRGBWord]
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. AlphaColour a -> SVGStyle n a
Fill AlphaColour a
c)

styleFillTexURL :: CSSMap -> HashMap Text (Gr n) -> Parser Text (SVGStyle n a)
styleFillTexURL CSSMap
css HashMap Text (Gr n)
gradients =
  do (Text
absrel,Text
frag) <- Parser Text (Text, Text)
parseIRI
     let t :: Maybe (Gr n)
t = forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
frag HashMap Text (Gr n)
gradients
     if forall a. Maybe a -> Bool
isJust Maybe (Gr n)
t then forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. Texture n -> SVGStyle n a
FillTex (Gr n -> Texture n
getTexture (forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Gr n)
t)))
                 else forall (m :: * -> *) a. Monad m => a -> m a
return forall n a. SVGStyle n a
EmptyStyle
  where getTexture :: Gr n -> Texture n
getTexture (Gr Maybe Text
refId GradientAttributes
ga Maybe (ViewBox n)
vb [CSSMap -> [GradientStop n]]
stops CSSMap
-> GradientAttributes
-> ViewBox n
-> [CSSMap -> [GradientStop n]]
-> Texture n
f) = CSSMap
-> GradientAttributes
-> ViewBox n
-> [CSSMap -> [GradientStop n]]
-> Texture n
f CSSMap
css GradientAttributes
ga (forall a. a -> Maybe a -> a
fromMaybe (n
0,n
0,n
0,n
0) Maybe (ViewBox n)
vb) [CSSMap -> [GradientStop n]]
stops

-- | Example: style="fill-rule:evenodd"
styleFillRule :: Parser Text (SVGStyle n a)
styleFillRule =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"fill-rule:"
     Parser ()
AT.skipSpace
     forall {n} {a}. Parser Text (SVGStyle n a)
styleFillRuleVal

styleFillRuleVal :: Parser Text (SVGStyle n a)
styleFillRuleVal =
  do forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [ (do{ Text -> Parser Text
AT.string Text
"evenodd"; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall n a. FR -> SVGStyle n a
FillRule FR
Even_Odd }),
                 (do{ Text -> Parser Text
AT.string Text
"nonzero"; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall n a. FR -> SVGStyle n a
FillRule FR
Nonzero }),
                 (do{ Text -> Parser Text
AT.string Text
"inherit"; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall n a. FR -> SVGStyle n a
FillRule FR
Inherit })
               ]

-- | Example: style="fill:#ffb13b" style="fill:red"
styleFillOpacity :: Parser Text (SVGStyle n a)
styleFillOpacity =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"fill-opacity:"
     Parser ()
AT.skipSpace
     forall {n} {a}. Parser Text (SVGStyle n a)
styleFillOpacityVal

styleFillOpacityVal :: Parser Text (SVGStyle n a)
styleFillOpacityVal =
  do Double
o <- Parser Text Double
myDouble
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. Double -> SVGStyle n a
FillOpacity forall a b. (a -> b) -> a -> b
$ forall a. Fractional a => Rational -> a
fromRational forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> Rational
toRational Double
o)

-- | Example: style="fill:#ffb13b" style="fill:red"
styleOpacity :: Parser Text (SVGStyle n a)
styleOpacity =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"opacity:"
     Parser ()
AT.skipSpace
     forall {n} {a}. Parser Text (SVGStyle n a)
styleOpacityVal

styleOpacityVal :: Parser Text (SVGStyle n a)
styleOpacityVal =
  do Double
o <- Parser Text Double
myDouble
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. Double -> SVGStyle n a
Diagrams.SVG.Attributes.Opacity forall a b. (a -> b) -> a -> b
$ forall a. Fractional a => Rational -> a
fromRational forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> Rational
toRational Double
o)


-- | Example: style="stroke:black"
styleStroke :: CSSMap -> HashMap Text (Gr n) -> Parser Text (SVGStyle n a)
styleStroke CSSMap
css HashMap Text (Gr n)
hmap =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"stroke:"
     Parser ()
AT.skipSpace
     forall {a} {n}.
(Floating a, RealFrac a, Num n) =>
CSSMap -> HashMap Text (Gr n) -> Parser Text (SVGStyle n a)
styleStrokeVal CSSMap
css HashMap Text (Gr n)
hmap

styleStrokeVal :: CSSMap -> HashMap Text (Gr n) -> Parser Text (SVGStyle n a)
styleStrokeVal CSSMap
css HashMap Text (Gr n)
gradients = forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [ forall {a} {n}.
(Floating a, RealFrac a) =>
Parser Text (SVGStyle n a)
styleStrokeColourVal, forall {n} {a}.
Num n =>
CSSMap -> HashMap Text (Gr n) -> Parser Text (SVGStyle n a)
styleStrokeTexURL CSSMap
css HashMap Text (Gr n)
gradients ]

styleStrokeColourVal :: Parser Text (SVGStyle n a)
styleStrokeColourVal =
  do AlphaColour a
c <- forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [forall {a}. (Ord a, Floating a) => Parser Text (AlphaColour a)
colorRRGGBB, forall {a}. (Ord a, Floating a) => Parser Text (AlphaColour a)
colorRGB, forall {a}. (Ord a, Floating a) => Parser Text (AlphaColour a)
colorString, forall {a}. (Floating a, Ord a) => Parser Text (AlphaColour a)
colorRGBPercent, forall {a}. (RealFrac a, Floating a) => Parser Text (AlphaColour a)
colorHSLPercent, forall {a}. Num a => Parser Text (AlphaColour a)
colorNone, forall {a}. (Floating a, Ord a) => Parser Text (AlphaColour a)
colorRGBWord]
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. AlphaColour a -> SVGStyle n a
Stroke AlphaColour a
c)

styleStrokeTexURL :: CSSMap -> HashMap Text (Gr n) -> Parser Text (SVGStyle n a)
styleStrokeTexURL CSSMap
css HashMap Text (Gr n)
gradients =
  do (Text
absrel,Text
frag) <- Parser Text (Text, Text)
parseIRI
     let t :: Maybe (Gr n)
t = forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
frag HashMap Text (Gr n)
gradients
     if forall a. Maybe a -> Bool
isJust Maybe (Gr n)
t then forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. Texture n -> SVGStyle n a
StrokeTex (Gr n -> Texture n
getTexture (forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Gr n)
t)))
                 else forall (m :: * -> *) a. Monad m => a -> m a
return forall n a. SVGStyle n a
EmptyStyle
  where getTexture :: Gr n -> Texture n
getTexture (Gr Maybe Text
refId GradientAttributes
ga Maybe (ViewBox n)
vb [CSSMap -> [GradientStop n]]
stops CSSMap
-> GradientAttributes
-> ViewBox n
-> [CSSMap -> [GradientStop n]]
-> Texture n
f) = CSSMap
-> GradientAttributes
-> ViewBox n
-> [CSSMap -> [GradientStop n]]
-> Texture n
f CSSMap
css GradientAttributes
ga (forall a. a -> Maybe a -> a
fromMaybe (n
0,n
0,n
0,n
0) Maybe (ViewBox n)
vb) [CSSMap -> [GradientStop n]]
stops

-- | Example: style="stroke-width:0.503546"
styleStrokeWidth :: Parser Text (SVGStyle n a)
styleStrokeWidth =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"stroke-width:"
     forall {n} {a}. Fractional n => Parser Text (SVGStyle n a)
styleStrokeWidthVal

styleStrokeWidthVal :: Parser Text (SVGStyle n a)
styleStrokeWidthVal =
  do LenPercent n
len <- forall {n}. Fractional n => Parser Text (LenPercent n)
styleLength
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. LenPercent n -> SVGStyle n a
StrokeWidth LenPercent n
len)

-------------------------------------------------------------------------------------
-- font

styleFontFamily :: Parser Text (SVGStyle n a)
styleFontFamily =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"font-family:"
     String
str <- forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
AT.manyTill Parser Char
AT.anyChar Parser Char
theEnd
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. String -> SVGStyle n a
FontFamily String
str)

theEnd :: Parser Char
theEnd = do forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Char -> Parser Char
AT.char Char
';', do { forall t. Chunk t => Parser t ()
endOfInput; forall (m :: * -> *) a. Monad m => a -> m a
return Char
' '}]


data FStyle = NormalStyle | Italic | Oblique | FSInherit

styleFontStyle :: Parser Text (SVGStyle n a)
styleFontStyle =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"font-style:"
     forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [ do { Text -> Parser Text
string Text
"normal";  forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FStyle -> SVGStyle n a
FontStyle FStyle
NormalStyle)}
               , do { Text -> Parser Text
string Text
"italic";  forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FStyle -> SVGStyle n a
FontStyle FStyle
Italic)}
               , do { Text -> Parser Text
string Text
"oblique"; forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FStyle -> SVGStyle n a
FontStyle FStyle
Oblique)}
               , do { Text -> Parser Text
string Text
"inherit"; forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FStyle -> SVGStyle n a
FontStyle FStyle
FSInherit)}
               ]


data FVariant = NormalVariant | SmallCaps | VInherit

styleFontVariant :: Parser Text (SVGStyle n a)
styleFontVariant =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"font-variant:"
     forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [ do { Text -> Parser Text
string Text
"normal";      forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FVariant -> SVGStyle n a
FontVariant FVariant
NormalVariant)}
               , do { Text -> Parser Text
string Text
"small-caps";  forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FVariant -> SVGStyle n a
FontVariant FVariant
SmallCaps)}
               , do { Text -> Parser Text
string Text
"inherit";     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FVariant -> SVGStyle n a
FontVariant FVariant
VInherit)}
               ]


data FWeight = NormalWeight | Bold | Bolder | Lighter 
             | N100 | N200 | N300 | N400 | N500 | N600 | N700 | N800 | N900
             | FWInherit

styleFontWeight :: Parser Text (SVGStyle n a)
styleFontWeight =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"font-weight:"
     forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [ do { Text -> Parser Text
string Text
"normal";  forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
NormalWeight)}
               , do { Text -> Parser Text
string Text
"bold";    forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
Bold)}
               , do { Text -> Parser Text
string Text
"bolder";  forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
Bolder)}
               , do { Text -> Parser Text
string Text
"lighter"; forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
Lighter)}
               , do { Text -> Parser Text
string Text
"100";     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
N100)}
               , do { Text -> Parser Text
string Text
"200";     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
N200)}
               , do { Text -> Parser Text
string Text
"300";     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
N300)}
               , do { Text -> Parser Text
string Text
"400";     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
N400)}
               , do { Text -> Parser Text
string Text
"500";     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
N500)}
               , do { Text -> Parser Text
string Text
"600";     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
N600)}
               , do { Text -> Parser Text
string Text
"700";     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
N700)}
               , do { Text -> Parser Text
string Text
"800";     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
N800)}
               , do { Text -> Parser Text
string Text
"900";     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
N900)}
               , do { Text -> Parser Text
string Text
"inherit"; forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
FWInherit)}
               ]


data FStretch = NormalStretch | Wider | Narrower | UltraCondensed | ExtraCondensed | Condensed
              | SemiCondensed | SemiExpanded | Expanded | ExtraExpanded | UltraExpanded | SInherit

styleFontStretch :: Parser Text (SVGStyle n a)
styleFontStretch =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"font-stretch:"
     forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [ do { Text -> Parser Text
string Text
"normal";          forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
NormalStretch)}
               , do { Text -> Parser Text
string Text
"wider";           forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
Wider)}
               , do { Text -> Parser Text
string Text
"narrower";        forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
Narrower)}
               , do { Text -> Parser Text
string Text
"ultra-condensed"; forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
UltraCondensed)}
               , do { Text -> Parser Text
string Text
"extra-condensed"; forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
ExtraCondensed)}
               , do { Text -> Parser Text
string Text
"condensed";       forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
Condensed)}
               , do { Text -> Parser Text
string Text
"semi-condensed";  forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
SemiCondensed)}
               , do { Text -> Parser Text
string Text
"semi-expanded";   forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
SemiExpanded)}
               , do { Text -> Parser Text
string Text
"expanded";        forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
Expanded)}
               , do { Text -> Parser Text
string Text
"extra-expanded";  forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
ExtraExpanded)}
               , do { Text -> Parser Text
string Text
"ultra-expanded";  forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
UltraExpanded)}
               , do { Text -> Parser Text
string Text
"inherit";         forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
SInherit)}
               ]

styleFontSize :: Parser Text (SVGStyle n a)
styleFontSize =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"font-size:"
     LenPercent n
len <- forall {n}. Fractional n => Parser Text (LenPercent n)
styleLength
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. LenPercent n -> SVGStyle n a
FontSize LenPercent n
len)

------------------------------------------------------------------------------------------------------------

-- | See <http://www.w3.org/TR/SVG/types.html#Length>
styleLength :: Parser Text (LenPercent n)
styleLength =
  do Parser ()
AT.skipSpace
     Double
d <- Parser Text Double
myDouble
     Parser ()
AT.skipSpace
     forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [ forall {n}. Fractional n => n -> Parser Text (LenPercent n)
styleLengthWithUnit (forall a. Fractional a => Rational -> a
fromRational forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> Rational
toRational Double
d),
                 forall {n}. n -> Parser Text (LenPercent n)
lengthPercent (forall a. Fractional a => Rational -> a
fromRational forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> Rational
toRational Double
d), forall (m :: * -> *) a. Monad m => a -> m a
return (forall n. n -> LenPercent n
Len (forall a. Fractional a => Rational -> a
fromRational forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> Rational
toRational Double
d)) ]

styleLengthWithUnit :: n -> Parser Text (LenPercent n)
styleLengthWithUnit n
d =
  do Unit
u <- Parser Text Unit
styleUnit
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n. n -> LenPercent n
Len (n
d forall a. Num a => a -> a -> a
* (forall {a}. Fractional a => Unit -> a
unitFactor Unit
u)))

lengthPercent :: n -> Parser Text (LenPercent n)
lengthPercent n
d =
  do Text -> Parser Text
AT.string Text
"%"
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n. n -> LenPercent n
Percent n
d)

styleUnit :: Parser Text Unit
styleUnit = do forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Parser Text Unit
styleEM,Parser Text Unit
styleEX,Parser Text Unit
stylePX,Parser Text Unit
styleIN,Parser Text Unit
styleCM,Parser Text Unit
styleMM,Parser Text Unit
stylePT,Parser Text Unit
stylePC]

styleEM :: Parser Text Unit
styleEM = do { forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Text -> Parser Text
AT.string Text
"em", Text -> Parser Text
AT.string Text
"EM"]; forall (m :: * -> *) a. Monad m => a -> m a
return Unit
EM }
styleEX :: Parser Text Unit
styleEX = do { forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Text -> Parser Text
AT.string Text
"ex", Text -> Parser Text
AT.string Text
"EX"]; forall (m :: * -> *) a. Monad m => a -> m a
return Unit
EX }
stylePX :: Parser Text Unit
stylePX = do { forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Text -> Parser Text
AT.string Text
"px", Text -> Parser Text
AT.string Text
"PX"]; forall (m :: * -> *) a. Monad m => a -> m a
return Unit
PX }
styleIN :: Parser Text Unit
styleIN = do { forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Text -> Parser Text
AT.string Text
"in", Text -> Parser Text
AT.string Text
"IN"]; forall (m :: * -> *) a. Monad m => a -> m a
return Unit
IN }
styleCM :: Parser Text Unit
styleCM = do { forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Text -> Parser Text
AT.string Text
"cm", Text -> Parser Text
AT.string Text
"CM"]; forall (m :: * -> *) a. Monad m => a -> m a
return Unit
CM }
styleMM :: Parser Text Unit
styleMM = do { forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Text -> Parser Text
AT.string Text
"mm", Text -> Parser Text
AT.string Text
"MM"]; forall (m :: * -> *) a. Monad m => a -> m a
return Unit
MM }
stylePT :: Parser Text Unit
stylePT = do { forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Text -> Parser Text
AT.string Text
"pt", Text -> Parser Text
AT.string Text
"PT"]; forall (m :: * -> *) a. Monad m => a -> m a
return Unit
PT }
stylePC :: Parser Text Unit
stylePC = do { forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Text -> Parser Text
AT.string Text
"pc", Text -> Parser Text
AT.string Text
"PC"]; forall (m :: * -> *) a. Monad m => a -> m a
return Unit
PC }

unitFactor :: Unit -> a
unitFactor Unit
EM = a
1
unitFactor Unit
EX = a
1
unitFactor Unit
PX = a
1
unitFactor Unit
IN = a
90
unitFactor Unit
CM = a
35.43307
unitFactor Unit
MM = a
3.543307
unitFactor Unit
PT = a
1.25
unitFactor Unit
PC = a
15

-- | Example: "stroke-linecap:butt"
styleStrokeLineCap :: Parser Text (SVGStyle n a)
styleStrokeLineCap =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"stroke-linecap:"
     Parser ()
AT.skipSpace
     forall {n} {a}. Parser Text (SVGStyle n a)
styleStrokeLineCapVal

styleStrokeLineCapVal :: Parser Text (SVGStyle n a)
styleStrokeLineCapVal =
  do LineCap
lc <- forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Parser Text LineCap
butt,Parser Text LineCap
round0,Parser Text LineCap
square0]
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. LineCap -> SVGStyle n a
StrokeLineCap LineCap
lc)

butt :: Parser Text LineCap
butt    = do { Text -> Parser Text
AT.string Text
"butt";   forall (m :: * -> *) a. Monad m => a -> m a
return LineCap
LineCapButt }
round0 :: Parser Text LineCap
round0  = do { Text -> Parser Text
AT.string Text
"round";  forall (m :: * -> *) a. Monad m => a -> m a
return LineCap
LineCapRound }
square0 :: Parser Text LineCap
square0 = do { Text -> Parser Text
AT.string Text
"square"; forall (m :: * -> *) a. Monad m => a -> m a
return LineCap
LineCapSquare }

-- | Example: "stroke-linejoin:miter;"
styleStrokeLineJoin :: Parser Text (SVGStyle n a)
styleStrokeLineJoin =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"stroke-linejoin:"
     Parser ()
AT.skipSpace
     forall {n} {a}. Parser Text (SVGStyle n a)
styleStrokeLineJoinVal

styleStrokeLineJoinVal :: Parser Text (SVGStyle n a)
styleStrokeLineJoinVal =
  do LineJoin
lj <- forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Parser Text LineJoin
miter,Parser Text LineJoin
round1,Parser Text LineJoin
bevel]
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. LineJoin -> SVGStyle n a
StrokeLineJoin LineJoin
lj)

miter :: Parser Text LineJoin
miter  = do { Text -> Parser Text
AT.string Text
"miter"; forall (m :: * -> *) a. Monad m => a -> m a
return LineJoin
LineJoinMiter }
round1 :: Parser Text LineJoin
round1 = do { Text -> Parser Text
AT.string Text
"round"; forall (m :: * -> *) a. Monad m => a -> m a
return LineJoin
LineJoinRound }
bevel :: Parser Text LineJoin
bevel  = do { Text -> Parser Text
AT.string Text
"bevel"; forall (m :: * -> *) a. Monad m => a -> m a
return LineJoin
LineJoinBevel }

styleClipPath :: HashMap Text (Tag b n) -> Parser Text (SVGStyle n a)
styleClipPath HashMap Text (Tag b n)
hmap =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"clip-path:"
     Parser ()
AT.skipSpace
     forall {n} {b} {a}.
RealFloat n =>
HashMap Text (Tag b n) -> Parser Text (SVGStyle n a)
styleClipPathVal HashMap Text (Tag b n)
hmap

styleClipPathVal :: HashMap Text (Tag b n) -> Parser Text (SVGStyle n a)
styleClipPathVal HashMap Text (Tag b n)
hmap =
  do (Text
absrel,Text
frag) <- Parser Text (Text, Text)
parseIRI
     let t :: Maybe (Tag b n)
t = forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
frag HashMap Text (Tag b n)
hmap
     if forall a. Maybe a -> Bool
isJust Maybe (Tag b n)
t then forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. Path V2 n -> SVGStyle n a
ClipPath forall a b. (a -> b) -> a -> b
$ forall n b.
RealFloat n =>
HashMap Text (Tag b n) -> Maybe (ViewBox n) -> Tag b n -> Path V2 n
evalPath HashMap Text (Tag b n)
hmap forall a. Maybe a
Nothing (forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Tag b n)
t))
                 else forall (m :: * -> *) a. Monad m => a -> m a
return forall n a. SVGStyle n a
EmptyStyle

-- | Evaluate the tree to a path. Is only needed for clipPaths
evalPath :: RealFloat n => H.HashMap Text (Tag b n) -> Maybe (ViewBox n) -> (Tag b n) -> Path V2 n
evalPath :: forall n b.
RealFloat n =>
HashMap Text (Tag b n) -> Maybe (ViewBox n) -> Tag b n -> Path V2 n
evalPath HashMap Text (Tag b n)
hmap (Just ViewBox n
viewBox) (Leaf Maybe Text
id1 ViewBox n -> Path V2 n
path (HashMaps b n, ViewBox n) -> Diagram b
diagram)               = ViewBox n -> Path V2 n
path ViewBox n
viewBox
evalPath HashMap Text (Tag b n)
hmap Maybe (ViewBox n)
Nothing        (Leaf Maybe Text
id1 ViewBox n -> Path V2 n
path (HashMaps b n, ViewBox n) -> Diagram b
diagram)               = ViewBox n -> Path V2 n
path (n
0,n
0,n
1,n
1) -- shouldn't happen, there should always be a viewbox
evalPath HashMap Text (Tag b n)
hmap Maybe (ViewBox n)
_       (SubTree Bool
_ Maybe Text
id1 (Double, Double)
_ (Just ViewBox n
viewBox) Maybe PreserveAR
ar HashMaps b n -> Diagram b -> Diagram b
f [Tag b n]
children) = forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (forall n b.
RealFloat n =>
HashMap Text (Tag b n) -> Maybe (ViewBox n) -> Tag b n -> Path V2 n
evalPath HashMap Text (Tag b n)
hmap (forall a. a -> Maybe a
Just ViewBox n
viewBox)) [Tag b n]
children)
evalPath HashMap Text (Tag b n)
hmap (Just ViewBox n
viewBox) (SubTree Bool
_ Maybe Text
id1 (Double, Double)
_ Maybe (ViewBox n)
Nothing Maybe PreserveAR
ar HashMaps b n -> Diagram b -> Diagram b
f [Tag b n]
children) = forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (forall n b.
RealFloat n =>
HashMap Text (Tag b n) -> Maybe (ViewBox n) -> Tag b n -> Path V2 n
evalPath HashMap Text (Tag b n)
hmap (forall a. a -> Maybe a
Just ViewBox n
viewBox)) [Tag b n]
children)
-- evalPath hmap (Reference selfId id1 wh f) = evalPath hmap (lookUp hmap (fragment id1)) -- TODO implement (not that common)
evalPath HashMap Text (Tag b n)
hmap Maybe (ViewBox n)
_ Tag b n
_ = forall a. Monoid a => a
mempty

-- | Lookup a diagram and return an empty diagram in case the SVG-file has a wrong reference
lookUp :: HashMap k (Tag b n) -> k -> Tag b n
lookUp HashMap k (Tag b n)
hmap k
i | forall a. Maybe a -> Bool
isJust Maybe (Tag b n)
l  = forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Tag b n)
l
              | Bool
otherwise = forall b n.
Maybe Text
-> (ViewBox n -> Path V2 n)
-> ((HashMaps b n, ViewBox n) -> Diagram b)
-> Tag b n
Leaf forall a. Maybe a
Nothing forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty -- an empty diagram if we can't find the id
  where l :: Maybe (Tag b n)
l = forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup k
i HashMap k (Tag b n)
hmap

-- | Example: "stroke-miterlimit:miter;"
styleStrokeMiterLimit :: Parser Text (SVGStyle n a)
styleStrokeMiterLimit =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"stroke-miterlimit:"
     Parser ()
AT.skipSpace
     forall {n} {a}. Fractional n => Parser Text (SVGStyle n a)
styleStrokeMiterLimitVal

styleStrokeMiterLimitVal :: Parser Text (SVGStyle n a)
styleStrokeMiterLimitVal =
  do Double
l <- Parser Text Double
myDouble
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall n a. n -> SVGStyle n a
StrokeMiterLimit forall a b. (a -> b) -> a -> b
$ (forall a. Fractional a => Rational -> a
fromRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => a -> Rational
toRational) Double
l

styleStrokeDashArray :: Parser Text (SVGStyle n a)
styleStrokeDashArray =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"stroke-dasharray:"
     forall {n} {a}. Fractional n => Parser Text (SVGStyle n a)
styleStrokeDashArrayVal

styleStrokeDashArrayVal :: Parser Text (SVGStyle n a)
styleStrokeDashArrayVal =
  do [LenPercent n]
len <- forall {n}. Fractional n => Parser Text [LenPercent n]
parseLengths
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n a. [LenPercent n] -> SVGStyle n a
StrokeDasharray [LenPercent n]
len)

parseLengths :: Parser Text [LenPercent n]
parseLengths = forall {a}. Parser Text a -> Text -> Parser Text [a]
separatedBy forall {n}. Fractional n => Parser Text (LenPercent n)
styleLength Text
","

styleStrokeOpacity :: Parser Text (SVGStyle n a)
styleStrokeOpacity =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"stroke-opacity:"
     Parser ()
AT.skipSpace
     forall {n} {a}. Parser Text (SVGStyle n a)
styleStrokeOpacityVal

styleStrokeOpacityVal :: Parser Text (SVGStyle n a)
styleStrokeOpacityVal =
  do Double
l <- Parser Text Double
myDouble
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall n a. Double -> SVGStyle n a
StrokeOpacity forall a b. (a -> b) -> a -> b
$ (forall a. Fractional a => Rational -> a
fromRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => a -> Rational
toRational) Double
l

styleStopColor :: Parser Text (SVGStyle n a)
styleStopColor =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"stop-color:"
     Parser ()
AT.skipSpace
     forall {a} {n}.
(Floating a, RealFrac a) =>
Parser Text (SVGStyle n a)
styleFillColourVal

styleStopOpacity :: Parser Text (SVGStyle n a)
styleStopOpacity =
  do Parser ()
AT.skipSpace
     Text -> Parser Text
AT.string Text
"stop-opacity:"
     Parser ()
AT.skipSpace
     forall {n} {a}. Parser Text (SVGStyle n a)
styleFillOpacityVal

-- TODO: Visibility, marker
-----------------------------------------------------------------------
-- Colors, see <http://www.w3.org/TR/SVG/color.html> and 
--             <http://www.w3.org/TR/SVG/painting.html#SpecifyingPaint>
-----------------------------------------------------------------------

colorString :: Parser Text (AlphaColour a)
colorString =
  do Text
a <- (Char -> Bool) -> Parser Text
Data.Attoparsec.Text.takeWhile Char -> Bool
isAlpha
     Colour a
c <- forall (m :: * -> *) a.
(MonadFail m, Monad m, Ord a, Floating a) =>
String -> m (Colour a)
readColourName (Text -> String
unpack Text
a)
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Num a => Colour a -> AlphaColour a
opaque Colour a
c)

colorRGB :: Parser Text (AlphaColour a)
colorRGB =
  do Char -> Parser Char
AT.char Char
'#'
     Char
h0 <- (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isHexDigit
     Char
h1 <- (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isHexDigit
     Char
h2 <- (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isHexDigit
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Num a => Colour a -> AlphaColour a
opaque ( forall b.
(Ord b, Floating b) =>
Word8 -> Word8 -> Word8 -> Colour b
sRGB24 (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Char -> Int
digitToInt Char
h0) forall a. Num a => a -> a -> a
* Int
16))
                              (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Char -> Int
digitToInt Char
h1) forall a. Num a => a -> a -> a
* Int
16))
                              (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Char -> Int
digitToInt Char
h2) forall a. Num a => a -> a -> a
* Int
16)) )

colorRRGGBB :: Parser Text (AlphaColour a)
colorRRGGBB =
  do Char -> Parser Char
AT.char Char
'#'
     Char
h0 <- (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isHexDigit
     Char
h1 <- (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isHexDigit
     Char
h2 <- (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isHexDigit
     Char
h3 <- (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isHexDigit
     Char
h4 <- (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isHexDigit
     Char
h5 <- (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isHexDigit
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Num a => Colour a -> AlphaColour a
opaque ( forall b.
(Ord b, Floating b) =>
Word8 -> Word8 -> Word8 -> Colour b
sRGB24 (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Char -> Int
digitToInt Char
h0) forall a. Num a => a -> a -> a
* Int
16 forall a. Num a => a -> a -> a
+ (Char -> Int
digitToInt Char
h1)) )
                              (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Char -> Int
digitToInt Char
h2) forall a. Num a => a -> a -> a
* Int
16 forall a. Num a => a -> a -> a
+ (Char -> Int
digitToInt Char
h3)) )
                              (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Char -> Int
digitToInt Char
h4) forall a. Num a => a -> a -> a
* Int
16 forall a. Num a => a -> a -> a
+ (Char -> Int
digitToInt Char
h5)) ) )

colorRGBWord :: Parser Text (AlphaColour a)
colorRGBWord =
  do Text -> Parser Text
AT.string Text
"rgb("
     Parser ()
AT.skipSpace
     Integer
r <- forall a. Integral a => Parser a
decimal
     Parser ()
AT.skipSpace
     Char -> Parser Char
AT.char Char
','
     Parser ()
AT.skipSpace
     Integer
g <- forall a. Integral a => Parser a
decimal
     Parser ()
AT.skipSpace
     Char -> Parser Char
AT.char Char
','
     Parser ()
AT.skipSpace
     Integer
b <- forall a. Integral a => Parser a
decimal
     Parser ()
AT.skipSpace
     Char -> Parser Char
AT.char Char
')'
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Num a => Colour a -> AlphaColour a
opaque (forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB ((forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
r)forall a. Fractional a => a -> a -> a
/a
255) ((forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
g)forall a. Fractional a => a -> a -> a
/a
255) ((forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
b)forall a. Fractional a => a -> a -> a
/a
255))

colorRGBPercent :: Parser Text (AlphaColour a)
colorRGBPercent =
  do Text -> Parser Text
AT.string Text
"rgb("
     Parser ()
AT.skipSpace
     Integer
r <- forall a. Integral a => Parser a
decimal
     Char -> Parser Char
AT.char Char
'%'
     Parser ()
AT.skipSpace
     Char -> Parser Char
AT.char Char
','
     Parser ()
AT.skipSpace
     Integer
g <- forall a. Integral a => Parser a
decimal
     Char -> Parser Char
AT.char Char
'%'
     Parser ()
AT.skipSpace
     Char -> Parser Char
AT.char Char
','
     Parser ()
AT.skipSpace
     Integer
b <- forall a. Integral a => Parser a
decimal
     Char -> Parser Char
AT.char Char
'%'
     Parser ()
AT.skipSpace
     Char -> Parser Char
AT.char Char
')'
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Num a => Colour a -> AlphaColour a
opaque (forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB ((forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
r)forall a. Fractional a => a -> a -> a
/a
100) ((forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
g)forall a. Fractional a => a -> a -> a
/a
100) ((forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
b)forall a. Fractional a => a -> a -> a
/a
100))

colorHSLPercent :: Parser Text (AlphaColour a)
colorHSLPercent =
  do Text -> Parser Text
AT.string Text
"hsl("
     Parser ()
AT.skipSpace
     Integer
h <- forall a. Integral a => Parser a
decimal
     Char -> Parser Char
AT.char Char
'%'
     Parser ()
AT.skipSpace
     Char -> Parser Char
AT.char Char
','
     Parser ()
AT.skipSpace
     Integer
s <- forall a. Integral a => Parser a
decimal
     Char -> Parser Char
AT.char Char
'%'
     Parser ()
AT.skipSpace
     Char -> Parser Char
AT.char Char
','
     Parser ()
AT.skipSpace
     Integer
l <- forall a. Integral a => Parser a
decimal
     Char -> Parser Char
AT.char Char
'%'
     Parser ()
AT.skipSpace
     Char -> Parser Char
AT.char Char
')'
     let c :: RGB a
c = forall a. (RealFrac a, Ord a) => a -> a -> a -> RGB a
hsl (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
h) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
s) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
l)
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Num a => Colour a -> AlphaColour a
opaque (forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB (forall a. RGB a -> a
channelRed RGB a
c) (forall a. RGB a -> a
channelGreen RGB a
c) (forall a. RGB a -> a
channelBlue RGB a
c))

colorNone :: Parser Text (AlphaColour a)
colorNone =
  do Text -> Parser Text
AT.string Text
"none"
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Num a => AlphaColour a
transparent

-------------------------------------------------------------------------------------
-- | Example: spreadMethod="pad"
parseSpread :: Maybe Text -> SpreadMethod
parseSpread :: Maybe Text -> SpreadMethod
parseSpread Maybe Text
spr | forall a. Maybe a -> Bool
isJust Maybe SpreadMethod
parsedSpread = forall a. HasCallStack => Maybe a -> a
fromJust Maybe SpreadMethod
parsedSpread
                | Bool
otherwise = SpreadMethod
GradPad -- most of the time its "pad"
  where parsedSpread :: Maybe SpreadMethod
parsedSpread = forall a. Parser a -> Maybe Text -> Maybe a
parseTempl Parser Text SpreadMethod
gradSpread Maybe Text
spr

gradSpread :: Parser Text SpreadMethod
gradSpread = forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Parser Text SpreadMethod
gradPad, Parser Text SpreadMethod
gradReflect, Parser Text SpreadMethod
gradRepeat ]

gradPad :: Parser Text SpreadMethod
gradPad = do Text -> Parser Text
AT.string Text
"pad"
             forall (m :: * -> *) a. Monad m => a -> m a
return SpreadMethod
GradPad

gradReflect :: Parser Text SpreadMethod
gradReflect = do Text -> Parser Text
AT.string Text
"reflect"
                 forall (m :: * -> *) a. Monad m => a -> m a
return SpreadMethod
GradReflect

gradRepeat :: Parser Text SpreadMethod
gradRepeat = do Text -> Parser Text
AT.string Text
"repeat"
                forall (m :: * -> *) a. Monad m => a -> m a
return SpreadMethod
GradRepeat

-------------------------------------------------------------------------------------
-- | Example: viewBox="0 0 100 30"
--   Viewboxes establish a new viewport. Percentages (e.g. x="50%") only make sense with a viewport.
parseViewBox :: RealFloat n => Maybe Text -> Maybe Text -> Maybe Text -> Maybe (ViewBox n)
parseViewBox :: forall n.
RealFloat n =>
Maybe Text -> Maybe Text -> Maybe Text -> Maybe (ViewBox n)
parseViewBox Maybe Text
vb Maybe Text
w Maybe Text
h | forall a. Maybe a -> Bool
isJust Maybe (n, n, n, n)
parsedVB    = Maybe (n, n, n, n)
parsedVB -- This is how it should always be, 
                                                    -- but sometimes an <svg>-tag has no viewbox attribute
                    | n
pw forall a. Eq a => a -> a -> Bool
== n
0 Bool -> Bool -> Bool
|| n
ph forall a. Eq a => a -> a -> Bool
== n
0 = forall a. Maybe a
Nothing -- TODO: What does a browser do here?
                    | Bool
otherwise          = forall a. a -> Maybe a
Just (n
0,n
0,n
pw, n
ph) -- If there is no viewbox the image size is the viewbox 
                                                             -- TODO: What does a browser do here?
                                                             -- The only other option I see is finding the min and max values of
                                                             -- shapes in user coordinate system, ignoring percentages
                                                             -- But one pass to just find out the viewbox?
  where parsedVB :: Maybe (n, n, n, n)
parsedVB = forall a. Parser a -> Maybe Text -> Maybe a
parseTempl forall {a} {b} {c} {d}.
(Fractional a, Fractional b, Fractional c, Fractional d) =>
Parser Text (a, b, c, d)
viewBox Maybe Text
vb

        -- Assuming percentages are not used in width/height of the top <svg>-tag
        -- and there are no sub-<svg>-tags that use percentage-width/height to refer to their calling viewbox
        -- Using width and height is a hack anyway
        pw :: n
pw | forall a. Maybe a -> Bool
isJust Maybe Text
w = forall n. RealFloat n => Text -> n
parseDouble forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
w
           | Bool
otherwise = n
0
        ph :: n
ph | forall a. Maybe a -> Bool
isJust Maybe Text
h = forall n. RealFloat n => Text -> n
parseDouble forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
h
           | Bool
otherwise = n
0

viewBox :: Parser Text (a, b, c, d)
viewBox =
  do Parser ()
AT.skipSpace
     Double
minx <- Parser Text Double
myDouble
     Parser ()
AT.skipSpace
     Double
miny <- Parser Text Double
myDouble
     Parser ()
AT.skipSpace
     Double
width  <- Parser Text Double
myDouble
     Parser ()
AT.skipSpace
     Double
height <- Parser Text Double
myDouble
     Parser ()
AT.skipSpace
     forall (m :: * -> *) a. Monad m => a -> m a
return ((forall a. Fractional a => Rational -> a
fromRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => a -> Rational
toRational) Double
minx,
             (forall a. Fractional a => Rational -> a
fromRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => a -> Rational
toRational) Double
miny,
             (forall a. Fractional a => Rational -> a
fromRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => a -> Rational
toRational) Double
width,
             (forall a. Fractional a => Rational -> a
fromRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => a -> Rational
toRational) Double
height)

-------------------------------------------------------------------------------------
-- Parse preserve aspect ratio
-- e.g. preserveAspectRatio="xMaxYMax meet"
-------------------------------------------------------------------------------------

parsePreserveAR :: Maybe Text -> Maybe PreserveAR
parsePreserveAR Maybe Text
x = forall a. Parser a -> Maybe Text -> Maybe a
parseTempl Parser Text PreserveAR
preserveAR Maybe Text
x

preserveAR :: Parser Text PreserveAR
preserveAR =
   do Parser ()
AT.skipSpace
      AlignSVG
align <- forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Parser Text AlignSVG
alignXMinYMin,Parser Text AlignSVG
alignXMidYMin,Parser Text AlignSVG
alignXMaxYMin,Parser Text AlignSVG
alignXMinYMid,Parser Text AlignSVG
alignXMidYMid,
                          Parser Text AlignSVG
alignXMaxYMid,Parser Text AlignSVG
alignXMinYMax,Parser Text AlignSVG
alignXMidYMax,Parser Text AlignSVG
alignXMaxYMax]
      Parser ()
AT.skipSpace
      MeetOrSlice
meetOrSlice <- forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Parser Text MeetOrSlice
meet, Parser Text MeetOrSlice
slice]
      forall (m :: * -> *) a. Monad m => a -> m a
return (AlignSVG -> MeetOrSlice -> PreserveAR
PAR AlignSVG
align MeetOrSlice
meetOrSlice)

meet :: Parser Text MeetOrSlice
meet =
   do Text -> Parser Text
AT.string Text
"meet"
      forall (m :: * -> *) a. Monad m => a -> m a
return MeetOrSlice
Meet

slice :: Parser Text MeetOrSlice
slice =
   do Text -> Parser Text
AT.string Text
"slice"
      forall (m :: * -> *) a. Monad m => a -> m a
return MeetOrSlice
Slice

alignXMinYMin :: Parser Text AlignSVG
alignXMinYMin =
   do Text -> Parser Text
AT.string Text
"xMinYMin"
      forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Double -> AlignSVG
AlignXY Double
0 Double
0)

alignXMidYMin :: Parser Text AlignSVG
alignXMidYMin =
   do Text -> Parser Text
AT.string Text
"xMidYMin"
      forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Double -> AlignSVG
AlignXY Double
0.5 Double
0)

alignXMaxYMin :: Parser Text AlignSVG
alignXMaxYMin =
   do Text -> Parser Text
AT.string Text
"xMaxYMin"
      forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Double -> AlignSVG
AlignXY Double
1 Double
0)

alignXMinYMid :: Parser Text AlignSVG
alignXMinYMid =
   do Text -> Parser Text
AT.string Text
"xMinYMid"
      forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Double -> AlignSVG
AlignXY Double
0 Double
0.5)

alignXMidYMid :: Parser Text AlignSVG
alignXMidYMid =
   do Text -> Parser Text
AT.string Text
"xMidYMid"
      forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Double -> AlignSVG
AlignXY Double
0.5 Double
0.5)

alignXMaxYMid :: Parser Text AlignSVG
alignXMaxYMid =
   do Text -> Parser Text
AT.string Text
"xMaxYMid"
      forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Double -> AlignSVG
AlignXY Double
1 Double
0.5)

alignXMinYMax :: Parser Text AlignSVG
alignXMinYMax =
   do Text -> Parser Text
AT.string Text
"xMinYMax"
      forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Double -> AlignSVG
AlignXY Double
0 Double
1)

alignXMidYMax :: Parser Text AlignSVG
alignXMidYMax =
   do Text -> Parser Text
AT.string Text
"xMidYMax"
      forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Double -> AlignSVG
AlignXY Double
0.5 Double
1)

alignXMaxYMax :: Parser Text AlignSVG
alignXMaxYMax =
   do Text -> Parser Text
AT.string Text
"xMaxYMax"
      forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Double -> AlignSVG
AlignXY Double
1 Double
1)