{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE TypeSynonymInstances  #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE ViewPatterns          #-}
{-# LANGUAGE InstanceSigs          #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell       #-}

-------------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Backend.Html5
-- Copyright   :  (c) 2015 Jeffrey Rosenbluth
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- A full-featured rendering backend for diagrams using HTML5 Canvas.
-- Implemented using the static-canvas package.
--
-- To invoke the Html5 backend, you have three options.
--
-- * You can use the "Diagrams.Backend.Html5.CmdLine" module to create
--   standalone executables which will display the diagram in a browser
--   using a web service.
--
-- * You can use the 'renderHtml5' function provided by this module,
--   which gives you more programmatic control over when and
--   how images are displayed (making it east to, for example, write a
--   single program that displays multiple images, or one that diaplays
--   images dynamically based on user input, and so on).
--
-- * For the most flexiblity you can invoke the 'renderDia' method from
--   'Diagrams.Core.Types.Backend' instance for @Html5@. In particular,
--   'Diagrams.Core.Types.renderDia' has the generic type
--
-- > renderDia :: b -> Options b v -> QDiagram b v m -> Result b v
--
-- (omitting a few type class contraints). @b@ represents the
-- backend type, @v@ the vector space, and @m@ the type of monoidal
-- query annotations on the diagram. 'Options' and 'Result' are
-- associated data and type families, respectively, which yield the
-- type of option records and rendering results specific to any
-- particular backend. For @b ~ Html5@ and @v ~ R2@, we have
--
-- > data Options Html5 V2 Double = Html5Options
-- >  { _size :: SizeSpec V2 -- ^^ The requested size
-- >  }
--
-- @
-- data family Render Html5 V2 Double = C (RenderM ())
-- @
--
-- @
-- type family Result Html5 V2 Double = Html5 ()
-- @
--
-- So the type of 'renderDia' resolves to
--
-- @
-- renderDia :: Html5 -> Options Html5 V2 Double -> QDiagram Html5 V2 Double m ->
-- Html5()
-- @
--
-- which you could call like @renderDia Html5 (Html5Options (width 250))
-- myDiagram@
--
------------------------------------------------------------------------------

module Diagrams.Backend.Html5

  ( Html5(..) -- rendering token
  , B
  , Options(..) -- for rendering options specific to Html5
  , renderHtml5

  -- * Lenses
  , size
  , canvasId
  , standalone

  ) where

import           Control.Monad.State          (when)
import qualified Control.Monad.StateStack     as SS
import           Control.Monad.Trans          (lift)

import           Data.Default.Class
import qualified Data.Foldable                as F
import           Data.Maybe                   (catMaybes, isJust, fromJust, fromMaybe)
import           Data.NumInstances            ()
import qualified Data.Text                    as T
import           Data.Text.Lazy.Builder       (Builder, toLazyText)
import qualified Data.Text.Lazy.IO            as L
import           Data.Tree                    (Tree(Node))
import           Data.Typeable                (Typeable)

import           Diagrams.Attributes
import           Diagrams.Prelude             hiding (fillTexture, moveTo, stroke, size)
import           Diagrams.TwoD.Adjust         (adjustDia2D)
import           Diagrams.TwoD.Attributes     (splitTextureFills)
import           Diagrams.TwoD.Path           (Clip (Clip))
import           Diagrams.TwoD.Text

import           Diagrams.Core.Compile
import           Diagrams.Core.Transform      (matrixHomRep)
import           Diagrams.Core.Types          (Annotation (..))

import qualified Graphics.Static               as  H

-- | This data declaration is simply used as a token to distinguish
--   this rendering engine.
data Html5 = Html5
    deriving (Eq, Ord, Read, Show, Typeable)

type B = Html5

type instance V Html5 = V2
type instance N Html5 = Double

data Html5State = Html5State { _accumStyle :: Style V2 Double
                             , _csPos :: (Double, Double) }

makeLenses ''Html5State

instance Default Html5State where
  def = Html5State { _accumStyle = mempty
                    , _csPos = (0,0) }

type RenderM a = SS.StateStackT Html5State H.CanvasFree a

liftC :: H.CanvasFree a -> RenderM a
liftC = lift

runRenderM :: RenderM a -> H.CanvasFree a
runRenderM = flip SS.evalStateStackT def

instance Monoid (Render Html5 V2 Double) where
  mempty  = C $ return ()
  (C c1) `mappend` (C c2) = C (c1 >> c2)

instance Backend Html5 V2 Double where
  data Render  Html5 V2 Double = C (RenderM ())
  type Result  Html5 V2 Double = Builder
  data Options Html5 V2 Double = Html5Options
          { _html5Size  :: SizeSpec V2 Double   -- ^ the requested size
          , _standalone :: Bool
          , _canvasId   :: String
          }

  renderRTree :: Html5 -> Options Html5 V2 Double -> RTree Html5 V2 Double Annotation
                        -> Result Html5 V2 Double
  renderRTree _ opts rt = buildF (round w) (round h)
                        . runRenderM
                        . runC
                        . toRender $ rt
    where
      V2 w h = specToSize 100 (opts^.size)
      buildF | opts^.standalone = H.buildDoc
             | otherwise        = \wd ht -> H.buildScript' wd ht (opts^.canvasId.to T.pack)

  adjustDia c opts d = adjustDia2D size c opts (d # reflectY)

runC :: Render Html5 V2 Double -> RenderM ()
runC (C r) = r

toRender :: RTree Html5 V2 Double Annotation -> Render Html5 V2 Double
toRender = fromRTree
  . Node (RStyle (mempty # recommendFillColor transparent))
  . (:[])
  . splitTextureFills
    where
      fromRTree (Node (RPrim p) _) = render Html5 p
      fromRTree (Node (RStyle sty) rs) = C $ do
        save
        html5Style sty
        accumStyle %= (<> sty)
        runC $ F.foldMap fromRTree rs
        restore
      fromRTree (Node _ rs) = F.foldMap fromRTree rs

-- lenses --------------------------------------------------------------

-- | Output size.
size :: Lens' (Options Html5 V2 Double) (SizeSpec V2 Double)
size = lens _html5Size $ \o i -> o { _html5Size = i }

-- | \"id\" for the @<canvas>@ element (prepended to \"StaticCanvas\").
--   Only applies to non-'standalone' diagrams.
canvasId :: Lens' (Options Html5 V2 Double) String
canvasId = lens _canvasId $ \o i -> o { _canvasId = i }

-- | Should the output be a standalone html file. Otherwise the output
--   is a @<canvas>@ element followed by a @<script>@ calling the
--   canvas.
standalone :: Lens' (Options Html5 V2 Double) Bool
standalone = lens _standalone $ \o i -> o { _standalone = i }

move :: Double -> Double -> RenderM ()
move x y = do csPos .= (x, y)

save :: RenderM ()
save = SS.save >> liftC H.save

restore :: RenderM ()
restore = liftC H.restore >> SS.restore

newPath :: RenderM ()
newPath = liftC $ H.beginPath

closePath :: RenderM ()
closePath = liftC $ H.closePath

moveTo :: Double -> Double -> RenderM ()
moveTo x y = do
  liftC $ H.moveTo x y
  move x y

relLineTo :: Double -> Double -> RenderM ()
relLineTo x y = do
  (p, q) <- use csPos
  let x' = p + x
      y' = q + y
  liftC $ H.lineTo x' y'
  move x' y'

relCurveTo :: Double -> Double -> Double -> Double -> Double -> Double -> RenderM ()
relCurveTo ax ay bx by cx cy = do
  p <- use csPos
  let [(ax',ay'),(bx',by'),(cx',cy')] = map (p +) [(ax,ay),(bx,by),(cx,cy)]
  liftC $ H.bezierCurveTo ax' ay' bx' by' cx' cy'
  move cx' cy'

-- | Get an accumulated style attribute from the render monad state.
getStyleAttrib :: AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib f = (fmap f . getAttr) <$> use accumStyle

-- | From the HTML5 canvas specification regarding line width:
--
--     "On setting, zero, negative, infinite, and NaN values must be
--     ignored, leaving the value unchanged; other values must change
--     the current value to the new value.
--
--   Hence we must implement a line width of zero by simply not
--   sending a stroke command.
stroke :: RenderM ()
stroke = do
  -- The default value of 0.5 is somewhat arbitary since lineWidth should never
  -- be 'Nothing'. 0.5 is choose since it is the lower bound of the
  -- default.
  w <- fromMaybe 0.5 <$> getStyleAttrib getLineWidth
  when (w > (0 :: Double)) (liftC H.stroke)

fill :: RenderM ()
fill = liftC $ H.fill

clip :: RenderM ()
clip = liftC $ H.clip

byteRange :: Double -> Int
byteRange d = floor (d * 255)

texture :: (H.Style -> H.CanvasFree ()) -> Texture Double -> Double -> RenderM ()
texture styleFn (SC (SomeColor c))  o = liftC . styleFn $ s
  where s = H.ColorStyle $ colorJS c o

texture styleFn (LG g) _ = liftC $ do
  grd <- H.createLinearGradient x0 y0 x1 y1
  mapM_ (addStop grd) stops
  styleFn grd
  where
    (x0, y0) = unp2 $ transform (g^.lGradTrans) (g^.lGradStart)
    (x1, y1) = unp2 $ transform (g^.lGradTrans) (g^.lGradEnd)
    stops = map (\s -> ( s^.stopFraction , colorJS (s^.stopColor) 1)) (g^.lGradStops)

texture styleFn (RG g) _ = liftC $ do
  grd <- H.createRadialGradient x0 y0 r0 x1 y1 r1
  mapM_ (addStop grd) stops
  styleFn grd
  where
    (r0, r1) = (s * g^.rGradRadius0, s * g^.rGradRadius1)
    (x0, y0) = unp2 $ transform (g^.rGradTrans) (g^.rGradCenter0)
    (x1, y1) = unp2 $ transform (g^.rGradTrans) (g^.rGradCenter1)
    stops = map (\st -> ( st^.stopFraction , colorJS (st^.stopColor) 1)) (g^.rGradStops)
    s = avgScale $ g^.rGradTrans

addStop :: H.Style -> (Double, H.Color) -> H.CanvasFree ()
addStop g (f, c) = H.addColorStop f c g

colorJS :: (Color c) => c -> Double  -> H.Color
colorJS c o = H.RGBA (byteRange r) (byteRange g) (byteRange b) (o * realToFrac a)
  where
    (r,g,b,a) = colorToSRGBA . toAlphaColour $  c

html5Transform :: T2 Double -> RenderM ()
html5Transform tr = liftC $ H.transform ax ay bx by tx ty
  where
    [[ax, ay], [bx, by], [tx, ty]] = (map . map) realToFrac (matrixHomRep tr)

strokeTexture :: Texture Double -> Double -> RenderM ()
strokeTexture = texture H.strokeStyle

fillTexture :: Texture Double -> Double -> RenderM ()
fillTexture = texture H.fillStyle

fromLineCap :: LineCap -> H.LineCapStyle
fromLineCap LineCapRound  = H.LineCapRound
fromLineCap LineCapSquare = H.LineCapSquare
fromLineCap _             = H.LineCapButt

fromLineJoin :: LineJoin -> H.LineJoinStyle
fromLineJoin LineJoinRound = H.LineJoinRound
fromLineJoin LineJoinBevel = H.LineJoinBevel
fromLineJoin _             = H.LineJoinMiter

showFontJS :: FontWeight -> FontSlant -> Double -> String -> T.Text
showFontJS wgt slant sz fnt = T.concat [a, " ", b, " ", c, " ", d]
  where
    a = case wgt of
          FontWeightBold   -> "bold"
          _                -> ""
    b = case slant of
          FontSlantNormal  -> ""
          FontSlantItalic  -> "italic"
          FontSlantOblique -> "oblique"
    c = T.concat [T.pack $ show sz, "pt"]
    d = T.pack fnt

renderC :: (Renderable a Html5, V a ~ V2, N a ~ Double) => a -> RenderM ()
renderC a = case (render Html5 a) of C r -> r

html5Style :: Style v Double  -> RenderM ()
html5Style s = sequence_
              . catMaybes $ [ handle clip'
                            , handle lWidth
                            , handle lCap
                            , handle lJoin
                            ]
  where handle :: (AttributeClass a) => (a -> RenderM ()) -> Maybe (RenderM ())
        handle f = f `fmap` getAttr s
        clip'    = mapM_ (\p -> html5Path p >> clip) . op Clip
        lWidth   = liftC . H.lineWidth . getLineWidth
        lCap     = liftC . H.lineCap . fromLineCap . getLineCap
        lJoin    = liftC . H.lineJoin . fromLineJoin . getLineJoin

instance Renderable (Segment Closed V2 Double) Html5 where
  render _ (Linear (OffsetClosed (V2 x y))) = C $ relLineTo x y
  render _ (Cubic (V2 x1 y1)
                  (V2 x2 y2)
                  (OffsetClosed (V2 x3 y3)))
    = C $ relCurveTo x1 y1 x2 y2 x3 y3

instance Renderable (Trail V2 Double) Html5 where
  render _ = withTrail renderLine renderLoop
    where
      renderLine ln = C $ do
        mapM_ renderC (lineSegments ln)
      renderLoop lp = C $ do
        case loopSegments lp of
          (segs, Linear _) -> mapM_ renderC segs
          _ -> mapM_ renderC (lineSegments . cutLoop $ lp)
        closePath

instance Renderable (Path V2 Double) Html5 where
  render _ p = C $ do
    html5Path p
    f <- getStyleAttrib getFillTexture
    s <- getStyleAttrib getLineTexture
    o <- fromMaybe 1 <$> getStyleAttrib getOpacity
    save
    when (isJust f) (fillTexture (fromJust f) (realToFrac o) >> fill)
    strokeTexture (fromMaybe (SC (SomeColor (black :: Colour Double))) s) (realToFrac o)
    stroke
    restore

-- Add a path to the Html5 context, without stroking or filling it.
html5Path :: Path V2 Double -> RenderM ()
html5Path (Path trs) = do
    newPath
    F.mapM_ renderTrail trs
  where
    renderTrail (viewLoc -> (unp2 -> p, tr)) = do
      uncurry moveTo p
      renderC tr

instance Renderable (Text Double) Html5 where
  render _ (Text tr al str) = C $ do
    tf      <- fromMaybe "Calibri" <$> getStyleAttrib getFont
    sz      <- fromMaybe 12 <$> getStyleAttrib getFontSize
    slant   <- fromMaybe FontSlantNormal <$> getStyleAttrib getFontSlant
    fw      <- fromMaybe FontWeightNormal <$> getStyleAttrib getFontWeight
    tx      <- fromMaybe (SC (SomeColor (black :: Colour Double)))
               <$> getStyleAttrib getFillTexture
    o       <- fromMaybe 1 <$> getStyleAttrib getOpacity
    let fSize = avgScale tr * sz
        fnt = showFontJS fw slant fSize tf
        vAlign = case al of
                   BaselineText -> H.TextBaselineIdeographic
                   BoxAlignedText _ h -> case h of
                     h' | h' <= 0.25 -> H.TextBaselineBottom
                     h' | h' >= 0.75 -> H.TextBaselineTop
                     _ -> H.TextBaselineMiddle
        hAlign = case al of
                   BaselineText -> H.TextAlignStart
                   BoxAlignedText w _ -> case w of
                     w' | w' <= 0.25 -> H.TextAlignStart
                     w' | w' >= 0.75 -> H.TextAlignEnd
                     _ -> H.TextAlignCenter
    save
    liftC $ H.textBaseline vAlign
    liftC $ H.textAlign hAlign
    liftC $ H.font fnt
    fillTexture tx (realToFrac o)
    html5Transform (tr <> reflectionY)
    liftC $ H.fillText (T.pack str) 0 0
    restore

instance Renderable (DImage Double External) Html5 where
  render _ (DImage path w h tr) = C $ do
    let ImageRef file = path
    save
    html5Transform (tr <> reflectionY)
    img <- liftC $ H.newImage (T.pack file)
    liftC $ H.drawImageSize img (fromIntegral (-w) / 2) (fromIntegral (-h) / 2)
                                (fromIntegral w) (fromIntegral h)
    restore

renderHtml5 :: FilePath -> SizeSpec V2 Double -> QDiagram Html5 V2 Double Any -> IO ()
renderHtml5 outFile  spec
  = L.writeFile outFile
  . toLazyText
  . renderDia Html5 (Html5Options spec True "")