{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE 
    DeriveDataTypeable
  , FlexibleInstances
  , MultiParamTypeClasses
  , StandaloneDeriving
  , TypeFamilies
  #-}

{-|
Module      : Diagrams.Backend.HsQML.DiagramObj.Renderer
Description : Rendering functions and instances.
Copyright   : (c) Marcin Mrotek, 2015
License     : BSD-3
Maintainer  : marcin.jan.mrotek@gmail.com
Stability   : experimental

Interface to the Diagrams backend machinery.
-} 

module Diagrams.Backend.HsQML.Render where

import Diagrams.Backend.HsQML.DiagramObj

import Data.Foldable (foldl', foldMap)
import Control.Lens hiding ((#), from, transform, under)
import Data.Monoid
import Data.Tree
import Data.Typeable
import Diagrams.Prelude hiding ((<>), start, moveTo, stroke, text, from)
import Diagrams.Core.Types
import Diagrams.TwoD.Adjust
import Diagrams.TwoD.Attributes(LineTexture, FillTexture) -- imported for haddock hyperlinks
import Diagrams.TwoD.Path (getFillRule)
import Diagrams.TwoD.Text hiding (text)
import Graphics.QML

data HsQML = HsQML deriving Typeable

type instance V HsQML = V2
type instance N HsQML = Double

instance Backend HsQML V2 Double where
  data Render HsQML V2 Double = HsQMLRender {getObj :: DiagramObj ()}
  type Result HsQML V2 Double = IO (ObjRef (DiagramObj ()))
  data Options HsQML V2 Double = HsQMLOptions { _sizeSpec :: SizeSpec V2 Double }
  renderRTree HsQML opts tree = newObjectDC . getObj $ renderHsQML opts tree
  adjustDia HsQML opts dia = (opts', reflectionY <> trans, dia' # scale 0.87 `underT` inv trans)
    where
      (opts', trans, dia') = adjustDia2D sizeSpec HsQML opts $ reflectY dia

sizeSpec 
  :: Functor f => (SizeSpec V2 Double -> f (SizeSpec V2 Double)) -> Options HsQML V2 Double -> f (Options HsQML V2 Double) 
-- ^A lens from HsQML backend options to a 'SizeSpec V2 Double'.
-- 
-- @ sizeSpec :: 'Lens'' ('Options' 'HsQML' 'V2') ('SizeSpec' 'V2' 'Double') @
sizeSpec = lens (\(HsQMLOptions s) -> s) (\_ s -> HsQMLOptions s)

addAnnotation :: Annotation -> DiagramObj ()
-- ^Currently not supported, returns 'mempty'.
addAnnotation _ = mempty

useStyle :: Style V2 Double -> DiagramObj ()
{-^
Apply style to a Context2D. Currently supports the following 'Attribute's:

 * 'LineCap'
 * 'LineJoin'
 * 'LineMiterLimit'
 * 'Opacity'
 * 'LineWidth'
 * 'LineTexture'
 * 'FillTexture'
 * 'Font'
 * 'FillRule'
-}
useStyle s = maybe mempty id . foldMap ($s) $
    [ handle $ setLineCap.getLineCap 
    , handle $ setLineJoin.getLineJoin
    , handle setLineMiterLimit
    , handle setOpacity
    , handle setLineWidth
    , handle setLineTexture
    , handle setFillTexture
    , handle setFont
    , handle $ setFillRule.getFillRule
    ]
  where handle f = fmap f.getAttr

renderHsQML :: Options HsQML V2 Double -> RTree HsQML V2 Double Annotation -> Render HsQML V2 Double
-- ^Render a 'RTree' to an intermediate representation.
renderHsQML opts (Node root ns) =
    case root of
       RStyle        s  -> HsQMLRender $ save <> useStyle s <> proceed <> restore
       RAnnot        a -> HsQMLRender $ addAnnotation a <> proceed
       RPrim         p  -> render HsQML p
       REmpty           -> HsQMLRender $ proceed
  where
    proceed = mconcat $ map (getObj . renderHsQML opts) ns

instance Renderable (Text Double) HsQML where
  render HsQML (Text t2 _ str) = HsQMLRender $ text str x y 
     where (x,y) = unp2 . papply t2 $ origin

renderTrail :: P2 Double -> Trail V2 Double -> DiagramObj ()
-- ^Render a trail, closing loops.
renderTrail start trail = mconcat
    [ beginPath
    , moveTo start
    , withTrail (\(Line (SegTree tree)        ) -> fst $ renderTree tree)
                (\(Loop (SegTree tree) closing) -> 
                    let (d, prev) = renderTree tree 
                    in d <> closeSeg closing prev start <> closePath <> fill)
                trail
    , stroke
    ]
  where renderTree = foldl' renderNode (mempty, start)
        renderNode (d, p) seg = ( d <> renderSeg p seg
                               , next) 
          where next = p .+^ segOffset seg

renderSeg :: P2 Double -> Segment Closed V2 Double -> DiagramObj ()
-- ^Render a closed segment beginning on a given point.
renderSeg from (Linear (OffsetClosed v)) = lineTo (from .+^ v)
renderSeg from (Cubic c1 c2 (OffsetClosed v)) = bezierCurveTo (from .+^ c1) (from .+^ c2) (from .+^ v)

closeSeg 
  :: Segment Open V2 Double -- ^The last segment of a loop.
  -> P2 Double -- ^First end.
  -> P2 Double -- ^Second end.
  -> DiagramObj ()
-- ^Close a loop using the last (open) segment and two endpoints.
closeSeg (Linear _) _ start = lineTo start
closeSeg (Cubic c1 c2 _) prev start = bezierCurveTo (prev .+^ c1) (prev .+^ c2) start 

instance Renderable (Trail V2 Double) HsQML where
  render HsQML trail = HsQMLRender $ renderTrail origin trail

instance Renderable (Path V2 Double) HsQML where
  render HsQML path = HsQMLRender . foldMap (uncurry renderTrail . viewLoc) $ pathTrails path