{-# LANGUAGE CPP               #-}
{-# LANGUAGE ConstraintKinds   #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE ViewPatterns      #-}
{-# LANGUAGE DeriveDataTypeable #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.SVG
-- Copyright   :  (c) 2011 diagrams-svg team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Generic tools for generating SVG files.
--
-----------------------------------------------------------------------------

module Graphics.Rendering.SVG
    ( SVGFloat
    , SvgM
    , AttributeValue
    , svgHeader
    , renderPath
    , renderClip
    , renderText
    , renderDImage
    , renderDImageEmb
    , renderStyles
    , renderMiterLimit
    , renderFillTextureDefs
    , renderFillTexture
    , renderLineTextureDefs
    , renderLineTexture
    , dataUri
    , getNumAttr
    ) where

-- from base
import           Data.List                   (intercalate)
#if __GLASGOW_HASKELL__ < 710
import           Data.Foldable               (foldMap)
#endif

import           Data.Maybe                  (fromMaybe)
import           Data.Monoid

-- from diagrams-core
import           Diagrams.Core.Transform     (matrixHomRep)

-- from diagrams-lib
import           Diagrams.Prelude            hiding (Attribute, Render, with,
                                              (<>))
import           Diagrams.TwoD.Path          (getFillRule)
import           Diagrams.TwoD.Text

-- from text
import           Data.Text                   (pack)
import qualified Data.Text                   as T

-- from lucid-svg
import           Lucid.Svg                   hiding (renderText)

-- from base64-bytestring, bytestring
import qualified Data.ByteString.Base64.Lazy as BS64
import qualified Data.ByteString.Lazy.Char8  as BS8

-- from JuicyPixels
import           Codec.Picture

-- from same package
import Diagrams.Backend.SVG.Attributes       (SvgId(..),SvgClass(..))

-- | Constaint on number type that diagrams-svg can use to render an SVG. This
--   includes the common number types: Double, Float
type SVGFloat n = (Show n, TypeableFloat n)
-- Could we change Text.Blaze.SVG to use
--   showFFloat :: RealFloat a => Maybe Int -> a -> ShowS
-- or something similar for all numbers so we need TypeableFloat constraint.

-- | The Svg monad, synonym for @HtmlT m ()@ Lucid.Base.
type SvgM = Svg ()

type AttributeValue = T.Text

getNumAttr :: AttributeClass (a n) => (a n -> t) -> Style v n -> Maybe t
getNumAttr f = (f <$>) . getAttr

-- | @svgHeader w h defs s@: @w@ width, @h@ height,
--   @defs@ global definitions for defs sections, @s@ actual SVG content.
svgHeader :: SVGFloat n => n -> n -> Maybe SvgM -> SvgM -> SvgM
svgHeader w h defines s =  doctype_ <> with (svg11_ (defs_  ds <> s))
  [ width_  (toText w)
  , height_ (toText h)
  , font_size_ "1"
  , viewBox_ (pack . unwords $ map show ([0, 0, round w, round h] :: [Int]))
  , stroke_ "rgb(0,0,0)"
  , stroke_opacity_ "1" ]
  where
    ds = fromMaybe mempty defines

renderPath :: SVGFloat n => Path V2 n -> SvgM
renderPath trs = if makePath == T.empty then mempty else path_ [d_ makePath]
  where
    makePath = foldMap renderTrail (op Path trs)

renderTrail :: SVGFloat n => Located (Trail V2 n) -> AttributeValue
renderTrail (viewLoc -> (P (V2 x y), t)) = mA x y <> withTrail renderLine renderLoop t
  where
    renderLine = foldMap renderSeg . lineSegments
    renderLoop lp =
      case loopSegments lp of
        -- let z handle the last segment if it is linear
        (segs, Linear _) -> foldMap renderSeg segs

        -- otherwise we have to emit it explicitly
        _ -> foldMap renderSeg (lineSegments . cutLoop $ lp)
      <> z

renderSeg :: SVGFloat n => Segment Closed V2 n -> AttributeValue
renderSeg (Linear (OffsetClosed (V2 x 0))) = hR x
renderSeg (Linear (OffsetClosed (V2 0 y))) = vR y
renderSeg (Linear (OffsetClosed (V2 x y))) = lR x y
renderSeg (Cubic  (V2 x0 y0)
                  (V2 x1 y1)
                  (OffsetClosed (V2 x2 y2))) = cR x0 y0 x1 y1 x2 y2

renderClip :: SVGFloat n => Path V2 n -> T.Text -> Int -> SvgM -> SvgM
renderClip p prefix ident svg = do
  defs_ $ clipPath_ [id_ (clipPathId ident)] (renderPath p)
  g_  [clip_path_ $ ("url(#" <> clipPathId ident <> ")")] svg
    where
      clipPathId i = prefix <> "myClip" <> (pack . show $ i)

renderStop :: SVGFloat n => GradientStop n -> SvgM
renderStop (GradientStop c v)
  = stop_ [ stop_color_   (colorToRgbText c)
          , offset_      (toText v)
          , stop_opacity_ (toText $ colorToOpacity c) ]

spreadMethodText :: SpreadMethod -> AttributeValue
spreadMethodText GradPad      = "pad"
spreadMethodText GradReflect  = "reflect"
spreadMethodText GradRepeat   = "repeat"

renderLinearGradient :: SVGFloat n => LGradient n -> Int -> SvgM
renderLinearGradient g i = linearGradient_
    [ id_ (pack $ "gradient" ++ show i)
    , x1_ (toText x1)
    , y1_ (toText y1)
    , x2_ (toText x2)
    , y2_ (toText y2)
    , gradientTransform_ mx
    , gradientUnits_ "userSpaceOnUse"
    , spreadMethod_ (spreadMethodText (g ^. lGradSpreadMethod)) ]
    $ foldMap renderStop (g^.lGradStops)
  where
    mx = matrix a1 a2 b1 b2 c1 c2
    [[a1, a2], [b1, b2], [c1, c2]] = matrixHomRep (g ^. lGradTrans)
    P (V2 x1 y1) = g ^. lGradStart
    P (V2 x2 y2) = g ^. lGradEnd

renderRadialGradient :: SVGFloat n => RGradient n -> Int -> SvgM
renderRadialGradient g i = radialGradient_
    [ id_ (pack $ "gradient" ++ show i)
    , r_ (toText (g ^. rGradRadius1))
    , cx_ (toText cx)
    , cy_ (toText cy)
    , fx_ (toText fx)
    , fy_ (toText fy)
    , gradientTransform_ mx
    , gradientUnits_ "userSpaceOnUse"
    , spreadMethod_ (spreadMethodText (g ^. rGradSpreadMethod)) ]
    ( foldMap renderStop ss )
  where
    mx = matrix a1 a2 b1 b2 c1 c2
    [[a1, a2], [b1, b2], [c1, c2]] = matrixHomRep (g ^.rGradTrans)
    P (V2 cx cy) = g ^. rGradCenter1
    P (V2 fx fy) = g ^. rGradCenter0 -- SVGs focal point is our inner center.

    -- Adjust the stops so that the gradient begins at the perimeter of
    -- the inner circle (center0, radius0) and ends at the outer circle.
    r0 = g ^. rGradRadius0
    r1 = g ^. rGradRadius1
    stopFracs = r0 / r1 : map (\s -> (r0 + (s ^. stopFraction) * (r1 - r0)) / r1)
                (g ^. rGradStops)
    gradStops = case g ^. rGradStops of
      []       -> []
      xs@(x:_) -> x : xs
    ss = zipWith (\gs sf -> gs & stopFraction .~ sf ) gradStops stopFracs

-- Create a gradient element so that it can be used as an attribute value for fill.
renderFillTextureDefs :: SVGFloat n => Int -> Style v n -> SvgM
renderFillTextureDefs i s =
  case getNumAttr getFillTexture s of
    Just (LG g) -> renderLinearGradient g i
    Just (RG g) -> renderRadialGradient g i
    _           -> mempty

-- Render the gradient using the id set up in renderFillTextureDefs.
renderFillTexture :: SVGFloat n => Int -> Style v n -> [Attribute]
renderFillTexture ident s = case getNumAttr getFillTexture s of
  Just (SC (SomeColor c)) -> renderTextAttr fill_ fillColorRgb <>
                             renderAttr fill_opacity_ fillColorOpacity
    where
      fillColorRgb     = Just $ colorToRgbText c
      fillColorOpacity = Just $ colorToOpacity c
  Just (LG _) -> [fill_ ("url(#gradient" <> (pack . show $ ident)
                                         <> ")"), fill_opacity_ "1"]
  Just (RG _) -> [fill_ ("url(#gradient" <> (pack . show $ ident)
                                         <> ")"), fill_opacity_ "1"]
  Nothing     -> []

renderLineTextureDefs :: SVGFloat n => Int -> Style v n -> SvgM
renderLineTextureDefs i s =
  case getNumAttr getLineTexture s of
    Just (LG g) -> renderLinearGradient g i
    Just (RG g) -> renderRadialGradient g i
    _           -> mempty

renderLineTexture :: SVGFloat n => Int -> Style v n -> [Attribute]
renderLineTexture ident s = case getNumAttr getLineTexture s of
  Just (SC (SomeColor c)) -> renderTextAttr stroke_ lineColorRgb <>
                             renderAttr stroke_opacity_ lineColorOpacity
    where
      lineColorRgb     = Just $ colorToRgbText c
      lineColorOpacity = Just $ colorToOpacity c
  Just (LG _) -> [stroke_ ("url(#gradient" <> (pack . show $ ident)
                                           <> ")"), stroke_opacity_ "1"]
  Just (RG _) -> [stroke_ ("url(#gradient" <> (pack . show $ ident)
                                           <> ")"), stroke_opacity_ "1"]
  Nothing     -> []

dataUri :: String -> BS8.ByteString -> AttributeValue
dataUri mime dat = pack $ "data:"++mime++";base64," ++ BS8.unpack (BS64.encode dat)

renderDImageEmb :: SVGFloat n => DImage n Embedded -> SvgM
renderDImageEmb di@(DImage (ImageRaster dImg) _ _ _) =
  renderDImage di $ dataUri "image/png" img
  where
    img = case encodeDynamicPng dImg of
            Left str   -> error str
            Right img' -> img'

renderDImage :: SVGFloat n => DImage n any -> AttributeValue -> SvgM
renderDImage (DImage _ w h tr) uridata =
  image_
    [ transform_ transformMatrix
    , width_  (pack . show $ w)
    , height_ (pack . show $ h)
    , xlinkHref_ uridata ]
  where
    [[a,b],[c,d],[e,f]] = matrixHomRep (tr `mappend` reflectionY
                                           `mappend` tX `mappend` tY)
    transformMatrix = matrix a b c d e f
    tX = translationX $ fromIntegral (-w)/2
    tY = translationY $ fromIntegral (-h)/2

renderText :: SVGFloat n => Text n -> SvgM
renderText (Text tt tAlign str) =
  text_
    [ transform_ transformMatrix
    , dominant_baseline_ vAlign
    , text_anchor_ hAlign
    , stroke_ "none" ]
    $ toHtml str
 where
  vAlign = case tAlign of
             BaselineText -> "alphabetic"
             BoxAlignedText _ h -> case h of -- A mere approximation
               h' | h' <= 0.25 -> "text-after-edge"
               h' | h' >= 0.75 -> "text-before-edge"
               _ -> "middle"
  hAlign = case tAlign of
             BaselineText -> "start"
             BoxAlignedText w _ -> case w of -- A mere approximation
               w' | w' <= 0.25 -> "start"
               w' | w' >= 0.75 -> "end"
               _ -> "middle"
  t                   = tt `mappend` reflectionY
  [[a,b],[c,d],[e,f]] = matrixHomRep t
  transformMatrix     = matrix a b c d e f

renderStyles :: SVGFloat n => Int -> Int -> Style v n -> [Attribute]
renderStyles fillId lineId s = concatMap ($ s) $
  [ renderLineTexture lineId
  , renderFillTexture fillId
  , renderLineWidth
  , renderLineCap
  , renderLineJoin
  , renderFillRule
  , renderDashing
  , renderOpacity
  , renderFontSize
  , renderFontSlant
  , renderFontWeight
  , renderFontFamily
  , renderSvgId
  , renderSvgClass
  , renderMiterLimit ]


renderSvgId :: SVGFloat n => Style v n -> [Attribute]
renderSvgId s = renderTextAttr id_ svgIdAttr
 where svgIdAttr = pack . getSvgId <$> getAttr s

renderSvgClass :: SVGFloat n => Style v n -> [Attribute]
renderSvgClass s = renderTextAttr class_ svgClassAttr
 where svgClassAttr = pack . getSvgClass <$> getAttr s

renderMiterLimit :: SVGFloat n => Style v n -> [Attribute]
renderMiterLimit s = renderAttr stroke_miterlimit_ miterLimit
 where miterLimit = getLineMiterLimit <$> getAttr s

renderOpacity :: SVGFloat n => Style v n -> [Attribute]
renderOpacity s = renderAttr opacity_ o
 where o = getOpacity <$> getAttr s

renderFillRule :: SVGFloat n => Style v n -> [Attribute]
renderFillRule s = renderTextAttr fill_rule_ fr
  where fr = (fillRuleToText . getFillRule) <$> getAttr s
        fillRuleToText :: FillRule -> AttributeValue
        fillRuleToText Winding = "nonzero"
        fillRuleToText EvenOdd = "evenodd"

renderLineWidth :: SVGFloat n => Style v n -> [Attribute]
renderLineWidth s = renderAttr stroke_width_ lWidth
  where lWidth = getNumAttr getLineWidth s

renderLineCap :: SVGFloat n => Style v n -> [Attribute]
renderLineCap s = renderTextAttr stroke_linecap_ lCap
  where lCap = (lineCapToText . getLineCap) <$> getAttr s
        lineCapToText :: LineCap -> AttributeValue
        lineCapToText LineCapButt   = "butt"
        lineCapToText LineCapRound  = "round"
        lineCapToText LineCapSquare = "square"

renderLineJoin :: SVGFloat n => Style v n -> [Attribute]
renderLineJoin s = renderTextAttr stroke_linejoin_ lj
  where lj = (lineJoinToText . getLineJoin) <$> getAttr s
        lineJoinToText :: LineJoin -> AttributeValue
        lineJoinToText LineJoinMiter = "miter"
        lineJoinToText LineJoinRound = "round"
        lineJoinToText LineJoinBevel = "bevel"

renderDashing :: SVGFloat n => Style v n -> [Attribute]
renderDashing s = renderTextAttr stroke_dasharray_ arr <>
                  renderAttr stroke_dashoffset_ dOffset
 where
  getDasharray  (Dashing a _) = a
  getDashoffset (Dashing _ o) = o
  dashArrayToStr              = intercalate "," . map show
  -- Ignore dashing if dashing array is empty
  checkEmpty (Just (Dashing [] _)) = Nothing
  checkEmpty other                 = other
  dashing'                    = checkEmpty $ getNumAttr getDashing s
  arr                         = (pack . dashArrayToStr . getDasharray) <$> dashing'
  dOffset                     = getDashoffset <$> dashing'

renderFontSize :: SVGFloat n => Style v n -> [Attribute]
renderFontSize s = renderTextAttr font_size_ fs
 where
  fs = pack <$> getNumAttr ((++ "px") . show . getFontSize) s

renderFontSlant :: SVGFloat n => Style v n -> [Attribute]
renderFontSlant s = renderTextAttr font_style_ fs
 where
  fs = (fontSlantAttr . getFontSlant) <$> getAttr s
  fontSlantAttr :: FontSlant -> AttributeValue
  fontSlantAttr FontSlantItalic  = "italic"
  fontSlantAttr FontSlantOblique = "oblique"
  fontSlantAttr FontSlantNormal  = "normal"

renderFontWeight :: SVGFloat n => Style v n -> [Attribute]
renderFontWeight s = renderTextAttr font_weight_ fw
 where
  fw = (fontWeightAttr . getFontWeight) <$> getAttr s
  fontWeightAttr :: FontWeight -> AttributeValue
  fontWeightAttr FontWeightNormal = "normal"
  fontWeightAttr FontWeightBold   = "bold"

renderFontFamily :: SVGFloat n => Style v n -> [Attribute]
renderFontFamily s = renderTextAttr  font_family_ ff
 where
  ff = (pack . getFont) <$> getAttr s

-- | Render a style attribute if available, empty otherwise.
renderAttr :: Show s => (AttributeValue -> Attribute) -> Maybe s -> [Attribute]
renderAttr attr valM = maybe [] (\v -> [attr (pack . show $ v)]) valM

renderTextAttr :: (AttributeValue -> Attribute) -> Maybe AttributeValue -> [Attribute]
renderTextAttr attr valM = maybe [] (\v -> [attr v]) valM

colorToRgbText :: forall c . Color c => c -> AttributeValue
colorToRgbText c = T.concat
  [ "rgb("
  , int r, ","
  , int g, ","
  , int b
  , ")" ]
 where
   int d     = pack . show $ (round (d * 255) :: Int)
   (r,g,b,_) = colorToSRGBA c

colorToOpacity :: forall c . Color c => c -> Double
colorToOpacity c = a
 where (_,_,_,a) = colorToSRGBA c