diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,31 @@ +Copyright (c) 2018, Commonwealth Scientific and Industrial Research Organisation +(CSIRO) ABN 41 687 119 230. + +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 QFPL 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,73 @@ + + +# Reflex Dom SVG Helper + +A helper library for working with SVG and creating dynamic SVG images using +[reflex-dom](https://github.com/reflex-frp/reflex-dom). This library provides +a pile of types and some helper functions to make the process of creating and +managing your SVG elements, more type safe and a bit easier. + +It currently supports the following SVG elements/properties: + +* rect +* circle +* polygon +* polyline +* ellipse +* line +* animate +* path (included is an API for building type safe paths) + +The SVG elements are designed to be created inside a SVG root element: + +```haskell +let dSVGEl = pure $ SVG_El (Width 600.0) (Height 400) +a <- svg_ dSVGEl $ do + ... -- other SVG elements go in here +``` + +Each of the SVG elements this library supports has a properties type +associated with it, similar to how the ``TextInput`` and other widget types +are configured in the core ``reflex-dom`` library. + +```haskell +data SVG_Rect = SVG_Rect + { _svg_rect_pos_x :: Pos X + , _svg_rect_pos_y :: Pos Y + , _svg_rect_width :: Width + , _svg_rect_height :: Height + , _svg_rect_cornerRadius_x :: Maybe (CornerRadius X) + , _svg_rect_cornerRadius_y :: Maybe (CornerRadius Y) + } +``` + +The respective module contains a function to take these properties and +convert them into the ``Map Text Text`` format that is expected by +``reflex-dom``. The functions in this module take care of this for you, and +allow you to add any other attributes as you require. You are able to manage +the properties of an SVG element as either a static input or a ``Dynamic``. + +Additionally there is a (still work-in-progress) API for type safe ```` +construction in the ``Reflex.Dom.Widget.SVG.Types.SVG_Path`` module. The +``SVG_Path`` type is a ``newtype`` over a ``NonEmpty PathCommand``, which +prevents you from having an empty list of Path instructions. As a minimal +example of using the API as it currently is: + +```haskell +-- Drawing a simple rectangle using a +r :: SVG_Path +r = _Wrapped # NonEmpty.fromList + [ _M (_PosX # 10.0) (_PosY # 10.0) + , _H (_PosX # 90.0) + , _V (_PosY # 90.0) + , _H (_PosX # 10.0) + , _L (_PosX # 10.0) (_PosY # 10.0) + ] +``` + +The functions ``_M``, ``_H``, ``_L``, and ``_V``, all correspond to their +```` commands from the [MDN Documentation on +Paths](https://developer.mozilla.org/en-US/docs/Web/SVG/Tutorial/Paths). +These are the non-relative variants of those commands, there are relative +versions as well, which are just lower-case named functions of the same type: +``_m``, ``_h``, and so on. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,25 @@ +0.3.2.0 + +* Bumped reflex-platform +* Added 'example' project +* Fix issue that prevented 'animate' attributes from rendering correctly +* Fix 'ellipse' 'cy' property +* Fix 'circle' 'radius' type and add an example to the Example file. +* Update the Example.lhs to work with latest changes +* Remove the shell.nix +* Update default.nix to use 'shellAware' function +* Update element types to more general 'Element' type +* Remove image from cabal file, add readme to extra-source-files + +0.2.0.0 + +* Add "viewBox" property support for root SVG tag. This breaks existing SVG_El definitions. +* Expose the 'raw' svg drawing functions. +* Update default.nix to not try to generate haddocks on GHCJS build. Would cause the build to fail. +* Add a helper function to change the indexed type of a Pos. + +0.1.1.0 + +* First version. Released on an unsuspecting world. +* Add import for SVG_Circle +* Update the props functions to correctly update the attribute map diff --git a/reflex-dom-svg.cabal b/reflex-dom-svg.cabal new file mode 100644 --- /dev/null +++ b/reflex-dom-svg.cabal @@ -0,0 +1,47 @@ +name: reflex-dom-svg +version: 0.3.2.0 +synopsis: Reflex functions for SVG elements. +description: Provides support for easily creating and manipulating SVG elements via Reflex. +license: BSD3 +license-file: LICENCE +author: Queensland Functional Programming Lab +maintainer: Queensland Functional Programming Lab +copyright: Copyright (c) 2018, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230. +category: FRP,Web,Graphics +build-type: Simple +extra-source-files: changelog.md, README.md +cabal-version: 1.24 + +source-repository head + type: git + location: git@github.com/qfpl/reflex-dom-svg/reflex-dom-svg.git + +library + ghc-options: -Wall + + exposed-modules: Reflex.Dom.Widget.SVG + , Reflex.Dom.Widget.SVG.Types + , Reflex.Dom.Widget.SVG.Types.Internal + , Reflex.Dom.Widget.SVG.Types.Pos + , Reflex.Dom.Widget.SVG.Types.CornerRadius + , Reflex.Dom.Widget.SVG.Types.Radius + , Reflex.Dom.Widget.SVG.Types.SVG_Path + , Reflex.Dom.Widget.SVG.Types.SVG_Rect + , Reflex.Dom.Widget.SVG.Types.SVG_Circle + , Reflex.Dom.Widget.SVG.Types.SVG_Ellipse + , Reflex.Dom.Widget.SVG.Types.SVG_Line + , Reflex.Dom.Widget.SVG.Types.SVG_Polygon + , Reflex.Dom.Widget.SVG.Types.SVG_PolyLine + , Reflex.Dom.Widget.SVG.Types.SVG_Animate + + build-depends: base >=4.9 && <=4.12 + , text >= 1.2 && < 1.3 + , reflex >= 0.4 && < 0.7 + , reflex-dom-core >= 0.5 && < 0.7 + , lens >= 4.16.1 && < 4.17 + , containers == 0.5.* + , safe == 0.3.* + + hs-source-dirs: src + + default-language: Haskell2010 diff --git a/src/Reflex/Dom/Widget/SVG.hs b/src/Reflex/Dom/Widget/SVG.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Dom/Widget/SVG.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | Main functions for creating SVG dom elements via Reflex +module Reflex.Dom.Widget.SVG + ( AsSVGTag (..) + , BasicSVG (..) + , BasicInner (..) + , SVG_Root (..) + , CanBeNested + , SVGEl (..) + , svg_ + , svgBasicDyn + , svgBasicDyn_ + , svgElDynAttr' + , svgElDynAttr_ + ) where + +import Control.Monad.Fix (MonadFix) +import Data.Text (Text) + +import Reflex (Dynamic, MonadHold) +import qualified Reflex as R + +import Reflex.Dom.Core (Element, EventResult, DomBuilderSpace, DomBuilder, PostBuild) +import qualified Reflex.Dom.Core as RD + +import Data.Map (Map) + +import Reflex.Dom.Widget.SVG.Types (SVG_El, makeSVGProps) + +-- | Lawless class to provide a constraint indicating that a given type is capable +-- of being represented by a SVG XML Tag. , , , etc. +class AsSVGTag s where + svgTagName :: s -> Text + +instance AsSVGTag BasicSVG where + svgTagName Rectangle = "rect" + svgTagName Circle = "circle" + svgTagName Ellipse = "ellipse" + svgTagName Path = "path" + svgTagName Line = "line" + svgTagName PolyLine = "polyline" + svgTagName Polygon = "polygon" + +instance AsSVGTag BasicInner where + svgTagName Animate = "animate" + +instance AsSVGTag SVG_Root where + svgTagName SVG_Root = "svg" + +-- | The SVG Root element: "" +data SVG_Root = SVG_Root + +-- | The basic SVG shapes. +data BasicSVG + = Rectangle + | Circle + | Ellipse + | Path + | Line + | PolyLine + | Polygon + deriving (Show, Eq) + +-- | The simplest inner element for a basic shape, the "" tag. +data BasicInner + = Animate + deriving (Eq, Ord) + +-- | Create a relationship between a set of SVG tags that can be nested inside a +-- different set of SVG tags. Currently this just creates the relationship +-- between the "" tag and the basic shapes ("", "", etc). +type family CanBeNested a :: * +type instance CanBeNested BasicSVG = BasicInner + +-- | This represents an SVG element, containing both the raw Reflex.Dom @El@ type +-- and a @Dynamic@ of all of the children that are nested in this element. +data SVGEl t m a = SVGEl + { _svgEl_el :: Element EventResult (DomBuilderSpace m) t + , _svgEl_children :: Dynamic t (Map (CanBeNested a) (Element EventResult (DomBuilderSpace m) t)) + } + +svgXMLNamespace :: Text +svgXMLNamespace = "http://www.w3.org/2000/svg" + +-- | This is for creating a SVG element with @Dynamic@ attributes, and ensuring we +-- use the right namespace so the browser actually picks up on it. The name +-- space in use is "http://www.w3.org/2000/svg". +svgElDynAttr' + :: forall t m a e. ( DomBuilder t m + , PostBuild t m + , AsSVGTag e + ) + => e + -> Dynamic t (Map Text Text) + -> m a + -> m (Element EventResult (DomBuilderSpace m) t, a) +svgElDynAttr' = RD.elDynAttrNS' + (Just svgXMLNamespace) + . svgTagName + +-- | As per @svgElDynAttr'@, but does not have any children. +svgElDynAttr_ + :: forall t m e. ( DomBuilder t m + , PostBuild t m + , AsSVGTag e + ) + => e + -> Dynamic t (Map Text Text) + -> m (Element EventResult (DomBuilderSpace m) t) +svgElDynAttr_ t dAttrs = fst <$> RD.elDynAttrNS' + (Just svgXMLNamespace) + (svgTagName t) + dAttrs + RD.blank + +-- | Create the Root SVG element. +-- +-- Note that there are not restrictions on the inner element, apart from the +-- return type being of @m (SVGEl t a)@. So you are free to place whatever you +-- like in there, but bear in mind that the browser rules for SVG are still in +-- play. So text inputs etc, won't work. +svg_ + :: ( DomBuilder t m + , PostBuild t m + , R.Reflex t + , AsSVGTag a + ) + => Dynamic t SVG_El + -> m ( SVGEl t m a ) + -> m ( Element EventResult (DomBuilderSpace m) t, SVGEl t m a) +svg_ dAttrs = + svgElDynAttr' SVG_Root (makeSVGProps <$> dAttrs) + +-- | Create a SVG element that has dynamic attributes and contains children that +-- are acceptable children for this element. "" as a Basic Shape can only +-- contain "" elements, for example. +-- +-- The SVG element will have some @Dynamic@ properties and a function that +-- allows these properties to be converted into a @Map Text Text@, inline with +-- other Reflex.Dom widgets. +svgBasicDyn + :: ( DomBuilder t m + , PostBuild t m + , MonadFix m + , MonadHold t m + , AsSVGTag s + , AsSVGTag (CanBeNested s) + , Ord (CanBeNested s) + ) + => s + -> ( p -> Map Text Text ) + -> Dynamic t p + -> Dynamic t ( Map (CanBeNested s) (Map Text Text) ) + -> m ( SVGEl t m s ) +svgBasicDyn t propFn dProps dInnerElMap = + fmap ( uncurry SVGEl ) . svgElDynAttr' t (propFn <$> dProps) $ RD.listWithKey dInnerElMap + (\innerS dInnerAttrs -> fst <$> svgElDynAttr' innerS dInnerAttrs RD.blank) + +-- | As per the @svgBasicDyn@ function, except with no inner elements. +svgBasicDyn_ + :: ( DomBuilder t m + , PostBuild t m + , MonadFix m + , MonadHold t m + , AsSVGTag s + , AsSVGTag (CanBeNested s) + , Ord (CanBeNested s) + ) + => s + -> ( p -> Map Text Text ) + -> Dynamic t p + -> m ( SVGEl t m s ) +svgBasicDyn_ t propFn dProps = + svgBasicDyn t propFn dProps (pure mempty) diff --git a/src/Reflex/Dom/Widget/SVG/Types.hs b/src/Reflex/Dom/Widget/SVG/Types.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Dom/Widget/SVG/Types.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +-- | Contains the root \ element properties and re-exports all of the individual SVG Types +module Reflex.Dom.Widget.SVG.Types + ( SVG_El (..) + , ViewBox (..) + , svg_root_width + , svg_root_height + , svg_root_viewbox + , viewBox_height + , viewBox_width + , viewBox_min_x + , viewBox_min_y + + , makeSVGProps + , makeViewBox + + , module Reflex.Dom.Widget.SVG.Types.Internal + + , module Reflex.Dom.Widget.SVG.Types.CornerRadius + , module Reflex.Dom.Widget.SVG.Types.Pos + , module Reflex.Dom.Widget.SVG.Types.Radius + + , module Reflex.Dom.Widget.SVG.Types.SVG_Animate + , module Reflex.Dom.Widget.SVG.Types.SVG_Circle + , module Reflex.Dom.Widget.SVG.Types.SVG_Ellipse + , module Reflex.Dom.Widget.SVG.Types.SVG_Line + , module Reflex.Dom.Widget.SVG.Types.SVG_Polygon + , module Reflex.Dom.Widget.SVG.Types.SVG_PolyLine + , module Reflex.Dom.Widget.SVG.Types.SVG_Rect + , module Reflex.Dom.Widget.SVG.Types.SVG_Path + ) + where + +import Control.Lens (Lens', at, to, (.~), + (^.), (^?), _Just, + _Wrapped) + +import Data.Function ((&)) + +import Data.Text (Text) +import qualified Data.Text as Text + +import Data.Map (Map) +import qualified Data.Map as Map + +import Reflex.Dom.Widget.SVG.Types.Internal + +import Reflex.Dom.Widget.SVG.Types.SVG_Path + +import Reflex.Dom.Widget.SVG.Types.CornerRadius +import Reflex.Dom.Widget.SVG.Types.Pos +import Reflex.Dom.Widget.SVG.Types.Radius + +import Reflex.Dom.Widget.SVG.Types.SVG_Animate +import Reflex.Dom.Widget.SVG.Types.SVG_Circle +import Reflex.Dom.Widget.SVG.Types.SVG_Ellipse +import Reflex.Dom.Widget.SVG.Types.SVG_Line +import Reflex.Dom.Widget.SVG.Types.SVG_Polygon +import Reflex.Dom.Widget.SVG.Types.SVG_PolyLine +import Reflex.Dom.Widget.SVG.Types.SVG_Rect + +-- | SVG @viewBox@ attribute +data ViewBox = ViewBox + { _viewBox_min_X :: Float + , _viewBox_min_Y :: Float + , _viewBox_width :: Width + , _viewBox_height :: Height + } + deriving (Eq, Show) + +-- | Lens for @_viewBox_min_X@ attribute on @ViewBox@ +viewBox_min_x :: Lens' ViewBox Float +viewBox_min_x f (ViewBox minX minY w h) = fmap (\minX' -> ViewBox minX' minY w h) (f minX) +{-# INLINE viewBox_min_x #-} + +-- | Lens for @_viewBox_min_Y@ attribute on @ViewBox@ +viewBox_min_y :: Lens' ViewBox Float +viewBox_min_y f (ViewBox minX minY w h) = fmap (\minY' -> ViewBox minX minY' w h) (f minY) +{-# INLINE viewBox_min_y #-} + +-- | Lens for @_viewBox_width@ attribute on @ViewBox@ +viewBox_width :: Lens' ViewBox Width +viewBox_width f (ViewBox minX minY w h) = fmap (\w' -> ViewBox minX minY w' h) (f w) +{-# INLINE viewBox_width #-} + +-- | Lens for @_viewBox_min_X@ attribute on @ViewBox@ +viewBox_height :: Lens' ViewBox Height +viewBox_height f (ViewBox minX minY w h) = fmap (ViewBox minX minY w) (f h) +{-# INLINE viewBox_height #-} + +-- | Minimum information required for building a SVG root element. +data SVG_El = SVG_El + { _svg_root_width :: Width + , _svg_root_height :: Height + , _svg_view_box :: Maybe ViewBox + } + deriving (Eq, Show) + +-- | Lens for @Height@ attribute on @SVG_El@ +svg_root_height :: Lens' SVG_El Height +svg_root_height f (SVG_El x1 x2 v) = fmap (\x2' -> SVG_El x1 x2' v) (f x2) +{-# INLINE svg_root_height #-} + +-- | Lens for @Width@ attribute on @SVG_El@ +svg_root_width :: Lens' SVG_El Width +svg_root_width f (SVG_El x1 x2 v) = fmap (\x1' -> SVG_El x1' x2 v) (f x1) +{-# INLINE svg_root_width #-} + +-- | Lens for @ViewBox@ attribute on @SVG_El@ +svg_root_viewbox :: Lens' SVG_El ( Maybe ViewBox ) +svg_root_viewbox f (SVG_El x1 x2 v) = fmap (SVG_El x1 x2) (f v) +{-# INLINE svg_root_viewbox #-} + +makeViewBox + :: ViewBox + -> Text +makeViewBox ViewBox {..} = Text.unwords $ Text.pack . show <$> + [ _viewBox_min_X + , _viewBox_min_Y + , _viewBox_width ^. _Wrapped + , _viewBox_height ^. _Wrapped + ] + +-- | Convert the record to the correct attribute map for Reflex. +makeSVGProps + :: SVG_El + -> Map Text Text +makeSVGProps s = Map.fromList + [ ("width", s ^. svg_root_width . wrappedToText ) + , ("height", s ^. svg_root_height . wrappedToText ) + , ("xmlns", "http://www.w3.org/2000/svg" ) + ] + & at "viewBox" .~ s ^? svg_root_viewbox . _Just . to makeViewBox diff --git a/src/Reflex/Dom/Widget/SVG/Types/CornerRadius.hs b/src/Reflex/Dom/Widget/SVG/Types/CornerRadius.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Dom/Widget/SVG/Types/CornerRadius.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +-- | Types and functions for a corner radius +module Reflex.Dom.Widget.SVG.Types.CornerRadius + ( CornerRadius + , _CornerRadiusX + , _CornerRadiusY + ) where + +import Control.Lens (Iso', Rewrapped, Wrapped (..), + iso, _Wrapped) + +import Reflex.Dom.Widget.SVG.Types.Pos (X, Y) + +-- | Corner Radius is effectively just a @Float@, but we can do better. +newtype CornerRadius p = + CornerRadius Float + deriving (Eq, Show) + +instance (CornerRadius p) ~ t => Rewrapped (CornerRadius p) t + +instance Wrapped (CornerRadius p) where + type Unwrapped (CornerRadius p) = Float + _Wrapped' = iso (\(CornerRadius x) -> x) CornerRadius + +-- | @Iso@ for the CornerRadius on the X axis +_CornerRadiusX :: Iso' (CornerRadius X) Float +_CornerRadiusX = _Wrapped + +-- | @Iso@ for the CornerRadius on the Y axis +_CornerRadiusY :: Iso' (CornerRadius Y) Float +_CornerRadiusY = _Wrapped diff --git a/src/Reflex/Dom/Widget/SVG/Types/Internal.hs b/src/Reflex/Dom/Widget/SVG/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Dom/Widget/SVG/Types/Internal.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +-- | Miscellaneous types and functions of the API. This module is named Internal +-- as it is possible it will change. +module Reflex.Dom.Widget.SVG.Types.Internal + ( Width (..) + , Height (..) + , AttributeName (..) + , RepeatCount (..) + , wrappedToText + ) where + +import Control.Lens (Contravariant, Rewrapped, Wrapped (..), iso, + to, _Wrapped) + +import Data.Text (Text) +import Data.Text.Lens (IsText, packed) + +-- | Wrap the @Float@ value with something more meaningful. +newtype Width = Width Float deriving (Eq, Show) +-- | Wrap the @Float@ value with something more meaningful. +newtype Height = Height Float deriving (Eq, Show) +-- | Wrap the @Text@ value with something more meaningful. +newtype AttributeName = AttributeName Text deriving (Eq, Show) + +instance Width ~ t => Rewrapped Width t +instance Wrapped Width where + type Unwrapped Width = Float + _Wrapped' = iso (\(Width x) -> x) Width + +instance Height ~ t => Rewrapped Height t +instance Wrapped Height where + type Unwrapped Height = Float + _Wrapped' = iso (\(Height x) -> x) Height + +instance AttributeName ~ t => Rewrapped AttributeName t +instance Wrapped AttributeName where + type Unwrapped AttributeName = Text + _Wrapped' = iso (\ (AttributeName x) -> x) AttributeName + +-- | Capture the information about the attribute. +data RepeatCount + = NumOfTimes Word + | Indefinite + deriving Eq + +instance Show RepeatCount where + show (NumOfTimes n) = show n + show Indefinite = "indefinite" + +-- | Helper function to convert a @Wrapped@ value to a @Text@ value. +wrappedToText + :: ( Unwrapped t ~ Unwrapped s + , IsText t1 + , Contravariant f + , Functor f + , Rewrapped t s + , Rewrapped s t + , Show (Unwrapped s) + ) + => (t1 -> f t1) + -> s + -> f t +wrappedToText = + _Wrapped . to show . packed diff --git a/src/Reflex/Dom/Widget/SVG/Types/Pos.hs b/src/Reflex/Dom/Widget/SVG/Types/Pos.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Dom/Widget/SVG/Types/Pos.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +-- | @Pos@ is a general purpose wrapper for the various times we want to +-- indicate we're using a specific positional value. +module Reflex.Dom.Widget.SVG.Types.Pos + ( Pos + , X + , Y + , CenterX + , CenterY + , _PosX + , _PosY + , _PosCenterX + , _PosCenterY + , changePosType + , makePointsProp + ) + where + +import Control.Lens (Iso', Rewrapped, + Wrapped (..), iso, (^.), + _Wrapped) + +import Data.Text (Text) + +import Data.Semigroup ((<>)) + +import Data.List.NonEmpty (NonEmpty) + +import Reflex.Dom.Widget.SVG.Types.Internal (wrappedToText) + +-- | Types to help keep our respective coordinate types separate +data X +-- | Types to help keep our respective coordinate types separate +data Y +-- | Types to help keep our respective coordinate types separate +data CenterX +-- | Types to help keep our respective coordinate types separate +data CenterY + +-- | Wrap up the normal @Float@ value with a @newtype@ so that we can't mix +-- things up as easily. Include a phantom type so we're able to be granular +-- about the specific position we're interested in. +newtype Pos p = + Pos Float + deriving (Eq, Show) + +instance (Pos p) ~ t => Rewrapped (Pos p) t + +instance Wrapped (Pos p) where + type Unwrapped (Pos p) = Float + _Wrapped' = iso (\(Pos x) -> x) Pos + +-- | Change the @Pos@ index type +changePosType :: Pos a -> Pos b +changePosType (Pos p) = Pos p + +-- | Specific Iso for describing a X coordinate +_PosX :: Iso' (Pos X) Float +_PosX = _Wrapped + +-- | Specific Iso for describing a Y coordinate +_PosY :: Iso' (Pos Y) Float +_PosY = _Wrapped + +-- | Specific Iso for describing a centered X coordinate +_PosCenterX :: Iso' (Pos CenterX) Float +_PosCenterX = _Wrapped + +-- | Specific Iso for describing a centered Y coordinate +_PosCenterY :: Iso' (Pos CenterY) Float +_PosCenterY = _Wrapped + +-- | Convert the list of points to a correctly formatted list of X/Y positions +-- expected by SVG attributes. +makePointsProp + :: NonEmpty (Pos X, Pos Y) + -> Text +makePointsProp = foldMap + (\(x,y) -> (x ^. wrappedToText) <> "," <> (y ^. wrappedToText) <> " ") diff --git a/src/Reflex/Dom/Widget/SVG/Types/Radius.hs b/src/Reflex/Dom/Widget/SVG/Types/Radius.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Dom/Widget/SVG/Types/Radius.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +-- | Types and function for the @Radius@ wrapper. +module Reflex.Dom.Widget.SVG.Types.Radius + ( Radius + , _Radius + , _RadiusX + , _RadiusY + ) where + +import Control.Lens (Iso', Rewrapped, Wrapped (..), + iso, _Wrapped) + +import Reflex.Dom.Widget.SVG.Types.Pos (X, Y) + +-- | The value of a @Radius@ is just a @Float@. But we can do better so we wrap +-- it up in a @newtype@ to keep things organised. +newtype Radius p = + Radius Float + deriving (Eq, Show) + +instance (Radius p) ~ t => Rewrapped (Radius p) t + +instance Wrapped (Radius p) where + type Unwrapped (Radius p) = Float + _Wrapped' = iso (\(Radius x) -> x) Radius + +-- | Iso for the float value of a radius +_Radius :: Iso' (Radius ()) Float +_Radius = _Wrapped + +-- | Iso for the float value of an X position radius +_RadiusX :: Iso' (Radius X) Float +_RadiusX = _Wrapped + +-- | Iso for the float value of an Y position radius +_RadiusY :: Iso' (Radius Y) Float +_RadiusY = _Wrapped diff --git a/src/Reflex/Dom/Widget/SVG/Types/SVG_Animate.hs b/src/Reflex/Dom/Widget/SVG/Types/SVG_Animate.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Dom/Widget/SVG/Types/SVG_Animate.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +-- | Types and functions for the \ SVG element. +module Reflex.Dom.Widget.SVG.Types.SVG_Animate + ( AnimFrom (..) + , AnimTo (..) + , AnimDuration (..) + , AsAnimDuration (..) + , SVG_Animate (..) + , svg_animate_attributeName + , svg_animate_from + , svg_animate_to + , svg_animate_dur + , svg_animate_repeatCount + , makeAnimateProps + ) where + +import Control.Lens (Lens', Prism', Rewrapped, + Unwrapped, Wrapped (..), + at, iso, prism, to, (?~), + (^.), _Wrapped) + +import Data.Function ((&)) + +import Data.Semigroup ((<>)) + +import Data.Text (Text, pack) +import Data.Text.Lens (packed) + +import Data.Map (Map) + +import GHC.Word (Word16) + +import Reflex.Dom.Widget.SVG.Types.Internal (AttributeName (..), + RepeatCount (..), + wrappedToText) + +-- | attribute +newtype AnimFrom = AnimFrom Word16 deriving (Eq, Show) + +-- | attribute +newtype AnimTo = AnimTo Word16 deriving (Eq, Show) + +instance AnimFrom ~ t => Rewrapped AnimFrom t +instance Wrapped AnimFrom where + type Unwrapped AnimFrom = Word16 + _Wrapped' = iso (\ (AnimFrom x) -> x) AnimFrom + +instance AnimTo ~ t => Rewrapped AnimTo t +instance Wrapped AnimTo where + type Unwrapped AnimTo = Word16 + _Wrapped' = iso (\ (AnimTo x) -> x) AnimTo + +-- | We don't allow for negative animation durations, and currently we're only +-- interested in animations that last a matter of seconds or milliseconds. +data AnimDuration + = Secs Word16 + | MSecs Word16 + deriving (Eq, Show) + +-- | Classy Prism set for the @AnimDuration@ type +class AsAnimDuration r where + _AnimDuration :: Prism' r AnimDuration -- ^ General prism for when you have to deal with all of the constructors + _Secs :: Prism' r Word16 -- ^ Prism for Seconds + _MSecs :: Prism' r Word16 -- ^ Prism for Milliseconds + _Secs = _AnimDuration . _Secs + _MSecs = _AnimDuration . _MSecs + +instance AsAnimDuration AnimDuration where + _AnimDuration = id + _Secs = prism Secs + (\case Secs d -> Right d + x -> Left x + ) + _MSecs = prism MSecs + (\case MSecs d -> Right d + x -> Left x + ) + +toText :: String -> Word16 -> Text +toText s = pack . (<> s) . show + +animDurationToText :: AnimDuration -> Text +animDurationToText (Secs s) = toText "s" s +animDurationToText (MSecs ms) = toText "ms" ms + +-- | Properties for the > element. +data SVG_Animate = SVG_Animate + { _svg_animate_attributeName :: AttributeName + , _svg_animate_from :: AnimFrom + , _svg_animate_to :: AnimTo + , _svg_animate_dur :: AnimDuration + , _svg_animate_repeatCount :: RepeatCount + } + deriving (Eq, Show) + +-- | Lens for the @AttirbuteName@ of an @SVG_Animate@ element. +svg_animate_attributeName :: Lens' SVG_Animate AttributeName +svg_animate_attributeName f (SVG_Animate x1 x2 x3 x4 x5) + = fmap (\y1 -> SVG_Animate y1 x2 x3 x4 x5) (f x1) +{-# INLINE svg_animate_attributeName #-} + +-- | Lens for the @AnimDuration@ of an @SVG_Animate@ element. +svg_animate_dur :: Lens' SVG_Animate AnimDuration +svg_animate_dur f (SVG_Animate x1 x2 x3 x4 x5) + = fmap (\y1 -> SVG_Animate x1 x2 x3 y1 x5) (f x4) +{-# INLINE svg_animate_dur #-} + +-- | Lens for the @AnimFrom@ of an @SVG_Animate@ element. +svg_animate_from :: Lens' SVG_Animate AnimFrom +svg_animate_from f (SVG_Animate x1 x2 x3 x4 x5) + = fmap (\y1 -> SVG_Animate x1 y1 x3 x4 x5) (f x2) +{-# INLINE svg_animate_from #-} + +-- | Lens for the @AnimTo@ of an @SVG_Animate@ element. +svg_animate_to :: Lens' SVG_Animate AnimTo +svg_animate_to f (SVG_Animate x1 x2 x3 x4 x5) + = fmap (\y1 -> SVG_Animate x1 x2 y1 x4 x5) (f x3) +{-# INLINE svg_animate_to #-} + +-- | Lens for the @AnimRepeatCount@ of an @SVG_Animate@ element. +svg_animate_repeatCount :: Lens' SVG_Animate RepeatCount +svg_animate_repeatCount f (SVG_Animate x1 x2 x3 x4 x5) + = fmap (SVG_Animate x1 x2 x3 x4) (f x5) +{-# INLINE svg_animate_repeatCount #-} + +-- | Convert the given properties to the correct attributes for a \. +makeAnimateProps + :: SVG_Animate + -> Map Text Text +makeAnimateProps a = mempty + & at "attributeName" ?~ a ^. svg_animate_attributeName . _Wrapped + & at "from" ?~ a ^. svg_animate_from . wrappedToText + & at "to" ?~ a ^. svg_animate_to . wrappedToText + & at "dur" ?~ a ^. svg_animate_dur . to animDurationToText + & at "repeatCount" ?~ a ^. svg_animate_repeatCount . to show . packed diff --git a/src/Reflex/Dom/Widget/SVG/Types/SVG_Circle.hs b/src/Reflex/Dom/Widget/SVG/Types/SVG_Circle.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Dom/Widget/SVG/Types/SVG_Circle.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Types and functions for the \ SVG element. +module Reflex.Dom.Widget.SVG.Types.SVG_Circle + ( SVG_Circle (..) + , svg_circle_pos_centerX + , svg_circle_pos_centerY + , svg_circle_radius + , makeCircleProps + ) where + +import Control.Lens (Lens', at, (?~), (^.)) + +import Data.Function ((&)) + +import Data.Map (Map) + +import Data.Text (Text) + +import Reflex.Dom.Widget.SVG.Types.Internal (wrappedToText) +import Reflex.Dom.Widget.SVG.Types.Pos (CenterX, CenterY, Pos) +import Reflex.Dom.Widget.SVG.Types.Radius (Radius) + +-- | Properties for the > element. +data SVG_Circle = SVG_Circle + { _svg_circle_pos_centerX :: Pos CenterX + , _svg_circle_pos_centerY :: Pos CenterY + , _svg_circle_radius :: Radius () + } + deriving (Eq, Show) + + +-- | Lens for the Center X position of an @SVG_Circle@ +svg_circle_pos_centerX :: Lens' SVG_Circle (Pos CenterX) +svg_circle_pos_centerX f (SVG_Circle x1 x2 x3) + = fmap (\y1 -> SVG_Circle y1 x2 x3) (f x1) +{-# INLINE svg_circle_pos_centerX #-} + +-- | Lens for the Center Y position of an @SVG_Circle@ +svg_circle_pos_centerY :: Lens' SVG_Circle (Pos CenterY) +svg_circle_pos_centerY f (SVG_Circle x1 x2 x3) + = fmap (\y1 -> SVG_Circle x1 y1 x3) (f x2) +{-# INLINE svg_circle_pos_centerY #-} + +-- | Lens for the @Radius@ of an @SVG_Circle@ +svg_circle_radius :: Lens' SVG_Circle (Radius ()) +svg_circle_radius f (SVG_Circle x1 x2 x3) + = fmap (SVG_Circle x1 x2) (f x3) +{-# INLINE svg_circle_radius #-} + +-- | Convert the given properties to the correct attributes for a \. +makeCircleProps + :: SVG_Circle + -> Map Text Text +makeCircleProps c = mempty + & at "cx" ?~ c ^. svg_circle_pos_centerX . wrappedToText + & at "cy" ?~ c ^. svg_circle_pos_centerY . wrappedToText + & at "r" ?~ c ^. svg_circle_radius . wrappedToText diff --git a/src/Reflex/Dom/Widget/SVG/Types/SVG_Ellipse.hs b/src/Reflex/Dom/Widget/SVG/Types/SVG_Ellipse.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Dom/Widget/SVG/Types/SVG_Ellipse.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Types and functions for the \ SVG element. +module Reflex.Dom.Widget.SVG.Types.SVG_Ellipse + ( SVG_Ellipse (..) + , svg_ellipse_radius_x + , svg_ellipse_radius_y + , svg_ellipse_center_x + , svg_ellipse_center_y + , makeEllipseProps + ) where + +import Control.Lens (Lens', at, (?~), (^.)) + +import Data.Function ((&)) +import Data.Map (Map) + +import Data.Text (Text) + +import Reflex.Dom.Widget.SVG.Types.Internal (wrappedToText) +import Reflex.Dom.Widget.SVG.Types.Pos (CenterX, CenterY, Pos, X, + Y) +import Reflex.Dom.Widget.SVG.Types.Radius (Radius) + +-- | Properties for the > element. +data SVG_Ellipse = SVG_Ellipse + { _svg_ellipse_radius_x :: Radius X + , _svg_ellipse_radius_y :: Radius Y + , _svg_ellipse_center_x :: Pos CenterX + , _svg_ellipse_center_y :: Pos CenterY + } + deriving (Eq, Show) + +-- | Lens for the Center X position of an @SVG_Ellipse@ +svg_ellipse_center_x :: Lens' SVG_Ellipse (Pos CenterX) +svg_ellipse_center_x f (SVG_Ellipse x1 x2 x3 x4) + = fmap (\y1 -> SVG_Ellipse x1 x2 y1 x4) (f x3) +{-# INLINE svg_ellipse_center_x #-} + +-- | Lens for the Center Y position of an @SVG_Ellipse@ +svg_ellipse_center_y :: Lens' SVG_Ellipse (Pos CenterY) +svg_ellipse_center_y f (SVG_Ellipse x1 x2 x3 x4) + = fmap (SVG_Ellipse x1 x2 x3) (f x4) +{-# INLINE svg_ellipse_center_y #-} + +-- | Lens for the Radius along the X axis of an @SVG_Ellipse@ +svg_ellipse_radius_x :: Lens' SVG_Ellipse (Radius X) +svg_ellipse_radius_x f (SVG_Ellipse x1 x2 x3 x4) + = fmap (\y1 -> SVG_Ellipse y1 x2 x3 x4) (f x1) +{-# INLINE svg_ellipse_radius_x #-} + +-- | Lens for the Radius along the Y axis of an @SVG_Ellipse@ +svg_ellipse_radius_y :: Lens' SVG_Ellipse (Radius Y) +svg_ellipse_radius_y f (SVG_Ellipse x1 x2 x3 x4) + = fmap (\y1 -> SVG_Ellipse x1 y1 x3 x4) (f x2) +{-# INLINE svg_ellipse_radius_y #-} + +-- | Convert the given properties to the correct attributes for a \. +makeEllipseProps + :: SVG_Ellipse + -> Map Text Text +makeEllipseProps e = mempty + & at "cx" ?~ e ^. svg_ellipse_center_x . wrappedToText + & at "cy" ?~ e ^. svg_ellipse_center_y . wrappedToText + & at "rx" ?~ e ^. svg_ellipse_radius_x . wrappedToText + & at "ry" ?~ e ^. svg_ellipse_radius_y . wrappedToText diff --git a/src/Reflex/Dom/Widget/SVG/Types/SVG_Line.hs b/src/Reflex/Dom/Widget/SVG/Types/SVG_Line.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Dom/Widget/SVG/Types/SVG_Line.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Types and functions for \ SVG element. +module Reflex.Dom.Widget.SVG.Types.SVG_Line + ( SVG_Line (..) + , svg_line_pos_end + , svg_line_pos_start + , makeSVGLineProps + ) where + +import Control.Lens (Lens', at, (?~), (^.), + _1, _2) + +import Data.Function ((&)) + +import Data.Map (Map) + +import Data.Text (Text) + +import Reflex.Dom.Widget.SVG.Types.Internal (wrappedToText) +import Reflex.Dom.Widget.SVG.Types.Pos (Pos, X, Y) + +-- | Properties for the > element. +data SVG_Line = SVG_Line + { _svg_line_pos_start :: ( Pos X, Pos Y ) + , _svg_line_pos_end :: ( Pos X, Pos Y ) + } + deriving (Eq, Show) + +-- | Lens for the end of the @SVG_Line@ +svg_line_pos_end :: Lens' SVG_Line (Pos X, Pos Y) +svg_line_pos_end f (SVG_Line x1 x2) + = fmap (SVG_Line x1) (f x2) +{-# INLINE svg_line_pos_end #-} + +-- | Lens for the start of the @SVG_Line@ +svg_line_pos_start :: Lens' SVG_Line (Pos X, Pos Y) +svg_line_pos_start f (SVG_Line x1 x2) + = fmap (`SVG_Line` x2) (f x1) +{-# INLINE svg_line_pos_start #-} + +-- | Convert our @SVG_Line@ to the correct attribute map for Reflex. +makeSVGLineProps + :: SVG_Line + -> Map Text Text +makeSVGLineProps l = mempty + & at "x1" ?~ l ^. svg_line_pos_start . _1 . wrappedToText + & at "y1" ?~ l ^. svg_line_pos_start . _2 . wrappedToText + & at "x2" ?~ l ^. svg_line_pos_end . _1 . wrappedToText + & at "y2" ?~ l ^. svg_line_pos_end . _2 . wrappedToText diff --git a/src/Reflex/Dom/Widget/SVG/Types/SVG_Path.hs b/src/Reflex/Dom/Widget/SVG/Types/SVG_Path.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Dom/Widget/SVG/Types/SVG_Path.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +-- | Types and functions for constructing type-safe SVG \ properties. +module Reflex.Dom.Widget.SVG.Types.SVG_Path + ( PathCommandType (..) + , PathCommand (..) + , PathCommandRelativity (..) + , SVG_Path (..) + , P (..) + , _SmthQuadBez + , _QuadBez + , _SmthCubicBez + , _CubicBez + , _MoveTo + , _LineTo + , _Horizontal + , _Vertical + , _ClosePath + , _PathComm + , _m + , _M + , _l + , _L + , _h + , _H + , _v + , _V + , _z + , _Z + , makePathProps + , pathCommandToText + ) where + +import Control.Lens (Prism', Rewrapped, + Wrapped (..), iso, prism, + ( # ), (^.), _1, _2, + _Wrapped) + +import Data.Map (Map) + +import Data.List.NonEmpty (NonEmpty, toList) + +import Data.Semigroup (Semigroup (..), (<>)) + +import Data.Text (Text) +import qualified Data.Text as Text + +import Reflex.Dom.Core ((=:)) + +import Reflex.Dom.Widget.SVG.Types.Internal (wrappedToText) +import Reflex.Dom.Widget.SVG.Types.Pos (Pos, X, Y) + +-- | For a bit of brevity we wrap a combined X,Y position in a tuple tucked in a newtype. +newtype P = + P (Pos X, Pos Y) + deriving (Eq, Show) + +instance P ~ t => Rewrapped P t + +instance Wrapped P where + type Unwrapped P = (Pos X, Pos Y) + _Wrapped' = iso (\(P x) -> x) P + +-- | These are the commands to be used when building the 'd' attribute for an SVG element. +data PathCommandType + = MoveTo P -- ^ Pick up and move the drawing instrument to another position + | LineTo P -- ^ Draw a straight line + | Horizontal (Pos X) -- ^ Straight horizontal line + | Vertical (Pos Y) -- ^ Straight vertical line + | SmthQuadBez P -- ^ Smooth Quadratic Bezier Curve + | QuadBez P P -- ^ Quadratic Bezier Curve using the given control points + | SmthCubicBez P P -- ^ Smooth Cubic Bezier Curve with control points at the end + | CubicBez P P P -- ^ Cubic Bezier Curve with beginning and end control points + | ClosePath -- ^ Draw a straight line from the current position to the first point in the path. + deriving (Eq, Show) + +-- | Indicates if a given command is expected to distances from the current +-- position or be set coordinates. See the for more. +data PathCommandRelativity + = Relative -- ^ Input are considered distances relative to the current position + | Absolute -- ^ Input is considered to be an absolute position + deriving (Eq, Show) + +-- | To be able to describe a path command, we need to know the command you would +-- like to use (and its inputs). As well as whether or not you're issuing a +-- relative command, or an absolute one. +data PathCommand + = PathComm PathCommandType PathCommandRelativity + deriving (Eq, Show) + +-- | A wrapper for a list of commands to describe a SVG path. An empty list of +-- commands doesn't make sense, so you have to construct a @NonEmpty@ list. +newtype SVG_Path = + D (NonEmpty PathCommand) + deriving (Eq, Show, Semigroup) + +instance SVG_Path ~ t => Rewrapped SVG_Path t + +instance Wrapped SVG_Path where + type Unwrapped SVG_Path = (NonEmpty PathCommand) + _Wrapped' = iso (\(D x) -> x) D + +-- | Prism for a Smooth Quadradic Bezier Curve [] +_SmthQuadBez :: Prism' PathCommandType P +_SmthQuadBez = prism SmthQuadBez + (\case SmthQuadBez x1y1 -> Right x1y1 + x -> Left x + ) + +-- | Prism for a Quadradic Bezier Curve [] +_QuadBez :: Prism' PathCommandType (P, P) +_QuadBez = prism (uncurry QuadBez) + (\case QuadBez x1y1 x2y2 -> Right (x1y1, x2y2) + x -> Left x + ) + + +-- | Prism for a Smooth Cubic Bezier Curve [] +_SmthCubicBez :: Prism' PathCommandType (P, P) +_SmthCubicBez = prism (uncurry SmthCubicBez) + (\case SmthCubicBez x1y1 x2y2 -> Right (x1y1, x2y2) + x -> Left x + ) + +-- | Prism for a Cubic Bezier Curve [] +_CubicBez :: Prism' PathCommandType (P, P, P) +_CubicBez = prism (\(x1y1,x2y2,x3y3) -> CubicBez x1y1 x2y2 x3y3) + (\case CubicBez x1y1 x2y2 x3y3 -> Right (x1y1, x2y2, x3y3) + x -> Left x + ) + +-- | Prism for the 'M/m' command [] +_MoveTo :: Prism' PathCommandType P +_MoveTo = prism MoveTo + (\case MoveTo xy -> Right xy + x -> Left x) + +-- | Prism for the 'L/l' command [] +_LineTo :: Prism' PathCommandType P +_LineTo = prism LineTo + (\case LineTo xy -> Right xy + x -> Left x) + +-- | Prism for the 'H/h' command [] +_Horizontal :: Prism' PathCommandType (Pos X) +_Horizontal = prism Horizontal + (\case Horizontal y1 -> Right y1 + x -> Left x) + +-- | Prism for the 'V/v' command [] +_Vertical :: Prism' PathCommandType (Pos Y) +_Vertical = prism Vertical + (\case Vertical y1 -> Right y1 + x -> Left x) + +-- | Prism for the 'Z/z' command [] +_ClosePath :: Prism' PathCommandType () +_ClosePath = prism (const ClosePath) + (\case ClosePath -> Right () + x -> Left x) + +-- | Prism for the @PathCommand@ that encompasses the command and it's relativity. +_PathComm :: Prism' PathCommand (PathCommandType, PathCommandRelativity) +_PathComm = prism (uncurry PathComm) (\(PathComm t r) -> Right (t, r)) + +absolutePosition, relativePath :: PathCommandType -> PathCommand +relativePath pc = _PathComm # (pc, Relative) +absolutePosition pc = _PathComm # (pc, Absolute) + +-- | These are some short-hand functions to help in the construction of a +-- @PathCommand@. Named to match their respective SVG equivalent. +_m,_M,_l,_L :: Pos X -> Pos Y -> PathCommand +_m x y = relativePath $ _MoveTo . _Wrapped # (x,y) +_M x y = absolutePosition $ _MoveTo . _Wrapped # (x,y) +_l x y = relativePath $ _LineTo . _Wrapped # (x,y) +_L x y = absolutePosition $ _LineTo . _Wrapped # (x,y) + +-- | These are some short-hand functions to help in the construction of a +-- @PathCommand@. Named to match their respective SVG equivalent. +_h,_H :: Pos X -> PathCommand +_h = relativePath . (_Horizontal #) +_H = absolutePosition . (_Horizontal #) + +-- | These are some short-hand functions to help in the construction of a +-- @PathCommand@. Named to match their respective SVG equivalent. +_v,_V :: Pos Y -> PathCommand +_v = relativePath . (_Vertical #) +_V = absolutePosition . (_Vertical #) + +-- | These are some short-hand functions to help in the construction of a +-- @PathCommand@. Named to match their respective SVG equivalent. +_z,_Z :: PathCommand +_z = relativePath (_ClosePath # ()) +_Z = absolutePosition (_ClosePath # ()) + +-- | Take a given @PathCommand@ and produce a @Text@ that is intended for a 'd' +-- attribute of a \ element. +pathCommandToText + :: PathCommand + -> Text +pathCommandToText ( PathComm pc pcr ) = + let + rComm c' Relative = Text.toLower c' + rComm c' _ = c' + + pt2 xy = + let + ptx = xy ^. _Wrapped . _1 . wrappedToText + pty = xy ^. _Wrapped . _2 . wrappedToText + in + ptx <> "," <> pty + in + case pc of + MoveTo xy -> rComm "M" pcr <> pt2 xy + LineTo xy -> rComm "L" pcr <> " " <> pt2 xy + Horizontal x -> rComm "H" pcr <> " " <> x ^. wrappedToText + Vertical y -> rComm "V" pcr <> " " <> y ^. wrappedToText + + SmthQuadBez xy -> rComm "T" pcr <> pt2 xy + QuadBez cpxcpy1 xy -> rComm "Q" pcr <> pt2 cpxcpy1 <> pt2 xy + SmthCubicBez cpxcpy2 xy -> rComm "S" pcr <> pt2 cpxcpy2 <> pt2 xy + CubicBez cpxcpy1 cpxcpy2 xy -> rComm "C" pcr <> pt2 cpxcpy1 <> pt2 cpxcpy2 <> pt2 xy + + ClosePath -> rComm "Z" pcr + +-- | Convert a @SVG_Path@ to a @Map Text Text@ that includes the correctly formatted 'd' attribute. +makePathProps + :: SVG_Path + -> Map Text Text +makePathProps (D p) = + ( "d" =: ) . Text.unwords . toList $ pathCommandToText <$> p diff --git a/src/Reflex/Dom/Widget/SVG/Types/SVG_PolyLine.hs b/src/Reflex/Dom/Widget/SVG/Types/SVG_PolyLine.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Dom/Widget/SVG/Types/SVG_PolyLine.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-- | Types and functions for the \ SVG element. +-- +-- The \ SVG element is an SVG basic shape that creates straight lines +-- connecting several points. Typically a polyline is used to create open shapes +-- as the last point doesn't have to be connected to the first point. For closed +-- shapes see the \ element. +module Reflex.Dom.Widget.SVG.Types.SVG_PolyLine + ( SVG_PolyLine (..) + , svg_polyLine_path + , svg_polyLine_start + , makePolyLineProps + ) where + +import Control.Lens (Lens') + +import Data.Map (Map) + +import Data.Text (Text) + +import Data.List.NonEmpty (NonEmpty, (<|)) + +import Reflex.Dom.Core ((=:)) + +import Reflex.Dom.Widget.SVG.Types.Pos (Pos, X, Y, makePointsProp) + +-- | Properties for the > element. +data SVG_PolyLine = SVG_PolyLine + { _svg_polyLine_start :: (Pos X, Pos Y) + , _svg_polyLine_path :: NonEmpty (Pos X, Pos Y) + } + deriving (Eq, Show) + +-- | Lens for the list of @(Pos X, Pos Y)@ of an @SVG_PolyLine@ path attribute. +svg_polyLine_path :: Lens' SVG_PolyLine (NonEmpty (Pos X, Pos Y)) +svg_polyLine_path f (SVG_PolyLine x1 x2) + = fmap (SVG_PolyLine x1) (f x2) +{-# INLINE svg_polyLine_path #-} + +-- | Lens for the starting @(Pos X, Pos Y)@ of an @SVG_PolyLine@ element. +svg_polyLine_start :: Lens' SVG_PolyLine (Pos X, Pos Y) +svg_polyLine_start f (SVG_PolyLine x1 x2) + = fmap (`SVG_PolyLine` x2) (f x1) +{-# INLINE svg_polyLine_start #-} + +-- | Convert the given properties to the correct 'points' attribute of a \. +makePolyLineProps + :: SVG_PolyLine + -> Map Text Text +makePolyLineProps SVG_PolyLine {..} = + "points" =: makePointsProp (_svg_polyLine_start <| _svg_polyLine_path) diff --git a/src/Reflex/Dom/Widget/SVG/Types/SVG_Polygon.hs b/src/Reflex/Dom/Widget/SVG/Types/SVG_Polygon.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Dom/Widget/SVG/Types/SVG_Polygon.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-- | Types and functions for the \ SVG element. +-- +-- The \ element defines a closed shape consisting of a set of connected +-- straight line segments. The last point is connected to the first point. For +-- open shapes see the \ element. +module Reflex.Dom.Widget.SVG.Types.SVG_Polygon + ( SVG_Polygon (..) + , svg_polygon_path + , svg_polygon_start + , makePolygonProps + ) where + +import Control.Lens (Lens') + +import Data.List.NonEmpty (NonEmpty, (<|)) +import Data.Map (Map) +import Data.Text (Text) + +import Reflex.Dom.Core ((=:)) + +import Reflex.Dom.Widget.SVG.Types.Pos (Pos, X, Y, makePointsProp) + +-- | Properties for the > element. +data SVG_Polygon = SVG_Polygon + { _svg_polygon_start :: (Pos X, Pos Y) + , _svg_polygon_path :: NonEmpty (Pos X, Pos Y) + } + deriving (Eq, Show) + +-- | Lens for the list of @(Pos X, Pos Y)@ of an @SVG_Polygon@ path attribute. +svg_polygon_path :: Lens' SVG_Polygon (NonEmpty (Pos X, Pos Y)) +svg_polygon_path f (SVG_Polygon x1 x2) = fmap (SVG_Polygon x1) (f x2) +{-# INLINE svg_polygon_path #-} + +-- | Lens for the starting @(Pos X, Pos Y)@ of an @SVG_Polygon@ element. +svg_polygon_start :: Lens' SVG_Polygon (Pos X, Pos Y) +svg_polygon_start f (SVG_Polygon x1 x2) = fmap (`SVG_Polygon` x2) (f x1) +{-# INLINE svg_polygon_start #-} + +-- | Convert the given properties to the correct 'points' attribute of a \. +makePolygonProps + :: SVG_Polygon + -> Map Text Text +makePolygonProps SVG_Polygon {..} = + "points" =: makePointsProp (_svg_polygon_start <| _svg_polygon_path) diff --git a/src/Reflex/Dom/Widget/SVG/Types/SVG_Rect.hs b/src/Reflex/Dom/Widget/SVG/Types/SVG_Rect.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Dom/Widget/SVG/Types/SVG_Rect.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Types and lenses for the \ SVG element. +module Reflex.Dom.Widget.SVG.Types.SVG_Rect + ( SVG_Rect (..) + , svg_rect_pos_x + , svg_rect_pos_y + , svg_rect_width + , svg_rect_height + , svg_rect_cornerRadius_x + , svg_rect_cornerRadius_y + , makeRectProps + ) + where + +import Control.Lens (Lens', at, (.~), + (?~), (^.), (^?), + _Just) + +import Data.Function ((&)) + +import Data.Map (Map) + +import Data.Text (Text) + +import Reflex.Dom.Widget.SVG.Types.CornerRadius (CornerRadius) +import Reflex.Dom.Widget.SVG.Types.Pos (Pos, X, Y) + +import Reflex.Dom.Widget.SVG.Types.Internal (Height, Width, + wrappedToText) + +-- | SVG > properties +data SVG_Rect = SVG_Rect + { _svg_rect_pos_x :: Pos X -- ^ Top left X position + , _svg_rect_pos_y :: Pos Y -- ^ Top left Y position + , _svg_rect_width :: Width + , _svg_rect_height :: Height + , _svg_rect_cornerRadius_x :: Maybe (CornerRadius X) -- ^ Optional rounded corner radius + , _svg_rect_cornerRadius_y :: Maybe (CornerRadius Y) -- ^ Optional rounded corner radius + } + deriving (Eq, Show) + +-- | Lens for the X corner radius +svg_rect_cornerRadius_x :: Lens' SVG_Rect (Maybe (CornerRadius X)) +svg_rect_cornerRadius_x f (SVG_Rect x1 x2 x3 x4 x5 x6) + = fmap (\y1 -> SVG_Rect x1 x2 x3 x4 y1 x6) (f x5) +{-# INLINE svg_rect_cornerRadius_x #-} + +-- | Lens for the Y corner radius +svg_rect_cornerRadius_y :: Lens' SVG_Rect (Maybe (CornerRadius Y)) +svg_rect_cornerRadius_y f (SVG_Rect x1 x2 x3 x4 x5 x6) + = fmap (SVG_Rect x1 x2 x3 x4 x5) (f x6) +{-# INLINE svg_rect_cornerRadius_y #-} + +-- | Lens for the @Width@ of a @SVG_Rect@ +svg_rect_width :: Lens' SVG_Rect Width +svg_rect_width f (SVG_Rect x1 x2 x3 x4 x5 x6) + = fmap (\y1 -> SVG_Rect x1 x2 y1 x4 x5 x6) (f x3) +{-# INLINE svg_rect_width #-} + +-- | Lens for the @Height@ of a @SVG_Rect@ +svg_rect_height :: Lens' SVG_Rect Height +svg_rect_height f (SVG_Rect x1 x2 x3 x4 x5 x6) + = fmap (\y1 -> SVG_Rect x1 x2 x3 y1 x5 x6) (f x4) +{-# INLINE svg_rect_height #-} + +-- | Lens for the @Pos X@ of a @SVG_Rect@ +svg_rect_pos_x :: Lens' SVG_Rect (Pos X) +svg_rect_pos_x f (SVG_Rect x1 x2 x3 x4 x5 x6) + = fmap (\y1 -> SVG_Rect y1 x2 x3 x4 x5 x6) (f x1) +{-# INLINE svg_rect_pos_x #-} + +-- | Lens for the @Pos Y@ of a @SVG_Rect@ +svg_rect_pos_y :: Lens' SVG_Rect (Pos Y) +svg_rect_pos_y f (SVG_Rect x1 x2 x3 x4 x5 x6) + = fmap (\y1 -> SVG_Rect x1 y1 x3 x4 x5 x6) (f x2) +{-# INLINE svg_rect_pos_y #-} + +-- | Convert the given properties to the correct attributes for a \. +makeRectProps + :: SVG_Rect + -> Map Text Text +makeRectProps r = mempty + & at "x" ?~ r ^. svg_rect_pos_x . wrappedToText + & at "y" ?~ r ^. svg_rect_pos_y . wrappedToText + & at "width" ?~ r ^. svg_rect_width . wrappedToText + & at "height" ?~ r ^. svg_rect_height . wrappedToText + & at "rx" .~ r ^? svg_rect_cornerRadius_x . _Just . wrappedToText + & at "ry" .~ r ^? svg_rect_cornerRadius_y . _Just . wrappedToText