{-# 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
(Int -> NameSpaces -> ShowS)
-> (NameSpaces -> String)
-> ([NameSpaces] -> ShowS)
-> Show NameSpaces
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 <- Parser Text a -> Parser Text [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 ([Parser Text a] -> Parser Text a
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice [Parser Text a -> Text -> Parser Text a
forall b. Parser Text b -> Text -> Parser Text b
parseOne Parser Text a
parse Text
sep, Parser Text a -> Parser Text a
forall b. Parser Text b -> Parser Text b
parseOne' Parser Text a
parse])
                           [a] -> Parser Text [a]
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
                        b -> Parser Text b
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
                     b -> Parser Text b
forall (m :: * -> *) a. Monad m => a -> m a
return b
s

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

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

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

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

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

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

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

parseUntil :: Char -> Parser Text String
parseUntil Char
c = Parser Char -> Parser Char -> Parser Text String
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
[Tup n] -> ShowS
Tup n -> String
(Int -> Tup n -> ShowS)
-> (Tup n -> String) -> ([Tup n] -> ShowS) -> Show (Tup n)
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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')')
     Char -> Parser Char
AT.char Char
')'
     Tup n -> Parser Text (Tup n)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Tup n
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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
     [Parser Char] -> Parser 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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')')
     Char -> Parser Char
AT.char Char
')'
     Tup n -> Parser Text (Tup n)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Text -> Tup n
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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
     [Parser Char] -> Parser 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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
     [Parser Char] -> Parser 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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')')
     Char -> Parser Char
AT.char Char
')'
     Tup n -> Parser Text (Tup n)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Text -> Text -> Tup n
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
[Transform n] -> ShowS
Transform n -> String
(Int -> Transform n -> ShowS)
-> (Transform n -> String)
-> ([Transform n] -> ShowS)
-> Show (Transform n)
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 :: Maybe Text -> [Transform n]
parseTr =  [Transform n] -> [Transform n]
forall a. [a] -> [a]
reverse ([Transform n] -> [Transform n])
-> (Maybe Text -> [Transform n]) -> Maybe Text -> [Transform n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
           [Maybe (Transform n)] -> [Transform n]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Transform n)] -> [Transform n])
-> (Maybe Text -> [Maybe (Transform n)])
-> Maybe Text
-> [Transform n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
           ((String -> [Maybe (Transform n)])
-> ([Maybe (Transform n)] -> [Maybe (Transform n)])
-> Either String [Maybe (Transform n)]
-> [Maybe (Transform n)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Maybe (Transform n)] -> String -> [Maybe (Transform n)]
forall a b. a -> b -> a
const []) [Maybe (Transform n)] -> [Maybe (Transform n)]
forall a. a -> a
id) (Either String [Maybe (Transform n)] -> [Maybe (Transform n)])
-> (Maybe Text -> Either String [Maybe (Transform n)])
-> Maybe Text
-> [Maybe (Transform n)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
           ( Parser [Maybe (Transform n)]
-> Text -> Either String [Maybe (Transform n)]
forall a. Parser a -> Text -> Either String a
AT.parseOnly (Parser Text (Maybe (Transform n)) -> Parser [Maybe (Transform n)]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
AT.many1 Parser Text (Maybe (Transform n))
forall n. RealFloat n => Parser Text (Maybe (Transform n))
parseTransform)) (Text -> Either String [Maybe (Transform n)])
-> (Maybe Text -> Text)
-> Maybe Text
-> Either String [Maybe (Transform n)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
           (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
empty)

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

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

getTransformations :: Transform (N t) -> t -> t
getTransformations (Tr (T1 N t
x))   =  N t -> t -> t
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)) = (N t -> t -> t
forall (v :: * -> *) n t.
(InSpace v n t, R1 v, Transformable t) =>
n -> t -> t
translateX N t
x) (t -> t) -> (t -> t) -> t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (N t -> t -> t
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)
   = (N t -> t -> t
forall (v :: * -> *) n t.
(InSpace v n t, R1 v, Transformable t) =>
n -> t -> t
translateX N t
x) (t -> t) -> (t -> t) -> t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (N t -> t -> t
forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Transformable t) =>
n -> t -> t
translateY N t
y) (t -> t) -> (t -> t) -> t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (N t -> t -> t
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
n -> t -> t
rotateBy N t
angle) (t -> t) -> (t -> t) -> t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (N t -> t -> t
forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Fractional n, Transformable t) =>
n -> t -> t
scaleX N t
scX) (t -> t) -> (t -> t) -> t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (N t -> t -> t
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) = Transform (N t) -> (N t, N t, N t, N t, N t)
forall e. RealFloat e => Transform e -> (e, e, e, e, e)
matrixDecompose (N t -> N t -> N t -> N t -> N t -> N t -> Transform (N t)
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)) = N t -> t -> t
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)) = t -> t
forall a. a -> a
id -- rotationAbout (p2 (x,y)) (angle)
getTransformations (Scale (T1 N t
x))   = N t -> t -> t
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)) = (N t -> t -> t
forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Fractional n, Transformable t) =>
n -> t -> t
scaleX N t
x) (t -> t) -> (t -> t) -> t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (N t -> t -> t
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)) = t -> t
forall a. a -> a
id
getTransformations (SkewY (T1 N t
y)) = t -> t
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 = (e -> e -> e
forall a. RealFloat a => a -> a -> a
atan2 e
m12 e
m22) e -> e -> e
forall a. Fractional a => a -> a -> a
/ (e
2e -> e -> e
forall a. Num a => a -> a -> a
*e
forall a. Floating a => a
pi)
    scX :: e
scX | e
m11 e -> e -> Bool
forall a. Ord a => a -> a -> Bool
>= e
0  =   e -> e
forall a. Floating a => a -> a
sqrt (e
m11e -> e -> e
forall a. Num a => a -> a -> a
*e
m11 e -> e -> e
forall a. Num a => a -> a -> a
+ e
m21e -> e -> e
forall a. Num a => a -> a -> a
*e
m21)
        | Bool
otherwise = - e -> e
forall a. Floating a => a -> a
sqrt (e
m11e -> e -> e
forall a. Num a => a -> a -> a
*e
m11 e -> e -> e
forall a. Num a => a -> a -> a
+ e
m21e -> e -> e
forall a. Num a => a -> a -> a
*e
m21)
    scY :: e
scY | e
m22 e -> e -> Bool
forall a. Ord a => a -> a -> Bool
>= e
0  =   e -> e
forall a. Floating a => a -> a
sqrt (e
m12e -> e -> e
forall a. Num a => a -> a -> a
*e
m12 e -> e -> e
forall a. Num a => a -> a -> a
+ e
m22e -> e -> e
forall a. Num a => a -> a -> a
*e
m22)
        | Bool
otherwise = - e -> e
forall a. Floating a => a -> a
sqrt (e
m12e -> e -> e
forall a. Num a => a -> a -> a
*e
m12 e -> e -> e
forall a. Num a => a -> a -> a
+ e
m22e -> e -> e
forall 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
')'
      Maybe (Transform n) -> Parser Text (Maybe (Transform n))
forall (m :: * -> *) a. Monad m => a -> m a
return (Transform n -> Maybe (Transform n)
forall a. a -> Maybe a
Just (Transform n -> Maybe (Transform n))
-> Transform n -> Maybe (Transform n)
forall a b. (a -> b) -> a -> b
$ n -> n -> n -> n -> n -> n -> Transform n
forall n. n -> n -> n -> n -> n -> n -> Transform n
Matrix (String -> n
forall c. RealFloat c => String -> c
pp String
a) (String -> n
forall c. RealFloat c => String -> c
pp String
b) (String -> n
forall c. RealFloat c => String -> c
pp String
c) (String -> n
forall c. RealFloat c => String -> c
pp String
d) (String -> n
forall c. RealFloat c => String -> c
pp String
e) (String -> n
forall c. RealFloat c => String -> c
pp String
f) )

evalTup :: Tup n -> Tup n
evalTup (TS1 Text
x)     = n -> Tup n
forall n. n -> Tup n
T1 (Text -> n
forall n. RealFloat n => Text -> n
parseDouble Text
x)
evalTup (TS2 Text
x Text
y)   = n -> n -> Tup n
forall n. n -> n -> Tup n
T2 (Text -> n
forall n. RealFloat n => Text -> n
parseDouble Text
x) (Text -> n
forall n. RealFloat n => Text -> n
parseDouble Text
y)
evalTup (TS3 Text
x Text
y Text
z) = n -> n -> n -> Tup n
forall n. n -> n -> n -> Tup n
T3 (Text -> n
forall n. RealFloat n => Text -> n
parseDouble Text
x) (Text -> n
forall n. RealFloat n => Text -> n
parseDouble Text
y) (Text -> n
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 <- [Parser Text (Tup Any)] -> Parser Text (Tup Any)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Parser Text (Tup Any)
forall n. Parser Text (Tup n)
parse2, Parser Text (Tup Any)
forall n. Parser Text (Tup n)
parse1]
     Maybe (Transform n) -> Parser Text (Maybe (Transform n))
forall (m :: * -> *) a. Monad m => a -> m a
return (Transform n -> Maybe (Transform n)
forall a. a -> Maybe a
Just (Transform n -> Maybe (Transform n))
-> Transform n -> Maybe (Transform n)
forall a b. (a -> b) -> a -> b
$ Tup n -> Transform n
forall n. Tup n -> Transform n
Tr (Tup Any -> Tup n
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 <- [Parser Text (Tup Any)] -> Parser Text (Tup Any)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Parser Text (Tup Any)
forall n. Parser Text (Tup n)
parse2, Parser Text (Tup Any)
forall n. Parser Text (Tup n)
parse1]
     Maybe (Transform n) -> Parser Text (Maybe (Transform n))
forall (m :: * -> *) a. Monad m => a -> m a
return (Transform n -> Maybe (Transform n)
forall a. a -> Maybe a
Just (Transform n -> Maybe (Transform n))
-> Transform n -> Maybe (Transform n)
forall a b. (a -> b) -> a -> b
$ Tup n -> Transform n
forall n. Tup n -> Transform n
Scale (Tup Any -> Tup n
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 <- [Parser Text (Tup Any)] -> Parser Text (Tup Any)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Parser Text (Tup Any)
forall n. Parser Text (Tup n)
parse1, Parser Text (Tup Any)
forall n. Parser Text (Tup n)
parse3]
     Maybe (Transform n) -> Parser Text (Maybe (Transform n))
forall (m :: * -> *) a. Monad m => a -> m a
return (Transform n -> Maybe (Transform n)
forall a. a -> Maybe a
Just (Transform n -> Maybe (Transform n))
-> Transform n -> Maybe (Transform n)
forall a b. (a -> b) -> a -> b
$ Tup n -> Transform n
forall n. Tup n -> Transform n
Rotate (Tup Any -> Tup n
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 <- Parser Text (Tup Any)
forall n. Parser Text (Tup n)
parse1
     Maybe (Transform n) -> Parser Text (Maybe (Transform n))
forall (m :: * -> *) a. Monad m => a -> m a
return (Transform n -> Maybe (Transform n)
forall a. a -> Maybe a
Just (Transform n -> Maybe (Transform n))
-> Transform n -> Maybe (Transform n)
forall a b. (a -> b) -> a -> b
$ Tup n -> Transform n
forall n. Tup n -> Transform n
SkewX (Tup Any -> Tup n
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 <- Parser Text (Tup Any)
forall n. Parser Text (Tup n)
parse1
     Maybe (Transform n) -> Parser Text (Maybe (Transform n))
forall (m :: * -> *) a. Monad m => a -> m a
return (Transform n -> Maybe (Transform n)
forall a. a -> Maybe a
Just (Transform n -> Maybe (Transform n))
-> Transform n -> Maybe (Transform n)
forall a b. (a -> b) -> a -> b
$ Tup n -> Transform n
forall n. Tup n -> Transform n
SkewY (Tup Any -> Tup n
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 :: 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 = [Maybe (SVGStyle n a)] -> [SVGStyle n a]
forall a. [Maybe a] -> [a]
catMaybes
         [(Parser (SVGStyle n a) -> Maybe Text -> Maybe (SVGStyle n a)
forall a. Parser a -> Maybe Text -> Maybe a
parseTempl (CSSMap -> GradientsMap n -> Parser (SVGStyle n a)
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),
          (Parser (SVGStyle n a) -> Maybe Text -> Maybe (SVGStyle n a)
forall a. Parser a -> Maybe Text -> Maybe a
parseTempl Parser (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleFillRuleVal)          (PresentationAttributes -> Maybe Text
fillRuleSVG PresentationAttributes
pa),
          (Parser (SVGStyle n a) -> Maybe Text -> Maybe (SVGStyle n a)
forall a. Parser a -> Maybe Text -> Maybe a
parseTempl Parser (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleFillOpacityVal)       (PresentationAttributes -> Maybe Text
fillOpacity PresentationAttributes
pa),
          (Parser (SVGStyle n a) -> Maybe Text -> Maybe (SVGStyle n a)
forall a. Parser a -> Maybe Text -> Maybe a
parseTempl Parser (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleOpacityVal)           (PresentationAttributes -> Maybe Text
Diagrams.SVG.Tree.opacity PresentationAttributes
pa),
          (Parser (SVGStyle n a) -> Maybe Text -> Maybe (SVGStyle n a)
forall a. Parser a -> Maybe Text -> Maybe a
parseTempl Parser (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleStrokeOpacityVal)     (PresentationAttributes -> Maybe Text
strokeOpacity PresentationAttributes
pa),
          (Parser (SVGStyle n a) -> Maybe Text -> Maybe (SVGStyle n a)
forall a. Parser a -> Maybe Text -> Maybe a
parseTempl (CSSMap -> GradientsMap n -> Parser (SVGStyle n a)
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),
          (Parser (SVGStyle n a) -> Maybe Text -> Maybe (SVGStyle n a)
forall a. Parser a -> Maybe Text -> Maybe a
parseTempl Parser (SVGStyle n a)
forall n a. Fractional n => Parser Text (SVGStyle n a)
styleStrokeWidthVal)       (PresentationAttributes -> Maybe Text
strokeWidth PresentationAttributes
pa),
          (Parser (SVGStyle n a) -> Maybe Text -> Maybe (SVGStyle n a)
forall a. Parser a -> Maybe Text -> Maybe a
parseTempl Parser (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleStrokeLineCapVal)     (PresentationAttributes -> Maybe Text
strokeLinecap PresentationAttributes
pa),
          (Parser (SVGStyle n a) -> Maybe Text -> Maybe (SVGStyle n a)
forall a. Parser a -> Maybe Text -> Maybe a
parseTempl Parser (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleStrokeLineJoinVal)    (PresentationAttributes -> Maybe Text
strokeLinejoin PresentationAttributes
pa),
          (Parser (SVGStyle n a) -> Maybe Text -> Maybe (SVGStyle n a)
forall a. Parser a -> Maybe Text -> Maybe a
parseTempl Parser (SVGStyle n a)
forall n a. Fractional n => Parser Text (SVGStyle n a)
styleStrokeMiterLimitVal)  (PresentationAttributes -> Maybe Text
strokeMiterlimit PresentationAttributes
pa),
          (Parser (SVGStyle n a) -> Maybe Text -> Maybe (SVGStyle n a)
forall a. Parser a -> Maybe Text -> Maybe a
parseTempl Parser (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleFontFamily)           (PresentationAttributes -> Maybe Text
fontFamily PresentationAttributes
pa),
          (Parser (SVGStyle n a) -> Maybe Text -> Maybe (SVGStyle n a)
forall a. Parser a -> Maybe Text -> Maybe a
parseTempl Parser (SVGStyle n a)
forall n a. Fractional n => Parser Text (SVGStyle n a)
styleFontSize)             (PresentationAttributes -> Maybe Text
fntSize PresentationAttributes
pa),
          (Parser (SVGStyle n a) -> Maybe Text -> Maybe (SVGStyle n a)
forall a. Parser a -> Maybe Text -> Maybe a
parseTempl (NodesMap b n -> Parser (SVGStyle n a)
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),
          (Parser (SVGStyle n a) -> Maybe Text -> Maybe (SVGStyle n a)
forall a. Parser a -> Maybe Text -> Maybe a
parseTempl Parser (SVGStyle n a)
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
(Int -> Unit -> ShowS)
-> (Unit -> String) -> ([Unit] -> ShowS) -> Show Unit
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
(Int -> FR -> ShowS)
-> (FR -> String) -> ([FR] -> ShowS) -> Show FR
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 = (String -> [SVGStyle n a])
-> ([SVGStyle n a] -> [SVGStyle n a])
-> Either String [SVGStyle n a]
-> [SVGStyle n a]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([SVGStyle n a] -> String -> [SVGStyle n a]
forall a b. a -> b -> a
const []) [SVGStyle n a] -> [SVGStyle n a]
forall a. a -> a
id (Either String [SVGStyle n a] -> [SVGStyle n a])
-> Either String [SVGStyle n a] -> [SVGStyle n a]
forall a b. (a -> b) -> a -> b
$
                         Parser [SVGStyle n a] -> Text -> Either String [SVGStyle n a]
forall a. Parser a -> Text -> Either String a
AT.parseOnly (Parser Text (SVGStyle n a) -> Text -> Parser [SVGStyle n a]
forall a. Parser Text a -> Text -> Parser Text [a]
separatedBy ((HashMap Text (Tag b n), CSSMap, HashMap Text (Gr n))
-> Parser Text (SVGStyle n a)
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
";") (Text -> Maybe Text -> 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) =
  [Parser Text (SVGStyle n a)] -> Parser Text (SVGStyle n a)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Parser Text (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleFillRule, Parser Text (SVGStyle n a)
forall n a. Fractional n => Parser Text (SVGStyle n a)
styleStrokeWidth, Parser Text (SVGStyle n a)
forall n a. Fractional n => Parser Text (SVGStyle n a)
styleStrokeDashArray, CSSMap -> HashMap Text (Gr n) -> Parser Text (SVGStyle n a)
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, CSSMap -> HashMap Text (Gr n) -> Parser Text (SVGStyle n a)
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, Parser Text (SVGStyle n a)
forall a n. (Floating a, RealFrac a) => Parser Text (SVGStyle n a)
styleStopColor,
             Parser Text (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleStopOpacity, Parser Text (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleFillOpacity, Parser Text (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleStrokeOpacity, Parser Text (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleOpacity,
             Parser Text (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleFontFamily, Parser Text (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleFontStyle, Parser Text (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleFontVariant, Parser Text (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleFontWeight, Parser Text (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleFontStretch, Parser Text (SVGStyle n a)
forall n a. Fractional n => Parser Text (SVGStyle n a)
styleFontSize,
             Parser Text (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleStrokeLineCap, Parser Text (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleStrokeLineJoin, Parser Text (SVGStyle n a)
forall n a. Fractional n => Parser Text (SVGStyle n a)
styleStrokeMiterLimit, HashMap Text (Tag b n) -> Parser Text (SVGStyle n a)
forall n b a.
RealFloat n =>
HashMap Text (Tag b n) -> Parser Text (SVGStyle n a)
styleClipPath HashMap Text (Tag b n)
ns, Parser Text (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
skipOne]

skipOne :: Parser Text (SVGStyle n a)
skipOne = do String
str <- Parser Char -> Parser Char -> Parser Text String
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 ?
             SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return SVGStyle n a
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_ = Maybe Text
-> (HashMap Text (Tag b n), CSSMap, HashMap Text (Gr n))
-> [SVGStyle n a]
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 ( Text -> Maybe Text
forall a. a -> Maybe a
Just ( [Text] -> Text
T.concat ( ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
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 = [Text -> CSSMap -> Maybe [(Text, Text)]
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] [Maybe [(Text, Text)]]
-> [Maybe [(Text, Text)]] -> [Maybe [(Text, Text)]]
forall a. [a] -> [a] -> [a]
++ [Text -> CSSMap -> Maybe [(Text, Text)]
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 = [[(Text, Text)]] -> [(Text, Text)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Text, Text)]] -> [(Text, Text)])
-> [[(Text, Text)]] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ [Maybe [(Text, Text)]] -> [[(Text, Text)]]
forall a. [Maybe a] -> [a]
catMaybes
                   ( [Text -> CSSMap -> Maybe [(Text, Text)]
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
"*" CSSMap
css] [Maybe [(Text, Text)]]
-> [Maybe [(Text, Text)]] -> [Maybe [(Text, Text)]]
forall a. [a] -> [a] -> [a]
++    -- apply this style to every element
                     (if Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
id_ then [Text -> CSSMap -> Maybe [(Text, Text)]
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup (Char
'#' Char -> Text -> Text
`Data.Text.cons` (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
id_)) CSSMap
css] else []) [Maybe [(Text, Text)]]
-> [Maybe [(Text, Text)]] -> [Maybe [(Text, Text)]]
forall a. [a] -> [a] -> [a]
++
                     ([[Maybe [(Text, Text)]]] -> [Maybe [(Text, Text)]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Text -> [Maybe [(Text, Text)]])
-> [Text] -> [[Maybe [(Text, Text)]]]
forall a b. (a -> b) -> [a] -> [b]
map Text -> [Maybe [(Text, Text)]]
styleFromClass (if Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
class_ then Text -> [Text]
T.words (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Text
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 :: Parser a -> Maybe Text -> Maybe a
parseTempl Parser a
p = ((String -> Maybe a) -> (a -> Maybe a) -> Either String a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> String -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just) (Either String a -> Maybe a)
-> (Maybe Text -> Either String a) -> Maybe Text -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
               (Parser a -> Text -> Either String a
forall a. Parser a -> Text -> Either String a
AT.parseOnly Parser a
p)(Text -> Either String a)
-> (Maybe Text -> Text) -> Maybe Text -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
               (Text -> Maybe Text -> Text
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 :: (n, n) -> n -> Maybe Text -> n
p (n
minx,n
maxx) n
def Maybe Text
x = LenPercent n -> n
unL (LenPercent n -> n) -> LenPercent n -> n
forall a b. (a -> b) -> a -> b
$ LenPercent n -> Maybe (LenPercent n) -> LenPercent n
forall a. a -> Maybe a -> a
fromMaybe (n -> LenPercent n
forall n. n -> LenPercent n
Len n
def) (Maybe (LenPercent n) -> LenPercent n)
-> Maybe (LenPercent n) -> LenPercent n
forall a b. (a -> b) -> a -> b
$ Parser (LenPercent n) -> Maybe Text -> Maybe (LenPercent n)
forall a. Parser a -> Maybe Text -> Maybe a
parseTempl Parser (LenPercent n)
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
xn -> n -> n
forall a. Fractional a => a -> a -> a
/n
100 n -> n -> n
forall a. Num a => a -> a -> a
* (n
maxxn -> n -> n
forall a. Num a => a -> a -> a
-n
minx)

parseIRI :: Parser Text (Text, Text)
parseIRI = do [Parser Text (Text, Text)] -> Parser Text (Text, Text)
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
')'
     (Text, Text) -> Parser Text (Text, Text)
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
     (Text, Text) -> Parser Text (Text, Text)
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 = ((Text, Text) -> Text) -> Maybe (Text, Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Text) -> Text
forall a b. (a, b) -> b
snd (Parser Text (Text, Text) -> Maybe Text -> Maybe (Text, Text)
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 = N c -> c -> c
forall a n. (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a
lwL N c
1 (c -> c) -> (c -> c) -> c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Colour Double -> c -> c
forall n a.
(InSpace V2 n a, Floating n, Typeable n, HasStyle a) =>
Colour Double -> a -> a
fc Colour Double
forall a. Num a => Colour a
black (c -> c) -> (c -> c) -> c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineCap -> c -> c
forall a. HasStyle a => LineCap -> a -> a
lineCap LineCap
LineCapButt (c -> c) -> (c -> c) -> c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineJoin -> c -> c
forall a. HasStyle a => LineJoin -> a -> a
lineJoin LineJoin
LineJoinMiter (c -> c) -> (c -> c) -> c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> c -> c
forall a. HasStyle a => Double -> a -> a
lineMiterLimit Double
4 (c -> c) -> (c -> c) -> c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlphaColour Double -> c -> c
forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
AlphaColour Double -> a -> a
lcA AlphaColour Double
forall a. Num a => AlphaColour a
transparent
                (c -> c) -> (c -> c) -> c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Measure (N c) -> c -> c
forall a n.
(N a ~ n, Typeable n, HasStyle a) =>
Measure n -> a -> a
fontSize Measure (N c)
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 = [a -> a] -> a -> a
forall a. [a -> a] -> a -> a
compose ((SVGStyle (N a) Double -> a -> a)
-> [SVGStyle (N a) Double] -> [a -> a]
forall a b. (a -> b) -> [a] -> [b]
map SVGStyle (N a) Double -> a -> a
forall a.
(HasStyle a, Typeable (N a), RealFloat (N a), V a ~ V2) =>
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) = AlphaColour Double -> a -> a
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) = Texture (N a) -> a -> a
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) = FillRule -> a -> a
forall a. HasStyle a => FillRule -> a -> a
fillRule FillRule
EvenOdd
getStyles (FillRule FR
Nonzero) = a -> a
forall a. a -> a
id
getStyles (FillRule FR
Inherit) = a -> a
forall a. a -> a
id
getStyles (FillOpacity Double
x) = Double -> a -> a
forall a. HasStyle a => Double -> a -> a
Diagrams.Prelude.opacity Double
x
getStyles (FontFamily String
str) = String -> a -> a
forall a. HasStyle a => String -> a -> a
font String
str
getStyles (FontStyle FStyle
s) = a -> a
forall a. a -> a
id
getStyles (FontVariant FVariant
s) = a -> a
forall a. a -> a
id
getStyles (FontWeight FWeight
s) = a -> a
forall a. a -> a
id
getStyles (FontStretch FStretch
s) = a -> a
forall a. a -> a
id
getStyles (FontSize (Len N a
len)) = Measure (N a) -> a -> a
forall a n.
(N a ~ n, Typeable n, HasStyle a) =>
Measure n -> a -> a
fontSize (N a -> Measure (N a)
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) = Double -> a -> a
forall a. HasStyle a => Double -> a -> a
Diagrams.Prelude.opacity Double
x
getStyles (StrokeOpacity Double
x) | Double
x Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0    = N a -> a -> a
forall a n. (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a
lwL N a
0
                            | Bool
otherwise = Double -> a -> a
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) = AlphaColour Double -> a -> a
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) = Texture (N a) -> a -> a
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)) = N a -> a -> a
forall a n. (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a
lwL (N a -> a -> a) -> N a -> a -> a
forall a b. (a -> b) -> a -> b
$ Rational -> N a
forall a. Fractional a => Rational -> a
fromRational (Rational -> N a) -> Rational -> N a
forall a b. (a -> b) -> a -> b
$ N a -> Rational
forall a. Real a => a -> Rational
toRational N a
x
getStyles (StrokeWidth (Percent N a
x)) = N a -> a -> a
forall a n. (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a
lwG N a
x
getStyles (StrokeLineCap LineCap
x) = LineCap -> a -> a
forall a. HasStyle a => LineCap -> a -> a
lineCap LineCap
x
getStyles (StrokeLineJoin LineJoin
x) = LineJoin -> a -> a
forall a. HasStyle a => LineJoin -> a -> a
lineJoin LineJoin
x
getStyles (StrokeMiterLimit N a
x) = a -> a
forall a. a -> a
id
getStyles (StrokeDasharray [LenPercent (N a)]
array) = [N a] -> N a -> a -> a
forall a n.
(N a ~ n, HasStyle a, Typeable n, Num n) =>
[n] -> n -> a -> a
dashingL ((LenPercent (N a) -> N a) -> [LenPercent (N a)] -> [N a]
forall a b. (a -> b) -> [a] -> [b]
map LenPercent (N a) -> N a
forall p. LenPercent p -> p
dash [LenPercent (N a)]
array) N a
0
   where dash :: LenPercent p -> p
dash (Len p
x) = p
x
         dash (Percent p
x) = p
x -- TODO implement percent length
getStyles (ClipPath Path V2 (N a)
path) = Path V2 (N a) -> a -> a
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
_ = a -> a
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
     CSSMap -> HashMap Text (Gr n) -> Parser Text (SVGStyle n a)
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 = [Parser Text (SVGStyle n a)] -> Parser Text (SVGStyle n a)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [ Parser Text (SVGStyle n a)
forall a n. (Floating a, RealFrac a) => Parser Text (SVGStyle n a)
styleFillColourVal, CSSMap -> HashMap Text (Gr n) -> Parser Text (SVGStyle n a)
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 <- [Parser Text (AlphaColour a)] -> Parser Text (AlphaColour a)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Parser Text (AlphaColour a)
forall a. (Ord a, Floating a) => Parser Text (AlphaColour a)
colorRRGGBB, Parser Text (AlphaColour a)
forall a. (Ord a, Floating a) => Parser Text (AlphaColour a)
colorRGB, Parser Text (AlphaColour a)
forall a. (Ord a, Floating a) => Parser Text (AlphaColour a)
colorString, Parser Text (AlphaColour a)
forall a. (Floating a, Ord a) => Parser Text (AlphaColour a)
colorRGBPercent, Parser Text (AlphaColour a)
forall a. (RealFrac a, Floating a) => Parser Text (AlphaColour a)
colorHSLPercent, Parser Text (AlphaColour a)
forall a. Num a => Parser Text (AlphaColour a)
colorNone, Parser Text (AlphaColour a)
forall a. (Floating a, Ord a) => Parser Text (AlphaColour a)
colorRGBWord]
     SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (AlphaColour a -> SVGStyle n a
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 = Text -> HashMap Text (Gr n) -> Maybe (Gr n)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
frag HashMap Text (Gr n)
gradients
     if Maybe (Gr n) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Gr n)
t then SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Texture n -> SVGStyle n a
forall n a. Texture n -> SVGStyle n a
FillTex (Gr n -> Texture n
getTexture (Maybe (Gr n) -> Gr n
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Gr n)
t)))
                 else SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return SVGStyle n a
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 (ViewBox n -> Maybe (ViewBox n) -> ViewBox n
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
     Parser Text (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleFillRuleVal

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

styleFillOpacityVal :: Parser Text (SVGStyle n a)
styleFillOpacityVal =
  do Double
o <- Parser Double
myDouble
     SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> SVGStyle n a
forall n a. Double -> SVGStyle n a
FillOpacity (Double -> SVGStyle n a) -> Double -> SVGStyle n a
forall a b. (a -> b) -> a -> b
$ Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> Rational -> Double
forall a b. (a -> b) -> a -> b
$ Double -> Rational
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
     Parser Text (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleOpacityVal

styleOpacityVal :: Parser Text (SVGStyle n a)
styleOpacityVal =
  do Double
o <- Parser Double
myDouble
     SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> SVGStyle n a
forall n a. Double -> SVGStyle n a
Diagrams.SVG.Attributes.Opacity (Double -> SVGStyle n a) -> Double -> SVGStyle n a
forall a b. (a -> b) -> a -> b
$ Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> Rational -> Double
forall a b. (a -> b) -> a -> b
$ Double -> Rational
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
     CSSMap -> HashMap Text (Gr n) -> Parser Text (SVGStyle n a)
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 = [Parser Text (SVGStyle n a)] -> Parser Text (SVGStyle n a)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [ Parser Text (SVGStyle n a)
forall a n. (Floating a, RealFrac a) => Parser Text (SVGStyle n a)
styleStrokeColourVal, CSSMap -> HashMap Text (Gr n) -> Parser Text (SVGStyle n a)
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 <- [Parser Text (AlphaColour a)] -> Parser Text (AlphaColour a)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Parser Text (AlphaColour a)
forall a. (Ord a, Floating a) => Parser Text (AlphaColour a)
colorRRGGBB, Parser Text (AlphaColour a)
forall a. (Ord a, Floating a) => Parser Text (AlphaColour a)
colorRGB, Parser Text (AlphaColour a)
forall a. (Ord a, Floating a) => Parser Text (AlphaColour a)
colorString, Parser Text (AlphaColour a)
forall a. (Floating a, Ord a) => Parser Text (AlphaColour a)
colorRGBPercent, Parser Text (AlphaColour a)
forall a. (RealFrac a, Floating a) => Parser Text (AlphaColour a)
colorHSLPercent, Parser Text (AlphaColour a)
forall a. Num a => Parser Text (AlphaColour a)
colorNone, Parser Text (AlphaColour a)
forall a. (Floating a, Ord a) => Parser Text (AlphaColour a)
colorRGBWord]
     SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (AlphaColour a -> SVGStyle n a
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 = Text -> HashMap Text (Gr n) -> Maybe (Gr n)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
frag HashMap Text (Gr n)
gradients
     if Maybe (Gr n) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Gr n)
t then SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Texture n -> SVGStyle n a
forall n a. Texture n -> SVGStyle n a
StrokeTex (Gr n -> Texture n
getTexture (Maybe (Gr n) -> Gr n
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Gr n)
t)))
                 else SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return SVGStyle n a
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 (ViewBox n -> Maybe (ViewBox n) -> ViewBox n
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:"
     Parser Text (SVGStyle n a)
forall n a. Fractional n => Parser Text (SVGStyle n a)
styleStrokeWidthVal

styleStrokeWidthVal :: Parser Text (SVGStyle n a)
styleStrokeWidthVal =
  do LenPercent n
len <- Parser Text (LenPercent n)
forall n. Fractional n => Parser Text (LenPercent n)
styleLength
     SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (LenPercent n -> SVGStyle n a
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 <- Parser Char -> Parser Char -> Parser Text String
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
AT.manyTill Parser Char
AT.anyChar Parser Char
theEnd
     SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> SVGStyle n a
forall n a. String -> SVGStyle n a
FontFamily String
str)

theEnd :: Parser Char
theEnd = do [Parser Char] -> Parser Char
forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Char -> Parser Char
AT.char Char
';', do { Parser ()
forall t. Chunk t => Parser t ()
endOfInput; Char -> Parser Char
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:"
     [Parser Text (SVGStyle n a)] -> Parser Text (SVGStyle n a)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [ do { Text -> Parser Text
string Text
"normal";  SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FStyle -> SVGStyle n a
forall n a. FStyle -> SVGStyle n a
FontStyle FStyle
NormalStyle)}
               , do { Text -> Parser Text
string Text
"italic";  SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FStyle -> SVGStyle n a
forall n a. FStyle -> SVGStyle n a
FontStyle FStyle
Italic)}
               , do { Text -> Parser Text
string Text
"oblique"; SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FStyle -> SVGStyle n a
forall n a. FStyle -> SVGStyle n a
FontStyle FStyle
Oblique)}
               , do { Text -> Parser Text
string Text
"inherit"; SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FStyle -> SVGStyle n a
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:"
     [Parser Text (SVGStyle n a)] -> Parser Text (SVGStyle n a)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [ do { Text -> Parser Text
string Text
"normal";      SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FVariant -> SVGStyle n a
forall n a. FVariant -> SVGStyle n a
FontVariant FVariant
NormalVariant)}
               , do { Text -> Parser Text
string Text
"small-caps";  SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FVariant -> SVGStyle n a
forall n a. FVariant -> SVGStyle n a
FontVariant FVariant
SmallCaps)}
               , do { Text -> Parser Text
string Text
"inherit";     SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FVariant -> SVGStyle n a
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:"
     [Parser Text (SVGStyle n a)] -> Parser Text (SVGStyle n a)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [ do { Text -> Parser Text
string Text
"normal";  SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FWeight -> SVGStyle n a
forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
NormalWeight)}
               , do { Text -> Parser Text
string Text
"bold";    SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FWeight -> SVGStyle n a
forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
Bold)}
               , do { Text -> Parser Text
string Text
"bolder";  SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FWeight -> SVGStyle n a
forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
Bolder)}
               , do { Text -> Parser Text
string Text
"lighter"; SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FWeight -> SVGStyle n a
forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
Lighter)}
               , do { Text -> Parser Text
string Text
"100";     SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FWeight -> SVGStyle n a
forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
N100)}
               , do { Text -> Parser Text
string Text
"200";     SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FWeight -> SVGStyle n a
forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
N200)}
               , do { Text -> Parser Text
string Text
"300";     SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FWeight -> SVGStyle n a
forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
N300)}
               , do { Text -> Parser Text
string Text
"400";     SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FWeight -> SVGStyle n a
forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
N400)}
               , do { Text -> Parser Text
string Text
"500";     SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FWeight -> SVGStyle n a
forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
N500)}
               , do { Text -> Parser Text
string Text
"600";     SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FWeight -> SVGStyle n a
forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
N600)}
               , do { Text -> Parser Text
string Text
"700";     SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FWeight -> SVGStyle n a
forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
N700)}
               , do { Text -> Parser Text
string Text
"800";     SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FWeight -> SVGStyle n a
forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
N800)}
               , do { Text -> Parser Text
string Text
"900";     SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FWeight -> SVGStyle n a
forall n a. FWeight -> SVGStyle n a
FontWeight FWeight
N900)}
               , do { Text -> Parser Text
string Text
"inherit"; SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FWeight -> SVGStyle n a
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:"
     [Parser Text (SVGStyle n a)] -> Parser Text (SVGStyle n a)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [ do { Text -> Parser Text
string Text
"normal";          SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FStretch -> SVGStyle n a
forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
NormalStretch)}
               , do { Text -> Parser Text
string Text
"wider";           SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FStretch -> SVGStyle n a
forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
Wider)}
               , do { Text -> Parser Text
string Text
"narrower";        SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FStretch -> SVGStyle n a
forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
Narrower)}
               , do { Text -> Parser Text
string Text
"ultra-condensed"; SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FStretch -> SVGStyle n a
forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
UltraCondensed)}
               , do { Text -> Parser Text
string Text
"extra-condensed"; SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FStretch -> SVGStyle n a
forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
ExtraCondensed)}
               , do { Text -> Parser Text
string Text
"condensed";       SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FStretch -> SVGStyle n a
forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
Condensed)}
               , do { Text -> Parser Text
string Text
"semi-condensed";  SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FStretch -> SVGStyle n a
forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
SemiCondensed)}
               , do { Text -> Parser Text
string Text
"semi-expanded";   SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FStretch -> SVGStyle n a
forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
SemiExpanded)}
               , do { Text -> Parser Text
string Text
"expanded";        SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FStretch -> SVGStyle n a
forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
Expanded)}
               , do { Text -> Parser Text
string Text
"extra-expanded";  SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FStretch -> SVGStyle n a
forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
ExtraExpanded)}
               , do { Text -> Parser Text
string Text
"ultra-expanded";  SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FStretch -> SVGStyle n a
forall n a. FStretch -> SVGStyle n a
FontStretch FStretch
UltraExpanded)}
               , do { Text -> Parser Text
string Text
"inherit";         SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FStretch -> SVGStyle n a
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 <- Parser Text (LenPercent n)
forall n. Fractional n => Parser Text (LenPercent n)
styleLength
     SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (LenPercent n -> SVGStyle n a
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 Double
myDouble
     Parser ()
AT.skipSpace
     [Parser Text (LenPercent n)] -> Parser Text (LenPercent n)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [ n -> Parser Text (LenPercent n)
forall n. Fractional n => n -> Parser Text (LenPercent n)
styleLengthWithUnit (Rational -> n
forall a. Fractional a => Rational -> a
fromRational (Rational -> n) -> Rational -> n
forall a b. (a -> b) -> a -> b
$ Double -> Rational
forall a. Real a => a -> Rational
toRational Double
d),
                 n -> Parser Text (LenPercent n)
forall n. n -> Parser Text (LenPercent n)
lengthPercent (Rational -> n
forall a. Fractional a => Rational -> a
fromRational (Rational -> n) -> Rational -> n
forall a b. (a -> b) -> a -> b
$ Double -> Rational
forall a. Real a => a -> Rational
toRational Double
d), LenPercent n -> Parser Text (LenPercent n)
forall (m :: * -> *) a. Monad m => a -> m a
return (n -> LenPercent n
forall n. n -> LenPercent n
Len (Rational -> n
forall a. Fractional a => Rational -> a
fromRational (Rational -> n) -> Rational -> n
forall a b. (a -> b) -> a -> b
$ Double -> Rational
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
     LenPercent n -> Parser Text (LenPercent n)
forall (m :: * -> *) a. Monad m => a -> m a
return (n -> LenPercent n
forall n. n -> LenPercent n
Len (n
d n -> n -> n
forall a. Num a => a -> a -> a
* (Unit -> n
forall p. Fractional p => Unit -> p
unitFactor Unit
u)))

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

styleUnit :: Parser Text Unit
styleUnit = do [Parser Text Unit] -> Parser Text Unit
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 { [Parser Text] -> Parser Text
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"]; Unit -> Parser Text Unit
forall (m :: * -> *) a. Monad m => a -> m a
return Unit
EM }
styleEX :: Parser Text Unit
styleEX = do { [Parser Text] -> Parser Text
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"]; Unit -> Parser Text Unit
forall (m :: * -> *) a. Monad m => a -> m a
return Unit
EX }
stylePX :: Parser Text Unit
stylePX = do { [Parser Text] -> Parser Text
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"]; Unit -> Parser Text Unit
forall (m :: * -> *) a. Monad m => a -> m a
return Unit
PX }
styleIN :: Parser Text Unit
styleIN = do { [Parser Text] -> Parser Text
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"]; Unit -> Parser Text Unit
forall (m :: * -> *) a. Monad m => a -> m a
return Unit
IN }
styleCM :: Parser Text Unit
styleCM = do { [Parser Text] -> Parser Text
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"]; Unit -> Parser Text Unit
forall (m :: * -> *) a. Monad m => a -> m a
return Unit
CM }
styleMM :: Parser Text Unit
styleMM = do { [Parser Text] -> Parser Text
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"]; Unit -> Parser Text Unit
forall (m :: * -> *) a. Monad m => a -> m a
return Unit
MM }
stylePT :: Parser Text Unit
stylePT = do { [Parser Text] -> Parser Text
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"]; Unit -> Parser Text Unit
forall (m :: * -> *) a. Monad m => a -> m a
return Unit
PT }
stylePC :: Parser Text Unit
stylePC = do { [Parser Text] -> Parser Text
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"]; Unit -> Parser Text Unit
forall (m :: * -> *) a. Monad m => a -> m a
return Unit
PC }

unitFactor :: Unit -> p
unitFactor Unit
EM = p
1
unitFactor Unit
EX = p
1
unitFactor Unit
PX = p
1
unitFactor Unit
IN = p
90
unitFactor Unit
CM = p
35.43307
unitFactor Unit
MM = p
3.543307
unitFactor Unit
PT = p
1.25
unitFactor Unit
PC = p
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
     Parser Text (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleStrokeLineCapVal

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

butt :: Parser Text LineCap
butt    = do { Text -> Parser Text
AT.string Text
"butt";   LineCap -> Parser Text LineCap
forall (m :: * -> *) a. Monad m => a -> m a
return LineCap
LineCapButt }
round0 :: Parser Text LineCap
round0  = do { Text -> Parser Text
AT.string Text
"round";  LineCap -> Parser Text LineCap
forall (m :: * -> *) a. Monad m => a -> m a
return LineCap
LineCapRound }
square0 :: Parser Text LineCap
square0 = do { Text -> Parser Text
AT.string Text
"square"; LineCap -> Parser Text LineCap
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
     Parser Text (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleStrokeLineJoinVal

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

miter :: Parser Text LineJoin
miter  = do { Text -> Parser Text
AT.string Text
"miter"; LineJoin -> Parser Text LineJoin
forall (m :: * -> *) a. Monad m => a -> m a
return LineJoin
LineJoinMiter }
round1 :: Parser Text LineJoin
round1 = do { Text -> Parser Text
AT.string Text
"round"; LineJoin -> Parser Text LineJoin
forall (m :: * -> *) a. Monad m => a -> m a
return LineJoin
LineJoinRound }
bevel :: Parser Text LineJoin
bevel  = do { Text -> Parser Text
AT.string Text
"bevel"; LineJoin -> Parser Text LineJoin
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
     HashMap Text (Tag b n) -> Parser Text (SVGStyle n a)
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 = Text -> HashMap Text (Tag b n) -> Maybe (Tag b n)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
frag HashMap Text (Tag b n)
hmap
     if Maybe (Tag b n) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Tag b n)
t then SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path V2 n -> SVGStyle n a
forall n a. Path V2 n -> SVGStyle n a
ClipPath (Path V2 n -> SVGStyle n a) -> Path V2 n -> SVGStyle n a
forall a b. (a -> b) -> a -> b
$ HashMap Text (Tag b n) -> Maybe (ViewBox n) -> Tag b n -> Path V2 n
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 Maybe (ViewBox n)
forall a. Maybe a
Nothing (Maybe (Tag b n) -> Tag b n
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Tag b n)
t))
                 else SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return SVGStyle n a
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 :: 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) = [Path V2 n] -> Path V2 n
forall a. Monoid a => [a] -> a
mconcat ((Tag b n -> Path V2 n) -> [Tag b n] -> [Path V2 n]
forall a b. (a -> b) -> [a] -> [b]
map (HashMap Text (Tag b n) -> Maybe (ViewBox n) -> Tag b n -> Path V2 n
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 (ViewBox n -> Maybe (ViewBox n)
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) = [Path V2 n] -> Path V2 n
forall a. Monoid a => [a] -> a
mconcat ((Tag b n -> Path V2 n) -> [Tag b n] -> [Path V2 n]
forall a b. (a -> b) -> [a] -> [b]
map (HashMap Text (Tag b n) -> Maybe (ViewBox n) -> Tag b n -> Path V2 n
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 (ViewBox n -> Maybe (ViewBox n)
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
_ = Path V2 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 | Maybe (Tag b n) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Tag b n)
l  = Maybe (Tag b n) -> Tag b n
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Tag b n)
l
              | Bool
otherwise = Maybe Text
-> (ViewBox n -> Path V2 n)
-> ((HashMaps b n, ViewBox n) -> Diagram b)
-> Tag b n
forall b n.
Maybe Text
-> (ViewBox n -> Path V2 n)
-> ((HashMaps b n, ViewBox n) -> Diagram b)
-> Tag b n
Leaf Maybe Text
forall a. Maybe a
Nothing ViewBox n -> Path V2 n
forall a. Monoid a => a
mempty (HashMaps b n, ViewBox n) -> Diagram b
forall a. Monoid a => a
mempty -- an empty diagram if we can't find the id
  where l :: Maybe (Tag b n)
l = k -> HashMap k (Tag b n) -> Maybe (Tag b n)
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
     Parser Text (SVGStyle n a)
forall n a. Fractional n => Parser Text (SVGStyle n a)
styleStrokeMiterLimitVal

styleStrokeMiterLimitVal :: Parser Text (SVGStyle n a)
styleStrokeMiterLimitVal =
  do Double
l <- Parser Double
myDouble
     SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SVGStyle n a -> Parser Text (SVGStyle n a))
-> SVGStyle n a -> Parser Text (SVGStyle n a)
forall a b. (a -> b) -> a -> b
$ n -> SVGStyle n a
forall n a. n -> SVGStyle n a
StrokeMiterLimit (n -> SVGStyle n a) -> n -> SVGStyle n a
forall a b. (a -> b) -> a -> b
$ (Rational -> n
forall a. Fractional a => Rational -> a
fromRational (Rational -> n) -> (Double -> Rational) -> Double -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Rational
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:"
     Parser Text (SVGStyle n a)
forall n a. Fractional n => Parser Text (SVGStyle n a)
styleStrokeDashArrayVal

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

parseLengths :: Parser Text [LenPercent n]
parseLengths = Parser Text (LenPercent n) -> Text -> Parser Text [LenPercent n]
forall a. Parser Text a -> Text -> Parser Text [a]
separatedBy Parser Text (LenPercent n)
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
     Parser Text (SVGStyle n a)
forall n a. Parser Text (SVGStyle n a)
styleStrokeOpacityVal

styleStrokeOpacityVal :: Parser Text (SVGStyle n a)
styleStrokeOpacityVal =
  do Double
l <- Parser Double
myDouble
     SVGStyle n a -> Parser Text (SVGStyle n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SVGStyle n a -> Parser Text (SVGStyle n a))
-> SVGStyle n a -> Parser Text (SVGStyle n a)
forall a b. (a -> b) -> a -> b
$ Double -> SVGStyle n a
forall n a. Double -> SVGStyle n a
StrokeOpacity (Double -> SVGStyle n a) -> Double -> SVGStyle n a
forall a b. (a -> b) -> a -> b
$ (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> (Double -> Rational) -> Double -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Rational
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
     Parser Text (SVGStyle n a)
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
     Parser Text (SVGStyle n a)
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 <- String -> Parser Text (Colour a)
forall (m :: * -> *) a.
(MonadFail m, Monad m, Ord a, Floating a) =>
String -> m (Colour a)
readColourName (Text -> String
unpack Text
a)
     AlphaColour a -> Parser Text (AlphaColour a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Colour a -> AlphaColour a
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
     AlphaColour a -> Parser Text (AlphaColour a)
forall (m :: * -> *) a. Monad m => a -> m a
return (AlphaColour a -> Parser Text (AlphaColour a))
-> AlphaColour a -> Parser Text (AlphaColour a)
forall a b. (a -> b) -> a -> b
$ Colour a -> AlphaColour a
forall a. Num a => Colour a -> AlphaColour a
opaque ( Word8 -> Word8 -> Word8 -> Colour a
forall b.
(Ord b, Floating b) =>
Word8 -> Word8 -> Word8 -> Colour b
sRGB24 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Char -> Int
digitToInt Char
h0) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16))
                              (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Char -> Int
digitToInt Char
h1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16))
                              (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Char -> Int
digitToInt Char
h2) Int -> Int -> Int
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
     AlphaColour a -> Parser Text (AlphaColour a)
forall (m :: * -> *) a. Monad m => a -> m a
return (AlphaColour a -> Parser Text (AlphaColour a))
-> AlphaColour a -> Parser Text (AlphaColour a)
forall a b. (a -> b) -> a -> b
$ Colour a -> AlphaColour a
forall a. Num a => Colour a -> AlphaColour a
opaque ( Word8 -> Word8 -> Word8 -> Colour a
forall b.
(Ord b, Floating b) =>
Word8 -> Word8 -> Word8 -> Colour b
sRGB24 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Char -> Int
digitToInt Char
h0) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Char -> Int
digitToInt Char
h1)) )
                              (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Char -> Int
digitToInt Char
h2) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Char -> Int
digitToInt Char
h3)) )
                              (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Char -> Int
digitToInt Char
h4) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
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 <- Parser Integer
forall a. Integral a => Parser a
decimal
     Parser ()
AT.skipSpace
     Char -> Parser Char
AT.char Char
','
     Parser ()
AT.skipSpace
     Integer
g <- Parser Integer
forall a. Integral a => Parser a
decimal
     Parser ()
AT.skipSpace
     Char -> Parser Char
AT.char Char
','
     Parser ()
AT.skipSpace
     Integer
b <- Parser Integer
forall a. Integral a => Parser a
decimal
     Parser ()
AT.skipSpace
     Char -> Parser Char
AT.char Char
')'
     AlphaColour a -> Parser Text (AlphaColour a)
forall (m :: * -> *) a. Monad m => a -> m a
return (AlphaColour a -> Parser Text (AlphaColour a))
-> AlphaColour a -> Parser Text (AlphaColour a)
forall a b. (a -> b) -> a -> b
$ Colour a -> AlphaColour a
forall a. Num a => Colour a -> AlphaColour a
opaque (a -> a -> a -> Colour a
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB ((Integer -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
r)a -> a -> a
forall a. Fractional a => a -> a -> a
/a
255) ((Integer -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
g)a -> a -> a
forall a. Fractional a => a -> a -> a
/a
255) ((Integer -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
b)a -> a -> a
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 <- Parser Integer
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 <- Parser Integer
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 <- Parser Integer
forall a. Integral a => Parser a
decimal
     Char -> Parser Char
AT.char Char
'%'
     Parser ()
AT.skipSpace
     Char -> Parser Char
AT.char Char
')'
     AlphaColour a -> Parser Text (AlphaColour a)
forall (m :: * -> *) a. Monad m => a -> m a
return (AlphaColour a -> Parser Text (AlphaColour a))
-> AlphaColour a -> Parser Text (AlphaColour a)
forall a b. (a -> b) -> a -> b
$ Colour a -> AlphaColour a
forall a. Num a => Colour a -> AlphaColour a
opaque (a -> a -> a -> Colour a
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB ((Integer -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
r)a -> a -> a
forall a. Fractional a => a -> a -> a
/a
100) ((Integer -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
g)a -> a -> a
forall a. Fractional a => a -> a -> a
/a
100) ((Integer -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
b)a -> a -> a
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 <- Parser Integer
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 <- Parser Integer
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 <- Parser Integer
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 = a -> a -> a -> RGB a
forall a. (RealFrac a, Ord a) => a -> a -> a -> RGB a
hsl (Integer -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
h) (Integer -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
s) (Integer -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
l)
     AlphaColour a -> Parser Text (AlphaColour a)
forall (m :: * -> *) a. Monad m => a -> m a
return (AlphaColour a -> Parser Text (AlphaColour a))
-> AlphaColour a -> Parser Text (AlphaColour a)
forall a b. (a -> b) -> a -> b
$ Colour a -> AlphaColour a
forall a. Num a => Colour a -> AlphaColour a
opaque (a -> a -> a -> Colour a
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB (RGB a -> a
forall a. RGB a -> a
channelRed RGB a
c) (RGB a -> a
forall a. RGB a -> a
channelGreen RGB a
c) (RGB a -> a
forall a. RGB a -> a
channelBlue RGB a
c))

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

-------------------------------------------------------------------------------------
-- | Example: spreadMethod="pad"
parseSpread :: Maybe Text -> SpreadMethod
parseSpread :: Maybe Text -> SpreadMethod
parseSpread Maybe Text
spr | Maybe SpreadMethod -> Bool
forall a. Maybe a -> Bool
isJust Maybe SpreadMethod
parsedSpread = Maybe SpreadMethod -> SpreadMethod
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 = Parser SpreadMethod -> Maybe Text -> Maybe SpreadMethod
forall a. Parser a -> Maybe Text -> Maybe a
parseTempl Parser SpreadMethod
gradSpread Maybe Text
spr

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

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

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

gradRepeat :: Parser SpreadMethod
gradRepeat = do Text -> Parser Text
AT.string Text
"repeat"
                SpreadMethod -> Parser SpreadMethod
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 :: Maybe Text -> Maybe Text -> Maybe Text -> Maybe (ViewBox n)
parseViewBox Maybe Text
vb Maybe Text
w Maybe Text
h | Maybe (ViewBox n) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (ViewBox n)
parsedVB    = Maybe (ViewBox n)
parsedVB -- This is how it should always be, 
                                                    -- but sometimes an <svg>-tag has no viewbox attribute
                    | n
pw n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
0 Bool -> Bool -> Bool
|| n
ph n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
0 = Maybe (ViewBox n)
forall a. Maybe a
Nothing -- TODO: What does a browser do here?
                    | Bool
otherwise          = ViewBox n -> Maybe (ViewBox n)
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 (ViewBox n)
parsedVB = Parser (ViewBox n) -> Maybe Text -> Maybe (ViewBox n)
forall a. Parser a -> Maybe Text -> Maybe a
parseTempl Parser (ViewBox n)
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 | Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
w = Text -> n
forall n. RealFloat n => Text -> n
parseDouble (Text -> n) -> Text -> n
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
w
           | Bool
otherwise = n
0
        ph :: n
ph | Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
h = Text -> n
forall n. RealFloat n => Text -> n
parseDouble (Text -> n) -> Text -> n
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Text
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 Double
myDouble
     Parser ()
AT.skipSpace
     Double
miny <- Parser Double
myDouble
     Parser ()
AT.skipSpace
     Double
width  <- Parser Double
myDouble
     Parser ()
AT.skipSpace
     Double
height <- Parser Double
myDouble
     Parser ()
AT.skipSpace
     (a, b, c, d) -> Parser Text (a, b, c, d)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Rational -> a
forall a. Fractional a => Rational -> a
fromRational (Rational -> a) -> (Double -> Rational) -> Double -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Rational
forall a. Real a => a -> Rational
toRational) Double
minx,
             (Rational -> b
forall a. Fractional a => Rational -> a
fromRational (Rational -> b) -> (Double -> Rational) -> Double -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Rational
forall a. Real a => a -> Rational
toRational) Double
miny,
             (Rational -> c
forall a. Fractional a => Rational -> a
fromRational (Rational -> c) -> (Double -> Rational) -> Double -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Rational
forall a. Real a => a -> Rational
toRational) Double
width,
             (Rational -> d
forall a. Fractional a => Rational -> a
fromRational (Rational -> d) -> (Double -> Rational) -> Double -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Rational
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 = Parser PreserveAR -> Maybe Text -> Maybe PreserveAR
forall a. Parser a -> Maybe Text -> Maybe a
parseTempl Parser PreserveAR
preserveAR Maybe Text
x

preserveAR :: Parser PreserveAR
preserveAR =
   do Parser ()
AT.skipSpace
      AlignSVG
align <- [Parser Text AlignSVG] -> Parser Text AlignSVG
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 <- [Parser Text MeetOrSlice] -> Parser Text MeetOrSlice
forall (f :: * -> *) a. Alternative f => [f a] -> f a
AT.choice [Parser Text MeetOrSlice
meet, Parser Text MeetOrSlice
slice]
      PreserveAR -> Parser PreserveAR
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"
      MeetOrSlice -> Parser Text MeetOrSlice
forall (m :: * -> *) a. Monad m => a -> m a
return MeetOrSlice
Meet

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

alignXMinYMin :: Parser Text AlignSVG
alignXMinYMin =
   do Text -> Parser Text
AT.string Text
"xMinYMin"
      AlignSVG -> Parser Text AlignSVG
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"
      AlignSVG -> Parser Text AlignSVG
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"
      AlignSVG -> Parser Text AlignSVG
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"
      AlignSVG -> Parser Text AlignSVG
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"
      AlignSVG -> Parser Text AlignSVG
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"
      AlignSVG -> Parser Text AlignSVG
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"
      AlignSVG -> Parser Text AlignSVG
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"
      AlignSVG -> Parser Text AlignSVG
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"
      AlignSVG -> Parser Text AlignSVG
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Double -> AlignSVG
AlignXY Double
1 Double
1)