diff --git a/diagrams-hsqml.cabal b/diagrams-hsqml.cabal --- a/diagrams-hsqml.cabal +++ b/diagrams-hsqml.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: diagrams-hsqml -version: 0.0.0.2 +version: 0.1.0.0 synopsis: HsQML (Qt5) backend for Diagrams description: `diagrams-hsqml` is a `diagrams` backend painting on a QtQuick Canvas. @@ -36,16 +36,24 @@ Diagrams.Backend.HsQML.Tutorial -- other-modules: -- other-extensions: - build-depends: base >=4.7 && <4.8 + build-depends: base >=4.8 && < 4.9 , colour , containers - , diagrams-core - , diagrams-lib + , diagrams-core >= 1.3 + , diagrams-lib >= 1.3 , hsqml , lens , text , transformers hs-source-dirs: src default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall + if flag(devel) + ghc-options: -Werror + +Flag devel + Description: Development settings + Manual: True + Default: False + diff --git a/src/Diagrams/Backend/HsQML.hs b/src/Diagrams/Backend/HsQML.hs --- a/src/Diagrams/Backend/HsQML.hs +++ b/src/Diagrams/Backend/HsQML.hs @@ -11,23 +11,22 @@ module Diagrams.Backend.HsQML ( renderHsQML - , SizeSpec2D(..) + , SizeSpec , 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 Diagrams.Size import Graphics.QML type B = HsQML -renderHsQML :: SizeSpec2D -> Diagram HsQML R2 -> IO (ObjRef (DiagramObj ())) +renderHsQML :: SizeSpec V2 Double -> Diagram HsQML -> IO (ObjRef (DiagramObj ())) -- ^Render a diagram to a QML object that controls a Canvas. renderHsQML s = renderDia HsQML (HsQMLOptions s) diff --git a/src/Diagrams/Backend/HsQML/DiagramObj/Commands.hs b/src/Diagrams/Backend/HsQML/DiagramObj/Commands.hs --- a/src/Diagrams/Backend/HsQML/DiagramObj/Commands.hs +++ b/src/Diagrams/Backend/HsQML/DiagramObj/Commands.hs @@ -6,7 +6,7 @@ Maintainer : marcin.jan.mrotek@gmail.com Stability : experimental -As 'DiagramObj' is a 'Monoid', complex diagrams may be optained by 'mappend'ing simple ones together. +As 'DiagramObj' is a 'Monoid', complex diagrams may be obtained by 'mappend'ing simple ones together. This module provides functions creating 'DiagramObj's containing a single command each. -} @@ -22,7 +22,7 @@ import Control.Monad.IO.Class import Data.Colour import Data.Colour.SRGB -import Diagrams.Prelude +import Diagrams.Prelude hiding (over) import Diagrams.TwoD.Attributes import Diagrams.TwoD.Text import Graphics.QML @@ -47,7 +47,7 @@ -- ^Connect the current path vertex to the start of the path. closePath = DiagramObj $ fireSignal S.closePath -moveTo :: P2 -> DiagramObj () +moveTo :: P2 Double -> DiagramObj () -- ^Change the current position. moveTo p = let (x,y) = unp2 p in DiagramObj $ \this -> fireSignal S.moveTo this x y @@ -59,15 +59,15 @@ -- ^Fill the current path. Works only on paths that were previously 'close'd. fill = DiagramObj $ fireSignal S.fill -lineTo :: P2 -> DiagramObj () +lineTo :: P2 Double -> 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. + :: P2 Double -- ^First control point. + -> P2 Double -- ^Second control point + -> P2 Double -- ^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 -> @@ -100,9 +100,9 @@ -- ^Set the global alpha (subject to 'save' and 'restore'). setOpacity o = DiagramObj $ \this -> fireSignal S.setGlobalAlpha this (getOpacity o) -setLineWidth :: LineWidth -> DiagramObj () +setLineWidth :: LineWidth Double -> DiagramObj () -- ^Set the line width (output coordinates assumed). -setLineWidth w = DiagramObj $ \this -> fireSignal S.setLineWidth this (fromOutput $ getLineWidth w) +setLineWidth w = DiagramObj $ \this -> fireSignal S.setLineWidth this (getLineWidth w) getRGBA :: SomeColor -> (Double, Double, Double, Double) -- ^Convert a colour to a tuple of (r,g,b,a) components. @@ -111,7 +111,7 @@ a = alphaChannel ac ac = someToAlpha c -getLinearGradient :: LGradient -> DiagramObj (ObjRef GradientObj) +getLinearGradient :: LGradient Double -> DiagramObj (ObjRef GradientObj) -- ^Create a linear gradient. getLinearGradient lg = DiagramObj $ \this -> do g <- newGradient @@ -120,7 +120,7 @@ where (x0,y0) = unp2.papply (lg^.lGradTrans) $ lg^.lGradStart (x1,y1) = unp2.papply (lg^.lGradTrans) $ lg^.lGradEnd -getRadialGradient :: RGradient -> DiagramObj (ObjRef GradientObj) +getRadialGradient :: RGradient Double -> DiagramObj (ObjRef GradientObj) -- ^Create a radial gradient. getRadialGradient rg = DiagramObj $ \this -> do g <- newGradient @@ -140,7 +140,7 @@ -- ^Set stroke style to a previously assembled gradient. setLineGradient = DiagramObj $ fireSignal S.setLineGradient -setLineTexture :: LineTexture -> DiagramObj () +setLineTexture :: LineTexture Double -> DiagramObj () -- ^Set stroke style. setLineTexture tex = case getLineTexture tex of @@ -148,7 +148,7 @@ LG l -> getLinearGradient l >>= liftIO.(setGradient $ l^.lGradStops) >> setLineGradient RG r -> getRadialGradient r >>= liftIO.(setGradient $ r^.rGradStops) >> setLineGradient -setGradient :: [GradientStop] -> ObjRef GradientObj -> IO () +setGradient :: [GradientStop Double] -> ObjRef GradientObj -> IO () -- ^Add colour stops to a gradient. setGradient stops grad = forM_ stops $ \stop -> let (r,g,b,a) = getRGBA (stop^.stopColor) @@ -164,7 +164,7 @@ -- ^Set fill style to a previously defined gradient. setFillGradient = DiagramObj $ fireSignal S.setFillGradient -setFillTexture :: FillTexture -> DiagramObj () +setFillTexture :: FillTexture Double -> DiagramObj () -- ^Set fill style. setFillTexture tex = case getFillTexture tex of diff --git a/src/Diagrams/Backend/HsQML/DiagramObj/Type.hs b/src/Diagrams/Backend/HsQML/DiagramObj/Type.hs --- a/src/Diagrams/Backend/HsQML/DiagramObj/Type.hs +++ b/src/Diagrams/Backend/HsQML/DiagramObj/Type.hs @@ -22,9 +22,7 @@ import Diagrams.Backend.HsQML.DiagramObj.Signals -import Control.Applicative import Control.Monad.IO.Class -import Data.Monoid import Data.Typeable import Graphics.QML diff --git a/src/Diagrams/Backend/HsQML/Render.hs b/src/Diagrams/Backend/HsQML/Render.hs --- a/src/Diagrams/Backend/HsQML/Render.hs +++ b/src/Diagrams/Backend/HsQML/Render.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE DeriveDataTypeable @@ -23,11 +24,11 @@ import Diagrams.Backend.HsQML.DiagramObj import Data.Foldable (foldl', foldMap) -import Control.Lens hiding ((#), from) +import Control.Lens hiding ((#), from, transform, under) import Data.Monoid import Data.Tree import Data.Typeable -import Diagrams.Prelude hiding ((<>), start, moveTo, stroke, text) +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 @@ -37,25 +38,30 @@ 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 } +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 = adjustDia2D sizeSpec HsQML opts (dia # reflectY) + 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 => (SizeSpec2D -> f SizeSpec2D) -> Options HsQML R2 -> f (Options HsQML R2) --- ^A lens from HsQML backend options to a 'SizeSpec2D'. + :: 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' 'R2') 'SizeSpec2D' @ +-- @ sizeSpec :: 'Lens'' ('Options' 'HsQML' 'V2') ('SizeSpec' 'V2' 'Double') @ sizeSpec = lens (\(HsQMLOptions s) -> s) (\_ s -> HsQMLOptions s) -addAnnotation :: String -> DiagramObj () +addAnnotation :: Annotation -> DiagramObj () -- ^Currently not supported, returns 'mempty'. addAnnotation _ = mempty -useStyle :: Style R2 -> DiagramObj () +useStyle :: Style V2 Double -> DiagramObj () {-^ Apply style to a Context2D. Currently supports the following 'Attribute's: @@ -82,22 +88,22 @@ ] where handle f = fmap f.getAttr -renderHsQML :: Options HsQML R2 -> RTree HsQML R2 Annotation -> Render HsQML R2 +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 (Href s) -> HsQMLRender $ addAnnotation s <> proceed + 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 HsQML where - render HsQML (Text _ t2 _ str) = HsQMLRender $ text str x y +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 -> Trail R2 -> DiagramObj () +renderTrail :: P2 Double -> Trail V2 Double -> DiagramObj () -- ^Render a trail, closing loops. renderTrail start trail = mconcat [ beginPath @@ -114,23 +120,23 @@ , next) where next = p .+^ segOffset seg -renderSeg :: P2 -> Segment Closed R2 -> DiagramObj () +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 R2 -- ^The last segment of a loop. - -> P2 -- ^First end. - -> P2 -- ^Second end. + :: 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 R2) HsQML where +instance Renderable (Trail V2 Double) HsQML where render HsQML trail = HsQMLRender $ renderTrail origin trail -instance Renderable (Path R2) HsQML where +instance Renderable (Path V2 Double) HsQML where render HsQML path = HsQMLRender . foldMap (uncurry renderTrail . viewLoc) $ pathTrails path