From 91cefa110dfd74262655fcbba13219e7c991f09a Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sat, 21 Feb 2015 21:53:40 +0000 Subject: [PATCH 1/8] Nessesary changes from style lenses. --- src/Diagrams/Attributes/Compile.hs | 4 +-- src/Diagrams/TwoD/Arrow.hs | 31 +++++++++--------- src/Diagrams/TwoD/Attributes.hs | 52 +++++++++++++++--------------- 3 files changed, 43 insertions(+), 44 deletions(-) diff --git a/src/Diagrams/Attributes/Compile.hs b/src/Diagrams/Attributes/Compile.hs index 0d418342..da5b78f8 100644 --- a/src/Diagrams/Attributes/Compile.hs +++ b/src/Diagrams/Attributes/Compile.hs @@ -26,7 +26,7 @@ import Data.Semigroup ((<>)) import Data.Tree (Tree (..)) import Diagrams.Core -import Diagrams.Core.Style (Style (..), attrToStyle) +import Diagrams.Core.Style (Style (..), attributeToStyle) import Diagrams.Core.Types (RNode (..), RTree) ------------------------------------------------------------ @@ -119,4 +119,4 @@ splitAttr code = fst . splitAttr' Nothing -- Nothing. applyMattr :: Maybe (AttrType code) -> RTree b v n a -> RTree b v n a applyMattr Nothing t = t - applyMattr (Just a) t = Node (RStyle $ attrToStyle a) [t] + applyMattr (Just a) t = Node (RStyle $ attributeToStyle (Attribute a)) [t] diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index f27ca3f5..d8e2f5de 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -11,7 +11,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Arrow --- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2013-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -103,11 +103,8 @@ module Diagrams.TwoD.Arrow , module Diagrams.TwoD.Arrowheads ) where -import Control.Applicative ((<*>)) -import Control.Lens (Lens', Setter', Traversal', - generateSignatures, lensRules, - makeLensesWith, view, (%~), (&), - (.~), (^.)) +import Control.Applicative ((<*>)) +import Control.Lens hiding (transform, none, (#)) import Data.Default.Class import Data.Functor ((<$>)) import Data.Maybe (fromMaybe) @@ -122,8 +119,8 @@ import Diagrams.Core.Types (QDiaLeaf (..), mkQD') import Diagrams.Angle import Diagrams.Attributes -import Diagrams.Direction hiding (dir) -import Diagrams.Located (Located (..), unLoc) +import Diagrams.Direction hiding (dir) +import Diagrams.Located (Located (..), unLoc) import Diagrams.Parametric import Diagrams.Path import Diagrams.Solve.Polynomial (quadForm) @@ -223,8 +220,10 @@ tailLength :: Lens' (ArrowOpts n) (Measure n) -- | Set both the @headLength@ and @tailLength@ simultaneously. lengths :: Traversal' (ArrowOpts n) (Measure n) -lengths f opts = (\h t -> opts & headLength .~ h & tailLength .~ t) <$> f (opts ^. headLength) - <*> f (opts ^. tailLength) +lengths f opts = + (\h t -> opts & headLength .~ h & tailLength .~ t) + <$> f (opts ^. headLength) + <*> f (opts ^. tailLength) -- | A lens for setting or modifying the texture of an arrowhead. For -- example, one may write @... (with & headTexture .~ grad)@ to get an @@ -232,18 +231,18 @@ lengths f opts = (\h t -> opts & headLength .~ h & tailLength .~ t) <$> f (opts -- defined. Or @... (with & headTexture .~ solid blue@ to set the head -- color to blue. For more general control over the style of arrowheads, -- see 'headStyle'. -headTexture :: TypeableFloat n => Setter' (ArrowOpts n) (Texture n) -headTexture = headStyle . styleFillTexture +headTexture :: TypeableFloat n => Lens' (ArrowOpts n) (Texture n) +headTexture = headStyle . _FillTexture -- | A lens for setting or modifying the texture of an arrow -- tail. -tailTexture :: TypeableFloat n => Setter' (ArrowOpts n) (Texture n) -tailTexture = tailStyle . styleFillTexture +tailTexture :: TypeableFloat n => Lens' (ArrowOpts n) (Texture n) +tailTexture = tailStyle . _FillTexture -- | A lens for setting or modifying the texture of an arrow -- shaft. -shaftTexture :: TypeableFloat n => Setter' (ArrowOpts n) (Texture n) -shaftTexture = shaftStyle . styleLineTexture +shaftTexture :: TypeableFloat n => Lens' (ArrowOpts n) (Texture n) +shaftTexture = shaftStyle . _LineTexture -- Set the default shaft style of an `ArrowOpts` record by applying the -- default style after all other styles have been applied. diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index d9dd842f..f45638f1 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} @@ -14,7 +15,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Attributes --- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2013-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -45,14 +46,14 @@ module Diagrams.TwoD.Attributes ( -- ** Line texture , LineTexture(..), getLineTexture, lineTexture, lineTextureA - , mkLineTexture, styleLineTexture + , mkLineTexture, _LineTexture -- ** Line color , lineColor, lc, lcA -- ** Fill texture , FillTexture(..), getFillTexture, fillTexture - , mkFillTexture, styleFillTexture + , mkFillTexture, _FillTexture -- ** Fill color , fillColor, fc, fcA, recommendFillColor @@ -62,19 +63,16 @@ module Diagrams.TwoD.Attributes ( ) where -import Control.Lens (Lens', Setter', generateSignatures, lensRules, - makeLensesWith, makePrisms, over, sets, (&), (.~)) +import Control.Lens hiding (transform) import Data.Colour hiding (AffineSpace, over) import Data.Data import Data.Default.Class -import Data.Maybe (fromMaybe) import Data.Monoid.Recommend import Data.Semigroup import Diagrams.Attributes import Diagrams.Attributes.Compile import Diagrams.Core -import Diagrams.Core.Style (setAttr) import Diagrams.Core.Types (RTree) import Diagrams.Located (unLoc) import Diagrams.Path (Path, pathTrails) @@ -120,7 +118,7 @@ type instance N (LGradient n) = n makeLensesWith (lensRules & generateSignatures .~ False) ''LGradient instance Fractional n => Transformable (LGradient n) where - transform = over lGradTrans . transform + transform = over lGradTrans . transform -- | A list of stops (colors and fractions). lGradStops :: Lens' (LGradient n) [GradientStop n] @@ -262,6 +260,12 @@ newtype LineTexture n = LineTexture (Last (Texture n)) deriving (Typeable, Semigroup) instance (Typeable n) => AttributeClass (LineTexture n) +instance Rewrapped (LineTexture n) (LineTexture n') +instance Wrapped (LineTexture n) where + type Unwrapped (LineTexture n) = Texture n + _Wrapped' = iso getLineTexture mkLineTexture + {-# INLINE _Wrapped' #-} + type instance V (LineTexture n) = V2 type instance N (LineTexture n) = n @@ -285,16 +289,11 @@ lineTextureA = applyTAttr mkLineTexture :: Texture v -> LineTexture v mkLineTexture = LineTexture . Last -styleLineTexture :: Typeable n => Setter' (Style V2 n) (Texture n) -styleLineTexture = sets modifyLineTexture +_LineTexture :: (Floating n, Typeable n) => Lens' (Style V2 n) (Texture n) +_LineTexture = atTAttr . anon def isDef . _Wrapping mkLineTexture where - modifyLineTexture f s - = flip setAttr s - . mkLineTexture - . f - . getLineTexture - . fromMaybe def . getAttr - $ s + isDef (LineTexture (Last (SC sc))) = toAlphaColour sc == opaque black + isDef _ = False -- | Set the line (stroke) color. This function is polymorphic in the -- color type (so it can be used with either 'Colour' or @@ -329,6 +328,12 @@ lineRGradient g = lineTexture (RG g) newtype FillTexture n = FillTexture (Recommend (Last (Texture n))) deriving (Typeable, Semigroup) +instance Rewrapped (FillTexture n) (FillTexture n') +instance Wrapped (FillTexture n) where + type Unwrapped (FillTexture n) = Texture n + _Wrapped' = iso getFillTexture mkFillTexture + {-# INLINE _Wrapped' #-} + instance Typeable n => AttributeClass (FillTexture n) type instance V (FillTexture n) = V2 @@ -353,16 +358,11 @@ fillTexture = applyTAttr . FillTexture . Commit . Last mkFillTexture :: Texture n -> FillTexture n mkFillTexture = FillTexture . Commit . Last -styleFillTexture :: (Typeable n) => Setter' (Style V2 n) (Texture n) -styleFillTexture = sets modifyFillTexture +_FillTexture :: (Typeable n, Floating n) => Lens' (Style V2 n) (Texture n) +_FillTexture = atTAttr . anon def isDef . _Wrapping mkFillTexture where - modifyFillTexture f s - = flip setAttr s - . mkFillTexture - . f - . getFillTexture - . fromMaybe def . getAttr - $ s + isDef (FillTexture (Recommend (Last (SC sc)))) = toAlphaColour sc == transparent + isDef _ = False -- | Set the fill color. This function is polymorphic in the color -- type (so it can be used with either 'Colour' or 'AlphaColour'), From ed729650e812d589c3bf2b36cc16a9da876eceb6 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Mon, 23 Feb 2015 19:58:12 +0000 Subject: [PATCH 2/8] All style lenses for most attributes. 3D attributes haven't been changed yet. This requires changes to the povray backend. --- src/Diagrams/Attributes.hs | 152 +++++++++++++++++++++---- src/Diagrams/Segment.hs | 16 +-- src/Diagrams/Size.hs | 16 +-- src/Diagrams/TwoD/Arrow.hs | 8 +- src/Diagrams/TwoD/Arrowheads.hs | 1 - src/Diagrams/TwoD/Attributes.hs | 53 +++++---- src/Diagrams/TwoD/Segment/Bernstein.hs | 21 ++-- src/Diagrams/TwoD/Text.hs | 66 ++++++++++- src/Diagrams/TwoD/Transform.hs | 1 - 9 files changed, 251 insertions(+), 83 deletions(-) diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index 4c8a2777..2833a4c1 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -3,12 +3,14 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Attributes --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -60,22 +62,32 @@ module Diagrams.Attributes ( -- ** Miter limit , LineMiterLimit(..), getLineMiterLimit, lineMiterLimit, lineMiterLimitA + -- * Recommend optics + + , _Recommend + , _Commit + , _recommend + , committed + , isCommitted + ) where +import Control.Applicative +import Control.Lens hiding (none, over) import Data.Colour -import Data.Colour.RGBSpace (RGB (..)) -import Data.Colour.SRGB (toSRGB) +import Data.Colour.RGBSpace (RGB (..)) +import Data.Colour.SRGB (toSRGB) import Data.Default.Class import Data.Distributive +import Data.Monoid.Recommend import Data.Semigroup import Data.Typeable import Diagrams.Core - ------------------------------------------------------------------ --- Standard Measures ------------------------------------------- ------------------------------------------------------------------ +------------------------------------------------------------------------ +-- Standard measures +------------------------------------------------------------------------ none, ultraThin, veryThin, thin, medium, thick, veryThick, ultraThick, tiny, verySmall, small, normal, large, veryLarge, huge @@ -97,15 +109,25 @@ large = normalized 0.05 veryLarge = normalized 0.07 huge = normalized 0.10 ------------------------------------------------------------------ --- Line Width ------------------------------------------------- ------------------------------------------------------------------ +------------------------------------------------------------------------ +-- Line width +------------------------------------------------------------------------ -- | Line widths specified on child nodes always override line widths -- specified at parent nodes. newtype LineWidth n = LineWidth (Last n) deriving (Typeable, Semigroup) +instance Rewrapped (LineWidth n) (LineWidth n') +instance Wrapped (LineWidth n) where + type Unwrapped (LineWidth n) = n + _Wrapped' = iso getLineWidth (LineWidth . Last) + {-# INLINE _Wrapped' #-} + +_LineWidth :: (Typeable n, OrderedField n) => Lens' (Style v n) (Measure n) +_LineWidth = atMAttr . mapping (mapping (_Wrapping (LineWidth . Last))) + . anon medium (const False) + instance Typeable n => AttributeClass (LineWidth n) type LineWidthM n = Measured n (LineWidth n) @@ -144,9 +166,9 @@ lwO = lw . output lwL :: (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a lwL = lw . local ------------------------------------------------------------------ --- Dashing ---------------------------------------------------- ------------------------------------------------------------------ +------------------------------------------------------------------------ +-- Dashing +------------------------------------------------------------------------ -- | Create lines that are dashing... er, dashed. data Dashing n = Dashing [n] n @@ -155,6 +177,16 @@ data Dashing n = Dashing [n] n newtype DashingA n = DashingA (Last (Dashing n)) deriving (Functor, Typeable, Semigroup) +instance Rewrapped (DashingA n) (DashingA n') +instance Wrapped (DashingA n) where + type Unwrapped (DashingA n) = Dashing n + _Wrapped' = iso getDashing (DashingA . Last) + {-# INLINE _Wrapped' #-} + +_Dashing :: (Typeable n, OrderedField n) + => Lens' (Style v n) (Maybe (Measured n (Dashing n))) +_Dashing = atMAttr . mapping (mapping (_Wrapping (DashingA . Last))) + instance Typeable n => AttributeClass (DashingA n) getDashing :: DashingA n -> Dashing n @@ -186,9 +218,9 @@ dashingO w v = dashing (map output w) (output v) dashingL :: (N a ~ n, HasStyle a, Typeable n, Num n) => [n] -> n -> a -> a dashingL w v = dashing (map local w) (local v) ------------------------------------------------------------- --- Color ------------------------------------------------- ------------------------------------------------------------- +------------------------------------------------------------------------ +-- Color +------------------------------------------------------------------------ -- $color -- Diagrams outsources all things color-related to Russell O\'Connor\'s @@ -246,8 +278,9 @@ alphaToColour :: (Floating a, Ord a, Fractional a) => AlphaColour a -> Colour a alphaToColour ac | alphaChannel ac == 0 = ac `over` black | otherwise = darken (recip (alphaChannel ac)) (ac `over` black) ------------------------------------------------------------- +------------------------------------------------------------------------ -- Opacity +------------------------------------------------------------------------ -- | Although the individual colors in a diagram can have -- transparency, the opacity/transparency of a diagram as a whole @@ -261,6 +294,15 @@ newtype Opacity = Opacity (Product Double) deriving (Typeable, Semigroup) instance AttributeClass Opacity +instance Rewrapped Opacity Opacity +instance Wrapped Opacity where + type Unwrapped Opacity = Double + _Wrapped' = iso getOpacity (Opacity . Product) + {-# INLINE _Wrapped' #-} + +_Opacity :: Lens' (Style v n) Double +_Opacity = atAttr . mapping (_Wrapping (Opacity . Product)) . non 1 + getOpacity :: Opacity -> Double getOpacity (Opacity (Product d)) = d @@ -270,9 +312,11 @@ getOpacity (Opacity (Product d)) = d opacity :: HasStyle a => Double -> a -> a opacity = applyAttr . Opacity . Product ------------------------------------------------------------- --- Line stuff ------------------------------------- ------------------------------------------------------------- +------------------------------------------------------------------------ +-- Line stuff +------------------------------------------------------------------------ + +-- line cap ------------------------------------------------------------ -- | What sort of shape should be placed at the endpoints of lines? data LineCap = LineCapButt -- ^ Lines end precisely at their endpoints. @@ -286,6 +330,15 @@ newtype LineCapA = LineCapA (Last LineCap) deriving (Typeable, Semigroup, Eq) instance AttributeClass LineCapA +instance Rewrapped LineCapA LineCapA +instance Wrapped LineCapA where + type Unwrapped LineCapA = LineCap + _Wrapped' = iso getLineCap (LineCapA . Last) + {-# INLINE _Wrapped' #-} + +_LineCap :: Lens' (Style v n) LineCap +_LineCap = atAttr . mapping (_Wrapping (LineCapA . Last)) . non def + instance Default LineCap where def = LineCapButt @@ -296,6 +349,8 @@ getLineCap (LineCapA (Last c)) = c lineCap :: HasStyle a => LineCap -> a -> a lineCap = applyAttr . LineCapA . Last +-- line join ----------------------------------------------------------- + -- | How should the join points between line segments be drawn? data LineJoin = LineJoinMiter -- ^ Use a \"miter\" shape (whatever that is). | LineJoinRound -- ^ Use rounded join points. @@ -308,8 +363,17 @@ newtype LineJoinA = LineJoinA (Last LineJoin) deriving (Typeable, Semigroup, Eq) instance AttributeClass LineJoinA +instance Rewrapped LineJoinA LineJoinA +instance Wrapped LineJoinA where + type Unwrapped LineJoinA = LineJoin + _Wrapped' = iso getLineJoin (LineJoinA . Last) + {-# INLINE _Wrapped' #-} + +_LineJoin :: Lens' (Style v n) LineJoin +_LineJoin = atAttr . mapping (_Wrapping (LineJoinA . Last)) . non def + instance Default LineJoin where - def = LineJoinMiter + def = LineJoinMiter getLineJoin :: LineJoinA -> LineJoin getLineJoin (LineJoinA (Last j)) = j @@ -318,14 +382,25 @@ getLineJoin (LineJoinA (Last j)) = j lineJoin :: HasStyle a => LineJoin -> a -> a lineJoin = applyAttr . LineJoinA . Last +-- miter limit --------------------------------------------------------- + -- | Miter limit attribute affecting the 'LineJoinMiter' joins. -- For some backends this value may have additional effects. newtype LineMiterLimit = LineMiterLimit (Last Double) deriving (Typeable, Semigroup) instance AttributeClass LineMiterLimit +instance Rewrapped LineMiterLimit LineMiterLimit +instance Wrapped LineMiterLimit where + type Unwrapped LineMiterLimit = Double + _Wrapped' = iso getLineMiterLimit (LineMiterLimit . Last) + {-# INLINE _Wrapped' #-} + +_LineMiterLimit :: Lens' (Style v n) Double +_LineMiterLimit = atAttr . mapping (_Wrapping (LineMiterLimit . Last)) . non 10 + instance Default LineMiterLimit where - def = LineMiterLimit (Last 10) + def = LineMiterLimit (Last 10) getLineMiterLimit :: LineMiterLimit -> Double getLineMiterLimit (LineMiterLimit (Last l)) = l @@ -338,3 +413,36 @@ lineMiterLimit = applyAttr . LineMiterLimit . Last lineMiterLimitA :: HasStyle a => LineMiterLimit -> a -> a lineMiterLimitA = applyAttr +------------------------------------------------------------------------ +-- Recommend optics +------------------------------------------------------------------------ + +-- | Prism onto a 'Recommend'. +_Recommend :: Prism' (Recommend a) a +_Recommend = prism' Recommend $ \case (Recommend a) -> Just a; _ -> Nothing + +-- | Prism onto a 'Commit'. +_Commit :: Prism' (Recommend a) a +_Commit = prism' Commit $ \case (Commit a) -> Just a; _ -> Nothing + +-- | Lens onto the value inside either a 'Recommend' or 'Commit'. Unlike +-- 'committed', this is a valid lens. +_recommend :: Lens (Recommend a) (Recommend b) a b +_recommend f (Recommend a) = Recommend <$> f a +_recommend f (Commit a) = Commit <$> f a + +-- | Lens onto weather something is commited or not. +isCommitted :: Lens' (Recommend a) Bool +isCommitted f r@(Recommend a) = f False <&> \b -> if b then Commit a else r +isCommitted f r@(Commit a) = f True <&> \b -> if b then r else Recommend a + +-- | 'Commit' a value for any 'Recommend'. This is *not* a valid 'Iso' +-- because the resulting @Recommend b@ is always a 'Commit'. This is +-- useful because it means any 'Recommend' styles set with a lens will +-- not be accidentally overridden. If you want a valid lens onto a +-- recommend value use '_recommend'. +-- +-- Other lenses that use this are labeled with a warning. +committed :: Iso (Recommend a) (Recommend b) a b +committed = iso getRecommend Commit + diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs index 0d10884e..c6816329 100644 --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -169,7 +169,7 @@ type instance V (Segment c v n) = v type instance N (Segment c v n) = n instance Transformable (Segment c v n) where - transform = mapSegmentVectors . apply + transform = mapSegmentVectors . apply instance Renderable (Segment c v n) NullBackend where render _ _ = mempty @@ -422,8 +422,8 @@ newtype SegCount = SegCount (Sum Int) deriving (Semigroup, Monoid) instance Wrapped SegCount where - type Unwrapped SegCount = Sum Int - _Wrapped' = iso (\(SegCount x) -> x) SegCount + type Unwrapped SegCount = Sum Int + _Wrapped' = iso (\(SegCount x) -> x) SegCount instance Rewrapped SegCount SegCount @@ -470,8 +470,8 @@ deriving instance (Num n, Ord n) => Monoid (ArcLength n) newtype TotalOffset v n = TotalOffset (v n) instance Wrapped (TotalOffset v n) where - type Unwrapped (TotalOffset v n) = v n - _Wrapped' = iso (\(TotalOffset x) -> x) TotalOffset + type Unwrapped (TotalOffset v n) = v n + _Wrapped' = iso (\(TotalOffset x) -> x) TotalOffset instance Rewrapped (TotalOffset v n) (TotalOffset v' n') @@ -526,8 +526,8 @@ instance (OrderedField n, Metric v) *: ArcLength ( Sum $ arcLengthBounded (stdTolerance/100) s , Sum . flip arcLengthBounded s ) - *: OffsetEnvelope (TotalOffset . segOffset $ s) - (getEnvelope s) + *: OffsetEnvelope (TotalOffset . segOffset $ s) + (getEnvelope s) - *: () + *: () diff --git a/src/Diagrams/Size.hs b/src/Diagrams/Size.hs index 1c5e8a84..40fd01b1 100644 --- a/src/Diagrams/Size.hs +++ b/src/Diagrams/Size.hs @@ -30,18 +30,18 @@ module Diagrams.Size -- ** Making size spec , mkSizeSpec - , dims - , absolute + , dims + , absolute -- ** Extracting size specs - , getSpec + , getSpec , specToSize -- ** Functions on size specs - , requiredScale + , requiredScale , requiredScaling - , sized - , sizedAs + , sized + , sizedAs , sizeAdjustment ) where @@ -146,8 +146,8 @@ sizedAs :: (InSpace v n a, SameSpace a b, HasLinearMap v, HasBasis v, Transforma => b -> a -> a sizedAs other = sized (dims $ size other) --- | Get the adjustment to fit a 'BoundingBox' in the given 'SizeSpec'. The --- vector is the new size and the transformation to position the lower +-- | Get the adjustment to fit a 'BoundingBox' in the given 'SizeSpec'. The +-- vector is the new size and the transformation to position the lower -- corner at the origin and scale to the size spec. sizeAdjustment :: (Additive v, Foldable v, OrderedField n) => SizeSpec v n -> BoundingBox v n -> (v n, Transformation v n) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index d8e2f5de..850cda7a 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -220,10 +220,8 @@ tailLength :: Lens' (ArrowOpts n) (Measure n) -- | Set both the @headLength@ and @tailLength@ simultaneously. lengths :: Traversal' (ArrowOpts n) (Measure n) -lengths f opts = - (\h t -> opts & headLength .~ h & tailLength .~ t) - <$> f (opts ^. headLength) - <*> f (opts ^. tailLength) +lengths f opts = (\h t -> opts & headLength .~ h & tailLength .~ t) <$> f (opts ^. headLength) + <*> f (opts ^. tailLength) -- | A lens for setting or modifying the texture of an arrowhead. For -- example, one may write @... (with & headTexture .~ grad)@ to get an @@ -235,7 +233,7 @@ headTexture :: TypeableFloat n => Lens' (ArrowOpts n) (Texture n) headTexture = headStyle . _FillTexture -- | A lens for setting or modifying the texture of an arrow --- tail. +-- tail. This is *not* a valid lens (see 'committed'). tailTexture :: TypeableFloat n => Lens' (ArrowOpts n) (Texture n) tailTexture = tailStyle . _FillTexture diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index 0eaea861..fb339ed9 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index f45638f1..b92b89e6 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -86,8 +86,8 @@ import Diagrams.TwoD.Types -- | A gradient stop contains a color and fraction (usually between 0 and 1) data GradientStop d = GradientStop - { _stopColor :: SomeColor - , _stopFraction :: d} + { _stopColor :: SomeColor + , _stopFraction :: d} makeLensesWith (lensRules & generateSignatures .~ False) ''GradientStop @@ -106,11 +106,11 @@ data SpreadMethod = GradPad | GradReflect | GradRepeat -- | Linear Gradient data LGradient n = LGradient - { _lGradStops :: [GradientStop n] - , _lGradStart :: Point V2 n - , _lGradEnd :: Point V2 n - , _lGradTrans :: Transformation V2 n - , _lGradSpreadMethod :: SpreadMethod } + { _lGradStops :: [GradientStop n] + , _lGradStart :: Point V2 n + , _lGradEnd :: Point V2 n + , _lGradTrans :: Transformation V2 n + , _lGradSpreadMethod :: SpreadMethod } type instance V (LGradient n) = V2 type instance N (LGradient n) = n @@ -141,13 +141,13 @@ lGradSpreadMethod :: Lens' (LGradient n) SpreadMethod -- | Radial Gradient data RGradient n = RGradient - { _rGradStops :: [GradientStop n] - , _rGradCenter0 :: Point V2 n - , _rGradRadius0 :: n - , _rGradCenter1 :: Point V2 n - , _rGradRadius1 :: n - , _rGradTrans :: Transformation V2 n - , _rGradSpreadMethod :: SpreadMethod } + { _rGradStops :: [GradientStop n] + , _rGradCenter0 :: Point V2 n + , _rGradRadius0 :: n + , _rGradCenter1 :: Point V2 n + , _rGradRadius1 :: n + , _rGradTrans :: Transformation V2 n + , _rGradSpreadMethod :: SpreadMethod } makeLensesWith (lensRules & generateSignatures .~ False) ''RGradient @@ -230,7 +230,7 @@ defaultRG = RG RGradient , _rGradRadius1 = 0.5 , _rGradTrans = mempty , _rGradSpreadMethod = GradPad -} + } -- | A convenient function for making gradient stops from a list of triples. -- (An opaque color, a stop fraction, an opacity). @@ -328,10 +328,16 @@ lineRGradient g = lineTexture (RG g) newtype FillTexture n = FillTexture (Recommend (Last (Texture n))) deriving (Typeable, Semigroup) +-- This isn't valid since it ignores Recommend! instance Rewrapped (FillTexture n) (FillTexture n') instance Wrapped (FillTexture n) where - type Unwrapped (FillTexture n) = Texture n - _Wrapped' = iso getFillTexture mkFillTexture + type Unwrapped (FillTexture n) = Recommend (Texture n) + _Wrapped' = iso getter setter -- == coerce + where + getter (FillTexture (Recommend (Last t))) = Recommend t + getter (FillTexture (Commit (Last t))) = Commit t + setter (Recommend t) = FillTexture (Recommend (Last t)) + setter (Commit t) = FillTexture (Commit (Last t)) {-# INLINE _Wrapped' #-} instance Typeable n => AttributeClass (FillTexture n) @@ -342,8 +348,7 @@ type instance N (FillTexture n) = n -- Only gradients get transformed. The transform is applied to the gradients -- transform field. Colors are left unchanged. instance Floating n => Transformable (FillTexture n) where - transform _ tx@(FillTexture (Recommend _)) = tx - transform t (FillTexture (Commit (Last tx))) = FillTexture (Commit (Last $ transform t tx)) + transform = over (_Wrapped' . _recommend) . transform instance Default (FillTexture n) where def = FillTexture (Recommend (Last (SC @@ -358,12 +363,18 @@ fillTexture = applyTAttr . FillTexture . Commit . Last mkFillTexture :: Texture n -> FillTexture n mkFillTexture = FillTexture . Commit . Last -_FillTexture :: (Typeable n, Floating n) => Lens' (Style V2 n) (Texture n) -_FillTexture = atTAttr . anon def isDef . _Wrapping mkFillTexture +-- | Lens onto the 'Recommend' of a fill texture. +_RFillTexture :: (Typeable n, Floating n) => Lens' (Style V2 n) (Recommend (Texture n)) +_RFillTexture = atTAttr . anon def isDef . _Wrapping (mkFillTexture . getRecommend) where isDef (FillTexture (Recommend (Last (SC sc)))) = toAlphaColour sc == transparent isDef _ = False +-- | Commit a fill texture in a style. To extract the fill texture +-- use '_RFillTexture'. This is *not* a valid lens (see 'committed'). +_FillTexture :: (Typeable n, Floating n) => Lens' (Style V2 n) (Texture n) +_FillTexture = _RFillTexture . committed + -- | Set the fill color. This function is polymorphic in the color -- type (so it can be used with either 'Colour' or 'AlphaColour'), -- but this can sometimes create problems for type inference, so the diff --git a/src/Diagrams/TwoD/Segment/Bernstein.hs b/src/Diagrams/TwoD/Segment/Bernstein.hs index 26ba2f58..092f099e 100644 --- a/src/Diagrams/TwoD/Segment/Bernstein.hs +++ b/src/Diagrams/TwoD/Segment/Bernstein.hs @@ -3,13 +3,13 @@ module Diagrams.TwoD.Segment.Bernstein ( BernsteinPoly (..) - , listToBernstein - , evaluateBernstein + , listToBernstein + , evaluateBernstein - , degreeElevate - , bernsteinDeriv - , evaluateBernsteinDerivs - ) where + , degreeElevate + , bernsteinDeriv + , evaluateBernsteinDerivs + ) where import Data.List (tails) import Diagrams.Core.V @@ -78,12 +78,12 @@ bernsteinDeriv (BernsteinPoly lp p) = BernsteinPoly (lp-1) $ zipWith (\a b -> (a - b) * fromIntegral lp) (tail p) p instance Fractional n => Parametric (BernsteinPoly n) where - atParam b = V1 . evaluateBernstein b + atParam b = V1 . evaluateBernstein b instance Num n => DomainBounds (BernsteinPoly n) instance Fractional n => EndValues (BernsteinPoly n) instance Fractional n => Sectionable (BernsteinPoly n) where - splitAtParam = bernsteinSplit - reverseDomain (BernsteinPoly i xs) = BernsteinPoly i (reverse xs) + splitAtParam = bernsteinSplit + reverseDomain (BernsteinPoly i xs) = BernsteinPoly i (reverse xs) -- | Split a bernstein polynomial bernsteinSplit :: Num n => BernsteinPoly n -> n -> (BernsteinPoly n, BernsteinPoly n) @@ -114,7 +114,7 @@ instance Fractional n => Num (BernsteinPoly n) where zipWith (flip (/)) (binomials (la + lb)) $ init $ map sum $ map (zipWith (*) a') (down b') ++ - map (zipWith (*) (reverse b')) (tail $ tails a') + map (zipWith (*) (reverse b')) (tail $ tails a') -- zipWith (zipWith (*)) (tail $ tails a') (repeat $ reverse b') where down l = tail $ scanl (flip (:)) [] l -- [[1], [2, 1], [3, 2, 1], ... a' = zipWith (*) a (binomials la) @@ -127,4 +127,3 @@ instance Fractional n => Num (BernsteinPoly n) where abs = fmap abs - diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs index 7194fe44..8dd70c74 100644 --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -1,9 +1,9 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -35,17 +35,19 @@ module Diagrams.TwoD.Text ( , FontWeight(..), FontWeightA, getFontWeight, fontWeight, bold ) where +import Control.Lens hiding (transform) +import Diagrams.Attributes (committed) import Diagrams.Core import Diagrams.Core.Envelope (pointEnvelope) import Diagrams.TwoD.Attributes (recommendFillColor) import Diagrams.TwoD.Types -import Data.Colour -import Data.Functor -import Data.Typeable +import Data.Colour hiding (over) import Data.Default.Class -import Data.Semigroup +import Data.Functor import Data.Monoid.Recommend +import Data.Semigroup +import Data.Typeable import Linear.Affine @@ -167,6 +169,15 @@ baselineText = mkText BaselineText newtype Font = Font (Last String) deriving (Typeable, Semigroup, Eq) +instance Rewrapped Font Font +instance Wrapped Font where + type Unwrapped Font = String + _Wrapped' = iso getFont (Font . Last) + {-# INLINE _Wrapped' #-} + +_Font :: (Typeable n, OrderedField n) => Lens' (Style v n) (Maybe String) +_Font = atAttr . mapping (_Wrapping (Font . Last)) + instance AttributeClass Font -- | Extract the font family name from a @Font@ attribute. @@ -190,7 +201,26 @@ instance Functor FontSize where fmap f (FontSize (Recommend (Last a))) = FontSize (Recommend (Last (f a))) fmap f (FontSize (Commit (Last a))) = FontSize (Commit (Last (f a))) --- (Recommend (Last (Texture n))) +instance Rewrapped (FontSize n) (FontSize n') +instance Wrapped (FontSize n) where + type Unwrapped (FontSize n) = Recommend n + _Wrapped' = iso getter setter + where getter (FontSize (Recommend (Last a))) = Recommend a + getter (FontSize (Commit (Last a))) = Commit a + setter (Recommend a) = FontSize $ Recommend (Last a) + setter (Commit a) = FontSize $ Commit (Last a) + {-# INLINE _Wrapped' #-} + +_RFontSize :: (Typeable n, OrderedField n) => Lens' (Style v n) (Measured n (Recommend n)) +_RFontSize = atMAttr . mapping (mapping (_Wrapping setter)) . anon (Recommend <$> local 1) (const False) + where + setter (Recommend a) = FontSize $ Recommend (Last a) + setter (Commit a) = FontSize $ Commit (Last a) + +-- | Lens to commit a font size. This is *not* a valid lens (see +-- 'commited'. +_FontSize :: (Typeable n, OrderedField n) => Lens' (Style v n) (Measure n) +_FontSize = _RFontSize . mapping committed type FontSizeM n = Measured n (FontSize n) @@ -248,6 +278,18 @@ newtype FontSlantA = FontSlantA (Last FontSlant) deriving (Typeable, Semigroup, Eq) instance AttributeClass FontSlantA +instance Rewrapped FontSlantA FontSlantA +instance Wrapped FontSlantA where + type Unwrapped FontSlantA = FontSlant + _Wrapped' = iso getFontSlant (FontSlantA . Last) + {-# INLINE _Wrapped' #-} + +instance Default FontSlant where + def = FontSlantNormal + +_FontSlant :: (Typeable n, OrderedField n) => Lens' (Style v n) FontSlant +_FontSlant = atAttr . mapping (_Wrapping (FontSlantA . Last)) . non def + -- | Extract the font slant from a 'FontSlantA' attribute. getFontSlant :: FontSlantA -> FontSlant getFontSlant (FontSlantA (Last s)) = s @@ -280,6 +322,18 @@ newtype FontWeightA = FontWeightA (Last FontWeight) deriving (Typeable, Semigroup, Eq) instance AttributeClass FontWeightA +instance Rewrapped FontWeightA FontWeightA +instance Wrapped FontWeightA where + type Unwrapped FontWeightA = FontWeight + _Wrapped' = iso getFontWeight (FontWeightA . Last) + {-# INLINE _Wrapped' #-} + +instance Default FontWeight where + def = FontWeightNormal + +_FontWeight :: (Typeable n, OrderedField n) => Lens' (Style v n) FontWeight +_FontWeight = atAttr . mapping (_Wrapping (FontWeightA . Last)) . non def + -- | Extract the font weight from a 'FontWeightA' attribute. getFontWeight :: FontWeightA -> FontWeight getFontWeight (FontWeightA (Last w)) = w diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs index 224cb100..3a12044b 100644 --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} From 7de372dd363c6a4ae6c68e53970c4d357c18f827 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Mon, 23 Feb 2015 20:02:01 +0000 Subject: [PATCH 3/8] Remove ConstraintKinds. --- src/Diagrams/Align.hs | 3 +-- src/Diagrams/Animation.hs | 1 - src/Diagrams/BoundingBox.hs | 9 ++++----- src/Diagrams/Combinators.hs | 1 - src/Diagrams/Size.hs | 1 - src/Diagrams/ThreeD/Align.hs | 1 - src/Diagrams/ThreeD/Size.hs | 3 +-- src/Diagrams/ThreeD/Transform.hs | 1 - src/Diagrams/Transform.hs | 1 - src/Diagrams/TwoD/Align.hs | 1 - src/Diagrams/TwoD/Arc.hs | 1 - src/Diagrams/TwoD/Attributes.hs | 1 - src/Diagrams/TwoD/Combinators.hs | 1 - src/Diagrams/TwoD/Path.hs | 1 - src/Diagrams/TwoD/Polygons.hs | 3 +-- src/Diagrams/TwoD/Segment.hs | 1 - src/Diagrams/TwoD/Shapes.hs | 1 - src/Diagrams/TwoD/Size.hs | 1 - src/Diagrams/TwoD/Text.hs | 1 - 19 files changed, 7 insertions(+), 26 deletions(-) diff --git a/src/Diagrams/Align.hs b/src/Diagrams/Align.hs index 6020d63d..3bebb46d 100644 --- a/src/Diagrams/Align.hs +++ b/src/Diagrams/Align.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -79,7 +78,7 @@ alignBy'Default boundary v d a = moveOriginTo (lerp ((d + 1) / 2) (boundary (negated v) a) ) a {-# ANN alignBy'Default ("HLint: ignore Use camelCase" :: String) #-} - + -- | Some standard functions which can be used as the `boundary` argument to -- `alignBy'`. diff --git a/src/Diagrams/Animation.hs b/src/Diagrams/Animation.hs index f9895e8e..aafb456a 100644 --- a/src/Diagrams/Animation.hs +++ b/src/Diagrams/Animation.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs index 64692a72..77bdec7b 100644 --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -185,19 +184,19 @@ boxExtents = maybe zero (\(l,u) -> u .-. l) . getCorners boxCenter :: (Additive v, Fractional n) => BoundingBox v n -> Maybe (Point v n) boxCenter = fmap (uncurry (lerp 0.5)) . getCorners --- | Get the center of a the bounding box of an enveloped object, return +-- | Get the center of a the bounding box of an enveloped object, return -- 'Nothing' for object with empty envelope. mCenterPoint :: (InSpace v n a, HasBasis v, Num n, Enveloped a) => a -> Maybe (Point v n) mCenterPoint = boxCenter . boundingBox --- | Get the center of a the bounding box of an enveloped object, return +-- | Get the center of a the bounding box of an enveloped object, return -- the origin for object with empty envelope. centerPoint :: (InSpace v n a, HasBasis v, Num n, Enveloped a) => a -> Point v n centerPoint = fromMaybe origin . mCenterPoint --- | Create a transformation mapping points from one bounding box to the +-- | Create a transformation mapping points from one bounding box to the -- other. Returns 'Nothing' if either of the boxes are empty. boxTransform :: (Additive v, Fractional n) @@ -209,7 +208,7 @@ boxTransform u v = do s = liftU2 (*) . uncurry (liftU2 (/)) . mapT boxExtents return $ Transformation i i (vl ^-^ s (v, u) ul) --- | Transforms an enveloped thing to fit within a @BoundingBox@. If the +-- | Transforms an enveloped thing to fit within a @BoundingBox@. If the -- bounding box is empty, then the result is also @mempty@. boxFit :: (InSpace v n a, HasBasis v, Enveloped a, Transformable a, Monoid a, Num n) diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs index 521ff2f7..5708d176 100644 --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} diff --git a/src/Diagrams/Size.hs b/src/Diagrams/Size.hs index 40fd01b1..289f0fd7 100644 --- a/src/Diagrams/Size.hs +++ b/src/Diagrams/Size.hs @@ -2,7 +2,6 @@ #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-} #endif -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/src/Diagrams/ThreeD/Align.hs b/src/Diagrams/ThreeD/Align.hs index 85c4cd9c..1e754b51 100644 --- a/src/Diagrams/ThreeD/Align.hs +++ b/src/Diagrams/ThreeD/Align.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- diff --git a/src/Diagrams/ThreeD/Size.hs b/src/Diagrams/ThreeD/Size.hs index cd1b68f2..28576553 100644 --- a/src/Diagrams/ThreeD/Size.hs +++ b/src/Diagrams/ThreeD/Size.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} @@ -35,7 +34,7 @@ import Diagrams.ThreeD.Vector ------------------------------------------------------------ -- | Compute the absolute z-coordinate range of an enveloped object in --- the form @(lo,hi)@. Return @Nothing@ for objects with an empty +-- the form @(lo,hi)@. Return @Nothing@ for objects with an empty -- envelope. extentZ :: (InSpace v n a, R3 v, Enveloped a) => a -> Maybe (n, n) extentZ = extent unitZ diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index ac03f7e1..bd85f046 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/src/Diagrams/Transform.hs b/src/Diagrams/Transform.hs index d2d74afc..b0e9fdf8 100644 --- a/src/Diagrams/Transform.hs +++ b/src/Diagrams/Transform.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Transform diff --git a/src/Diagrams/TwoD/Align.hs b/src/Diagrams/TwoD/Align.hs index 4023a9b6..acb3c0b8 100644 --- a/src/Diagrams/TwoD/Align.hs +++ b/src/Diagrams/TwoD/Align.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs index 9151c85b..6e2ae236 100644 --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index b92b89e6..df6fb755 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index 409a8481..01bd4270 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs index 81199f3c..86bef595 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs index ff927d1e..aa0cad64 100644 --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -98,7 +97,7 @@ data PolyType n = PolyPolar [Angle n] [n] -- words, a polygon specified by \"turtle -- graphics\": go straight ahead x1 units; turn by -- external angle a1; go straight ahead x2 units; turn by - -- external angle a2; etc. The polygon will be centered + -- external angle a2; etc. The polygon will be centered -- at the /centroid/ of its vertices. -- -- * The first argument is a list of /vertex/ diff --git a/src/Diagrams/TwoD/Segment.hs b/src/Diagrams/TwoD/Segment.hs index 896bafde..8773e981 100644 --- a/src/Diagrams/TwoD/Segment.hs +++ b/src/Diagrams/TwoD/Segment.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Diagrams/TwoD/Shapes.hs b/src/Diagrams/TwoD/Shapes.hs index 194d1472..6cc782ea 100644 --- a/src/Diagrams/TwoD/Shapes.hs +++ b/src/Diagrams/TwoD/Shapes.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Diagrams/TwoD/Size.hs b/src/Diagrams/TwoD/Size.hs index ab11013a..d313c316 100644 --- a/src/Diagrams/TwoD/Size.hs +++ b/src/Diagrams/TwoD/Size.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs index 8dd70c74..dbe03b70 100644 --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} From 9d4ed09a29cb961efb3a4901a8bcace398d6c3e8 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Tue, 24 Feb 2015 21:00:52 +0000 Subject: [PATCH 4/8] Change style lenses naming. Now _Attribute is an Iso and _attribute is a lens onto the attribute in a style. --- src/Diagrams/Attributes.hs | 94 +++++++++++++++++++++---------- src/Diagrams/ThreeD/Attributes.hs | 59 ++++++++++++++++--- src/Diagrams/TwoD/Arrow.hs | 6 +- src/Diagrams/TwoD/Attributes.hs | 59 +++++++++++-------- src/Diagrams/TwoD/Text.hs | 58 ++++++++++++------- 5 files changed, 192 insertions(+), 84 deletions(-) diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index 2833a4c1..7eaa7dc8 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -37,38 +37,42 @@ module Diagrams.Attributes ( , lw, lwN, lwO, lwL, lwG -- ** Dashing - , Dashing(..), DashingA, getDashing - , dashing, dashingN, dashingO, dashingL, dashingG + , Dashing(..), DashingA, _Dashing, _DashingM, getDashing + , dashing, dashingN, dashingO, dashingL, dashingG, _dashing -- * Color -- $color - , Color(..), SomeColor(..), someToAlpha + , Color(..), SomeColor(..), _SomeColor, someToAlpha -- ** Opacity - , Opacity, getOpacity, opacity + , Opacity, _Opacity + , getOpacity, opacity, _opacity -- ** Converting colors , colorToSRGBA, colorToRGBA -- * Line stuff -- ** Cap style - , LineCap(..), LineCapA, getLineCap, lineCap + , LineCap(..), LineCapA, _LineCap + , getLineCap, lineCap, _lineCap -- ** Join style - , LineJoin(..), LineJoinA, getLineJoin, lineJoin + , LineJoin(..), LineJoinA, _LineJoin + , getLineJoin, lineJoin, _lineJoin -- ** Miter limit - , LineMiterLimit(..), getLineMiterLimit, lineMiterLimit, lineMiterLimitA + , LineMiterLimit(..), _LineMiterLimit + , getLineMiterLimit, lineMiterLimit, lineMiterLimitA, _lineMiterLimit -- * Recommend optics , _Recommend , _Commit , _recommend - , committed , isCommitted + , committed ) where @@ -122,11 +126,12 @@ instance Rewrapped (LineWidth n) (LineWidth n') instance Wrapped (LineWidth n) where type Unwrapped (LineWidth n) = n _Wrapped' = iso getLineWidth (LineWidth . Last) - {-# INLINE _Wrapped' #-} -_LineWidth :: (Typeable n, OrderedField n) => Lens' (Style v n) (Measure n) -_LineWidth = atMAttr . mapping (mapping (_Wrapping (LineWidth . Last))) - . anon medium (const False) +_LineWidth :: (Typeable n, OrderedField n) => Iso' (LineWidth n) n +_LineWidth = iso getLineWidth (LineWidth . Last) + +_LineWidthM :: (Typeable n, OrderedField n) => Iso' (LineWidthM n) (Measure n) +_LineWidthM = mapping _LineWidth instance Typeable n => AttributeClass (LineWidth n) @@ -166,6 +171,11 @@ lwO = lw . output lwL :: (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a lwL = lw . local +-- | Lens onto a measured line width in a style. +_lineWidth, _lw :: (Typeable n, OrderedField n) => Lens' (Style v n) (Measure n) +_lineWidth = atMAttr . anon def (const False) . _LineWidthM +_lw = _lineWidth + ------------------------------------------------------------------------ -- Dashing ------------------------------------------------------------------------ @@ -183,9 +193,11 @@ instance Wrapped (DashingA n) where _Wrapped' = iso getDashing (DashingA . Last) {-# INLINE _Wrapped' #-} -_Dashing :: (Typeable n, OrderedField n) - => Lens' (Style v n) (Maybe (Measured n (Dashing n))) -_Dashing = atMAttr . mapping (mapping (_Wrapping (DashingA . Last))) +_Dashing :: Iso' (DashingA n) (Dashing n) +_Dashing = iso getDashing (DashingA . Last) + +_DashingM :: Iso' (Measured n (DashingA n)) (Measured n (Dashing n)) +_DashingM = mapping _Dashing instance Typeable n => AttributeClass (DashingA n) @@ -218,6 +230,11 @@ dashingO w v = dashing (map output w) (output v) dashingL :: (N a ~ n, HasStyle a, Typeable n, Num n) => [n] -> n -> a -> a dashingL w v = dashing (map local w) (local v) +-- | Lens onto a measured dashing attribute in a style. +_dashing :: (Typeable n, OrderedField n) + => Lens' (Style v n) (Maybe (Measured n (Dashing n))) +_dashing = atMAttr . mapping _DashingM + ------------------------------------------------------------------------ -- Color ------------------------------------------------------------------------ @@ -247,6 +264,10 @@ class Color c where data SomeColor = forall c. Color c => SomeColor c deriving Typeable +-- | Isomorphism between 'SomeColor' and 'AlphaColour' 'Double'. +_SomeColor :: Iso' SomeColor (AlphaColour Double) +_SomeColor = iso toAlphaColour fromAlphaColour + someToAlpha :: SomeColor -> AlphaColour Double someToAlpha (SomeColor c) = toAlphaColour c @@ -297,11 +318,10 @@ instance AttributeClass Opacity instance Rewrapped Opacity Opacity instance Wrapped Opacity where type Unwrapped Opacity = Double - _Wrapped' = iso getOpacity (Opacity . Product) - {-# INLINE _Wrapped' #-} + _Wrapped' = _Opacity -_Opacity :: Lens' (Style v n) Double -_Opacity = atAttr . mapping (_Wrapping (Opacity . Product)) . non 1 +_Opacity :: Iso' Opacity Double +_Opacity = iso getOpacity (Opacity . Product) getOpacity :: Opacity -> Double getOpacity (Opacity (Product d)) = d @@ -312,6 +332,10 @@ getOpacity (Opacity (Product d)) = d opacity :: HasStyle a => Double -> a -> a opacity = applyAttr . Opacity . Product +-- | Lens onto the opacity in a style. +_opacity :: Lens' (Style v n) Double +_opacity = atAttr . mapping _Opacity . non 1 + ------------------------------------------------------------------------ -- Line stuff ------------------------------------------------------------------------ @@ -333,11 +357,11 @@ instance AttributeClass LineCapA instance Rewrapped LineCapA LineCapA instance Wrapped LineCapA where type Unwrapped LineCapA = LineCap - _Wrapped' = iso getLineCap (LineCapA . Last) + _Wrapped' = _LineCap {-# INLINE _Wrapped' #-} -_LineCap :: Lens' (Style v n) LineCap -_LineCap = atAttr . mapping (_Wrapping (LineCapA . Last)) . non def +_LineCap :: Iso' LineCapA LineCap +_LineCap = iso getLineCap (LineCapA . Last) instance Default LineCap where def = LineCapButt @@ -349,6 +373,10 @@ getLineCap (LineCapA (Last c)) = c lineCap :: HasStyle a => LineCap -> a -> a lineCap = applyAttr . LineCapA . Last +-- | Lens onto the line cap in a style +_lineCap :: Lens' (Style v n) LineCap +_lineCap = atAttr . mapping _LineCap . non def + -- line join ----------------------------------------------------------- -- | How should the join points between line segments be drawn? @@ -366,11 +394,10 @@ instance AttributeClass LineJoinA instance Rewrapped LineJoinA LineJoinA instance Wrapped LineJoinA where type Unwrapped LineJoinA = LineJoin - _Wrapped' = iso getLineJoin (LineJoinA . Last) - {-# INLINE _Wrapped' #-} + _Wrapped' = _LineJoin -_LineJoin :: Lens' (Style v n) LineJoin -_LineJoin = atAttr . mapping (_Wrapping (LineJoinA . Last)) . non def +_LineJoin :: Iso' LineJoinA LineJoin +_LineJoin = iso getLineJoin (LineJoinA . Last) instance Default LineJoin where def = LineJoinMiter @@ -382,6 +409,9 @@ getLineJoin (LineJoinA (Last j)) = j lineJoin :: HasStyle a => LineJoin -> a -> a lineJoin = applyAttr . LineJoinA . Last +_lineJoin :: Lens' (Style v n) LineJoin +_lineJoin = atAttr . mapping _LineJoin . non def + -- miter limit --------------------------------------------------------- -- | Miter limit attribute affecting the 'LineJoinMiter' joins. @@ -393,11 +423,10 @@ instance AttributeClass LineMiterLimit instance Rewrapped LineMiterLimit LineMiterLimit instance Wrapped LineMiterLimit where type Unwrapped LineMiterLimit = Double - _Wrapped' = iso getLineMiterLimit (LineMiterLimit . Last) - {-# INLINE _Wrapped' #-} + _Wrapped' = _LineMiterLimit -_LineMiterLimit :: Lens' (Style v n) Double -_LineMiterLimit = atAttr . mapping (_Wrapping (LineMiterLimit . Last)) . non 10 +_LineMiterLimit :: Iso' LineMiterLimit Double +_LineMiterLimit = iso getLineMiterLimit (LineMiterLimit . Last) instance Default LineMiterLimit where def = LineMiterLimit (Last 10) @@ -413,6 +442,9 @@ lineMiterLimit = applyAttr . LineMiterLimit . Last lineMiterLimitA :: HasStyle a => LineMiterLimit -> a -> a lineMiterLimitA = applyAttr +_lineMiterLimit :: Lens' (Style v n) Double +_lineMiterLimit = atAttr . mapping _LineMiterLimit . non 10 + ------------------------------------------------------------------------ -- Recommend optics ------------------------------------------------------------------------ @@ -431,7 +463,7 @@ _recommend :: Lens (Recommend a) (Recommend b) a b _recommend f (Recommend a) = Recommend <$> f a _recommend f (Commit a) = Commit <$> f a --- | Lens onto weather something is commited or not. +-- | Lens onto weather something is committed or not. isCommitted :: Lens' (Recommend a) Bool isCommitted f r@(Recommend a) = f False <&> \b -> if b then Commit a else r isCommitted f r@(Commit a) = f True <&> \b -> if b then r else Recommend a diff --git a/src/Diagrams/ThreeD/Attributes.hs b/src/Diagrams/ThreeD/Attributes.hs index cad554d7..e80953f4 100644 --- a/src/Diagrams/ThreeD/Attributes.hs +++ b/src/Diagrams/ThreeD/Attributes.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Attributes @@ -41,12 +42,20 @@ newtype SurfaceColor = SurfaceColor (Last (Colour Double)) instance AttributeClass SurfaceColor -surfaceColor :: Iso' SurfaceColor (Colour Double) -surfaceColor = iso (\(SurfaceColor (Last c)) -> c) (SurfaceColor . Last) +instance Wrapped SurfaceColor where + type Unwrapped SurfaceColor = Colour Double + _Wrapped' = _SurfaceColor + +_SurfaceColor :: Iso' SurfaceColor (Colour Double) +_SurfaceColor = iso (\(SurfaceColor (Last c)) -> c) (SurfaceColor . Last) -- | Set the surface color. sc :: HasStyle d => Colour Double -> d -> d -sc = applyAttr . review surfaceColor +sc = applyAttr . review _SurfaceColor + +-- | Lens onto the surface colour of a style. +_sc :: Lens' (Style v n) (Maybe (Colour Double)) +_sc = atAttr . mapping _SurfaceColor -- | @Diffuse@ is the fraction of incident light reflected diffusely, -- that is, in all directions. The actual light reflected is the @@ -58,6 +67,11 @@ newtype Diffuse = Diffuse (Last Double) instance AttributeClass Diffuse +instance Wrapped Diffuse where + type Unwrapped Diffuse = Double + _Wrapped' = _Diffuse + +-- | Isomorphism between 'Diffuse' and 'Double' _Diffuse :: Iso' Diffuse Double _Diffuse = iso (\(Diffuse (Last d)) -> d) (Diffuse . Last) @@ -65,6 +79,10 @@ _Diffuse = iso (\(Diffuse (Last d)) -> d) (Diffuse . Last) diffuse :: HasStyle d => Double -> d -> d diffuse = applyAttr . review _Diffuse +-- | Lens onto the possible diffuse reflectance in a style. +_diffuse :: Lens' (Style v n) (Maybe Double) +_diffuse = atAttr . mapping _Diffuse + -- | @Ambient@ is an ad-hoc representation of indirect lighting. The -- product of @Ambient@ and @SurfaceColor@ is added to the light -- leaving an object due to diffuse and specular terms. @Ambient@ can @@ -76,13 +94,21 @@ newtype Ambient = Ambient (Last Double) instance AttributeClass Ambient +instance Wrapped Ambient where + type Unwrapped Ambient = Double + _Wrapped' = iso (\(Ambient (Last d)) -> d) (Ambient . Last) + _Ambient :: Iso' Ambient Double -_Ambient = iso (\(Ambient (Last d)) -> d) (Ambient . Last) +_Ambient = _Wrapped' -- | Set the emittance due to ambient light. ambient :: HasStyle d => Double -> d -> d ambient = applyAttr . review _Ambient +-- | Lens onto the possible ambience in a style. +_ambient :: Lens' (Style v n) (Maybe Double) +_ambient = atAttr . mapping _Ambient + -- | A specular highlight has two terms, the intensity, between 0 and -- 1, and the size. The highlight size is assumed to be the exponent -- in a Phong shading model (though Backends are free to use a @@ -90,9 +116,10 @@ ambient = applyAttr . review _Ambient -- between 1 and 50 or so, with higher values for shinier objects. -- Physically, the intensity and the value of @Diffuse@ must add up to -- less than 1; this is not enforced. -data Specular = Specular { _specularIntensity :: Double - , _specularSize :: Double - } +data Specular = Specular + { _specularIntensity :: Double + , _specularSize :: Double + } makeLenses ''Specular @@ -101,6 +128,10 @@ newtype Highlight = Highlight (Last Specular) instance AttributeClass Highlight +instance Wrapped Highlight where + type Unwrapped Highlight = Specular + _Wrapped' = _Highlight + _Highlight :: Iso' Highlight Specular _Highlight = iso (\(Highlight (Last s)) -> s) (Highlight . Last) @@ -108,3 +139,17 @@ _Highlight = iso (\(Highlight (Last s)) -> s) (Highlight . Last) highlight :: HasStyle d => Specular -> d -> d highlight = applyAttr . review _Highlight +-- | Lens onto the possible specular highlight in a style +_highlight :: Lens' (Style v n) (Maybe Specular) +_highlight = atAttr . mapping _Highlight + +-- | Traversal over the highlight intensity of a style. If the style has +-- no 'Specular', setting this will do nothing. +highlightIntensity :: Traversal' (Style v n) Double +highlightIntensity = _highlight . _Just . specularSize + +-- | Traversal over the highlight size in a style. If the style has no +-- 'Specular', setting this will do nothing. +highlightSize :: Traversal' (Style v n) Double +highlightSize = _highlight . _Just . specularSize + diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 850cda7a..84aa745d 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -230,17 +230,17 @@ lengths f opts = (\h t -> opts & headLength .~ h & tailLength .~ t) <$> f (opts -- color to blue. For more general control over the style of arrowheads, -- see 'headStyle'. headTexture :: TypeableFloat n => Lens' (ArrowOpts n) (Texture n) -headTexture = headStyle . _FillTexture +headTexture = headStyle . _fillTexture -- | A lens for setting or modifying the texture of an arrow -- tail. This is *not* a valid lens (see 'committed'). tailTexture :: TypeableFloat n => Lens' (ArrowOpts n) (Texture n) -tailTexture = tailStyle . _FillTexture +tailTexture = tailStyle . _fillTexture -- | A lens for setting or modifying the texture of an arrow -- shaft. shaftTexture :: TypeableFloat n => Lens' (ArrowOpts n) (Texture n) -shaftTexture = shaftStyle . _LineTexture +shaftTexture = shaftStyle . _lineTexture -- Set the default shaft style of an `ArrowOpts` record by applying the -- default style after all other styles have been applied. diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index df6fb755..6812f85f 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -44,15 +44,15 @@ module Diagrams.TwoD.Attributes ( , rGradSpreadMethod, mkRadialGradient -- ** Line texture - , LineTexture(..), getLineTexture, lineTexture, lineTextureA - , mkLineTexture, _LineTexture + , LineTexture(..), _LineTexture, getLineTexture, lineTexture, lineTextureA + , mkLineTexture, _lineTexture -- ** Line color , lineColor, lc, lcA -- ** Fill texture - , FillTexture(..), getFillTexture, fillTexture - , mkFillTexture, _FillTexture + , FillTexture(..), _FillTexture, getFillTexture, fillTexture + , mkFillTexture, _fillTexture, _fillTextureR -- ** Fill color , fillColor, fc, fcA, recommendFillColor @@ -86,7 +86,8 @@ import Diagrams.TwoD.Types -- | A gradient stop contains a color and fraction (usually between 0 and 1) data GradientStop d = GradientStop { _stopColor :: SomeColor - , _stopFraction :: d} + , _stopFraction :: d + } makeLensesWith (lensRules & generateSignatures .~ False) ''GradientStop @@ -251,6 +252,8 @@ mkRadialGradient :: Num n => [GradientStop n] -> Point V2 n -> n mkRadialGradient stops c0 r0 c1 r1 spreadMethod = RG (RGradient stops c0 r0 c1 r1 mempty spreadMethod) +-- Line Texture -------------------------------------------------------- + -- | The texture with which lines are drawn. Note that child -- textures always override parent textures. -- More precisely, the semigroup structure on line texture attributes @@ -259,14 +262,18 @@ newtype LineTexture n = LineTexture (Last (Texture n)) deriving (Typeable, Semigroup) instance (Typeable n) => AttributeClass (LineTexture n) +type instance V (LineTexture n) = V2 +type instance N (LineTexture n) = n + instance Rewrapped (LineTexture n) (LineTexture n') instance Wrapped (LineTexture n) where type Unwrapped (LineTexture n) = Texture n - _Wrapped' = iso getLineTexture mkLineTexture + _Wrapped' = iso getLineTexture (LineTexture . Last) {-# INLINE _Wrapped' #-} -type instance V (LineTexture n) = V2 -type instance N (LineTexture n) = n +_LineTexture :: Iso (LineTexture n) (LineTexture n') + (Texture n) (Texture n') +_LineTexture = _Wrapped -- Only gradients get transformed. The transform is applied to the gradients -- transform field. Colors are left unchanged. @@ -276,6 +283,9 @@ instance Floating n => Transformable (LineTexture n) where instance Default (LineTexture n) where def = LineTexture (Last (SC (SomeColor (black :: Colour Double)))) +mkLineTexture :: Texture n -> LineTexture n +mkLineTexture = LineTexture . Last + getLineTexture :: LineTexture n -> Texture n getLineTexture (LineTexture (Last t)) = t @@ -285,11 +295,8 @@ lineTexture = applyTAttr . LineTexture . Last lineTextureA :: (Typeable n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => LineTexture n -> a -> a lineTextureA = applyTAttr -mkLineTexture :: Texture v -> LineTexture v -mkLineTexture = LineTexture . Last - -_LineTexture :: (Floating n, Typeable n) => Lens' (Style V2 n) (Texture n) -_LineTexture = atTAttr . anon def isDef . _Wrapping mkLineTexture +_lineTexture :: (Floating n, Typeable n) => Lens' (Style V2 n) (Texture n) +_lineTexture = atTAttr . anon def isDef . _LineTexture where isDef (LineTexture (Last (SC sc))) = toAlphaColour sc == opaque black isDef _ = False @@ -321,6 +328,8 @@ lineLGradient g = lineTexture (LG g) lineRGradient :: (Typeable n, Floating n, HasStyle a, V a ~ V2, N a ~ n) => RGradient n -> a -> a lineRGradient g = lineTexture (RG g) +-- Fill Texture -------------------------------------------------------- + -- | The texture with which objects are filled. -- The semigroup structure on fill texture attributes -- is that of 'Recommed . Last'. @@ -341,13 +350,16 @@ instance Wrapped (FillTexture n) where instance Typeable n => AttributeClass (FillTexture n) +_FillTexture :: Iso' (FillTexture n) (Recommend (Texture n)) +_FillTexture = _Wrapped' + type instance V (FillTexture n) = V2 type instance N (FillTexture n) = n -- Only gradients get transformed. The transform is applied to the gradients -- transform field. Colors are left unchanged. instance Floating n => Transformable (FillTexture n) where - transform = over (_Wrapped' . _recommend) . transform + transform = over (_FillTexture . _recommend) . transform instance Default (FillTexture n) where def = FillTexture (Recommend (Last (SC @@ -357,22 +369,22 @@ getFillTexture :: FillTexture n -> Texture n getFillTexture (FillTexture tx) = getLast . getRecommend $ tx fillTexture :: (HasStyle a, V a ~ V2, N a ~ n, Typeable n, Floating n) => Texture n -> a -> a -fillTexture = applyTAttr . FillTexture . Commit . Last +fillTexture = applyTAttr . mkFillTexture mkFillTexture :: Texture n -> FillTexture n mkFillTexture = FillTexture . Commit . Last --- | Lens onto the 'Recommend' of a fill texture. -_RFillTexture :: (Typeable n, Floating n) => Lens' (Style V2 n) (Recommend (Texture n)) -_RFillTexture = atTAttr . anon def isDef . _Wrapping (mkFillTexture . getRecommend) +-- | Lens onto the 'Recommend' of a fill texture in a style. +_fillTextureR :: (Typeable n, Floating n) => Lens' (Style V2 n) (Recommend (Texture n)) +_fillTextureR = atTAttr . anon def isDef . _FillTexture where isDef (FillTexture (Recommend (Last (SC sc)))) = toAlphaColour sc == transparent isDef _ = False --- | Commit a fill texture in a style. To extract the fill texture --- use '_RFillTexture'. This is *not* a valid lens (see 'committed'). -_FillTexture :: (Typeable n, Floating n) => Lens' (Style V2 n) (Texture n) -_FillTexture = _RFillTexture . committed +-- | Commit a fill texture in a style. This is *not* a valid lens +-- because the resulting texture is always 'Commit' (see 'committed'). +_fillTexture :: (Typeable n, Floating n) => Lens' (Style V2 n) (Texture n) +_fillTexture = _fillTextureR . committed -- | Set the fill color. This function is polymorphic in the color -- type (so it can be used with either 'Colour' or 'AlphaColour'), @@ -397,7 +409,8 @@ fc = fillColor -- (i.e. colors with transparency). See comment after 'fillColor' about backends. fcA :: (HasStyle a, V a ~ V2, N a ~ n, Floating n, Typeable n) => AlphaColour Double -> a -> a fcA = fillColor ------------------------------------------------------------- + +-- Split fills --------------------------------------------------------- data FillTextureLoops n = FillTextureLoops diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs index dbe03b70..9c86b871 100644 --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -24,14 +24,19 @@ module Diagrams.TwoD.Text ( -- * Text attributes -- ** Font family - , Font(..), getFont, font + , Font(..), _Font + , getFont, font, _font -- ** Font size - , FontSize(..), getFontSize, fontSizeM, fontSize + , FontSize(..), _FontSize + , getFontSize, fontSizeM, fontSize , fontSizeN, fontSizeO, fontSizeL, fontSizeG + , _fontSizeR, _fontSize -- ** Font slant - , FontSlant(..), FontSlantA, getFontSlant, fontSlant, italic, oblique + , FontSlant(..), FontSlantA, _FontSlant + , getFontSlant, fontSlant, italic, oblique, _fontSlant -- ** Font weight - , FontWeight(..), FontWeightA, getFontWeight, fontWeight, bold + , FontWeight(..), FontWeightA, _FontWeight + , getFontWeight, fontWeight, bold, _fontWeight ) where import Control.Lens hiding (transform) @@ -172,10 +177,9 @@ instance Rewrapped Font Font instance Wrapped Font where type Unwrapped Font = String _Wrapped' = iso getFont (Font . Last) - {-# INLINE _Wrapped' #-} -_Font :: (Typeable n, OrderedField n) => Lens' (Style v n) (Maybe String) -_Font = atAttr . mapping (_Wrapping (Font . Last)) +_Font :: Iso' Font String +_Font = iso getFont (Font . Last) instance AttributeClass Font @@ -187,6 +191,9 @@ getFont (Font (Last f)) = f font :: HasStyle a => String -> a -> a font = applyAttr . Font . Last +_font :: (Typeable n, OrderedField n) => Lens' (Style v n) (Maybe String) +_font = atAttr . mapping (_Wrapping (Font . Last)) + -------------------------------------------------- -- Font size @@ -210,16 +217,11 @@ instance Wrapped (FontSize n) where setter (Commit a) = FontSize $ Commit (Last a) {-# INLINE _Wrapped' #-} -_RFontSize :: (Typeable n, OrderedField n) => Lens' (Style v n) (Measured n (Recommend n)) -_RFontSize = atMAttr . mapping (mapping (_Wrapping setter)) . anon (Recommend <$> local 1) (const False) - where - setter (Recommend a) = FontSize $ Recommend (Last a) - setter (Commit a) = FontSize $ Commit (Last a) +_FontSize :: Iso' (FontSize n) (Recommend n) +_FontSize = _Wrapped' --- | Lens to commit a font size. This is *not* a valid lens (see --- 'commited'. -_FontSize :: (Typeable n, OrderedField n) => Lens' (Style v n) (Measure n) -_FontSize = _RFontSize . mapping committed +_FontSizeM :: Iso' (FontSizeM n) (Measured n (Recommend n)) +_FontSizeM = mapping _FontSize type FontSizeM n = Measured n (FontSize n) @@ -262,6 +264,14 @@ fontSizeM = applyMAttr recommendFontSize :: (N a ~ n, Typeable n, HasStyle a) => Measure n -> a -> a recommendFontSize = applyMAttr . fmap (FontSize . Recommend . Last) +_fontSizeR :: (Typeable n, OrderedField n) => Lens' (Style v n) (Measured n (Recommend n)) +_fontSizeR = atMAttr . anon def (const False) . _FontSizeM + +-- | Lens to commit a font size. This is *not* a valid lens (see +-- 'commited'. +_fontSize :: (Typeable n, OrderedField n) => Lens' (Style v n) (Measure n) +_fontSize = _fontSizeR . mapping committed + -------------------------------------------------- -- Font slant @@ -286,8 +296,8 @@ instance Wrapped FontSlantA where instance Default FontSlant where def = FontSlantNormal -_FontSlant :: (Typeable n, OrderedField n) => Lens' (Style v n) FontSlant -_FontSlant = atAttr . mapping (_Wrapping (FontSlantA . Last)) . non def +_FontSlant :: Iso' FontSlantA FontSlant +_FontSlant = _Wrapped' -- | Extract the font slant from a 'FontSlantA' attribute. getFontSlant :: FontSlantA -> FontSlant @@ -299,6 +309,10 @@ getFontSlant (FontSlantA (Last s)) = s fontSlant :: HasStyle a => FontSlant -> a -> a fontSlant = applyAttr . FontSlantA . Last +-- | Lens onto the font slant in a style. +_fontSlant :: (Typeable n, OrderedField n) => Lens' (Style v n) FontSlant +_fontSlant = atAttr . mapping _FontSlant . non def + -- | Set all text in italics. italic :: HasStyle a => a -> a italic = fontSlant FontSlantItalic @@ -330,8 +344,8 @@ instance Wrapped FontWeightA where instance Default FontWeight where def = FontWeightNormal -_FontWeight :: (Typeable n, OrderedField n) => Lens' (Style v n) FontWeight -_FontWeight = atAttr . mapping (_Wrapping (FontWeightA . Last)) . non def +_FontWeight :: Iso' FontWeightA FontWeight +_FontWeight = _Wrapped' -- | Extract the font weight from a 'FontWeightA' attribute. getFontWeight :: FontWeightA -> FontWeight @@ -346,3 +360,7 @@ fontWeight = applyAttr . FontWeightA . Last -- | Set all text using a bold font weight. bold :: HasStyle a => a -> a bold = fontWeight FontWeightBold + +-- | Lens onto the font weight in a style. +_fontWeight :: (Typeable n, OrderedField n) => Lens' (Style v n) FontWeight +_fontWeight = atAttr . mapping _FontWeight . non def From 700a433bc07a8aa85ea244c9f6e7909bfb609dd9 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Tue, 24 Feb 2015 21:45:33 +0000 Subject: [PATCH 5/8] Remove Wrapped instances for attributes. They're just added noise, you never really use them because you need to know the types. We can always add them later. --- src/Diagrams/Attributes.hs | 32 ------------------------ src/Diagrams/ThreeD/Attributes.hs | 18 +------------- src/Diagrams/TwoD/Attributes.hs | 32 ++++++++---------------- src/Diagrams/TwoD/Text.hs | 41 ++++++++----------------------- 4 files changed, 21 insertions(+), 102 deletions(-) diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index 7eaa7dc8..10843ac4 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -122,11 +122,6 @@ huge = normalized 0.10 newtype LineWidth n = LineWidth (Last n) deriving (Typeable, Semigroup) -instance Rewrapped (LineWidth n) (LineWidth n') -instance Wrapped (LineWidth n) where - type Unwrapped (LineWidth n) = n - _Wrapped' = iso getLineWidth (LineWidth . Last) - _LineWidth :: (Typeable n, OrderedField n) => Iso' (LineWidth n) n _LineWidth = iso getLineWidth (LineWidth . Last) @@ -187,12 +182,6 @@ data Dashing n = Dashing [n] n newtype DashingA n = DashingA (Last (Dashing n)) deriving (Functor, Typeable, Semigroup) -instance Rewrapped (DashingA n) (DashingA n') -instance Wrapped (DashingA n) where - type Unwrapped (DashingA n) = Dashing n - _Wrapped' = iso getDashing (DashingA . Last) - {-# INLINE _Wrapped' #-} - _Dashing :: Iso' (DashingA n) (Dashing n) _Dashing = iso getDashing (DashingA . Last) @@ -315,11 +304,6 @@ newtype Opacity = Opacity (Product Double) deriving (Typeable, Semigroup) instance AttributeClass Opacity -instance Rewrapped Opacity Opacity -instance Wrapped Opacity where - type Unwrapped Opacity = Double - _Wrapped' = _Opacity - _Opacity :: Iso' Opacity Double _Opacity = iso getOpacity (Opacity . Product) @@ -354,12 +338,6 @@ newtype LineCapA = LineCapA (Last LineCap) deriving (Typeable, Semigroup, Eq) instance AttributeClass LineCapA -instance Rewrapped LineCapA LineCapA -instance Wrapped LineCapA where - type Unwrapped LineCapA = LineCap - _Wrapped' = _LineCap - {-# INLINE _Wrapped' #-} - _LineCap :: Iso' LineCapA LineCap _LineCap = iso getLineCap (LineCapA . Last) @@ -391,11 +369,6 @@ newtype LineJoinA = LineJoinA (Last LineJoin) deriving (Typeable, Semigroup, Eq) instance AttributeClass LineJoinA -instance Rewrapped LineJoinA LineJoinA -instance Wrapped LineJoinA where - type Unwrapped LineJoinA = LineJoin - _Wrapped' = _LineJoin - _LineJoin :: Iso' LineJoinA LineJoin _LineJoin = iso getLineJoin (LineJoinA . Last) @@ -420,11 +393,6 @@ newtype LineMiterLimit = LineMiterLimit (Last Double) deriving (Typeable, Semigroup) instance AttributeClass LineMiterLimit -instance Rewrapped LineMiterLimit LineMiterLimit -instance Wrapped LineMiterLimit where - type Unwrapped LineMiterLimit = Double - _Wrapped' = _LineMiterLimit - _LineMiterLimit :: Iso' LineMiterLimit Double _LineMiterLimit = iso getLineMiterLimit (LineMiterLimit . Last) diff --git a/src/Diagrams/ThreeD/Attributes.hs b/src/Diagrams/ThreeD/Attributes.hs index e80953f4..39f85e53 100644 --- a/src/Diagrams/ThreeD/Attributes.hs +++ b/src/Diagrams/ThreeD/Attributes.hs @@ -42,10 +42,6 @@ newtype SurfaceColor = SurfaceColor (Last (Colour Double)) instance AttributeClass SurfaceColor -instance Wrapped SurfaceColor where - type Unwrapped SurfaceColor = Colour Double - _Wrapped' = _SurfaceColor - _SurfaceColor :: Iso' SurfaceColor (Colour Double) _SurfaceColor = iso (\(SurfaceColor (Last c)) -> c) (SurfaceColor . Last) @@ -67,10 +63,6 @@ newtype Diffuse = Diffuse (Last Double) instance AttributeClass Diffuse -instance Wrapped Diffuse where - type Unwrapped Diffuse = Double - _Wrapped' = _Diffuse - -- | Isomorphism between 'Diffuse' and 'Double' _Diffuse :: Iso' Diffuse Double _Diffuse = iso (\(Diffuse (Last d)) -> d) (Diffuse . Last) @@ -94,12 +86,8 @@ newtype Ambient = Ambient (Last Double) instance AttributeClass Ambient -instance Wrapped Ambient where - type Unwrapped Ambient = Double - _Wrapped' = iso (\(Ambient (Last d)) -> d) (Ambient . Last) - _Ambient :: Iso' Ambient Double -_Ambient = _Wrapped' +_Ambient = iso (\(Ambient (Last d)) -> d) (Ambient . Last) -- | Set the emittance due to ambient light. ambient :: HasStyle d => Double -> d -> d @@ -128,10 +116,6 @@ newtype Highlight = Highlight (Last Specular) instance AttributeClass Highlight -instance Wrapped Highlight where - type Unwrapped Highlight = Specular - _Wrapped' = _Highlight - _Highlight :: Iso' Highlight Specular _Highlight = iso (\(Highlight (Last s)) -> s) (Highlight . Last) diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index 6812f85f..004e2f0d 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -265,15 +265,9 @@ instance (Typeable n) => AttributeClass (LineTexture n) type instance V (LineTexture n) = V2 type instance N (LineTexture n) = n -instance Rewrapped (LineTexture n) (LineTexture n') -instance Wrapped (LineTexture n) where - type Unwrapped (LineTexture n) = Texture n - _Wrapped' = iso getLineTexture (LineTexture . Last) - {-# INLINE _Wrapped' #-} - _LineTexture :: Iso (LineTexture n) (LineTexture n') (Texture n) (Texture n') -_LineTexture = _Wrapped +_LineTexture = iso getLineTexture (LineTexture . Last) -- Only gradients get transformed. The transform is applied to the gradients -- transform field. Colors are left unchanged. @@ -336,22 +330,17 @@ lineRGradient g = lineTexture (RG g) newtype FillTexture n = FillTexture (Recommend (Last (Texture n))) deriving (Typeable, Semigroup) --- This isn't valid since it ignores Recommend! -instance Rewrapped (FillTexture n) (FillTexture n') -instance Wrapped (FillTexture n) where - type Unwrapped (FillTexture n) = Recommend (Texture n) - _Wrapped' = iso getter setter -- == coerce - where - getter (FillTexture (Recommend (Last t))) = Recommend t - getter (FillTexture (Commit (Last t))) = Commit t - setter (Recommend t) = FillTexture (Recommend (Last t)) - setter (Commit t) = FillTexture (Commit (Last t)) - {-# INLINE _Wrapped' #-} - instance Typeable n => AttributeClass (FillTexture n) _FillTexture :: Iso' (FillTexture n) (Recommend (Texture n)) -_FillTexture = _Wrapped' +_FillTexture = iso getter setter + where + getter (FillTexture (Recommend (Last t))) = Recommend t + getter (FillTexture (Commit (Last t))) = Commit t + setter (Recommend t) = FillTexture (Recommend (Last t)) + setter (Commit t) = FillTexture (Commit (Last t)) + -- = iso (\(FillTexture a) -> a) FillTexture . mapping _Wrapped + -- -- once we depend on monoid-extras-0.4 type instance V (FillTexture n) = V2 type instance N (FillTexture n) = n @@ -362,8 +351,7 @@ instance Floating n => Transformable (FillTexture n) where transform = over (_FillTexture . _recommend) . transform instance Default (FillTexture n) where - def = FillTexture (Recommend (Last (SC - (SomeColor (transparent :: AlphaColour Double))))) + def = review (_FillTexture . _Recommend . _SC . _SomeColor) transparent getFillTexture :: FillTexture n -> Texture n getFillTexture (FillTexture tx) = getLast . getRecommend $ tx diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs index 9c86b871..df1dcb51 100644 --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -173,11 +173,6 @@ baselineText = mkText BaselineText newtype Font = Font (Last String) deriving (Typeable, Semigroup, Eq) -instance Rewrapped Font Font -instance Wrapped Font where - type Unwrapped Font = String - _Wrapped' = iso getFont (Font . Last) - _Font :: Iso' Font String _Font = iso getFont (Font . Last) @@ -192,7 +187,7 @@ font :: HasStyle a => String -> a -> a font = applyAttr . Font . Last _font :: (Typeable n, OrderedField n) => Lens' (Style v n) (Maybe String) -_font = atAttr . mapping (_Wrapping (Font . Last)) +_font = atAttr . mapping _Font -------------------------------------------------- -- Font size @@ -207,18 +202,14 @@ instance Functor FontSize where fmap f (FontSize (Recommend (Last a))) = FontSize (Recommend (Last (f a))) fmap f (FontSize (Commit (Last a))) = FontSize (Commit (Last (f a))) -instance Rewrapped (FontSize n) (FontSize n') -instance Wrapped (FontSize n) where - type Unwrapped (FontSize n) = Recommend n - _Wrapped' = iso getter setter - where getter (FontSize (Recommend (Last a))) = Recommend a - getter (FontSize (Commit (Last a))) = Commit a - setter (Recommend a) = FontSize $ Recommend (Last a) - setter (Commit a) = FontSize $ Commit (Last a) - {-# INLINE _Wrapped' #-} - _FontSize :: Iso' (FontSize n) (Recommend n) -_FontSize = _Wrapped' +_FontSize = iso getter setter + where getter (FontSize (Recommend (Last a))) = Recommend a + getter (FontSize (Commit (Last a))) = Commit a + setter (Recommend a) = FontSize $ Recommend (Last a) + setter (Commit a) = FontSize $ Commit (Last a) + -- = iso (\(FontSize a) -> a) FontSize . mapping _Wrapped + -- once we depend on monoid-extras-0.4 _FontSizeM :: Iso' (FontSizeM n) (Measured n (Recommend n)) _FontSizeM = mapping _FontSize @@ -287,17 +278,11 @@ newtype FontSlantA = FontSlantA (Last FontSlant) deriving (Typeable, Semigroup, Eq) instance AttributeClass FontSlantA -instance Rewrapped FontSlantA FontSlantA -instance Wrapped FontSlantA where - type Unwrapped FontSlantA = FontSlant - _Wrapped' = iso getFontSlant (FontSlantA . Last) - {-# INLINE _Wrapped' #-} - instance Default FontSlant where def = FontSlantNormal _FontSlant :: Iso' FontSlantA FontSlant -_FontSlant = _Wrapped' +_FontSlant = iso getFontSlant (FontSlantA . Last) -- | Extract the font slant from a 'FontSlantA' attribute. getFontSlant :: FontSlantA -> FontSlant @@ -335,17 +320,11 @@ newtype FontWeightA = FontWeightA (Last FontWeight) deriving (Typeable, Semigroup, Eq) instance AttributeClass FontWeightA -instance Rewrapped FontWeightA FontWeightA -instance Wrapped FontWeightA where - type Unwrapped FontWeightA = FontWeight - _Wrapped' = iso getFontWeight (FontWeightA . Last) - {-# INLINE _Wrapped' #-} - instance Default FontWeight where def = FontWeightNormal _FontWeight :: Iso' FontWeightA FontWeight -_FontWeight = _Wrapped' +_FontWeight = iso getFontWeight (FontWeightA . Last) -- | Extract the font weight from a 'FontWeightA' attribute. getFontWeight :: FontWeightA -> FontWeight From 1e3512f371ffc78caae01763fb24254e77abc727 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Tue, 24 Feb 2015 22:18:42 +0000 Subject: [PATCH 6/8] Fix _fillTexture lens by using Maybe. --- src/Diagrams/TwoD/Arrow.hs | 6 +++--- src/Diagrams/TwoD/Attributes.hs | 13 +++++-------- 2 files changed, 8 insertions(+), 11 deletions(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 84aa745d..352e4011 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -230,17 +230,17 @@ lengths f opts = (\h t -> opts & headLength .~ h & tailLength .~ t) <$> f (opts -- color to blue. For more general control over the style of arrowheads, -- see 'headStyle'. headTexture :: TypeableFloat n => Lens' (ArrowOpts n) (Texture n) -headTexture = headStyle . _fillTexture +headTexture = headStyle . atTAttr . anon def (const False) . _FillTexture . committed -- | A lens for setting or modifying the texture of an arrow -- tail. This is *not* a valid lens (see 'committed'). tailTexture :: TypeableFloat n => Lens' (ArrowOpts n) (Texture n) -tailTexture = tailStyle . _fillTexture +tailTexture = tailStyle . atTAttr . anon def (const False) . _FillTexture . committed -- | A lens for setting or modifying the texture of an arrow -- shaft. shaftTexture :: TypeableFloat n => Lens' (ArrowOpts n) (Texture n) -shaftTexture = shaftStyle . _lineTexture +shaftTexture = shaftStyle . atTAttr . anon def (const False) . _LineTexture -- Set the default shaft style of an `ArrowOpts` record by applying the -- default style after all other styles have been applied. diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index 004e2f0d..2b3cba42 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -362,17 +362,14 @@ fillTexture = applyTAttr . mkFillTexture mkFillTexture :: Texture n -> FillTexture n mkFillTexture = FillTexture . Commit . Last --- | Lens onto the 'Recommend' of a fill texture in a style. -_fillTextureR :: (Typeable n, Floating n) => Lens' (Style V2 n) (Recommend (Texture n)) -_fillTextureR = atTAttr . anon def isDef . _FillTexture - where - isDef (FillTexture (Recommend (Last (SC sc)))) = toAlphaColour sc == transparent - isDef _ = False +-- | Lens onto the possible recommend of a fill texture in a style. +_fillTextureR :: (Typeable n, Floating n) => Lens' (Style V2 n) (Maybe (Recommend (Texture n))) +_fillTextureR = atTAttr . mapping _FillTexture -- | Commit a fill texture in a style. This is *not* a valid lens -- because the resulting texture is always 'Commit' (see 'committed'). -_fillTexture :: (Typeable n, Floating n) => Lens' (Style V2 n) (Texture n) -_fillTexture = _fillTextureR . committed +_fillTexture :: (Typeable n, Floating n) => Lens' (Style V2 n) (Maybe (Texture n)) +_fillTexture = _fillTextureR . mapping committed -- | Set the fill color. This function is polymorphic in the color -- type (so it can be used with either 'Colour' or 'AlphaColour'), From b41d398eba226ab31b6df018aa9e7e79a4437c9e Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Wed, 25 Feb 2015 09:34:32 +0000 Subject: [PATCH 7/8] Revert "Fix _fillTexture lens by using Maybe." There's no need to use the maybe value, transparent it equivilent to no fill. This reverts commit 731f1814900b794a1baf0aca59d47c92f482bd01. --- src/Diagrams/TwoD/Arrow.hs | 6 +++--- src/Diagrams/TwoD/Attributes.hs | 13 ++++++++----- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 352e4011..84aa745d 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -230,17 +230,17 @@ lengths f opts = (\h t -> opts & headLength .~ h & tailLength .~ t) <$> f (opts -- color to blue. For more general control over the style of arrowheads, -- see 'headStyle'. headTexture :: TypeableFloat n => Lens' (ArrowOpts n) (Texture n) -headTexture = headStyle . atTAttr . anon def (const False) . _FillTexture . committed +headTexture = headStyle . _fillTexture -- | A lens for setting or modifying the texture of an arrow -- tail. This is *not* a valid lens (see 'committed'). tailTexture :: TypeableFloat n => Lens' (ArrowOpts n) (Texture n) -tailTexture = tailStyle . atTAttr . anon def (const False) . _FillTexture . committed +tailTexture = tailStyle . _fillTexture -- | A lens for setting or modifying the texture of an arrow -- shaft. shaftTexture :: TypeableFloat n => Lens' (ArrowOpts n) (Texture n) -shaftTexture = shaftStyle . atTAttr . anon def (const False) . _LineTexture +shaftTexture = shaftStyle . _lineTexture -- Set the default shaft style of an `ArrowOpts` record by applying the -- default style after all other styles have been applied. diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index 2b3cba42..004e2f0d 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -362,14 +362,17 @@ fillTexture = applyTAttr . mkFillTexture mkFillTexture :: Texture n -> FillTexture n mkFillTexture = FillTexture . Commit . Last --- | Lens onto the possible recommend of a fill texture in a style. -_fillTextureR :: (Typeable n, Floating n) => Lens' (Style V2 n) (Maybe (Recommend (Texture n))) -_fillTextureR = atTAttr . mapping _FillTexture +-- | Lens onto the 'Recommend' of a fill texture in a style. +_fillTextureR :: (Typeable n, Floating n) => Lens' (Style V2 n) (Recommend (Texture n)) +_fillTextureR = atTAttr . anon def isDef . _FillTexture + where + isDef (FillTexture (Recommend (Last (SC sc)))) = toAlphaColour sc == transparent + isDef _ = False -- | Commit a fill texture in a style. This is *not* a valid lens -- because the resulting texture is always 'Commit' (see 'committed'). -_fillTexture :: (Typeable n, Floating n) => Lens' (Style V2 n) (Maybe (Texture n)) -_fillTexture = _fillTextureR . mapping committed +_fillTexture :: (Typeable n, Floating n) => Lens' (Style V2 n) (Texture n) +_fillTexture = _fillTextureR . committed -- | Set the fill color. This function is polymorphic in the color -- type (so it can be used with either 'Colour' or 'AlphaColour'), From 73d067629151aab58453dd842a4a7fba34a97c43 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Fri, 27 Feb 2015 17:43:27 +0000 Subject: [PATCH 8/8] Export more style lenses in TwoD. --- src/Diagrams/Attributes.hs | 6 ++++-- src/Diagrams/TwoD.hs | 18 ++++++++++-------- src/Diagrams/TwoD/Text.hs | 5 +++-- 3 files changed, 17 insertions(+), 12 deletions(-) diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index 10843ac4..97cba75e 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -351,7 +351,7 @@ getLineCap (LineCapA (Last c)) = c lineCap :: HasStyle a => LineCap -> a -> a lineCap = applyAttr . LineCapA . Last --- | Lens onto the line cap in a style +-- | Lens onto the line cap in a style. _lineCap :: Lens' (Style v n) LineCap _lineCap = atAttr . mapping _LineCap . non def @@ -382,6 +382,7 @@ getLineJoin (LineJoinA (Last j)) = j lineJoin :: HasStyle a => LineJoin -> a -> a lineJoin = applyAttr . LineJoinA . Last +-- | Lens onto the line join type in a style. _lineJoin :: Lens' (Style v n) LineJoin _lineJoin = atAttr . mapping _LineJoin . non def @@ -410,6 +411,7 @@ lineMiterLimit = applyAttr . LineMiterLimit . Last lineMiterLimitA :: HasStyle a => LineMiterLimit -> a -> a lineMiterLimitA = applyAttr +-- | Lens onto the line miter limit in a style. _lineMiterLimit :: Lens' (Style v n) Double _lineMiterLimit = atAttr . mapping _LineMiterLimit . non 10 @@ -431,7 +433,7 @@ _recommend :: Lens (Recommend a) (Recommend b) a b _recommend f (Recommend a) = Recommend <$> f a _recommend f (Commit a) = Commit <$> f a --- | Lens onto weather something is committed or not. +-- | Lens onto whether something is committed or not. isCommitted :: Lens' (Recommend a) Bool isCommitted f r@(Recommend a) = f False <&> \b -> if b then Commit a else r isCommitted f r@(Commit a) = f True <&> \b -> if b then r else Recommend a diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index 931fc029..b871eb6e 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -162,6 +162,7 @@ module Diagrams.TwoD -- * Text , text, topLeftText, alignedText, baselineText , font, italic, oblique, bold, fontSize + , _font, _fontSizeR, _fontSize , fontSizeO, fontSizeL, fontSizeN, fontSizeG -- * Images @@ -242,20 +243,21 @@ module Diagrams.TwoD -- * Textures , Texture(..), solid - , SpreadMethod(..), GradientStop(..), mkStops, getFillTexture - , fillTexture, getLineTexture, lineTexture, lineTextureA - , stopFraction, stopColor + , SpreadMethod(..), GradientStop(..) + , _FillTexture, fillTexture, _fillTexture, getFillTexture + , _LineTexture, lineTexture, _lineTexture, lineTextureA, getLineTexture + , stopFraction, stopColor, mkStops - , LGradient(..), lGradStops, lGradTrans, lGradStart, lGradEnd - , lGradSpreadMethod, defaultLG, _LG, mkLinearGradient + , LGradient(..), _LG, lGradStops, lGradTrans, lGradStart, lGradEnd + , lGradSpreadMethod, defaultLG, mkLinearGradient , RGradient(..) , rGradStops, rGradCenter0, rGradRadius0, rGradCenter1, rGradRadius1 , rGradTrans, rGradSpreadMethod, defaultRG, _RG, mkRadialGradient -- ** Colors - , fillColor, fc, fcA, recommendFillColor - , lineColor, lc, lcA, _SC + , fillColor, _SC, fc, fcA, recommendFillColor + , lineColor, lc, lcA -- * Visual aids for understanding the internal model , showOrigin diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs index df1dcb51..23cb3c59 100644 --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -9,7 +9,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Text --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -20,7 +20,7 @@ module Diagrams.TwoD.Text ( -- * Creating text diagrams Text(..), TextAlignment(..) - , text, topLeftText, alignedText, baselineText + , text, topLeftText, alignedText, baselineText, mkText -- * Text attributes -- ** Font family @@ -186,6 +186,7 @@ getFont (Font (Last f)) = f font :: HasStyle a => String -> a -> a font = applyAttr . Font . Last +-- | Lens onto the font name of a style. _font :: (Typeable n, OrderedField n) => Lens' (Style v n) (Maybe String) _font = atAttr . mapping _Font