{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE ViewPatterns          #-}

{-# OPTIONS_GHC -fno-warn-unused-imports       #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Core.Style
-- Copyright   :  (c) 2011-2015 diagrams-core team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- A definition of /styles/ for diagrams as extensible, heterogeneous
-- collections of attributes.
--
-----------------------------------------------------------------------------

module Diagrams.Core.Style
  ( -- * Attributes
    -- $attr

    AttributeClass
  , Attribute(..)

    -- ** Attributes prisms
  , _Attribute
  , _MAttribute
  , _TAttribute

    -- ** Attributes utilities
  , unwrapAttribute
  , unmeasureAttribute
  , attributeType

    -- * Styles
    -- $style

  , Style(..)

    -- ** Making styles
  , attributeToStyle

    -- ** Extracting attibutes from styles
  , getAttr
  , unmeasureAttrs

    -- ** Attibute lenses
  , atAttr
  , atMAttr
  , atTAttr

    -- ** Applying styles
  , applyAttr
  , applyMAttr
  , applyTAttr

  , HasStyle(..)

  ) where

import           Control.Applicative
import           Control.Arrow           ((***))
import           Control.Lens            hiding (transform)
import qualified Data.HashMap.Strict     as HM
import           Data.Kind               (Type)
import qualified Data.Map                as M
import           Data.Monoid.Action      as A
import           Data.Semigroup
import qualified Data.Set                as S
import           Data.Typeable

import           Diagrams.Core.Measure
import           Diagrams.Core.Transform
import           Diagrams.Core.V

import           Linear.Vector

------------------------------------------------------------
--  Attributes  --------------------------------------------
------------------------------------------------------------

-- $attr
-- An /attribute/ is anything that determines some aspect of a
-- diagram's rendering.  The standard diagrams library defines several
-- standard attributes (line color, line width, fill color, etc.) but
-- additional attributes may easily be created.  Additionally, a given
-- backend need not handle (or even know about) attributes used in
-- diagrams it renders.
--
-- The attribute code is inspired by xmonad's @Message@ type, which
-- was in turn based on ideas in:
--
-- Simon Marlow.
-- /An Extensible Dynamically-Typed Hierarchy of Exceptions/.
-- Proceedings of the 2006 ACM SIGPLAN workshop on
-- Haskell. <http://research.microsoft.com/apps/pubs/default.aspx?id=67968>.

-- | Every attribute must be an instance of @AttributeClass@, which
--   simply guarantees 'Typeable' and 'Semigroup' constraints.  The
--   'Semigroup' instance for an attribute determines how it will combine
--   with other attributes of the same type.
class (Typeable a, Semigroup a) => AttributeClass a

-- | An existential wrapper type to hold attributes.  Some attributes
--   are simply inert/static; some are affected by transformations;
--   and some are affected by transformations and can be modified
--   generically.
data Attribute (v :: Type -> Type) n :: Type where
  Attribute  :: AttributeClass a => a -> Attribute v n
  MAttribute :: AttributeClass a => Measured n a -> Attribute v n
  TAttribute :: (AttributeClass a, Transformable a, V a ~ v, N a ~ n) => a -> Attribute v n

type instance V (Attribute v n) = v
type instance N (Attribute v n) = n

-- | Attributes form a semigroup, where the semigroup operation simply
--   returns the right-hand attribute when the types do not match, and
--   otherwise uses the semigroup operation specific to the (matching)
--   types.
instance Typeable n => Semigroup (Attribute v n) where
  (Attribute a
a1)  <> :: Attribute v n -> Attribute v n -> Attribute v n
<> (forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview forall a (v :: * -> *) n.
AttributeClass a =>
Prism' (Attribute v n) a
_Attribute  -> Just a
a2) = forall a (v :: * -> *) n. AttributeClass a => a -> Attribute v n
Attribute  (a
a1 forall a. Semigroup a => a -> a -> a
<> a
a2)
  (MAttribute Measured n a
a1) <> (forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview forall a n (v :: * -> *).
(AttributeClass a, Typeable n) =>
Prism' (Attribute v n) (Measured n a)
_MAttribute -> Just Measured n a
a2) = forall a n (v :: * -> *).
AttributeClass a =>
Measured n a -> Attribute v n
MAttribute (Measured n a
a1 forall a. Semigroup a => a -> a -> a
<> Measured n a
a2)
  (TAttribute a
a1) <> (forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, AttributeClass a, Transformable a) =>
Prism' (Attribute v n) a
_TAttribute -> Just a
a2) = forall a (v :: * -> *) n.
(AttributeClass a, Transformable a, V a ~ v, N a ~ n) =>
a -> Attribute v n
TAttribute (a
a1 forall a. Semigroup a => a -> a -> a
<> a
a2)
  Attribute v n
_               <> Attribute v n
a2                               = Attribute v n
a2

-- | 'TAttribute's are transformed directly, 'MAttribute's have their
--   local scale multiplied by the average scale of the transform.
--   Plain 'Attribute's are unaffected.
instance (Additive v, Traversable v, Floating n) => Transformable (Attribute v n) where
  transform :: Transformation (V (Attribute v n)) (N (Attribute v n))
-> Attribute v n -> Attribute v n
transform Transformation (V (Attribute v n)) (N (Attribute v n))
_ (Attribute a
a)  = forall a (v :: * -> *) n. AttributeClass a => a -> Attribute v n
Attribute a
a
  transform Transformation (V (Attribute v n)) (N (Attribute v n))
t (MAttribute Measured n a
a) = forall a n (v :: * -> *).
AttributeClass a =>
Measured n a -> Attribute v n
MAttribute forall a b. (a -> b) -> a -> b
$ forall n a. Num n => n -> Measured n a -> Measured n a
scaleLocal (forall (v :: * -> *) n.
(Additive v, Traversable v, Floating n) =>
Transformation v n -> n
avgScale Transformation (V (Attribute v n)) (N (Attribute v n))
t) Measured n a
a
  transform Transformation (V (Attribute v n)) (N (Attribute v n))
t (TAttribute a
a) = forall a (v :: * -> *) n.
(AttributeClass a, Transformable a, V a ~ v, N a ~ n) =>
a -> Attribute v n
TAttribute forall a b. (a -> b) -> a -> b
$ forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (Attribute v n)) (N (Attribute v n))
t a
a

-- | Shows the kind of attribute and the type contained in the
--   attribute.
instance Show (Attribute v n) where
  showsPrec :: Int -> Attribute v n -> ShowS
showsPrec Int
d Attribute v n
attr = Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ case Attribute v n
attr of
    Attribute a
a  -> String -> ShowS
showString String
"Attribute "  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 (forall a. Typeable a => a -> TypeRep
typeOf a
a)
    MAttribute Measured n a
a -> String -> ShowS
showString String
"MAttribute " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 (forall n a. Typeable a => Measured n a -> TypeRep
mType Measured n a
a)
    TAttribute a
a -> String -> ShowS
showString String
"TAttribute " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 (forall a. Typeable a => a -> TypeRep
typeOf a
a)

-- | Unwrap an unknown 'Attribute' type, performing a dynamic (but
--   safe) check on the type of the result. If the required type
--   matches the type of the attribute, the attribute value is
--   returned wrapped in @Just@; if the types do not match, @Nothing@
--   is returned.
--
--   Measured attributes cannot be extrated from this function until
--   they have been unmeasured with 'unmeasureAttribute'. If you want a
--   measured attibute use the '_MAttribute' prism.
unwrapAttribute :: AttributeClass a => Attribute v n -> Maybe a
unwrapAttribute :: forall a (v :: * -> *) n.
AttributeClass a =>
Attribute v n -> Maybe a
unwrapAttribute (Attribute a
a)  = forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
a
unwrapAttribute (MAttribute Measured n a
_) = forall a. Maybe a
Nothing
unwrapAttribute (TAttribute a
a) = forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
a
{-# INLINE unwrapAttribute #-}

-- | Prism onto an 'Attribute'.
_Attribute :: AttributeClass a => Prism' (Attribute v n) a
_Attribute :: forall a (v :: * -> *) n.
AttributeClass a =>
Prism' (Attribute v n) a
_Attribute = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' forall a (v :: * -> *) n. AttributeClass a => a -> Attribute v n
Attribute forall a b. (a -> b) -> a -> b
$ \Attribute v n
t -> case Attribute v n
t of Attribute a
a -> forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
a; Attribute v n
_ -> forall a. Maybe a
Nothing
{-# INLINE _Attribute #-}

-- | Prism onto an 'MAttribute'.
_MAttribute :: (AttributeClass a, Typeable n) => Prism' (Attribute v n) (Measured n a)
_MAttribute :: forall a n (v :: * -> *).
(AttributeClass a, Typeable n) =>
Prism' (Attribute v n) (Measured n a)
_MAttribute = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' forall a n (v :: * -> *).
AttributeClass a =>
Measured n a -> Attribute v n
MAttribute forall a b. (a -> b) -> a -> b
$ \Attribute v n
t -> case Attribute v n
t of MAttribute Measured n a
a -> forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast Measured n a
a; Attribute v n
_ -> forall a. Maybe a
Nothing
{-# INLINE _MAttribute #-}

-- | Prism onto a 'TAttribute'.
_TAttribute :: (V a ~ v, N a ~ n, AttributeClass a, Transformable a)
            => Prism' (Attribute v n) a
_TAttribute :: forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, AttributeClass a, Transformable a) =>
Prism' (Attribute v n) a
_TAttribute = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' forall a (v :: * -> *) n.
(AttributeClass a, Transformable a, V a ~ v, N a ~ n) =>
a -> Attribute v n
TAttribute forall a b. (a -> b) -> a -> b
$ \Attribute v n
t -> case Attribute v n
t of TAttribute a
a -> forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
a; Attribute v n
_ -> forall a. Maybe a
Nothing
{-# INLINE _TAttribute #-}

-- | Turn an 'MAttribute' into an 'Attribute' using the given 'global'
--   and 'normalized' scale.
unmeasureAttribute :: (Num n)
                   => n -> n -> Attribute v n -> Attribute v n
unmeasureAttribute :: forall n (v :: * -> *).
Num n =>
n -> n -> Attribute v n -> Attribute v n
unmeasureAttribute n
g n
n (MAttribute Measured n a
m) = forall a (v :: * -> *) n. AttributeClass a => a -> Attribute v n
Attribute (forall n a. Num n => n -> n -> Measured n a -> a
fromMeasured n
g n
n Measured n a
m)
unmeasureAttribute n
_ n
_ Attribute v n
a              = Attribute v n
a

-- | Type of an attribute that is stored with a style. Measured
--   attributes return the type as if it where unmeasured.
attributeType :: Attribute v n -> TypeRep
attributeType :: forall (v :: * -> *) n. Attribute v n -> TypeRep
attributeType (Attribute a
a)  = forall a. Typeable a => a -> TypeRep
typeOf a
a
attributeType (MAttribute Measured n a
a) = forall n a. Typeable a => Measured n a -> TypeRep
mType Measured n a
a
attributeType (TAttribute a
a) = forall a. Typeable a => a -> TypeRep
typeOf a
a

-- Note that we use type 'a' not 'Measured n a' so we don't have to rebuild
-- when unmeasuring the attributes.
mType :: forall n a. Typeable a => Measured n a -> TypeRep
mType :: forall n a. Typeable a => Measured n a -> TypeRep
mType Measured n a
_ = forall a. Typeable a => a -> TypeRep
typeOf (forall a. HasCallStack => a
undefined :: a)

-- naming convention: "Attribute" deals with the 'AttibuteType'
-- directly and "Attr" is for other things (like styles). Users should
-- rarely (if at all) deal with the 'Attibute' type directly.

------------------------------------------------------------
--  Styles  ------------------------------------------------
------------------------------------------------------------

-- $style
-- A 'Style' is a heterogeneous collection of attributes, containing
-- at most one attribute of any given type.  This is also based on
-- ideas stolen from xmonad, specifically xmonad's implementation of
-- user-extensible state.

-- | A @Style@ is a heterogeneous collection of attributes, containing
--   at most one attribute of any given type.
newtype Style v n = Style (HM.HashMap TypeRep (Attribute v n))

-- instances -----------------------------------------------------------

type instance V (Style v n) = v
type instance N (Style v n) = n

instance Rewrapped (Style v n) (Style v' n')
instance Wrapped (Style v n) where
  type Unwrapped (Style v n) = HM.HashMap TypeRep (Attribute v n)
  _Wrapped' :: Iso' (Style v n) (Unwrapped (Style v n))
_Wrapped' = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(Style HashMap TypeRep (Attribute v n)
m) -> HashMap TypeRep (Attribute v n)
m) forall (v :: * -> *) n.
HashMap TypeRep (Attribute v n) -> Style v n
Style
  {-# INLINE _Wrapped' #-}

instance Each (Style v n) (Style v' n') (Attribute v n) (Attribute v' n') where
  each :: Traversal
  (Style v n) (Style v' n') (Attribute v n) (Attribute v' n')
each = forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Each s t a b => Traversal s t a b
each
  {-# INLINE each #-}

type instance Index (Style v n)   = TypeRep
type instance IxValue (Style v n) = Attribute v n

instance Ixed (Style v n) where
  ix :: Index (Style v n) -> Traversal' (Style v n) (IxValue (Style v n))
ix Index (Style v n)
k = forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (Style v n)
k
  {-# INLINE ix #-}

instance At (Style v n) where
  at :: Index (Style v n)
-> Lens' (Style v n) (Maybe (IxValue (Style v n)))
at Index (Style v n)
k = forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Style v n)
k
  {-# INLINE at #-}

-- | Combine a style by combining the attributes; if the two styles have
--   attributes of the same type they are combined according to their
--   semigroup structure.
instance Typeable n => Semigroup (Style v n) where
  Style HashMap TypeRep (Attribute v n)
s1 <> :: Style v n -> Style v n -> Style v n
<> Style HashMap TypeRep (Attribute v n)
s2 = forall (v :: * -> *) n.
HashMap TypeRep (Attribute v n) -> Style v n
Style forall a b. (a -> b) -> a -> b
$ forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HM.unionWith forall a. Semigroup a => a -> a -> a
(<>) HashMap TypeRep (Attribute v n)
s1 HashMap TypeRep (Attribute v n)
s2

-- | The empty style contains no attributes.
instance Typeable n => Monoid (Style v n) where
  mempty :: Style v n
mempty  = forall (v :: * -> *) n.
HashMap TypeRep (Attribute v n) -> Style v n
Style forall k v. HashMap k v
HM.empty
  mappend :: Style v n -> Style v n -> Style v n
mappend = forall a. Semigroup a => a -> a -> a
(<>)

instance (Additive v, Traversable v, Floating n) => Transformable (Style v n) where
  transform :: Transformation (V (Style v n)) (N (Style v n))
-> Style v n -> Style v n
transform Transformation (V (Style v n)) (N (Style v n))
t = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s t a b. Each s t a b => Traversal s t a b
each (forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (Style v n)) (N (Style v n))
t)

-- | Styles have no action on other monoids.
instance A.Action (Style v n) m

-- | Show the attributes in the style.
instance Show (Style v n) where
  showsPrec :: Int -> Style v n -> ShowS
showsPrec Int
d Style v n
sty = Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
    String -> ShowS
showString String
"Style " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
d (Style v n
sty forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall s t a b. Each s t a b => Traversal s t a b
each)

-- making styles -------------------------------------------------------

-- | Turn an attribute into a style. An easier way to make a style is to
--   use the monoid instance and apply library functions for applying
--   that attribute:
--
-- @
-- myStyle = mempty # fc blue :: Style V2 Double
-- @
attributeToStyle :: Attribute v n -> Style v n
attributeToStyle :: forall (v :: * -> *) n. Attribute v n -> Style v n
attributeToStyle Attribute v n
a = forall (v :: * -> *) n.
HashMap TypeRep (Attribute v n) -> Style v n
Style forall a b. (a -> b) -> a -> b
$ forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton (forall (v :: * -> *) n. Attribute v n -> TypeRep
attributeType Attribute v n
a) Attribute v n
a

-- extracting attributes -----------------------------------------------

-- | Extract an attribute from a style of a particular type.  If the
--   style contains an attribute of the requested type, it will be
--   returned wrapped in @Just@; otherwise, @Nothing@ is returned.
--
--   Trying to extract a measured attibute will fail. It either has to
--   be unmeasured with 'unmeasureAttrs' or use the 'atMAttr' lens.
getAttr :: forall a v n. AttributeClass a => Style v n -> Maybe a
getAttr :: forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr (Style HashMap TypeRep (Attribute v n)
s) = forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup TypeRep
ty HashMap TypeRep (Attribute v n)
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a (v :: * -> *) n.
AttributeClass a =>
Attribute v n -> Maybe a
unwrapAttribute
  where ty :: TypeRep
ty = forall a. Typeable a => a -> TypeRep
typeOf (forall a. HasCallStack => a
undefined :: a)
  -- unwrapAttribute can fail if someone tries to unwrap a measured
  -- attribute before it gets "unmeasured"

-- | Replace all 'MAttribute's with 'Attribute's using the 'global' and
--   'normalized' scales.
unmeasureAttrs :: (Num n) => n -> n -> Style v n -> Style v n
unmeasureAttrs :: forall n (v :: * -> *). Num n => n -> n -> Style v n -> Style v n
unmeasureAttrs n
g n
n = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s t a b. Each s t a b => Traversal s t a b
each (forall n (v :: * -> *).
Num n =>
n -> n -> Attribute v n -> Attribute v n
unmeasureAttribute n
g n
n)

-- style lenses --------------------------------------------------------

mkAttrLens :: forall v n a. Typeable a
           => (a -> TypeRep)
           -> Prism' (Attribute v n) a
           -> Lens' (Style v n) (Maybe a)
mkAttrLens :: forall (v :: * -> *) n a.
Typeable a =>
(a -> TypeRep)
-> Prism' (Attribute v n) a -> Lens' (Style v n) (Maybe a)
mkAttrLens a -> TypeRep
tyF Prism' (Attribute v n) a
p Maybe a -> f (Maybe a)
f Style v n
sty =
  Maybe a -> f (Maybe a)
f (Style v n
sty forall s a. s -> Getting (First a) s a -> Maybe a
^? forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix TypeRep
ty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' (Attribute v n) a
p) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Maybe a
mAtt -> Style v n
sty forall a b. a -> (a -> b) -> b
& forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at TypeRep
ty forall s t a b. ASetter s t a b -> b -> s -> t
.~ (forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review Prism' (Attribute v n) a
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
mAtt)
  where ty :: TypeRep
ty = a -> TypeRep
tyF (forall a. HasCallStack => a
undefined :: a)
{-# INLINE mkAttrLens #-}

-- | Lens onto a plain attribute of a style.
atAttr :: AttributeClass a
       => Lens' (Style v n) (Maybe a)
atAttr :: forall a (v :: * -> *) n.
AttributeClass a =>
Lens' (Style v n) (Maybe a)
atAttr = forall (v :: * -> *) n a.
Typeable a =>
(a -> TypeRep)
-> Prism' (Attribute v n) a -> Lens' (Style v n) (Maybe a)
mkAttrLens forall a. Typeable a => a -> TypeRep
typeOf forall a (v :: * -> *) n.
AttributeClass a =>
Prism' (Attribute v n) a
_Attribute
{-# INLINE atAttr #-}

-- | Lens onto a measured attribute of a style.
atMAttr :: (AttributeClass a, Typeable n)
        => Lens' (Style v n) (Maybe (Measured n a))
atMAttr :: forall a n (v :: * -> *).
(AttributeClass a, Typeable n) =>
Lens' (Style v n) (Maybe (Measured n a))
atMAttr = forall (v :: * -> *) n a.
Typeable a =>
(a -> TypeRep)
-> Prism' (Attribute v n) a -> Lens' (Style v n) (Maybe a)
mkAttrLens forall n a. Typeable a => Measured n a -> TypeRep
mType forall a n (v :: * -> *).
(AttributeClass a, Typeable n) =>
Prism' (Attribute v n) (Measured n a)
_MAttribute
{-# INLINE atMAttr #-}

-- | Lens onto a transformable attribute of a style.
atTAttr :: (V a ~ v, N a ~ n, AttributeClass a, Transformable a)
        => Lens' (Style v n) (Maybe a)
atTAttr :: forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, AttributeClass a, Transformable a) =>
Lens' (Style v n) (Maybe a)
atTAttr = forall (v :: * -> *) n a.
Typeable a =>
(a -> TypeRep)
-> Prism' (Attribute v n) a -> Lens' (Style v n) (Maybe a)
mkAttrLens forall a. Typeable a => a -> TypeRep
typeOf forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, AttributeClass a, Transformable a) =>
Prism' (Attribute v n) a
_TAttribute
{-# INLINE atTAttr #-}

-- applying styles -----------------------------------------------------

-- | Type class for things which have a style.
class HasStyle a where
  -- | /Apply/ a style by combining it (on the left) with the
  --   existing style.
  applyStyle :: Style (V a) (N a) -> a -> a

instance Typeable n => HasStyle (Style v n) where
  applyStyle :: Style (V (Style v n)) (N (Style v n)) -> Style v n -> Style v n
applyStyle = forall a. Monoid a => a -> a -> a
mappend

instance (HasStyle a, HasStyle b, V a ~ V b, N a ~ N b) => HasStyle (a,b) where
  applyStyle :: Style (V (a, b)) (N (a, b)) -> (a, b) -> (a, b)
applyStyle Style (V (a, b)) (N (a, b))
s = forall a. HasStyle a => Style (V a) (N a) -> a -> a
applyStyle Style (V (a, b)) (N (a, b))
s forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall a. HasStyle a => Style (V a) (N a) -> a -> a
applyStyle Style (V (a, b)) (N (a, b))
s

instance HasStyle a => HasStyle [a] where
  applyStyle :: Style (V [a]) (N [a]) -> [a] -> [a]
applyStyle = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasStyle a => Style (V a) (N a) -> a -> a
applyStyle

instance HasStyle b => HasStyle (a -> b) where
  applyStyle :: Style (V (a -> b)) (N (a -> b)) -> (a -> b) -> a -> b
applyStyle = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasStyle a => Style (V a) (N a) -> a -> a
applyStyle

instance HasStyle a => HasStyle (M.Map k a) where
  applyStyle :: Style (V (Map k a)) (N (Map k a)) -> Map k a -> Map k a
applyStyle = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasStyle a => Style (V a) (N a) -> a -> a
applyStyle

instance (HasStyle a, Ord a) => HasStyle (S.Set a) where
  applyStyle :: Style (V (Set a)) (N (Set a)) -> Set a -> Set a
applyStyle = forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasStyle a => Style (V a) (N a) -> a -> a
applyStyle

instance HasStyle b => HasStyle (Measured n b) where
  applyStyle :: Style (V (Measured n b)) (N (Measured n b))
-> Measured n b -> Measured n b
applyStyle = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasStyle a => Style (V a) (N a) -> a -> a
applyStyle

-- | Apply an attribute to an instance of 'HasStyle' (such as a
--   diagram or a style). If the object already has an attribute of
--   the same type, the new attribute is combined on the left with the
--   existing attribute, according to their semigroup structure.
applyAttr :: (AttributeClass a, HasStyle d) => a -> d -> d
applyAttr :: forall a d. (AttributeClass a, HasStyle d) => a -> d -> d
applyAttr = forall a. HasStyle a => Style (V a) (N a) -> a -> a
applyStyle forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n. Attribute v n -> Style v n
attributeToStyle forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (v :: * -> *) n. AttributeClass a => a -> Attribute v n
Attribute

-- | Apply a measured attribute to an instance of 'HasStyle' (such as a
--   diagram or a style). If the object already has an attribute of
--   the same type, the new attribute is combined on the left with the
--   existing attribute, according to their semigroup structure.
applyMAttr :: (AttributeClass a, N d ~ n, HasStyle d) => Measured n a -> d -> d
applyMAttr :: forall a d n.
(AttributeClass a, N d ~ n, HasStyle d) =>
Measured n a -> d -> d
applyMAttr = forall a. HasStyle a => Style (V a) (N a) -> a -> a
applyStyle forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n. Attribute v n -> Style v n
attributeToStyle forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a n (v :: * -> *).
AttributeClass a =>
Measured n a -> Attribute v n
MAttribute

-- | Apply a transformable attribute to an instance of 'HasStyle'
--   (such as a diagram or a style). If the object already has an
--   attribute of the same type, the new attribute is combined on the
--   left with the existing attribute, according to their semigroup
--   structure.
applyTAttr :: (AttributeClass a, Transformable a, V a ~ V d, N a ~ N d, HasStyle d) => a -> d -> d
applyTAttr :: forall a d.
(AttributeClass a, Transformable a, V a ~ V d, N a ~ N d,
 HasStyle d) =>
a -> d -> d
applyTAttr = forall a. HasStyle a => Style (V a) (N a) -> a -> a
applyStyle forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n. Attribute v n -> Style v n
attributeToStyle forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (v :: * -> *) n.
(AttributeClass a, Transformable a, V a ~ v, N a ~ n) =>
a -> Attribute v n
TAttribute