diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +## v0.1 (2016-02-19) + + initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +Copyright 2015 diagrams-reflex team: + + Daniel Bergey + +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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,60 @@ +diagrams-reflex [![Build Status](https://travis-ci.org/diagrams/diagrams-reflex.png?branch=master)](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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/diagrams-reflex.cabal b/diagrams-reflex.cabal new file mode 100644 --- /dev/null +++ b/diagrams-reflex.cabal @@ -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 diff --git a/src/Diagrams/Backend/Reflex.hs b/src/Diagrams/Backend/Reflex.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/Reflex.hs @@ -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) diff --git a/src/Graphics/Rendering/Reflex.hs b/src/Graphics/Rendering/Reflex.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Reflex.hs @@ -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