Render.hs

{-# 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)
import Data.Monoid
import Data.Tree
import Data.Typeable
import Diagrams.Prelude hiding ((<>), start, moveTo, stroke, text)
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

instance Backend HsQML R2 where
  data Render HsQML R2 = HsQMLRender {getObj :: DiagramObj ()}
  type Result HsQML R2 = IO (ObjRef (DiagramObj ()))
  data Options HsQML R2 = HsQMLOptions { _sizeSpec :: SizeSpec2D }
  renderRTree HsQML opts tree = newObjectDC . getObj $ renderHsQML opts tree
  adjustDia HsQML opts dia = adjustDia2D sizeSpec HsQML opts (dia # reflectY)

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

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

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

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

renderTrail :: P2 -> Trail R2 -> 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 -> Segment Closed R2 -> 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 R2 -- ^The last segment of a loop.
  -> P2 -- ^First end.
  -> P2 -- ^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 R2) HsQML where
  render HsQML trail = HsQMLRender $ renderTrail origin trail

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