{-# 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 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 :: * -> *) n :: * 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
<> (Getting (First a) (Attribute v n) a -> Attribute v n -> Maybe a
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First a) (Attribute v n) a
forall a (v :: * -> *) n.
AttributeClass a =>
Prism' (Attribute v n) a
_Attribute  -> Just a
a2) = a -> Attribute v n
forall a (v :: * -> *) n. AttributeClass a => a -> Attribute v n
Attribute  (a
a1 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
a2)
  (MAttribute Measured n a
a1) <> (Getting (First (Measured n a)) (Attribute v n) (Measured n a)
-> Attribute v n -> Maybe (Measured n a)
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First (Measured n a)) (Attribute v n) (Measured n a)
forall a n (v :: * -> *).
(AttributeClass a, Typeable n) =>
Prism' (Attribute v n) (Measured n a)
_MAttribute -> Just Measured n a
a2) = Measured n a -> Attribute v n
forall a n (v :: * -> *).
AttributeClass a =>
Measured n a -> Attribute v n
MAttribute (Measured n a
a1 Measured n a -> Measured n a -> Measured n a
forall a. Semigroup a => a -> a -> a
<> Measured n a
a2)
  (TAttribute a
a1) <> (Getting (First a) (Attribute v n) a -> Attribute v n -> Maybe a
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First a) (Attribute v n) a
forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, AttributeClass a, Transformable a) =>
Prism' (Attribute v n) a
_TAttribute -> Just a
a2) = a -> Attribute v n
forall a (v :: * -> *) n.
(AttributeClass a, Transformable a, V a ~ v, N a ~ n) =>
a -> Attribute v n
TAttribute (a
a1 a -> a -> a
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)  = a -> Attribute v n
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) = Measured n a -> Attribute v n
forall a n (v :: * -> *).
AttributeClass a =>
Measured n a -> Attribute v n
MAttribute (Measured n a -> Attribute v n) -> Measured n a -> Attribute v n
forall a b. (a -> b) -> a -> b
$ n -> Measured n a -> Measured n a
forall n a. Num n => n -> Measured n a -> Measured n a
scaleLocal (Transformation v n -> n
forall (v :: * -> *) n.
(Additive v, Traversable v, Floating n) =>
Transformation v n -> n
avgScale Transformation v n
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) = a -> Attribute v n
forall a (v :: * -> *) n.
(AttributeClass a, Transformable a, V a ~ v, N a ~ n) =>
a -> Attribute v n
TAttribute (a -> Attribute v n) -> a -> Attribute v n
forall a b. (a -> b) -> a -> b
$ Transformation (V a) (N a) -> a -> a
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V a) (N a)
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ case Attribute v n
attr of
    Attribute a
a  -> String -> ShowS
showString String
"Attribute "  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> TypeRep -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
a)
    MAttribute Measured n a
a -> String -> ShowS
showString String
"MAttribute " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> TypeRep -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 (Measured n a -> TypeRep
forall n a. Typeable a => Measured n a -> TypeRep
mType Measured n a
a)
    TAttribute a
a -> String -> ShowS
showString String
"TAttribute " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> TypeRep -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 (a -> TypeRep
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 :: Attribute v n -> Maybe a
unwrapAttribute (Attribute a
a)  = a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
a
unwrapAttribute (MAttribute Measured n a
_) = Maybe a
forall a. Maybe a
Nothing
unwrapAttribute (TAttribute a
a) = a -> Maybe 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 :: Prism' (Attribute v n) a
_Attribute = (a -> Attribute v n)
-> (Attribute v n -> Maybe a) -> Prism' (Attribute v n) a
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' a -> Attribute v n
forall a (v :: * -> *) n. AttributeClass a => a -> Attribute v n
Attribute ((Attribute v n -> Maybe a) -> Prism' (Attribute v n) a)
-> (Attribute v n -> Maybe a) -> Prism' (Attribute v n) a
forall a b. (a -> b) -> a -> b
$ \Attribute v n
t -> case Attribute v n
t of Attribute a
a -> a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
a; Attribute v n
_ -> Maybe a
forall a. Maybe a
Nothing
{-# INLINE _Attribute #-}

-- | Prism onto an 'MAttribute'.
_MAttribute :: (AttributeClass a, Typeable n) => Prism' (Attribute v n) (Measured n a)
_MAttribute :: Prism' (Attribute v n) (Measured n a)
_MAttribute = (Measured n a -> Attribute v n)
-> (Attribute v n -> Maybe (Measured n a))
-> Prism' (Attribute v n) (Measured n a)
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' Measured n a -> Attribute v n
forall a n (v :: * -> *).
AttributeClass a =>
Measured n a -> Attribute v n
MAttribute ((Attribute v n -> Maybe (Measured n a))
 -> Prism' (Attribute v n) (Measured n a))
-> (Attribute v n -> Maybe (Measured n a))
-> Prism' (Attribute v n) (Measured n a)
forall a b. (a -> b) -> a -> b
$ \Attribute v n
t -> case Attribute v n
t of MAttribute Measured n a
a -> Measured n a -> Maybe (Measured n a)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast Measured n a
a; Attribute v n
_ -> Maybe (Measured n a)
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 :: Prism' (Attribute v n) a
_TAttribute = (a -> Attribute v n)
-> (Attribute v n -> Maybe a) -> Prism' (Attribute v n) a
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' a -> Attribute v n
forall a (v :: * -> *) n.
(AttributeClass a, Transformable a, V a ~ v, N a ~ n) =>
a -> Attribute v n
TAttribute ((Attribute v n -> Maybe a) -> Prism' (Attribute v n) a)
-> (Attribute v n -> Maybe a) -> Prism' (Attribute v n) a
forall a b. (a -> b) -> a -> b
$ \Attribute v n
t -> case Attribute v n
t of TAttribute a
a -> a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
a; Attribute v n
_ -> Maybe a
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 :: n -> n -> Attribute v n -> Attribute v n
unmeasureAttribute n
g n
n (MAttribute Measured n a
m) = a -> Attribute v n
forall a (v :: * -> *) n. AttributeClass a => a -> Attribute v n
Attribute (n -> n -> Measured n a -> a
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 :: Attribute v n -> TypeRep
attributeType (Attribute a
a)  = a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
a
attributeType (MAttribute Measured n a
a) = Measured n a -> TypeRep
forall n a. Typeable a => Measured n a -> TypeRep
mType Measured n a
a
attributeType (TAttribute a
a) = a -> TypeRep
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 :: Measured n a -> TypeRep
mType Measured n a
_ = a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (a
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' :: p (Unwrapped (Style v n)) (f (Unwrapped (Style v n)))
-> p (Style v n) (f (Style v n))
_Wrapped' = (Style v n -> HashMap TypeRep (Attribute v n))
-> (HashMap TypeRep (Attribute v n) -> Style v n)
-> Iso
     (Style v n)
     (Style v n)
     (HashMap TypeRep (Attribute v n))
     (HashMap TypeRep (Attribute v n))
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) HashMap TypeRep (Attribute v n) -> Style v n
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 :: (Attribute v n -> f (Attribute v' n'))
-> Style v n -> f (Style v' n')
each = (HashMap TypeRep (Attribute v n)
 -> f (HashMap TypeRep (Attribute v' n')))
-> Style v n -> f (Style v' n')
forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped ((HashMap TypeRep (Attribute v n)
  -> f (HashMap TypeRep (Attribute v' n')))
 -> Style v n -> f (Style v' n'))
-> ((Attribute v n -> f (Attribute v' n'))
    -> HashMap TypeRep (Attribute v n)
    -> f (HashMap TypeRep (Attribute v' n')))
-> (Attribute v n -> f (Attribute v' n'))
-> Style v n
-> f (Style v' n')
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attribute v n -> f (Attribute v' n'))
-> HashMap TypeRep (Attribute v n)
-> f (HashMap TypeRep (Attribute v' n'))
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 = (HashMap TypeRep (Attribute v n)
 -> f (HashMap TypeRep (Attribute v n)))
-> Style v n -> f (Style v n)
forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped' ((HashMap TypeRep (Attribute v n)
  -> f (HashMap TypeRep (Attribute v n)))
 -> Style v n -> f (Style v n))
-> ((Attribute v n -> f (Attribute v n))
    -> HashMap TypeRep (Attribute v n)
    -> f (HashMap TypeRep (Attribute v n)))
-> (Attribute v n -> f (Attribute v n))
-> Style v n
-> f (Style v n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap TypeRep (Attribute v n))
-> Traversal'
     (HashMap TypeRep (Attribute v n))
     (IxValue (HashMap TypeRep (Attribute v n)))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (HashMap TypeRep (Attribute v n))
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 = (HashMap TypeRep (Attribute v n)
 -> f (HashMap TypeRep (Attribute v n)))
-> Style v n -> f (Style v n)
forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped' ((HashMap TypeRep (Attribute v n)
  -> f (HashMap TypeRep (Attribute v n)))
 -> Style v n -> f (Style v n))
-> ((Maybe (Attribute v n) -> f (Maybe (Attribute v n)))
    -> HashMap TypeRep (Attribute v n)
    -> f (HashMap TypeRep (Attribute v n)))
-> (Maybe (Attribute v n) -> f (Maybe (Attribute v n)))
-> Style v n
-> f (Style v n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap TypeRep (Attribute v n))
-> Lens'
     (HashMap TypeRep (Attribute v n))
     (Maybe (IxValue (HashMap TypeRep (Attribute v n))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap TypeRep (Attribute v n))
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 = HashMap TypeRep (Attribute v n) -> Style v n
forall (v :: * -> *) n.
HashMap TypeRep (Attribute v n) -> Style v n
Style (HashMap TypeRep (Attribute v n) -> Style v n)
-> HashMap TypeRep (Attribute v n) -> Style v n
forall a b. (a -> b) -> a -> b
$ (Attribute v n -> Attribute v n -> Attribute v n)
-> HashMap TypeRep (Attribute v n)
-> HashMap TypeRep (Attribute v n)
-> HashMap TypeRep (Attribute v n)
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HM.unionWith Attribute v n -> Attribute v n -> Attribute v n
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  = HashMap TypeRep (Attribute v n) -> Style v n
forall (v :: * -> *) n.
HashMap TypeRep (Attribute v n) -> Style v n
Style HashMap TypeRep (Attribute v n)
forall k v. HashMap k v
HM.empty
  mappend :: Style v n -> Style v n -> Style v n
mappend = Style v n -> Style v n -> Style v n
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 = ASetter (Style v n) (Style v n) (Attribute v n) (Attribute v n)
-> (Attribute v n -> Attribute v n) -> Style v n -> Style v n
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Style v n) (Style v n) (Attribute v n) (Attribute v n)
forall s t a b. Each s t a b => Traversal s t a b
each (Transformation (V (Attribute v n)) (N (Attribute v n))
-> Attribute v n -> Attribute v n
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (Style v n)) (N (Style v n))
Transformation (V (Attribute v n)) (N (Attribute 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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    String -> ShowS
showString String
"Style " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Attribute v n] -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
d (Style v n
sty Style v n
-> Getting (Endo [Attribute v n]) (Style v n) (Attribute v n)
-> [Attribute v n]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [Attribute v n]) (Style v n) (Attribute v n)
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 :: Attribute v n -> Style v n
attributeToStyle Attribute v n
a = HashMap TypeRep (Attribute v n) -> Style v n
forall (v :: * -> *) n.
HashMap TypeRep (Attribute v n) -> Style v n
Style (HashMap TypeRep (Attribute v n) -> Style v n)
-> HashMap TypeRep (Attribute v n) -> Style v n
forall a b. (a -> b) -> a -> b
$ TypeRep -> Attribute v n -> HashMap TypeRep (Attribute v n)
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton (Attribute v n -> TypeRep
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 :: Style v n -> Maybe a
getAttr (Style HashMap TypeRep (Attribute v n)
s) = TypeRep -> HashMap TypeRep (Attribute v n) -> Maybe (Attribute v n)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup TypeRep
ty HashMap TypeRep (Attribute v n)
s Maybe (Attribute v n) -> (Attribute v n -> Maybe a) -> Maybe a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Attribute v n -> Maybe a
forall a (v :: * -> *) n.
AttributeClass a =>
Attribute v n -> Maybe a
unwrapAttribute
  where ty :: TypeRep
ty = a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (a
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 :: n -> n -> Style v n -> Style v n
unmeasureAttrs n
g n
n = ASetter (Style v n) (Style v n) (Attribute v n) (Attribute v n)
-> (Attribute v n -> Attribute v n) -> Style v n -> Style v n
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Style v n) (Style v n) (Attribute v n) (Attribute v n)
forall s t a b. Each s t a b => Traversal s t a b
each (n -> n -> Attribute v n -> Attribute v n
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 :: (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 Style v n -> Getting (First a) (Style v n) a -> Maybe a
forall s a. s -> Getting (First a) s a -> Maybe a
^? Index (Style v n) -> Traversal' (Style v n) (IxValue (Style v n))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix TypeRep
Index (Style v n)
ty ((Attribute v n -> Const (First a) (Attribute v n))
 -> Style v n -> Const (First a) (Style v n))
-> ((a -> Const (First a) a)
    -> Attribute v n -> Const (First a) (Attribute v n))
-> Getting (First a) (Style v n) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Const (First a) a)
-> Attribute v n -> Const (First a) (Attribute v n)
Prism' (Attribute v n) a
p) f (Maybe a) -> (Maybe a -> Style v n) -> f (Style v n)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Maybe a
mAtt -> Style v n
sty Style v n -> (Style v n -> Style v n) -> Style v n
forall a b. a -> (a -> b) -> b
& Index (Style v n)
-> Lens' (Style v n) (Maybe (IxValue (Style v n)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at TypeRep
Index (Style v n)
ty ((Maybe (Attribute v n) -> Identity (Maybe (Attribute v n)))
 -> Style v n -> Identity (Style v n))
-> Maybe (Attribute v n) -> Style v n -> Style v n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (AReview (Attribute v n) a -> a -> Attribute v n
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview (Attribute v n) a
Prism' (Attribute v n) a
p (a -> Attribute v n) -> Maybe a -> Maybe (Attribute v n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
mAtt)
  where ty :: TypeRep
ty = a -> TypeRep
tyF (a
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 :: Lens' (Style v n) (Maybe a)
atAttr = (a -> TypeRep)
-> Prism' (Attribute v n) a -> Lens' (Style v n) (Maybe a)
forall (v :: * -> *) n a.
Typeable a =>
(a -> TypeRep)
-> Prism' (Attribute v n) a -> Lens' (Style v n) (Maybe a)
mkAttrLens a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf forall a (v :: * -> *) n.
AttributeClass a =>
Prism' (Attribute v n) 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 :: Lens' (Style v n) (Maybe (Measured n a))
atMAttr = (Measured n a -> TypeRep)
-> Prism' (Attribute v n) (Measured n a)
-> Lens' (Style v n) (Maybe (Measured n a))
forall (v :: * -> *) n a.
Typeable a =>
(a -> TypeRep)
-> Prism' (Attribute v n) a -> Lens' (Style v n) (Maybe a)
mkAttrLens Measured n a -> TypeRep
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)
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 :: Lens' (Style v n) (Maybe a)
atTAttr = (a -> TypeRep)
-> Prism' (Attribute v n) a -> Lens' (Style v n) (Maybe a)
forall (v :: * -> *) n a.
Typeable a =>
(a -> TypeRep)
-> Prism' (Attribute v n) a -> Lens' (Style v n) (Maybe a)
mkAttrLens a -> TypeRep
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
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 = Style (V (Style v n)) (N (Style v n)) -> Style v n -> Style v n
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 = Style (V a) (N a) -> a -> a
forall a. HasStyle a => Style (V a) (N a) -> a -> a
applyStyle Style (V a) (N a)
Style (V (a, b)) (N (a, b))
s (a -> a) -> (b -> b) -> (a, b) -> (a, b)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Style (V b) (N b) -> b -> b
forall a. HasStyle a => Style (V a) (N a) -> a -> a
applyStyle Style (V b) (N b)
Style (V (a, b)) (N (a, b))
s

instance HasStyle a => HasStyle [a] where
  applyStyle :: Style (V [a]) (N [a]) -> [a] -> [a]
applyStyle = (a -> a) -> [a] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> a) -> [a] -> [a])
-> (Style (V a) (N a) -> a -> a) -> Style (V a) (N a) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style (V a) (N a) -> a -> a
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 = (b -> b) -> (a -> b) -> a -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> b) -> (a -> b) -> a -> b)
-> (Style (V b) (N b) -> b -> b)
-> Style (V b) (N b)
-> (a -> b)
-> a
-> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style (V b) (N b) -> b -> b
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 = (a -> a) -> Map k a -> Map k a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> a) -> Map k a -> Map k a)
-> (Style (V a) (N a) -> a -> a)
-> Style (V a) (N a)
-> Map k a
-> Map k a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style (V a) (N a) -> a -> a
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 = (a -> a) -> Set a -> Set a
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map ((a -> a) -> Set a -> Set a)
-> (Style (V a) (N a) -> a -> a)
-> Style (V a) (N a)
-> Set a
-> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style (V a) (N a) -> a -> a
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 = (b -> b) -> Measured n b -> Measured n b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> b) -> Measured n b -> Measured n b)
-> (Style (V b) (N b) -> b -> b)
-> Style (V b) (N b)
-> Measured n b
-> Measured n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style (V b) (N b) -> b -> b
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 :: a -> d -> d
applyAttr = Style (V d) (N d) -> d -> d
forall a. HasStyle a => Style (V a) (N a) -> a -> a
applyStyle (Style (V d) (N d) -> d -> d)
-> (a -> Style (V d) (N d)) -> a -> d -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attribute (V d) (N d) -> Style (V d) (N d)
forall (v :: * -> *) n. Attribute v n -> Style v n
attributeToStyle (Attribute (V d) (N d) -> Style (V d) (N d))
-> (a -> Attribute (V d) (N d)) -> a -> Style (V d) (N d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Attribute (V d) (N d)
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 :: Measured n a -> d -> d
applyMAttr = Style (V d) n -> d -> d
forall a. HasStyle a => Style (V a) (N a) -> a -> a
applyStyle (Style (V d) n -> d -> d)
-> (Measured n a -> Style (V d) n) -> Measured n a -> d -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attribute (V d) n -> Style (V d) n
forall (v :: * -> *) n. Attribute v n -> Style v n
attributeToStyle (Attribute (V d) n -> Style (V d) n)
-> (Measured n a -> Attribute (V d) n)
-> Measured n a
-> Style (V d) n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Measured n a -> Attribute (V d) n
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 :: a -> d -> d
applyTAttr = Style (V d) (N d) -> d -> d
forall a. HasStyle a => Style (V a) (N a) -> a -> a
applyStyle (Style (V d) (N d) -> d -> d)
-> (a -> Style (V d) (N d)) -> a -> d -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attribute (V d) (N d) -> Style (V d) (N d)
forall (v :: * -> *) n. Attribute v n -> Style v n
attributeToStyle (Attribute (V d) (N d) -> Style (V d) (N d))
-> (a -> Attribute (V d) (N d)) -> a -> Style (V d) (N d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Attribute (V d) (N d)
forall a (v :: * -> *) n.
(AttributeClass a, Transformable a, V a ~ v, N a ~ n) =>
a -> Attribute v n
TAttribute