{-# LANGUAGE CPP               #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies      #-}

-------------------------------------------------------------------------------
-- |
-- Module      :  SVG.Core
-- Copyright   :  (c) 2015 Jeffrey Rosenbluth
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  jeffrey.rosenbluth@gmail.com
--
-- svg-builder Core types and functions.
--
-------------------------------------------------------------------------------

module Graphics.Svg.Core
( -- * Types
  Attribute
, Element
, ToElement(..)
, Term(..)
  -- * Combinators
, makeAttribute
, makeElement
, makeElementNoEnd
, makeElementDoctype
, with
  -- * Rendering
, renderBS
, renderToFile
, renderText
) where

import           Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder as BB
import qualified Blaze.ByteString.Builder.Html.Utf8 as BB
import qualified Data.ByteString.Lazy as LB
import           Data.ByteString.Lazy (ByteString)
import           Data.Hashable (Hashable(..))
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as M
#if !MIN_VERSION_base(4,8,0)
import           Data.Monoid (Monoid(..))
#endif
import           Data.Semigroup (Semigroup(..))
import           Data.String
import           Data.Text (Text)
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT

--------------------------------------------------------------------------------
-- Types

-- | Attribute name value.
data Attribute = Attribute !Text !Text
  deriving (Int -> Attribute -> ShowS
[Attribute] -> ShowS
Attribute -> String
(Int -> Attribute -> ShowS)
-> (Attribute -> String)
-> ([Attribute] -> ShowS)
-> Show Attribute
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Attribute] -> ShowS
$cshowList :: [Attribute] -> ShowS
show :: Attribute -> String
$cshow :: Attribute -> String
showsPrec :: Int -> Attribute -> ShowS
$cshowsPrec :: Int -> Attribute -> ShowS
Show,Attribute -> Attribute -> Bool
(Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool) -> Eq Attribute
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Attribute -> Attribute -> Bool
$c/= :: Attribute -> Attribute -> Bool
== :: Attribute -> Attribute -> Bool
$c== :: Attribute -> Attribute -> Bool
Eq)

instance Hashable Attribute where
  hashWithSalt :: Int -> Attribute -> Int
hashWithSalt Int
salt (Attribute Text
a Text
b) = Int
salt Int -> Text -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Text
a Int -> Text -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Text
b

-- | Type of an SVG element.
newtype Element = Element (HashMap Text Text -> Builder)

instance Show Element where
  show :: Element -> String
show Element
e = Text -> String
LT.unpack (Text -> String) -> (Element -> Text) -> Element -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
renderText (Element -> String) -> Element -> String
forall a b. (a -> b) -> a -> b
$ Element
e

instance Semigroup Element where
  Element HashMap Text Text -> Builder
e1 <> :: Element -> Element -> Element
<> Element HashMap Text Text -> Builder
e2 = (HashMap Text Text -> Builder) -> Element
Element (HashMap Text Text -> Builder
e1 (HashMap Text Text -> Builder)
-> (HashMap Text Text -> Builder) -> HashMap Text Text -> Builder
forall a. Semigroup a => a -> a -> a
<> HashMap Text Text -> Builder
e2)

instance Monoid Element where
  mempty :: Element
mempty = (HashMap Text Text -> Builder) -> Element
Element HashMap Text Text -> Builder
forall a. Monoid a => a
mempty
#if !(MIN_VERSION_base(4,11,0))
  mappend = (<>)
#endif

instance IsString Element where
  fromString :: String -> Element
fromString = String -> Element
forall a. ToElement a => a -> Element
toElement

-- | Things that can be converted to SVG elements.
class ToElement a where
  toElement :: a -> Element

instance ToElement String where
  toElement :: String -> Element
toElement = (HashMap Text Text -> Builder) -> Element
Element ((HashMap Text Text -> Builder) -> Element)
-> (String -> HashMap Text Text -> Builder) -> String -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> HashMap Text Text -> Builder
forall a b. a -> b -> a
const (Builder -> HashMap Text Text -> Builder)
-> (String -> Builder) -> String -> HashMap Text Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
BB.fromHtmlEscapedString

instance ToElement Text where
  toElement :: Text -> Element
toElement = (HashMap Text Text -> Builder) -> Element
Element ((HashMap Text Text -> Builder) -> Element)
-> (Text -> HashMap Text Text -> Builder) -> Text -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> HashMap Text Text -> Builder
forall a b. a -> b -> a
const (Builder -> HashMap Text Text -> Builder)
-> (Text -> Builder) -> Text -> HashMap Text Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
BB.fromHtmlEscapedText

instance ToElement LT.Text where
  toElement :: Text -> Element
toElement = (HashMap Text Text -> Builder) -> Element
Element ((HashMap Text Text -> Builder) -> Element)
-> (Text -> HashMap Text Text -> Builder) -> Text -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> HashMap Text Text -> Builder
forall a b. a -> b -> a
const (Builder -> HashMap Text Text -> Builder)
-> (Text -> Builder) -> Text -> HashMap Text Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
BB.fromHtmlEscapedLazyText

-- | Used to make specific SVG element builders.
class Term result where
  -- | Used for constructing elements e.g. @term "circle"@ yields 'circle_'.
  term :: Text -> [Attribute] -> result

instance (e ~ Element) => Term (e -> Element) where
  term :: Text -> [Attribute] -> e -> Element
term Text
name [Attribute]
attrs e
e = Element -> [Attribute] -> Element
with (Text -> Element -> Element
makeElement Text
name e
Element
e) [Attribute]
attrs

instance Term Element where
  term :: Text -> [Attribute] -> Element
term Text
name [Attribute]
attrs = Element -> [Attribute] -> Element
with (Text -> Element
makeElementNoEnd Text
name) [Attribute]
attrs

--------------------------------------------------------------------------------
-- Combinators

-- | Make an attribute.
makeAttribute :: Text -- ^ Attribute name.
              -> Text -- ^ Attribute value.
              -> Attribute
makeAttribute :: Text -> Text -> Attribute
makeAttribute = Text -> Text -> Attribute
Attribute

-- | Union two sets of attributes and append duplicate keys.
unionAttrs :: HashMap Text Text -> HashMap Text Text -> HashMap Text Text
unionAttrs :: HashMap Text Text -> HashMap Text Text -> HashMap Text Text
unionAttrs = (Text -> Text -> Text)
-> HashMap Text Text -> HashMap Text Text -> HashMap Text Text
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
M.unionWith Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>)

-- | Add a list of attributes to an element
with :: Element -> [Attribute] -> Element
with :: Element -> [Attribute] -> Element
with (Element HashMap Text Text -> Builder
e) [Attribute]
attrs = (HashMap Text Text -> Builder) -> Element
Element ((HashMap Text Text -> Builder) -> Element)
-> (HashMap Text Text -> Builder) -> Element
forall a b. (a -> b) -> a -> b
$ \HashMap Text Text
a ->
  HashMap Text Text -> Builder
e (HashMap Text Text -> HashMap Text Text -> HashMap Text Text
unionAttrs ((Text -> Text -> Text) -> [(Text, Text)] -> HashMap Text Text
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
M.fromListWith Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>) ((Attribute -> (Text, Text)) -> [Attribute] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map Attribute -> (Text, Text)
toPair [Attribute]
attrs)) HashMap Text Text
a)
  where
    toPair :: Attribute -> (Text, Text)
toPair (Attribute Text
x Text
y) = (Text
x,Text
y)

-- | Make an SVG element builder
makeElement :: Text -> Element -> Element
makeElement :: Text -> Element -> Element
makeElement Text
name (Element HashMap Text Text -> Builder
c) = (HashMap Text Text -> Builder) -> Element
Element ((HashMap Text Text -> Builder) -> Element)
-> (HashMap Text Text -> Builder) -> Element
forall a b. (a -> b) -> a -> b
$ \HashMap Text Text
a -> (HashMap Text Text -> Builder) -> HashMap Text Text -> Builder
go HashMap Text Text -> Builder
c HashMap Text Text
a
  where
    go :: (HashMap Text Text -> Builder) -> HashMap Text Text -> Builder
go HashMap Text Text -> Builder
children HashMap Text Text
attrs =
         String -> Builder
s2b String
"<" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
BB.fromText Text
name
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Text -> Builder) -> HashMap Text Text -> Builder
forall m k v. Monoid m => (k -> v -> m) -> HashMap k v -> m
foldlMapWithKey Text -> Text -> Builder
buildAttr HashMap Text Text
attrs Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
s2b String
">"
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> HashMap Text Text -> Builder
children HashMap Text Text
forall a. Monoid a => a
mempty
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
s2b String
"</" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
BB.fromText Text
name Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
s2b String
">"

-- | Make an SVG doctype element builder.
makeElementDoctype :: Text -> Element
makeElementDoctype :: Text -> Element
makeElementDoctype Text
name = (HashMap Text Text -> Builder) -> Element
Element ((HashMap Text Text -> Builder) -> Element)
-> (HashMap Text Text -> Builder) -> Element
forall a b. (a -> b) -> a -> b
$ \HashMap Text Text
a -> HashMap Text Text -> Builder
go HashMap Text Text
a
  where
    go :: HashMap Text Text -> Builder
go HashMap Text Text
attrs =
         String -> Builder
s2b String
"<" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
BB.fromText Text
name
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Text -> Builder) -> HashMap Text Text -> Builder
forall m k v. Monoid m => (k -> v -> m) -> HashMap k v -> m
foldlMapWithKey Text -> Text -> Builder
buildAttr HashMap Text Text
attrs Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
s2b String
">"

-- | Make an SVG element with no end tag, contains only attributes.
makeElementNoEnd :: Text -> Element
makeElementNoEnd :: Text -> Element
makeElementNoEnd Text
name = (HashMap Text Text -> Builder) -> Element
Element ((HashMap Text Text -> Builder) -> Element)
-> (HashMap Text Text -> Builder) -> Element
forall a b. (a -> b) -> a -> b
$ \HashMap Text Text
a -> HashMap Text Text -> Builder
go HashMap Text Text
a
  where
    go :: HashMap Text Text -> Builder
go HashMap Text Text
attrs =
         String -> Builder
s2b String
"<" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
BB.fromText Text
name
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Text -> Builder) -> HashMap Text Text -> Builder
forall m k v. Monoid m => (k -> v -> m) -> HashMap k v -> m
foldlMapWithKey Text -> Text -> Builder
buildAttr HashMap Text Text
attrs Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
s2b String
"/>"

-- | Folding and monoidally appending attributes.
foldlMapWithKey :: Monoid m => (k -> v -> m) -> HashMap k v -> m
foldlMapWithKey :: forall m k v. Monoid m => (k -> v -> m) -> HashMap k v -> m
foldlMapWithKey k -> v -> m
f = (m -> k -> v -> m) -> m -> HashMap k v -> m
forall a k v. (a -> k -> v -> a) -> a -> HashMap k v -> a
M.foldlWithKey' (\m
m k
k v
v -> m
m m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` k -> v -> m
f k
k v
v) m
forall a. Monoid a => a
mempty

s2b :: String -> Builder
s2b :: String -> Builder
s2b = String -> Builder
BB.fromString

-- | Build and encode an attribute.
buildAttr :: Text -> Text -> Builder
buildAttr :: Text -> Text -> Builder
buildAttr Text
key Text
val =
  String -> Builder
s2b String
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  Text -> Builder
BB.fromText Text
key Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  if Text
val Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
forall a. Monoid a => a
mempty
    then Builder
forall a. Monoid a => a
mempty
    else String -> Builder
s2b String
"=\"" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
BB.fromHtmlEscapedText Text
val Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
s2b String
"\""

--------------------------------------------------------------------------------
-- Rendering

-- | Render a 'Element' to lazy bytestring.
renderBS :: Element -> ByteString
renderBS :: Element -> ByteString
renderBS (Element HashMap Text Text -> Builder
e) = Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ HashMap Text Text -> Builder
e HashMap Text Text
forall a. Monoid a => a
mempty

-- | Render a 'Element' to a file.
renderToFile :: FilePath -> Element -> IO ()
renderToFile :: String -> Element -> IO ()
renderToFile String
fp = String -> ByteString -> IO ()
LB.writeFile String
fp (ByteString -> IO ())
-> (Element -> ByteString) -> Element -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> ByteString
renderBS

-- | Reder an 'Element' to lazy text.
renderText :: Element -> LT.Text
renderText :: Element -> Text
renderText = ByteString -> Text
LT.decodeUtf8 (ByteString -> Text) -> (Element -> ByteString) -> Element -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> ByteString
renderBS