diagrams-reflex (empty) → 0.1
raw patch · 7 files changed
+594/−0 lines, 7 filesdep +basedep +colourdep +containerssetup-changed
Dependencies added: base, colour, containers, diagrams-core, diagrams-lib, lens, monoid-extras, mtl, reflex, reflex-dom, reflex-dom-contrib
Files
- CHANGELOG.md +3/−0
- LICENSE +32/−0
- README.md +60/−0
- Setup.hs +3/−0
- diagrams-reflex.cabal +40/−0
- src/Diagrams/Backend/Reflex.hs +173/−0
- src/Graphics/Rendering/Reflex.hs +283/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+## v0.1 (2016-02-19)++ initial release
+ LICENSE view
@@ -0,0 +1,32 @@+Copyright 2015 diagrams-reflex team:++ Daniel Bergey <bergey@alum.mit.edu>++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 Ryan Yates 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.
+ README.md view
@@ -0,0 +1,60 @@+diagrams-reflex [](http://travis-ci.org/diagrams/diagrams-reflex)+------------+++_diagrams-reflex_ is a an SVG backend for [diagrams], to be used in+the browser via [ghcjs]. Diagrams is a powerful, flexible, declarative+domain-specific language for creating vector graphics, using the+[Haskell programming language][haskell].++[diagrams]: http://projects.haskell.org/diagrams/+[haskell]: http://www.haskell.org/haskellwiki/Haskell+[ghcjs]: https://github.com/ghcjs/ghcjs++# Installation++```+git clone git@github.com:diagrams/diagrams-reflex+cd diagrams-reflex+```++Pick one of the build methods below.++## With stack++```+stack build+```++## wiith [reflex-platform](https://github.com/reflex-frp/reflex-platform)++```+work-on ./ghcjs.nix ./.+```++# Examples++The examples directory contains several simple examples. Running+versions of these examples (and others, not all using `reflex`) are+online at+[http://bergey.github.io/gooey](http://bergey.github.io/gooey).++# Capabilities++The following features are supported. If they don't work as expected+(or as other Diagrams Backends), please file a bug report.++ - fill color (solid only)+ - line color+ - line width+ - line cap & join+ - dashing+ - opacity+ - Paths+ - Text+ - mouse events+ - font weight++These features are not yet implemented. Pull requests welcome!++ - textures
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ diagrams-reflex.cabal view
@@ -0,0 +1,40 @@+Name: diagrams-reflex+Version: 0.1+Synopsis: reflex backend for diagrams drawing EDSL.+Homepage: http://projects.haskell.org/diagrams/+License: BSD3+License-file: LICENSE+Extra-source-files: README.md, CHANGELOG.md+Author: Daniel Bergey+Maintainer: diagrams-discuss@googlegroups.com+Bug-reports: http://github.com/diagrams/diagrams-reflex/issues+Stability: Experimental+Category: Graphics+Build-type: Simple+Cabal-version: >=1.10+Description: This package provides a modular backend for rendering+ diagrams created with the diagrams EDSL to dynamic inline SVGs.+ It uses @reflex-dom@ and the @reflex@ FRP system.+Source-repository head+ type: git+ location: http://github.com/diagrams/diagrams-reflex++Library+ Exposed-modules: Diagrams.Backend.Reflex+ Other-modules: Graphics.Rendering.Reflex+ Hs-source-dirs: src+ Build-depends: base >= 4.3 && < 4.9+ , mtl >= 1 && < 2.3+ , colour >= 2.3.2 && < 2.4+ , diagrams-core >= 1.3 && < 1.4+ , diagrams-lib >= 1.3 && < 1.4+ , monoid-extras >= 0.3 && < 0.5+ , reflex-dom >= 0.2 && < 0.4+ , reflex >= 0.3 && < 0.5+ , reflex-dom-contrib >= 0.4 && < 0.5+ , containers >= 0.3 && < 0.6+ , lens >= 4.0 && < 4.14++ Ghc-options: -Wall++ Default-language: Haskell2010
+ src/Diagrams/Backend/Reflex.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-}+ -- UndecidableInstances needed for ghc < 707++----------------------------------------------------------------------------+-- |+-- Module : Diagrams.Backend.Reflex+-- Copyright : (c) 2015 diagrams-svg team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-----------------------------------------------------------------------------++module Diagrams.Backend.Reflex+ ( ReflexSvg(..) -- rendering token+ , B+ -- for rendering options specific to Reflex+ , Options(..), sizeSpec, svgAttributes+ -- ,svgDefinitions, idPrefix, svgAttributes, generateDoctype+ , DiaEv(..)+ , reflexDia+ ) where++#if __GLASGOW_HASKELL__ < 710+import Data.Foldable as F (foldMap)+#endif+import Data.Tree++-- from base+import Control.Monad.Reader++-- from lens+import Control.Lens hiding (children, transform, ( # ))++-- from diagrams-core+import Diagrams.Core.Compile+import Diagrams.Core.Types (Annotation (..))++-- from diagrams-lib+import Diagrams.Prelude hiding (Attribute, size, view, local, text)+import Diagrams.TwoD.Adjust (adjustDia2D)+import Diagrams.TwoD.Text (Text(..))++-- from containers+import qualified Data.Map as M++-- from reflex+import Reflex++-- from reflex-dom+import Reflex.Dom.Class+import Reflex.Dom.Widget.Basic++-- from reflex-dom-contrib+import Reflex.Dom.Contrib.Widgets.Svg++-- from this package+import Graphics.Rendering.Reflex (Element(..), RenderM)+import qualified Graphics.Rendering.Reflex as R++-- | @ReflexSvg@ is simply a token used to identify this rendering backend+-- (to aid type inference).+data ReflexSvg = ReflexSvg+ deriving (Show)++type B = ReflexSvg++type instance V ReflexSvg = V2+type instance N ReflexSvg = Double++instance Monoid (Render ReflexSvg V2 Double) where+ mempty = Render mempty+ Render r1 `mappend` Render r2_ = Render $ mappend r1 r2_++instance Backend ReflexSvg V2 Double where+ newtype Render ReflexSvg V2 Double = Render RenderM+ type Result ReflexSvg V2 Double = Element+ data Options ReflexSvg V2 Double = ReflexOptions+ { _size :: SizeSpec V2 Double -- ^ The requested size.+ , _svgAttributes :: R.Attrs+ -- ^ Attributes to apply to the entire svg element.+ }++ renderRTree :: ReflexSvg -> Options ReflexSvg V2 Double -> RTree ReflexSvg V2 Double Annotation -> Result ReflexSvg V2 Double+ renderRTree _ opts rt = Element "svg" attrs $ runReader (rtree rt) mempty+ where+ rtree :: RTree ReflexSvg V2 Double Annotation -> RenderM+ rtree (Node n rs) = case n of+ RPrim p -> unRender $ render ReflexSvg p+ RStyle sty -> local (<> sty) r+ _ -> r+ where+ r = foldMap rtree rs+ V2 w h = specToSize 100 . view sizeSpec $ opts+ attrs = M.fromList [ ("width", show w)+ , ("height", show h) ]+ <> _svgAttributes opts++ adjustDia c opts d = ( sz, t <> reflectionY, d' ) where+ (sz, t, d') = adjustDia2D sizeSpec c opts (d # reflectY)++-- | Lens onto the size of the options.+sizeSpec :: Lens' (Options ReflexSvg V2 Double) (SizeSpec V2 Double)+sizeSpec f opts = f (_size opts) <&> \s -> opts { _size = s }++-- | Lens onto the svgAttributes field of the options. This field+-- is provided to supply SVG attributes to the entire diagram.+svgAttributes :: Lens' (Options ReflexSvg V2 Double) R.Attrs+svgAttributes f opts =+ f (_svgAttributes opts) <&> \ds -> opts { _svgAttributes = ds }++mkWidget :: forall t m. MonadWidget t m => Element -> m ()+mkWidget (Element name attrs children) = svgAttr name attrs (mapM_ mkWidget children)+mkWidget (SvgText str) = text str++unRender :: Render ReflexSvg V2 Double -> RenderM+unRender (Render els) = els++instance Renderable (Path V2 Double) ReflexSvg where+ render _ = Render . R.renderPath++instance Renderable (Text Double) ReflexSvg where+ render _ = Render . R.renderText++instance Default (Options ReflexSvg V2 Double) where+ def = ReflexOptions absolute mempty++data DiaEv t a = DiaEv+ { diaMousedownEv :: Event t a+ , diaMouseupEv :: Event t a+ , diaMousemoveEv :: Event t a+ , diaMousedownPos :: Event t (P2 Double)+ , diaMouseupPos :: Event t (P2 Double)+ , diaMousemovePos :: Event t (P2 Double)+ }++reflexDia :: forall t m a. (Monoid' a, MonadWidget t m) =>+ Options ReflexSvg V2 Double -> QDiagram ReflexSvg V2 Double a -> m (DiaEv t a)+reflexDia opts dia = do+ -- render SVG, get stream with al events+ let (t, (Element n as cs)) = renderDiaT ReflexSvg opts dia+ (allEvents, _) <- svgAttr' n as $ mapM_ mkWidget cs+ -- particular event streams+ let+ q :: forall en. EventResultType en ~ (Int, Int) => EventName en -> Event t a+ q eventType = Diagrams.Prelude.sample dia <$> pos eventType+ pos :: forall en. EventResultType en ~ (Int, Int) => EventName en -> Event t (P2 Double)+ pos en = transform (inv t) . fmap fromIntegral . p2 <$> domEvent en allEvents+ return $ DiaEv+ (q Mousedown)+ (q Mouseup)+ (q Mousemove)+ (pos Mousedown)+ (pos Mouseup)+ (pos Mousemove)
+ src/Graphics/Rendering/Reflex.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Rendering.Reflex+-- Copyright : (c) 2015 diagrams-reflex team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- Lower level tools for creating SVGs.+--+-----------------------------------------------------------------------------++module Graphics.Rendering.Reflex+ ( RenderM+ , Element(..)+ , Attrs+ -- , AttributeValue+ -- , svgHeader+ , renderPath+ -- , renderClip+ , renderText+ -- , renderDImage+ -- , renderDImageEmb+ , renderStyles+ , renderMiterLimit+ -- , renderFillTextureDefs+ -- , renderFillTexture+ -- , renderLineTextureDefs+ -- , renderLineTexture+ -- , dataUri+ , getNumAttr+ ) where++-- from base+import Data.List (intercalate)+#if __GLASGOW_HASKELL__ < 710+import Data.Foldable (foldMap)+#endif++-- from mtl+import Control.Monad.Reader as R++-- from diagrams-lib+import Diagrams.Prelude hiding (Attribute, Render, with, text)+import Diagrams.TwoD.Path (getFillRule)+import Diagrams.TwoD.Text+import Diagrams.Core.Transform (matrixHomRep)++-- from containers+import Data.Map (Map)+import qualified Data.Map as M++-- from base64-bytestring, bytestring+-- import qualified Data.ByteString.Base64.Lazy as BS64+-- import qualified Data.ByteString.Lazy.Char8 as BS8++data Element = Element+ String -- ^ SVG element name+ (Map String String) -- ^ Attributes+ [Element] -- ^ Children+ | SvgText String++type RenderM = Reader (Style V2 Double) [Element]++instance Monoid RenderM where+ mempty = return []+ mappend a b = mappend <$> a <*> b++type AttributeValue = String++type Attrs = Map String String++getNumAttr :: AttributeClass (a Double) => (a Double -> t) -> Style v Double -> Maybe t+getNumAttr f = (f <$>) . getAttr++renderPath :: Path V2 Double -> RenderM+renderPath trs+ | makePath == "" = return []+ | otherwise = do+ sty <- ask+ return [ Element "path" (M.insert "d" makePath $ renderStyles sty) [] ]+ where+ makePath = foldMap renderTrail (op Path trs)++renderTrail :: Located (Trail V2 Double) -> AttributeValue+renderTrail (viewLoc -> (P (V2 x y), t)) =+ concat [ "M " , show x, ",", show y, " " ]+ <> withTrail renderLine renderLoop t+ where+ renderLine = foldMap renderSeg . lineSegments+ renderLoop lp =+ case loopSegments lp of+ -- let z handle the last segment if it is linear+ (segs, Linear _) -> foldMap renderSeg segs++ -- otherwise we have to emit it explicitly+ _ -> foldMap renderSeg (lineSegments . cutLoop $ lp)+ <> "Z"++renderSeg :: Segment Closed V2 Double -> AttributeValue+renderSeg (Linear (OffsetClosed (V2 x 0))) = concat [ "h ", show x, " "]+renderSeg (Linear (OffsetClosed (V2 0 y))) = concat [ "v ", show y, " " ]+renderSeg (Linear (OffsetClosed (V2 x y))) = concat [ "l ", show x, ",", show y, " "]+renderSeg (Cubic (V2 x0 y0) (V2 x1 y1) (OffsetClosed (V2 x2 y2))) =+ concat [ " c ", show x0, ",", show y0, " ", show x1, ",", show y1+ , " ", show x2, " ", show y2]++renderText :: Text Double -> RenderM+renderText (Text tt tAlign str) = return [ Element "text" attrs [ SvgText str ] ]+ where+ attrs = M.fromList+ [ ("transform", transformMatrix)+ , ("dominant_baseline", vAlign)+ , ("text_anchor", hAlign)+ , ("stroke", "none")+ ]+ vAlign = case tAlign of+ BaselineText -> "alphabetic"+ BoxAlignedText _ h -> case h of -- A mere approximation+ h' | h' <= 0.25 -> "text-after-edge"+ h' | h' >= 0.75 -> "text-before-edge"+ _ -> "middle"+ hAlign = case tAlign of+ BaselineText -> "start"+ BoxAlignedText w _ -> case w of -- A mere approximation+ w' | w' <= 0.25 -> "start"+ w' | w' >= 0.75 -> "end"+ _ -> "middle"+ t = tt <> reflectionY+ [[a,b],[c,d],[e,f]] = matrixHomRep t+ transformMatrix = matrix a b c d e f++-- | Specifies a transform in the form of a transformation matrix+matrix :: (Show a, RealFloat a) => a -> a -> a -> a -> a -> a -> String+matrix a b c d e f = concat+ [ "matrix(", show a, ",", show b, ",", show c+ , ",", show d, ",", show e, ",", show f, ")"]++renderStyles :: Style v Double -> Attrs+renderStyles s = foldMap ($ s) $+ [ renderLineTexture+ , renderFillTexture+ , renderLineWidth+ , renderLineCap+ , renderLineJoin+ , renderFillRule+ , renderDashing+ , renderOpacity+ , renderFontSize+ , renderFontSlant+ , renderFontWeight+ , renderFontFamily+ -- , renderSvgId+ -- , renderSvgClass+ , renderMiterLimit ]++renderMiterLimit :: Style v Double -> Attrs+renderMiterLimit s = renderAttr "stroke-miterlimit" miterLimit+ where miterLimit = getLineMiterLimit <$> getAttr s++renderOpacity :: Style v Double -> Attrs+renderOpacity s = renderAttr "opacity" o+ where o = getOpacity <$> getAttr s++renderFillRule :: Style v Double -> Attrs+renderFillRule s = renderTextAttr "fill-rule" fr+ where fr = (fillRuleToText . getFillRule) <$> getAttr s+ fillRuleToText :: FillRule -> AttributeValue+ fillRuleToText Winding = "nonzero"+ fillRuleToText EvenOdd = "evenodd"++renderLineWidth :: Style v Double -> Attrs+renderLineWidth s = renderAttr "stroke-width" lWidth+ where lWidth = getNumAttr getLineWidth s++renderLineCap :: Style v Double -> Attrs+renderLineCap s = renderTextAttr "stroke-linecap" lCap+ where lCap = (lineCapToText . getLineCap) <$> getAttr s+ lineCapToText :: LineCap -> AttributeValue+ lineCapToText LineCapButt = "butt"+ lineCapToText LineCapRound = "round"+ lineCapToText LineCapSquare = "square"++renderLineJoin :: Style v Double -> Attrs+renderLineJoin s = renderTextAttr "stroke-linejoin" lj+ where lj = (lineJoinToText . getLineJoin) <$> getAttr s+ lineJoinToText :: LineJoin -> AttributeValue+ lineJoinToText LineJoinMiter = "miter"+ lineJoinToText LineJoinRound = "round"+ lineJoinToText LineJoinBevel = "bevel"++renderDashing :: Style v Double -> Attrs+renderDashing s = renderTextAttr "stroke-dasharray" arr <>+ renderAttr "stroke-dashoffset" dOffset+ where+ getDasharray (Dashing a _) = a+ getDashoffset (Dashing _ o) = o+ dashArrayToStr = intercalate "," . map show+ -- Ignore dashing if dashing array is empty+ checkEmpty (Just (Dashing [] _)) = Nothing+ checkEmpty other = other+ dashing' = checkEmpty $ getNumAttr getDashing s+ arr = (dashArrayToStr . getDasharray) <$> dashing'+ dOffset = getDashoffset <$> dashing'++renderFontSize :: Style v Double -> Attrs+renderFontSize s = renderTextAttr "font-size" fs+ where+ fs = getNumAttr ((++ "px") . show . getFontSize) s++renderFontSlant :: Style v Double -> Attrs+renderFontSlant s = renderTextAttr "font-style" fs+ where+ fs = (fontSlantAttr . getFontSlant) <$> getAttr s+ fontSlantAttr :: FontSlant -> AttributeValue+ fontSlantAttr FontSlantItalic = "italic"+ fontSlantAttr FontSlantOblique = "oblique"+ fontSlantAttr FontSlantNormal = "normal"++renderFontWeight :: Style v Double -> Attrs+renderFontWeight s = renderTextAttr "font-weight" fw+ where+ fw = (fontWeightAttr . getFontWeight) <$> getAttr s+ fontWeightAttr :: FontWeight -> AttributeValue+ fontWeightAttr FontWeightNormal = "normal"+ fontWeightAttr FontWeightBold = "bold"++renderFontFamily :: Style v Double -> Attrs+renderFontFamily s = renderTextAttr "font-family" ff+ where+ ff = (getFont) <$> getAttr s++-- | Render a style attribute if available, empty otherwise.+renderAttr :: Show s => String -> Maybe s -> Attrs+renderAttr attrName valM = maybe mempty (\v -> M.singleton attrName $ show v) valM++renderTextAttr :: String -> Maybe AttributeValue -> Attrs+renderTextAttr attrName valM = maybe mempty (\v -> M.singleton attrName v) valM++-- TODO add gradients+-- | Render solid colors, ignore gradients for now.+renderFillTexture :: Style v Double -> Attrs+renderFillTexture s = case getNumAttr getFillTexture s of+ Just (SC (SomeColor c)) ->+ M.fromList [("fill", fillColorRgb), ("fill-opacity", fillColorOpacity)]+ where+ fillColorRgb = colorToRgbString c+ fillColorOpacity = colorToOpacity c+ _ -> mempty++renderLineTexture :: Style v Double -> Attrs+renderLineTexture s = case getNumAttr getLineTexture s of+ Just (SC (SomeColor c)) -> M.fromList+ [ ("stroke", lineColorRgb), ("stroke-opacity", lineColorOpacity) ]+ where+ lineColorRgb = colorToRgbString c+ lineColorOpacity = colorToOpacity c+ _ -> mempty++colorToRgbString :: forall c . Color c => c -> String+colorToRgbString c = concat+ [ "rgb("+ , int r, ","+ , int g, ","+ , int b+ , ")" ]+ where+ int d = show $ (round (d * 255) :: Int)+ (r,g,b,_) = colorToSRGBA c++colorToOpacity :: forall c . Color c => c -> String+colorToOpacity c = show a+ where (_,_,_,a) = colorToSRGBA c