packages feed

diagrams-hsqml (empty) → 0.0.0.0

raw patch · 11 files changed

+984/−0 lines, 11 filesdep +basedep +colourdep +containerssetup-changed

Dependencies added: base, colour, containers, diagrams-core, diagrams-lib, hsqml, lens, text, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Marcin Mrotek++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Marcin Mrotek nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ diagrams-hsqml.cabal view
@@ -0,0 +1,47 @@+-- Initial diagrams-hsqml.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                diagrams-hsqml+version:             0.0.0.0+synopsis:            HsQML (Qt5) backend for Diagrams+description:         +  `diagrams-hsqml` is a `diagrams` backend painting on a QtQuick Canvas.+  .+  To use the package, you only need the main module "Diagrams.Backend.HsQML"+  .+  Example usage and QML scripts provided in "Diagrams.Backend.HsQML.Tutorial"+homepage:            https://github.com/marcinmrotek/diagrams-hsqml+license:             BSD3+license-file:        LICENSE+author:              Marcin Mrotek+maintainer:          marcin.jan.mrotek@gmail.com+-- copyright:           +category:            Graphics+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10++library+  exposed-modules:     Diagrams.Backend.HsQML+                       Diagrams.Backend.HsQML.GradientObj+                       Diagrams.Backend.HsQML.DiagramObj+                       Diagrams.Backend.HsQML.DiagramObj.Signals+                       Diagrams.Backend.HsQML.DiagramObj.Type+                       Diagrams.Backend.HsQML.DiagramObj.Commands+                       Diagrams.Backend.HsQML.Render+                       Diagrams.Backend.HsQML.Tutorial+  -- other-modules:       +  -- other-extensions:    +  build-depends:       base >=4.7 && <4.8+                     , colour+                     , containers+                     , diagrams-core+                     , diagrams-lib+                     , hsqml+                     , lens+                     , text+                     , transformers+  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options:       -Wall+
+ src/Diagrams/Backend/HsQML.hs view
@@ -0,0 +1,33 @@+{-|+Module      : Diagrams.Backend.HsQML+Description : Main module.+Copyright   : (c) Marcin Mrotek, 2015+License     : BSD-3+Maintainer  : marcin.jan.mrotek@gmail.com+Stability   : experimental++The end-user API.+-} ++module Diagrams.Backend.HsQML (+    renderHsQML+  , SizeSpec2D(..)+  , mkSizeSpec+  , HsQML(..), Options(..)+  , B+  , DiagramObj+) where++import Diagrams.Core.Types(Backend(..))+import Diagrams.Backend.HsQML.Render hiding (renderHsQML)+import Diagrams.Backend.HsQML.DiagramObj.Type+import Diagrams.Core+import Diagrams.TwoD.Size+import Diagrams.TwoD.Types+import Graphics.QML++type B = HsQML++renderHsQML :: SizeSpec2D -> Diagram HsQML R2 -> IO (ObjRef (DiagramObj ()))+-- ^Render a diagram to a QML object that controls a Canvas.+renderHsQML s = renderDia HsQML (HsQMLOptions s)
+ src/Diagrams/Backend/HsQML/DiagramObj.hs view
@@ -0,0 +1,8 @@+module Diagrams.Backend.HsQML.DiagramObj (+    module Diagrams.Backend.HsQML.DiagramObj.Commands+  , module Diagrams.Backend.HsQML.DiagramObj.Type+) where++import Diagrams.Backend.HsQML.DiagramObj.Commands+import Diagrams.Backend.HsQML.DiagramObj.Type+
+ src/Diagrams/Backend/HsQML/DiagramObj/Commands.hs view
@@ -0,0 +1,182 @@+{-|+Module      : Diagrams.Backend.HsQML.DiagramObj.Commands+Description : Functions to create a DiagramObj containing a single command.+Copyright   : (c) Marcin Mrotek, 2015+License     : BSD-3+Maintainer  : marcin.jan.mrotek@gmail.com+Stability   : experimental++As 'DiagramObj' is a 'Monoid', complex diagrams may be optained by 'mappend'ing simple ones together.+This module provides functions creating 'DiagramObj's containing a single command each.+-}++module Diagrams.Backend.HsQML.DiagramObj.Commands where++import Diagrams.Backend.HsQML.GradientObj+import Diagrams.Backend.HsQML.DiagramObj.Type+import qualified Diagrams.Backend.HsQML.DiagramObj.Signals as S+import Data.Text (pack)++import Control.Lens hiding (over)+import Control.Monad (forM_)+import Control.Monad.IO.Class+import Data.Colour+import Data.Colour.SRGB+import Diagrams.Prelude+import Diagrams.TwoD.Attributes+import Diagrams.TwoD.Text+import Graphics.QML++save :: DiagramObj ()+-- ^Push the current state (style, font, etc) onto the state stack.+save = DiagramObj $ fireSignal S.save++restore :: DiagramObj ()+-- ^Pop the current state (style, font, etc) from the state stack.+restore = DiagramObj $ fireSignal S.restore++text :: String -> Double -> Double -> DiagramObj ()+-- ^Display text on a specified point.+text txt x y = DiagramObj $ \this -> fireSignal S.renderText this (pack txt) x y++beginPath :: DiagramObj ()+-- ^Start assembling a new path.+beginPath = DiagramObj $ fireSignal S.beginPath++closePath :: DiagramObj ()+-- ^Connect the current path vertex to the start of the path.+closePath = DiagramObj $ fireSignal S.closePath++moveTo :: P2 -> DiagramObj ()+-- ^Change the current position.+moveTo p = let (x,y) = unp2 p in DiagramObj $ \this -> fireSignal S.moveTo this x y++stroke :: DiagramObj ()+-- ^Stroke the current path.+stroke = DiagramObj $ fireSignal S.stroke++fill :: DiagramObj ()+-- ^Fill the current path. Works only on paths that were previously 'close'd.+fill = DiagramObj $ fireSignal S.fill++lineTo :: P2 -> DiagramObj ()+-- ^Draw a straight line from the current position to a given point.+lineTo p = DiagramObj $ \this -> fireSignal S.lineTo this x y+  where (x,y) = unp2 p++bezierCurveTo +  :: P2 -- ^First control point.+  -> P2 -- ^Second control point+  -> P2 -- ^End point.+   -> DiagramObj () +-- ^Draw a bezier curve from the current position to a given point, using two control points.+bezierCurveTo cp1 cp2 p = DiagramObj $ \this -> +    fireSignal S.bezierCurveTo this cp1x cp1y cp2x cp2y x y +  where (cp1x, cp1y) = unp2 cp1+        (cp2x, cp2y) = unp2 cp2+        (  x,   y) = unp2 p++setLineCap :: LineCap -> DiagramObj ()+-- ^Set the line cap style.+setLineCap cap = DiagramObj $ \this -> fireSignal S.setLineCap this . pack $+   case cap of+     LineCapButt   -> "butt"+     LineCapRound  -> "round"+     LineCapSquare -> "square"++setLineJoin :: LineJoin -> DiagramObj ()+-- ^Set the line join style.+setLineJoin j = DiagramObj $ \this -> fireSignal S.setLineJoin this . pack $+   case j of+     LineJoinMiter -> "miter"+     LineJoinRound -> "round"+     LineJoinBevel -> "bevel"++setLineMiterLimit :: LineMiterLimit -> DiagramObj ()+-- ^Set the miter limit.+setLineMiterLimit m = DiagramObj $ \this -> fireSignal S.setLineMiterLimit this (getLineMiterLimit m)++setOpacity :: Opacity -> DiagramObj ()+-- ^Set the global alpha (subject to 'save' and 'restore').+setOpacity o = DiagramObj $ \this -> fireSignal S.setGlobalAlpha this (getOpacity o)++setLineWidth :: LineWidth -> DiagramObj ()+-- ^Set the line width (output coordinates assumed).+setLineWidth w = DiagramObj $ \this -> fireSignal S.setLineWidth this (fromOutput $ getLineWidth w)++getRGBA :: SomeColor -> (Double, Double, Double, Double)+-- ^Convert a colour to a tuple of (r,g,b,a) components.+getRGBA c = (r,g,b,a)+  where RGB r g b = fromIntegral <$> toSRGB24 (ac `over` black)+        a = alphaChannel ac+        ac = toAlphaColour c++getLinearGradient :: LGradient -> DiagramObj (ObjRef GradientObj)+-- ^Created a linear gradient.+getLinearGradient lg = DiagramObj $ \this -> do+    g <- newGradient+    fireSignal S.connectLinearGradient this g x0 y0 x1 y1+    return g+  where (x0,y0) = unp2.papply (lg^.lGradTrans) $ lg^.lGradStart+        (x1,y1) = unp2.papply (lg^.lGradTrans) $ lg^.lGradEnd+   +getRadialGradient :: RGradient -> DiagramObj (ObjRef GradientObj)+-- ^Create a radial gradient.+getRadialGradient rg = DiagramObj $ \this -> do+    g <- newGradient+    fireSignal S.connectRadialGradient this g x0 y0 r0 x1 y1 r1+    return g+  where (x0,y0) = unp2.papply (rg^.rGradTrans) $ rg^.rGradCenter0+        (x1,y1) = unp2.papply (rg^.rGradTrans) $ rg^.rGradCenter1+        r0 = rg^.rGradRadius0+        r1 = rg^.rGradRadius1++setStrokeColour :: SomeColor -> DiagramObj ()+-- ^Set stroke style to a flat colour.+setStrokeColour c = DiagramObj $ \this -> fireSignal S.setStrokeColour this r g b a +   where (r,g,b,a) = getRGBA c++setLineGradient :: DiagramObj ()+-- ^Set stroke style to a previously assembled gradient.+setLineGradient = DiagramObj $ fireSignal S.setLineGradient++setLineTexture :: LineTexture -> DiagramObj ()+-- ^Set stroke style.+setLineTexture tex =+   case getLineTexture tex of+     SC c -> setStrokeColour c+     LG l -> getLinearGradient l >>= liftIO.(setGradient $ l^.lGradStops) >> setLineGradient+     RG r -> getRadialGradient r >>= liftIO.(setGradient $ r^.rGradStops) >> setLineGradient++setGradient :: [GradientStop] -> ObjRef GradientObj -> IO ()+-- ^Add colour stops to a gradient.+setGradient stops grad = forM_ stops +   $ \stop -> let (r,g,b,a) = getRGBA (stop^.stopColor)+                  o = stop^.stopFraction+              in addColourStop grad r g b a o ++setFillColour :: SomeColor -> DiagramObj ()+-- ^Set fill style to a flat colour.+setFillColour c = DiagramObj $ \this -> fireSignal S.setFillColour this r g b a +  where (r,g,b,a) = getRGBA c++setFillGradient :: DiagramObj ()+-- ^Set fill style to a previously defined gradient.+setFillGradient = DiagramObj $ fireSignal S.setFillGradient++setFillTexture :: FillTexture -> DiagramObj ()+-- ^Set fill style.+setFillTexture tex =+   case getFillTexture tex of+    SC c -> setFillColour c+    LG l -> getLinearGradient l >>= liftIO.(setGradient $ l^.lGradStops) >> setFillGradient+    RG r -> getRadialGradient r >>= liftIO.(setGradient $ r^.rGradStops) >> setFillGradient++setFont :: Font -> DiagramObj ()+-- ^Set font.+setFont f = DiagramObj $ \this -> fireSignal S.setFont this (pack $ getFont f)++setFillRule :: FillRule -> DiagramObj ()+-- ^Set fill rule.+setFillRule EvenOdd = DiagramObj $ fireSignal S.oddEvenFill+setFillRule Winding = DiagramObj $ fireSignal S.windingFill
+ src/Diagrams/Backend/HsQML/DiagramObj/Signals.hs view
@@ -0,0 +1,198 @@+{-# OPTIONS_HADDOCK show-extensions #-}+{-# LANGUAGE+    DeriveDataTypeable+  , EmptyDataDecls+  , TypeFamilies+  #-}++{-|+Module      : Diagrams.Backend.HsQML.DiagramObj.Signals +Description : Signals used by DiagramObj.+Copyright   : (c) Marcin Mrotek, 2015+License     : BSD-3+Maintainer  : marcin.jan.mrotek@gmail.com+Stability   : experimental++Ceci est une boilerplate.+-} ++module Diagrams.Backend.HsQML.DiagramObj.Signals where++import Diagrams.Backend.HsQML.GradientObj (GradientObj)++import Data.Proxy+import Data.Text (Text)+import Data.Typeable+import Graphics.QML++data Save                  deriving Typeable+data Restore               deriving Typeable+data RenderText            deriving Typeable+data BeginPath             deriving Typeable+data ClosePath             deriving Typeable+data MoveTo                deriving Typeable+data Stroke                deriving Typeable+data Fill                  deriving Typeable+data LineTo                deriving Typeable+data BezierCurveTo         deriving Typeable+data SetLineCap            deriving Typeable+data SetLineJoin           deriving Typeable+data SetLineMiterLimit     deriving Typeable+data SetGlobalAlpha        deriving Typeable+data SetLineWidth          deriving Typeable+data SetStrokeColour       deriving Typeable+data SetFillColour         deriving Typeable+data ConnectLinearGradient deriving Typeable+data ConnectRadialGradient deriving Typeable+data SetLineGradient       deriving Typeable+data SetFillGradient       deriving Typeable+data SetFont               deriving Typeable+data OddEvenFill           deriving Typeable+data WindingFill           deriving Typeable++save :: Proxy Save+save = Proxy++restore :: Proxy Restore+restore = Proxy++renderText :: Proxy RenderText+renderText = Proxy++beginPath :: Proxy BeginPath+beginPath = Proxy++closePath :: Proxy ClosePath+closePath = Proxy++moveTo :: Proxy MoveTo+moveTo = Proxy++stroke :: Proxy Stroke+stroke = Proxy++fill :: Proxy Fill+fill = Proxy++lineTo :: Proxy LineTo+lineTo = Proxy++bezierCurveTo :: Proxy BezierCurveTo+bezierCurveTo = Proxy++setLineCap :: Proxy SetLineCap+setLineCap = Proxy++setLineJoin :: Proxy SetLineJoin+setLineJoin = Proxy++setLineMiterLimit :: Proxy SetLineMiterLimit+setLineMiterLimit = Proxy++setGlobalAlpha :: Proxy SetGlobalAlpha+setGlobalAlpha = Proxy++setLineWidth :: Proxy SetLineWidth+setLineWidth = Proxy++setStrokeColour :: Proxy SetStrokeColour+setStrokeColour = Proxy++setFillColour :: Proxy SetFillColour+setFillColour = Proxy++connectLinearGradient :: Proxy ConnectLinearGradient+connectLinearGradient = Proxy++connectRadialGradient :: Proxy ConnectRadialGradient+connectRadialGradient = Proxy++setLineGradient :: Proxy SetLineGradient+setLineGradient = Proxy++setFillGradient :: Proxy SetFillGradient+setFillGradient = Proxy++setFont :: Proxy SetFont+setFont = Proxy++oddEvenFill :: Proxy OddEvenFill+oddEvenFill = Proxy++windingFill :: Proxy WindingFill+windingFill = Proxy++instance SignalKeyClass Save where+   type SignalParams Save = IO ()++instance SignalKeyClass Restore where+   type SignalParams Restore = IO ()++instance SignalKeyClass RenderText where+  type SignalParams RenderText = Text -> Double -> Double -> IO ()++instance SignalKeyClass BeginPath where+  type SignalParams BeginPath = IO ()++instance SignalKeyClass ClosePath where+  type SignalParams ClosePath = IO ()++instance SignalKeyClass MoveTo where+  type SignalParams MoveTo = Double -> Double -> IO ()++instance SignalKeyClass Stroke where+  type SignalParams Stroke = IO ()++instance SignalKeyClass Fill where+  type SignalParams Fill = IO ()++instance SignalKeyClass LineTo where+  type SignalParams LineTo = Double -> Double -> IO ()++instance SignalKeyClass BezierCurveTo where+  type SignalParams BezierCurveTo = +    Double -> Double -> Double -> Double -> Double -> Double -> IO ()++instance SignalKeyClass SetLineCap where+  type SignalParams SetLineCap = Text -> IO ()++instance SignalKeyClass SetLineJoin where+  type SignalParams SetLineJoin = Text -> IO ()++instance SignalKeyClass SetLineMiterLimit where+  type SignalParams SetLineMiterLimit = Double -> IO ()++instance SignalKeyClass SetGlobalAlpha where+  type SignalParams SetGlobalAlpha = Double -> IO ()++instance SignalKeyClass SetLineWidth where+  type SignalParams SetLineWidth = Double -> IO ()++instance SignalKeyClass SetStrokeColour where+  type SignalParams SetStrokeColour = Double -> Double -> Double -> Double -> IO ()++instance SignalKeyClass SetFillColour where+  type SignalParams SetFillColour = Double -> Double -> Double -> Double -> IO ()++instance SignalKeyClass ConnectLinearGradient where+  type SignalParams ConnectLinearGradient = +    ObjRef GradientObj -> Double -> Double -> Double -> Double -> IO () ++instance SignalKeyClass ConnectRadialGradient where+  type SignalParams ConnectRadialGradient = +    ObjRef GradientObj -> Double -> Double -> Double -> Double -> Double -> Double -> IO () ++instance SignalKeyClass SetLineGradient where+  type SignalParams SetLineGradient = IO ()++instance SignalKeyClass SetFillGradient where+  type SignalParams SetFillGradient = IO ()++instance SignalKeyClass SetFont where+  type SignalParams SetFont = Text -> IO ()++instance SignalKeyClass OddEvenFill where+  type SignalParams OddEvenFill = IO ()++instance SignalKeyClass WindingFill where+  type SignalParams WindingFill = IO ()
+ src/Diagrams/Backend/HsQML/DiagramObj/Type.hs view
@@ -0,0 +1,113 @@+{-# OPTIONS_HADDOCK show-extensions #-}+{-# LANGUAGE +    DeriveDataTypeable+  , DeriveFunctor+  , FlexibleInstances+  , GeneralizedNewtypeDeriving +  #-}++{-|+Module      : Diagrams.Backend.HsQML.DiagramObj.Type +Description : Definition of DiagramObj.+Copyright   : (c) Marcin Mrotek, 2015+License     : BSD-3+Maintainer  : marcin.jan.mrotek@gmail.com+Stability   : experimental++The 'DiagramObj' type, together with a corresponding 'DefaultClass' instance that defines the necessary methods and signals for use by QML.+-} +++module Diagrams.Backend.HsQML.DiagramObj.Type where ++import Diagrams.Backend.HsQML.DiagramObj.Signals++import Control.Applicative+import Control.Monad.IO.Class+import Data.Monoid+import Data.Typeable++import Graphics.QML+import Graphics.QML.Objects.ParamNames++{-|+The type to the parts of the diagram are rendered. +The end result of rendering is always a DiagramObj ().+The monoid instance sequences actions on the same argument, with noop as identity.+As DiagramObj is a wrapper over a function to IO, 'Functor', 'Applicative', 'Monad', and 'MonadIO' instances are defined in an expected way.+-}+newtype DiagramObj a = DiagramObj { +-- |Function called on every repaint of the QML.+-- The 'ObjRef' is necessary to fire signals into QML.+    reload :: ObjRef (DiagramObj ()) -> IO a +   }+  deriving (Functor, Typeable)++instance Monoid a => Monoid (DiagramObj a) where+   mempty = DiagramObj $ \_ -> return mempty+   (DiagramObj r1) `mappend` (DiagramObj r2) = +     DiagramObj $ \this -> do+        a <- r1 this+        b <- r2 this+        return $ a `mappend` b++instance Applicative DiagramObj where+   pure a = DiagramObj $ \_ -> return a+   (DiagramObj f') <*> (DiagramObj x') =+     DiagramObj $ \this -> do+        f <- f' this+        x <- x' this+        return $ f x++instance Monad DiagramObj where+   return a = DiagramObj $ \_ -> return a+   (DiagramObj a') >>= f' = +      DiagramObj $ \this -> do+        a <- a' this+        let DiagramObj f = f' a+        f this++instance MonadIO DiagramObj where+   liftIO m = DiagramObj $ \_ -> m++instance DefaultClass (DiagramObj ()) where+  classMembers = +    [ defMethod' "reload" $ \this -> reload (fromObjRef this) this+    , defSignal "save"            save+    , defSignal "restore"         restore+    , defSignal "stroke"          stroke+    , defSignal "fill"            fill+    , defSignal "beginPath"       beginPath+    , defSignal "closePath"       closePath+    , defSignal "setLineGradient" setLineGradient+    , defSignal "setFillGradient" setFillGradient+    , defSignal "oddEvenFill" oddEvenFill+    , defSignal "windingFill" windingFill+    , defSignalNamedParams  "text" renderText+    $ fstName "text" `plusName` "x" `plusName` "y"+    , defSignalNamedParams  "moveTo"        moveTo+    $ fstName "x" `plusName` "y"+    , defSignalNamedParams  "lineTo"        lineTo+    $ fstName "x" `plusName` "y"+    , defSignalNamedParams  "bezierCurveTo" bezierCurveTo+    $ fstName  "cp1x" `plusName` "cp1y" +    `plusName` "cp2x" `plusName` "cp2y"+    `plusName`    "x" `plusName`    "y"+    , defSignalNamedParams "connectLinearGradient" connectLinearGradient+    $ fstName "gradient"+    `plusName` "x0" `plusName` "yo"+    `plusName` "x1" `plusName` "y1"+    , defSignalNamedParams "connectRadialGradient" connectRadialGradient+    $ fstName "gradient"+    `plusName` "x0" `plusName` "yo" `plusName` "r0"+    `plusName` "x1" `plusName` "y1" `plusName` "r1"+    , defSignalNamedParams "setStrokeColour" setStrokeColour+    $ fstName "r" `plusName` "g" `plusName` "b" `plusName` "a"+    , defSignalNamedParams "setFillColour" setFillColour+    $ fstName "r" `plusName` "g" `plusName` "b" `plusName` "a"+    , defSignalNamedParams "setFont" setFont+    $ fstName "font" +    , defSignalNamedParams "setLineWidth" setLineWidth+    $ fstName "setLineWidth"+    ]+
+ src/Diagrams/Backend/HsQML/GradientObj.hs view
@@ -0,0 +1,55 @@+{-# OPTIONS_HADDOCK show-extensions #-}+{-# LANGUAGE +    DeriveDataTypeable +  , TypeFamilies+  #-}++{-|+Module      : Diagrams.Backend.HsQML.DiagramObj.GradientObj+Description : Rendering functions and instances.+Copyright   : (c) Marcin Mrotek, 2015+License     : BSD-3+Maintainer  : marcin.jan.mrotek@gmail.com+Stability   : experimental++A QML object controlling the gradient object.+-} ++module Diagrams.Backend.HsQML.GradientObj where++import Data.Typeable+import Graphics.QML+import Graphics.QML.Objects.ParamNames++data AddColourStopSignal deriving Typeable++addColourStopSignal :: Proxy AddColourStopSignal+addColourStopSignal = Proxy++instance SignalKeyClass AddColourStopSignal where+   type SignalParams AddColourStopSignal = +     Double -> Double -> Double -> Double -> Double -> IO ()++data GradientObj = GradientObj deriving Typeable++instance DefaultClass GradientObj where+   classMembers =+       [ defSignalNamedParams "addStop" addColourStopSignal+       $ fstName "r" `plusName` "g" `plusName` "b" `plusName` "a" `plusName` "offset"+       ]++addColourStop +  :: ObjRef GradientObj -- ^Reference to a gradient object.+  -> Double -- ^Red channel value.+  -> Double -- ^Green channel value.+  -> Double -- ^Blue channel value.+  -> Double -- ^Alpha channel value.+  -> Double -- ^Offset channel value.+  -> IO ()+-- ^Adds a new colour stop to a gradient.+addColourStop this r g b a off = fireSignal addColourStopSignal this r g b a off++newGradient :: IO (ObjRef GradientObj)+-- ^Create a new gradient object.+newGradient = newObjectDC GradientObj +
+ src/Diagrams/Backend/HsQML/Render.hs view
@@ -0,0 +1,136 @@+{-# 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+
+ src/Diagrams/Backend/HsQML/Tutorial.hs view
@@ -0,0 +1,180 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++module Diagrams.Backend.HsQML.Tutorial (+-- * DiagramCanvas QML script+-- $diagramcanvas++-- * Context object+-- $contextobject++-- * Main window+-- $mainwindow++-- * Rendering diagrams+-- $rendering+) where++import Graphics.QML+import Diagrams.Backend.HsQML+import Diagrams.Backend.HsQML.DiagramObj.Type++{- $diagramcanvas+To use this backend you first need a custom Canvas object to handle signals coming from Haskell.+Example script to place in your QML search path (can be next to your main QML document):++> -- DiagramCanvas.qml+>import QtQuick 2.4+>+>Canvas {+>  id: canvas;+>  property variant diagram;+>  renderStrategy: Canvas.Threaded;+>  renderTarget: Canvas.FramebufferObject;+>+>  onDiagramChanged: {+>    var context = canvas.getContext('2d');+>    if(canvas.diagram && context) {+>    console.log("reconnect");+>    canvas.diagram.save.connect(function() {canvas.context.save()})+>    canvas.diagram.restore.connect(function () {canvas.context.restore()});+>    canvas.diagram.text.connect(function (text,x,y) {canvas.context.strokeText(text,x,y)});+>    canvas.diagram.beginPath.connect(function () {canvas.context.beginPath()});+>    canvas.diagram.closePath.connect(function () {canvas.context.closePath()});+>    canvas.diagram.stroke.connect(function () {canvas.context.stroke()});+>    canvas.diagram.fill.connect(function() {canvas.context.fill()});+>    canvas.diagram.moveTo.connect(function (x,y) {canvas.context.moveTo(x,y)});+>    canvas.diagram.lineTo.connect(function (x,y) {canvas.context.lineTo(x,y)});+>    canvas.diagram.bezierCurveTo.connect(function(cp1x,cp1y,cp2x,cp2y,x,y) +>                                           {canvas.context.bezierCurveTo(cp1x,cp1y,cp2x,cp2y,x,y)});+>    canvas.diagram.connectLinearGradient.connect(connectLG);+>    canvas.diagram.connectRadialGradient.connect(connectRG);+>+>    canvas.diagram.setStrokeColour.connect(function(r,g,b,a) +>                                            {canvas.context.strokeStyle = Qt.rgba(r,g,b,a).toString();});+>    canvas.diagram.setFillColour.connect(function(r,g,b,a) +>                                            {canvas.context.fillStyle = Qt.rgba(r,g,b,a)});+>    canvas.diagram.setFont.connect(function(f) {canvas.context.font = f});+>    canvas.diagram.setLineWidth.connect(function(w) {canvas.context.lineWidth = w});+>    canvas.diagram.oddEvenFill.connect(function() {canvas.context.fillRule = Qt.OddEvenFill});+>    canvas.diagram.windingFill.connect(function() {canvas.context.fillRule = Qt.WindingFill});+>    } else {+>     console.log("warning! no diagram or context object to connect");+>    }+>  }+>+>  onPaint: {+>    if(canvas.diagram) {+>      canvas.diagram.reload();+>    }+>  }+>+>  function connectLG(gradient, x0, y0, x1, y1) {+>    var grad = canvas.context.createLinearGradient(x0, y0, x1, y1);+>    gradient.addStop.connect( function(r,g,b,a, off) {grad.addColorStop(off, Qt.rgba(r,g,b,a))});+>    canvas.diagram.setLineGradient.connect(function() {canvas.context.strokeStyle = grad;});+>    canvas.diagram.setFillGradient.connect(function() {canvas.context.fillStyle = grad;});+>+>  }+>+>  function connectRG(gradient, x0, y0, r0, x1, y1, r1) {+>    var grad = canvas.context.createRadialGradient(x0, y0, r0, x1, y1, r1);+>    gradient.addStop.connect(function(r,g,b,a, off) {grad.addColorStop(off, Qt.rgba(r,g,b,a))});+>    canvas.diagram.setLineGradient.connect(function() {canvas.context.strokeStyle = grad;});+>    canvas.diagram.setFillGradient.connect(function() {canvas.context.fillStyle = grad;});+>  }+>}+-}++{- $contextobject+You can make an 'ObjRef' to a 'DiagramObj' available to the QML script by placing it in a property of your context object:++> -- Main.hs+> module Main where+> import Control.Applicative+> import Control.Concurrent+> import Control.Concurrent.MVar+> import Data.Typeable+> import Diagrams.Prelude+> import Diagrams.Backend.HsQML+> import Graphics.QML+>+>data Repaint deriving Typeable+>+>repaint :: Proxy Repaint+>repaint = Proxy+>+>instance SignalKeyClass Repaint where+>  type SignalParams Repaint = IO ()+>+>data MainObj = MainObj +>    { diagramObj :: MVar (ObjRef (DiagramObj ()))+>    }+>  deriving Typeable+>+>instance DefaultClass MainObj where+>  classMembers = +>    [ defPropertySigRO' "mainDiagram" diagramChanged $ \this -> +>       case fromObjRef this of+>          MainObj mvar -> readMVar mvar+>    , defPropertyConst' "self" return+>    , defSignal "repaint" repaint+>    ]+-}++{- $mainwindow+Then, place a DiagramCanvas somewhere in your application, and connect it to the controller object:++> -- main.qml+>import QtQuick 2.0+>import QtQuick.Controls 1.3+>import QtQuick.Window 2.2+>+>ApplicationWindow {+>  title: "test";+>  width: 800;+>  height: 800;+>  visible: true;+>+>  toolBar: ToolBar {+>    ToolButton {+>      onClicked: canvas.repaint();+>    }+>  }+>+>  DiagramCanvas {+>    id: canvas;+>    anchors.fill: parent;+>  +>    function repaint() {+>       canvas.diagram = self.mainDiagram;+>       canvas.paint(canvas.canvasWindow);+>    }+>+>    Connections {+>      target: self;+>      onRepaint: canvas.repaint();+>    }+>  }+>+>}+-}++{- $rendering+The 'renderHsQML' function creates an 'ObjRef' to the controller object.++> -- Main.hs+>diagram :: Diagram B R2+>diagram = circle 1+>+>main :: IO ()+>main = do+>  diag <- renderHsQML (mkSizeSpec (Just 800) (Just 800)) diagram+>  mainObj <- MainObj <$> newMVar diag+>  ctx <- newObjectDC mainObj+>  i <- forkIO . requireEventLoop . liftIO $ fireSignal repaint ctx+>  runEngineLoop defaultEngineConfig+>     { initialDocument = fileDocument "qml/main.qml"+>     , contextObject = Just $ anyObjRef ctx+>     }+>  killThread i+-}