diagrams-lib-1.4: src/Diagrams/Attributes.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
-----------------------------------------------------------------------------
-- |
-- Module : Diagrams.Attributes
-- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE)
-- License : BSD-style (see LICENSE)
-- Maintainer : diagrams-discuss@googlegroups.com
--
-- Diagrams may have /attributes/ which affect the way they are
-- rendered. This module defines some common attributes; particular
-- backends may also define more backend-specific attributes.
--
-- Every attribute type must have a /semigroup/ structure, that is, an
-- associative binary operation for combining two attributes into one.
-- Unless otherwise noted, all the attributes defined here use the
-- 'Last' structure, that is, combining two attributes simply keeps
-- the second one and throws away the first. This means that child
-- attributes always override parent attributes.
--
-----------------------------------------------------------------------------
module Diagrams.Attributes (
-- ** Standard measures
ultraThin, veryThin, thin, medium, thick, veryThick, ultraThick, none
, tiny, verySmall, small, normal, large, veryLarge, huge
-- ** Line width
, LineWidth, getLineWidth
, _LineWidth, _LineWidthM
, lineWidth, lineWidthM
, _lineWidth, _lw, _lineWidthU
, lw, lwN, lwO, lwL, lwG
-- ** Dashing
, Dashing(..), getDashing
, dashing, dashingN, dashingO, dashingL, dashingG
, _dashing, _dashingU
-- * Color
-- $color
, Color(..), SomeColor(..), _SomeColor, someToAlpha
-- ** Opacity
, Opacity, _Opacity
, getOpacity, opacity, _opacity
, FillOpacity, _FillOpacity
, getFillOpacity, fillOpacity, _fillOpacity
, StrokeOpacity, _StrokeOpacity
, getStrokeOpacity, strokeOpacity, _strokeOpacity
-- ** Converting colors
, colorToSRGBA, colorToRGBA
-- * Line stuff
-- ** Cap style
, LineCap(..)
, getLineCap, lineCap, _lineCap
-- ** Join style
, LineJoin(..)
, getLineJoin, lineJoin, _lineJoin
-- ** Miter limit
, LineMiterLimit(..), _LineMiterLimit
, getLineMiterLimit, lineMiterLimit, lineMiterLimitA, _lineMiterLimit
-- * Recommend optics
, _Recommend
, _Commit
, _recommend
, isCommitted
, committed
) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Lens hiding (none, over)
import Data.Colour
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
------------------------------------------------------------------------
none, ultraThin, veryThin, thin, medium, thick, veryThick, ultraThick,
tiny, verySmall, small, normal, large, veryLarge, huge
:: OrderedField n => Measure n
none = output 0
ultraThin = normalized 0.0005 `atLeast` output 0.5
veryThin = normalized 0.001 `atLeast` output 0.5
thin = normalized 0.002 `atLeast` output 0.5
medium = normalized 0.004 `atLeast` output 0.5
thick = normalized 0.0075 `atLeast` output 0.5
veryThick = normalized 0.01 `atLeast` output 0.5
ultraThick = normalized 0.02 `atLeast` output 0.5
tiny = normalized 0.01
verySmall = normalized 0.015
small = normalized 0.023
normal = normalized 0.035
large = normalized 0.05
veryLarge = normalized 0.07
huge = normalized 0.10
------------------------------------------------------------------------
-- 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)
_LineWidth :: Iso' (LineWidth n) n
_LineWidth = iso getLineWidth (LineWidth . Last)
_LineWidthM :: Iso' (LineWidthM n) (Measure n)
_LineWidthM = mapping _LineWidth
instance Typeable n => AttributeClass (LineWidth n)
type LineWidthM n = Measured n (LineWidth n)
instance OrderedField n => Default (LineWidthM n) where
def = fmap (LineWidth . Last) medium
getLineWidth :: LineWidth n -> n
getLineWidth (LineWidth (Last w)) = w
-- | Set the line (stroke) width.
lineWidth :: (N a ~ n, HasStyle a, Typeable n) => Measure n -> a -> a
lineWidth = applyMAttr . fmap (LineWidth . Last)
-- | Apply a 'LineWidth' attribute.
lineWidthM :: (N a ~ n, HasStyle a, Typeable n) => LineWidthM n -> a -> a
lineWidthM = applyMAttr
-- | Default for 'lineWidth'.
lw :: (N a ~ n, HasStyle a, Typeable n) => Measure n -> a -> a
lw = lineWidth
-- | A convenient synonym for 'lineWidth (global w)'.
lwG :: (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a
lwG = lw . global
-- | A convenient synonym for 'lineWidth (normalized w)'.
lwN :: (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a
lwN = lw . normalized
-- | A convenient synonym for 'lineWidth (output w)'.
lwO :: (N a ~ n, HasStyle a, Typeable n) => n -> a -> a
lwO = lw . output
-- | A convenient sysnonym for 'lineWidth (local w)'.
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
-- | Lens onto the unmeasured linewith attribute. This is useful for
-- backends to use on styles once they have been unmeasured. Using on
-- a diagram style could lead to unexpected results.
_lineWidthU :: Typeable n => Lens' (Style v n) (Maybe n)
_lineWidthU = atAttr . mapping _LineWidth
------------------------------------------------------------------------
-- Dashing
------------------------------------------------------------------------
-- | Create lines that are dashing... er, dashed.
data Dashing n = Dashing [n] n
deriving (Functor, Typeable, Eq)
instance Semigroup (Dashing n) where
_ <> b = b
instance Typeable n => AttributeClass (Dashing n)
getDashing :: Dashing n -> Dashing n
getDashing = id
-- | Set the line dashing style.
dashing :: (N a ~ n, HasStyle a, Typeable n)
=> [Measure n] -- ^ A list specifying alternate lengths of on
-- and off portions of the stroke. The empty
-- list indicates no dashing.
-> Measure n -- ^ An offset into the dash pattern at which the
-- stroke should start.
-> a -> a
dashing ds offs = applyMAttr . distribute $ Dashing ds offs
-- | A convenient synonym for 'dashing (global w)'.
dashingG :: (N a ~ n, HasStyle a, Typeable n, Num n) => [n] -> n -> a -> a
dashingG w v = dashing (map global w) (global v)
-- | A convenient synonym for 'dashing (normalized w)'.
dashingN :: (N a ~ n, HasStyle a, Typeable n, Num n) => [n] -> n -> a -> a
dashingN w v = dashing (map normalized w) (normalized v)
-- | A convenient synonym for 'dashing (output w)'.
dashingO :: (N a ~ n, HasStyle a, Typeable n) => [n] -> n -> a -> a
dashingO w v = dashing (map output w) (output v)
-- | A convenient sysnonym for 'dashing (local w)'.
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
=> Lens' (Style v n) (Maybe (Measured n (Dashing n)))
_dashing = atMAttr
-- | Lens onto the unmeasured 'Dashing' attribute. This is useful for
-- backends to use on styles once they have been unmeasured. Using on
-- a diagram style could lead to unexpected results.
_dashingU :: Typeable n => Lens' (Style v n) (Maybe (Dashing n))
_dashingU = atAttr
------------------------------------------------------------------------
-- Color
------------------------------------------------------------------------
-- $color
-- Diagrams outsources all things color-related to Russell O\'Connor\'s
-- very nice colour package
-- (<http://hackage.haskell.org/package/colour>). For starters, it
-- provides a large collection of standard color names. However, it
-- also provides a rich set of combinators for combining and
-- manipulating colors; see its documentation for more information.
-- | The 'Color' type class encompasses color representations which
-- can be used by the Diagrams library. Instances are provided for
-- both the 'Data.Colour.Colour' and 'Data.Colour.AlphaColour' types
-- from the "Data.Colour" library.
class Color c where
-- | Convert a color to its standard representation, AlphaColour.
toAlphaColour :: c -> AlphaColour Double
-- | Convert from an AlphaColour Double. Note that this direction
-- may lose some information. For example, the instance for
-- 'Colour' drops the alpha channel.
fromAlphaColour :: AlphaColour Double -> c
-- | An existential wrapper for instances of the 'Color' class.
data SomeColor = forall c. Color c => SomeColor c
deriving Typeable
instance Show SomeColor where
showsPrec d (colorToSRGBA -> (r,g,b,a)) =
showParen (d > 10) $ showString "SomeColor " .
if a == 0
then showString "transparent"
else showString "(sRGB " . showsPrec 11 r . showChar ' '
. showsPrec 11 g . showChar ' '
. showsPrec 11 b .
(if a /= 1
then showString " `withOpacity` " . showsPrec 11 a
else id) . showChar ')'
-- | Isomorphism between 'SomeColor' and 'AlphaColour' 'Double'.
_SomeColor :: Iso' SomeColor (AlphaColour Double)
_SomeColor = iso toAlphaColour fromAlphaColour
someToAlpha :: SomeColor -> AlphaColour Double
someToAlpha (SomeColor c) = toAlphaColour c
instance a ~ Double => Color (Colour a) where
toAlphaColour = opaque
fromAlphaColour = (`over` black)
instance a ~ Double => Color (AlphaColour a) where
toAlphaColour = id
fromAlphaColour = id
instance Color SomeColor where
toAlphaColour (SomeColor c) = toAlphaColour c
fromAlphaColour = SomeColor
-- | Convert to sRGBA.
colorToSRGBA, colorToRGBA :: Color c => c -> (Double, Double, Double, Double)
colorToSRGBA col = (r, g, b, a)
where
c' = toAlphaColour col
c = alphaToColour c'
a = alphaChannel c'
RGB r g b = toSRGB c
colorToRGBA = colorToSRGBA
{-# DEPRECATED colorToRGBA "Renamed to colorToSRGBA." #-}
alphaToColour :: (Floating a, Ord 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
-- can be specified with the @Opacity@ attribute. The opacity is a
-- value between 1 (completely opaque, the default) and 0
-- (completely transparent). Opacity is multiplicative, that is,
-- @'opacity' o1 . 'opacity' o2 === 'opacity' (o1 * o2)@. In other
-- words, for example, @opacity 0.8@ means \"decrease this diagram's
-- opacity to 80% of its previous opacity\".
newtype Opacity = Opacity (Product Double)
deriving (Typeable, Semigroup)
instance AttributeClass Opacity
_Opacity :: Iso' Opacity Double
_Opacity = iso getOpacity (Opacity . Product)
getOpacity :: Opacity -> Double
getOpacity (Opacity (Product d)) = d
-- | Multiply the opacity (see 'Opacity') by the given value. For
-- example, @opacity 0.8@ means \"decrease this diagram's opacity to
-- 80% of its previous opacity\".
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
-- fill opacity --------------------------------------------------------
-- | Like 'Opacity', but set the opacity only for fills (as opposed to strokes).
-- As with 'Opacity', the fill opacity is a value between 1
-- (completely opaque, the default) and 0 (completely transparent),
-- and is multiplicative.
newtype FillOpacity = FillOpacity (Product Double)
deriving (Typeable, Semigroup)
instance AttributeClass FillOpacity
_FillOpacity :: Iso' FillOpacity Double
_FillOpacity = iso getFillOpacity (FillOpacity . Product)
getFillOpacity :: FillOpacity -> Double
getFillOpacity (FillOpacity (Product d)) = d
-- | Multiply the fill opacity (see 'FillOpacity') by the given value. For
-- example, @fillOpacity 0.8@ means \"decrease this diagram's fill opacity to
-- 80% of its previous value\".
fillOpacity :: HasStyle a => Double -> a -> a
fillOpacity = applyAttr . FillOpacity . Product
-- | Lens onto the fill opacity in a style.
_fillOpacity :: Lens' (Style v n) Double
_fillOpacity = atAttr . mapping _FillOpacity . non 1
-- stroke opacity --------------------------------------------------------
-- | Like 'Opacity', but set the opacity only for strokes (as opposed to fills).
-- As with 'Opacity', the fill opacity is a value between 1
-- (completely opaque, the default) and 0 (completely transparent),
-- and is multiplicative.
newtype StrokeOpacity = StrokeOpacity (Product Double)
deriving (Typeable, Semigroup)
instance AttributeClass StrokeOpacity
_StrokeOpacity :: Iso' StrokeOpacity Double
_StrokeOpacity = iso getStrokeOpacity (StrokeOpacity . Product)
getStrokeOpacity :: StrokeOpacity -> Double
getStrokeOpacity (StrokeOpacity (Product d)) = d
-- | Multiply the stroke opacity (see 'StrokeOpacity') by the given value. For
-- example, @strokeOpacity 0.8@ means \"decrease this diagram's
-- stroke opacity to 80% of its previous value\".
strokeOpacity :: HasStyle a => Double -> a -> a
strokeOpacity = applyAttr . StrokeOpacity . Product
-- | Lens onto the stroke opacity in a style.
_strokeOpacity :: Lens' (Style v n) Double
_strokeOpacity = atAttr . mapping _StrokeOpacity . non 1
------------------------------------------------------------------------
-- 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.
| LineCapRound -- ^ Lines are capped with semicircles
-- centered on endpoints.
| LineCapSquare -- ^ Lines are capped with a squares
-- centered on endpoints.
deriving (Eq, Ord, Show, Typeable)
instance Default LineCap where
def = LineCapButt
instance AttributeClass LineCap
-- | Last semigroup structure.
instance Semigroup LineCap where
_ <> b = b
getLineCap :: LineCap -> LineCap
getLineCap = id
-- | Set the line end cap attribute.
lineCap :: HasStyle a => LineCap -> a -> a
lineCap = applyAttr
-- | Lens onto the line cap in a style.
_lineCap :: Lens' (Style v n) LineCap
_lineCap = atAttr . non def
-- 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.
| LineJoinBevel -- ^ Use a \"bevel\" shape (whatever
-- that is). Are these...
-- carpentry terms?
deriving (Eq, Ord, Show, Typeable)
instance AttributeClass LineJoin
-- | Last semigroup structure.
instance Semigroup LineJoin where
_ <> b = b
instance Default LineJoin where
def = LineJoinMiter
getLineJoin :: LineJoin -> LineJoin
getLineJoin = id
-- | Set the segment join style.
lineJoin :: HasStyle a => LineJoin -> a -> a
lineJoin = applyAttr
-- | Lens onto the line join type in a style.
_lineJoin :: Lens' (Style v n) LineJoin
_lineJoin = atAttr . non def
-- 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, Eq, Ord)
instance AttributeClass LineMiterLimit
_LineMiterLimit :: Iso' LineMiterLimit Double
_LineMiterLimit = iso getLineMiterLimit (LineMiterLimit . Last)
instance Default LineMiterLimit where
def = LineMiterLimit (Last 10)
getLineMiterLimit :: LineMiterLimit -> Double
getLineMiterLimit (LineMiterLimit (Last l)) = l
-- | Set the miter limit for joins with 'LineJoinMiter'.
lineMiterLimit :: HasStyle a => Double -> a -> a
lineMiterLimit = applyAttr . LineMiterLimit . Last
-- | Apply a 'LineMiterLimit' attribute.
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 . non def . _LineMiterLimit
------------------------------------------------------------------------
-- 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 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
-- | '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