diagrams-core 0.1.1 → 0.2

raw patch · 11 files changed

+353/−70 lines, 11 filesdep +semigroupsPVP ok

version bump matches the API change (PVP)

Dependencies added: semigroups

API changes (from Hackage documentation)

Files

• CHANGES +12/−0
• diagrams-core.cabal +3/−1
• src/Graphics/Rendering/Diagrams.hs +5/−5
• src/Graphics/Rendering/Diagrams/Bounds.hs +6/−3
• src/Graphics/Rendering/Diagrams/Core.hs +61/−18
• src/Graphics/Rendering/Diagrams/HasOrigin.hs +4/−1
• src/Graphics/Rendering/Diagrams/Monoids.hs +145/−3
• src/Graphics/Rendering/Diagrams/Names.hs +1/−1
• src/Graphics/Rendering/Diagrams/Points.hs +5/−1
• src/Graphics/Rendering/Diagrams/Style.hs +97/−29
• src/Graphics/Rendering/Diagrams/Transform.hs +14/−8

@@ -0,0 +1,12 @@+0.1: 17 May 2011+  * initial preview release++0.1.1: 18 May 2011+  * link to new website++0.2: 3 June 2011+  * bounding regions can now be overridden+  * new namePoint function for more flexibly assigning names to arbitrary points+  * add HasStyle, Boundable, and HasOrigin instances for lists+  * add a "trivial backend"+  * transformable attributes

@@ -1,5 +1,5 @@ Name:                diagrams-core-Version:             0.1.1+Version:             0.2 Synopsis:            Core libraries for diagrams EDSL Description:         The core modules underlying diagrams,                       an embedded domain-specific language @@ -12,6 +12,7 @@ Category:            Graphics Build-type:          Simple Cabal-version:       >=1.6+Extra-source-files:  CHANGES Tested-with:         GHC == 6.12.3, GHC >= 7.0.2 && <= 7.0.3 Source-repository head   type:     darcs@@ -35,6 +36,7 @@    Build-depends:       base >= 4.2 && < 4.4,                        containers >= 0.3 && < 0.5,+                       semigroups >= 0.3.4 && < 0.6,                        vector-space >= 0.7 && < 0.8,                        MemoTrie >= 0.4.7 && < 0.5 

@@ -65,11 +65,11 @@          -- * Attributes and styles         , AttributeClass-       , Attribute, mkAttr, unwrapAttr+       , Attribute, mkAttr, mkTAttr, unwrapAttr         , Style, HasStyle(..)-       , getAttr, setAttr, addAttr-       , applyAttr+       , getAttr, combineAttr+       , applyAttr, applyTAttr           -- * Bounding regions @@ -96,9 +96,9 @@        , prims        , bounds, names, query, sample -       , named, withName+       , named, namePoint, withName -       , freeze+       , freeze, setBounds         , atop 

@@ -132,21 +132,24 @@ instance (InnerSpace v, OrderedField (Scalar v)) => Boundable (Bounds v) where   getBounds = id +instance (Boundable b) => Boundable [b] where+  getBounds = mconcat . map getBounds+ ------------------------------------------------------------ --  Computing with bounds ------------------------------------------------------------  -- | Compute the point along the boundary in the given direction.-boundary :: Boundable a => (V a) -> a -> Point (V a)+boundary :: Boundable a => V a -> a -> Point (V a) boundary v a = P $ appBounds (getBounds a) v *^ v  -- | Compute the diameter of a boundable object along a particular --   vector.-diameter :: Boundable a => (V a) -> a -> Scalar (V a)+diameter :: Boundable a => V a -> a -> Scalar (V a) diameter v a = f v ^+^ f (negateV v)   where f = appBounds (getBounds a)  -- | Compute the radius (1\/2 the diameter) of a boundable object --   along a particular vector.-radius :: Boundable a => (V a) -> a -> Scalar (V a)+radius :: Boundable a => V a -> a -> Scalar (V a) radius v a = 0.5 * diameter v a

@@ -6,7 +6,7 @@            , ExistentialQuantification            , ScopedTypeVariables            , GeneralizedNewtypeDeriving-           , StandaloneDeriving+           , DeriveDataTypeable            , TypeOperators            , OverlappingInstances            , UndecidableInstances@@ -57,9 +57,14 @@        , atop           -- ** Modifying diagrams+         -- *** Names        , named+       , namePoint        , withName++         -- *** Other        , freeze+       , setBounds           -- * Primtives          -- $prim@@ -98,6 +103,8 @@ import Data.Monoid import Control.Arrow (second) +import Data.Typeable+ -- XXX TODO: add lots of actual diagrams to illustrate the -- documentation!  Haddock supports \<\<inline image urls\>\>. @@ -108,12 +115,16 @@ -- | Monoidal annotations which travel up the diagram tree, i.e. which --   are aggregated from component diagrams to the whole: -----   * functional bounding regions (see "Graphics.Rendering.Diagrams.Bounds")+--   * functional bounds (see "Graphics.Rendering.Diagrams.Bounds").+--     The bounds are \"forgetful\" meaning that at any point we can+--     throw away the existing bounds and replace them with new ones;+--     sometimes we want to consider a diagram as having different+--     bounds unrelated to its \"natural\" bounds. -- --   * name/point associations (see "Graphics.Rendering.Diagrams.Names") -- --   * query functions (see "Graphics.Rendering.Diagrams.Query")-type UpAnnots v m = Bounds v ::: NameMap v ::: Query v m ::: Nil+type UpAnnots v m = Forgetful (Bounds v) ::: NameMap v ::: Query v m ::: Nil  -- | Monoidal annotations which travel down the diagram tree, --   i.e. which accumulate along each path to a leaf (and which can@@ -125,17 +136,18 @@ --   * styles (see "Graphics.Rendering.Diagrams.Style") -- --   * names (see "Graphics.Rendering.Diagrams.Names")-type DownAnnots v = Split (Transformation v) ::: Style ::: AM [] Name ::: Nil+type DownAnnots v = (Split (Transformation v) :+: Style v) ::: AM [] Name ::: Nil  -- | The fundamental diagram type is represented by trees of --   primitives with various monoidal annotations. newtype AnnDiagram b v m   = AD { unAD :: UDTree (UpAnnots v m) (DownAnnots v) (Prim b v) }+  deriving (Typeable)  -- | Lift a function on annotated trees to a function on diagrams. inAD :: (UDTree (UpAnnots v m) (DownAnnots v) (Prim b v)          -> UDTree (UpAnnots v' m') (DownAnnots v') (Prim b' v'))-     -> (AnnDiagram b v m -> AnnDiagram b' v' m')+     -> AnnDiagram b v m -> AnnDiagram b' v' m' inAD f = AD . f . unAD  type instance V (AnnDiagram b v m) = v@@ -150,26 +162,37 @@ -- | Extract a list of primitives from a diagram, together with their --   associated transformations and styles. prims :: (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid m)-      => AnnDiagram b v m -> [(Prim b v, (Split (Transformation v), Style))]-prims = (map . second) (wibble . toTuple) . flatten . unAD-  where wibble (t,(s,_)) = (t,s)+      => AnnDiagram b v m -> [(Prim b v, (Split (Transformation v), Style v))]+prims = (map . second) (untangle . fst . toTuple) . flatten . unAD  -- | Get the bounds of a diagram. bounds :: (OrderedField (Scalar v), InnerSpace v, HasLinearMap v)        => AnnDiagram b v m -> Bounds v-bounds = getU' . unAD+bounds = unForget . getU' . unAD +-- | Replace the bounds of a diagram.+setBounds :: (OrderedField (Scalar v), InnerSpace v, HasLinearMap v, Monoid m)+          => Bounds v -> AnnDiagram b v m -> AnnDiagram b v m+setBounds = inAD . applyU . inj . Forgetful+ -- | Get the name map of a diagram. names :: HasLinearMap v => AnnDiagram b v m -> NameMap v names = getU' . unAD --- | Attach a name to a diagram.+-- | Attach a name to (the local origin of) a diagram. named :: forall v b n m.          ( IsName n          , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid m)       => n -> AnnDiagram b v m -> AnnDiagram b v m-named = inAD . applyU . inj . fromNames . (:[]) . (,origin :: Point v)+named = namePoint (const origin) +-- | Attach a name to the given point in this diagram.+namePoint :: forall v b n m.+         ( IsName n+         , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid m)+      => (AnnDiagram b v m -> Point v) -> n -> AnnDiagram b v m -> AnnDiagram b v m+namePoint p n d = inAD (applyU . inj $ fromNames [(n,p d)]) d+ -- | Given a name and a diagram transformation indexed by a point, --   perform the transformation using the first point associated with --   the name, or perform the identity transformation if the name does@@ -177,7 +200,7 @@ withName :: HasLinearMap v          => Name -> (Point v -> AnnDiagram b v m -> AnnDiagram b v m)          -> AnnDiagram b v m -> AnnDiagram b v m-withName n f d = maybe id f (lookupN n (names d) >>= listToMaybe) $ d+withName n f d = maybe id f (lookupN n (names d) >>= listToMaybe) d  -- | Get the query function associated with a diagram. query :: (HasLinearMap v, Monoid m) => AnnDiagram b v m -> Query v m@@ -190,7 +213,7 @@ -- | Create a diagram from a single primitive, along with a bounding --   region, name map, and query function. mkAD :: Prim b v -> Bounds v -> NameMap v -> Query v m -> AnnDiagram b v m-mkAD p b n a = AD $ leaf (b ::: n ::: a ::: Nil) p+mkAD p b n a = AD $ leaf (Normal b ::: n ::: a ::: Nil) p  ------------------------------------------------------------ --  Instances@@ -230,7 +253,7 @@ -- This is a bit ugly, but it will have to do for now... instance Functor (AnnDiagram b v) where   fmap f = inAD (mapU g)-    where g (b ::: n ::: a ::: Nil) = (b ::: n ::: fmap f a ::: Nil)+    where g (b ::: n ::: a ::: Nil) = b ::: n ::: fmap f a ::: Nil           g _ = error "impossible case in Functor (AnnDiagram b v) instance (g)"  ---- Applicative@@ -255,6 +278,7 @@ instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid m)       => HasStyle (AnnDiagram b v m) where   applyStyle = inAD . applyD . inj+             . (inR :: Style v -> Split (Transformation v) :+: Style v)  -- | By default, diagram attributes are not affected by --   transformations.  This means, for example, that @lw 0.01 circle@@@ -274,7 +298,9 @@ --   transformations. freeze :: forall v b m. (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid m)        => AnnDiagram b v m -> AnnDiagram b v m-freeze = inAD . applyD . inj $ (split :: Split (Transformation v))+freeze = inAD . applyD . inj+       . (inL :: Split (Transformation v) -> Split (Transformation v) :+: Style v)+       $ split  ---- Boundable @@ -297,7 +323,9 @@ --   components appropriately. instance (HasLinearMap v, OrderedField (Scalar v), InnerSpace v, Monoid m)       => Transformable (AnnDiagram b v m) where-  transform = inAD . applyD . inj . M+  transform = inAD . applyD . inj+            . (inL :: Split (Transformation v) -> Split (Transformation v) :+: Style v)+            . M  ---- Qualifiable @@ -378,7 +406,7 @@    -- | Perform a rendering operation with a local style.   withStyle      :: b          -- ^ Backend token (needed only for type inference)-                 -> Style      -- ^ Style to use+                 -> Style v    -- ^ Style to use                  -> Transformation v  -- ^ Transformation to be applied to the style                  -> Render b v -- ^ Rendering operation to run                  -> Render b v -- ^ Rendering operation using the style locally@@ -409,7 +437,7 @@             => b -> Options b v -> AnnDiagram b v m -> Result b v   renderDia b opts =     doRender b opts . mconcat . map renderOne . prims . adjustDia b opts-      where renderOne :: (Prim b v, (Split (Transformation v), Style))+      where renderOne :: (Prim b v, (Split (Transformation v), Style v))                       -> Render b v             renderOne (p, (M t,      s))               = withStyle b s mempty (render b (transform t p))@@ -418,6 +446,21 @@               = withStyle b s t1 (render b (transform (t1 <> t2) p))    -- See Note [backend token]++-- | The "trivial backend" which does nothing.  Useful for fixing the+--   type of diagrams whose rendering behavior we really don't care+--   about (e.g. diagrams we are just going to use for bounding other+--   diagrams, etc.)+instance HasLinearMap v => Backend () v where+  data Render  () v = UnitRender+  type Result  () v = ()+  data Options () v = UnitOptions+  withStyle _ _ _ _ = UnitRender+  doRender _ _ _    = ()++instance Monoid (Render () v) where+  mempty  = UnitRender+  mappend = const (const UnitRender)  -- | A class for backends which support rendering multiple diagrams, --   e.g. to a multi-page pdf or something similar.

@@ -48,7 +48,7 @@   moveOriginTo :: Point (V t) -> t -> t  -- | Move the local origin by a relative vector.-moveOriginBy :: HasOrigin t => (V t) -> t -> t+moveOriginBy :: HasOrigin t => V t -> t -> t moveOriginBy = moveOriginTo . P  -- | Translate the object by the translation that sends the origin to@@ -66,3 +66,6 @@  instance VectorSpace v => HasOrigin (Point v) where   moveOriginTo (P u) p = p .-^ u++instance HasOrigin a => HasOrigin [a] where+  moveOriginTo = map . moveOriginTo

@@ -1,6 +1,9 @@ {-# LANGUAGE MultiParamTypeClasses            , FlexibleInstances            , GeneralizedNewtypeDeriving+           , DeriveFunctor+           , TypeFamilies+           , TypeOperators   #-}  -----------------------------------------------------------------------------@@ -25,17 +28,30 @@         , Split(..), split +         -- * Forgetful monoids+         -- $forget++       , Forgetful(..), unForget, forget+          -- * Applicative monoids         , AM(..), inAM2 +         -- * Coproduct monoid+       , (:+:)+       , inL, inR+       , mappendL, mappendR+       , killL, killR+       , untangle        ) where +import Graphics.Rendering.Diagrams.V import Graphics.Rendering.Diagrams.Util  import Data.Monoid import Data.Foldable import Control.Applicative+import Data.Either (lefts, rights)  ------------------------------------------------------------ --  Monoid actions@@ -102,11 +118,56 @@  -- | By default, the action of a split monoid is the same as for --   the underlying monoid, as if the split were removed.-instance (Action m n) => Action (Split m) n where+instance Action m n => Action (Split m) n where   act (M m) n      = act m n   act (m1 :| m2) n = act m1 (act m2 n)  ------------------------------------------------------------+--  Forgetful monoids+------------------------------------------------------------++-- $forget+-- Sometimes we want to be able to "forget" some information.  In+-- particular, we can introduce special @Forgetful@ values which cause+-- anything to their right to be forgotten.++-- | A value of type @Forgetful m@ is either a \"normal\" value of+--   type @m@, which combines normally with other normal values, or a+--   \"forgetful\" value, which combines normally with other values to+--   its left but discards values combined on the right.  Also, when+--   combining a forgetful value with a normal one the result is+--   always forgetful.+data Forgetful m = Normal m+                 | Forgetful m+  deriving Functor++unForget :: Forgetful m -> m+unForget (Normal m)    = m+unForget (Forgetful m) = m++-- | If @m@ is a 'Monoid', then @Forgetful m@ is a monoid with two+--   sorts of values, \"normal\" and \"forgetful\": the normal ones+--   combine normally and the forgetful ones discard anything to the+--   right.+instance Monoid m => Monoid (Forgetful m) where+  mempty = Normal mempty++  (Normal m1)    `mappend` (Normal m2)    = Normal (m1 <> m2)+  (Normal m1)    `mappend` (Forgetful m2) = Forgetful (m1 <> m2)+  (Forgetful m1) `mappend` _              = Forgetful m1++-- | A convenient name for @Forgetful mempty@, so @a \<\> forget \<\>+--   b == Forgetful a@.+forget :: Monoid m => Forgetful m+forget = Forgetful mempty++instance Action m n => Action (Forgetful m) n where+  act (Normal m) n    = act m n+  act (Forgetful m) n = act m n++type instance V (Forgetful m) = V m++------------------------------------------------------------ --  Applicative monoids ------------------------------------------------------------ @@ -121,7 +182,7 @@   deriving (Functor, Applicative)  -- | Apply a binary function inside an 'AM' newtype wrapper.-inAM2 :: (f m -> f m -> f m) -> (AM f m -> AM f m -> AM f m)+inAM2 :: (f m -> f m -> f m) -> AM f m -> AM f m -> AM f m inAM2 g (AM f1) (AM f2) = AM (g f1 f2)  -- | @f1 ``mappend`` f2@ is defined as @'mappend' '<$>' f1 '<*>' f2@.@@ -217,7 +278,88 @@ --   having each element in the structure act on the value --   independently, and then folding the resulting structure. instance (Action m n, Foldable f, Functor f, Monoid n) => Action (AM f m) n where-  act (AM f) n = fold $ fmap (flip act n) f+  act (AM f) n = fold $ fmap (`act` n) f  -- XXX need to prove that this satisfies the laws!  There are other -- "obvious" instances too.++------------------------------------------------------------+-- Monoid coproduct+------------------------------------------------------------++-- | @m :+: n@ is the coproduct of monoids @m@ and @n@.  Values of+--   type @m :+: n@ consist of alternating lists of @m@ and @n@+--   values.  The empty list is the identity, and composition is list+--   concatenation, with appropriate combining of adjacent elements+--   when possible.+newtype m :+: n = MCo { unMCo :: [Either m n] }++-- For efficiency and simplicity, we implement it just as [Either m+-- n]: of course, this does not preserve the invariant of strictly+-- alternating types, but it doesn't really matter as long as we don't+-- let anyone inspect the internal representation.++-- | Injection from the left monoid into a coproduct.+inL :: m -> m :+: n+inL m = MCo [Left m]++-- | Injection from the right monoid into a coproduct.+inR :: n -> m :+: n+inR n = MCo [Right n]++-- | Prepend a value from the left monoid.+mappendL :: m -> m :+: n -> m :+: n+mappendL = mappend . inL++-- | Prepend a value from the right monoid.+mappendR :: n -> m :+: n -> m :+: n+mappendR = mappend . inR++{-+normalize :: (Monoid m, Monoid n) => m :+: n -> m :+: n+normalize (MCo es) = MCo (normalize' es)+  where normalize' []  = []+        normalize' [e] = [e]+        normalize' (Left e1:Left e2 : es) = normalize' (Left (e1 <> e2) : es)+        normalize' (Left e1:es) = Left e1 : normalize' es+        normalize' (Right e1:Right e2:es) = normalize' (Right (e1 <> e2) : es)+        normalize' (Right e1:es) = Right e1 : normalize' es+-}++-- | The coproduct of two monoids is itself a monoid.+instance Monoid (m :+: n) where+  mempty = MCo []+  (MCo es1) `mappend` (MCo es2) = MCo (es1 ++ es2)++-- | @killR@ takes a value in a coproduct monoid and sends all the+--   values from the right monoid to the identity.+killR :: Monoid m => m :+: n -> m+killR = mconcat . lefts . unMCo++-- | @killL@ takes a value in a coproduct monoid and sends all the+--   values from the left monoid to the identity.+killL :: Monoid n => m :+: n -> n+killL = mconcat . rights . unMCo++-- | Take a value from a coproduct monoid where the left monoid has an+--   action on the right, and \"untangle\" it into a pair of values.  In+--   particular,+--+-- > m1 <> n1 <> m2 <> n2 <> m3 <> n3 <> ...+--+--   is sent to+--+-- > (m1 <> m2 <> m3 <> ..., (act m1 n1) <> (act (m1 <> m2) n2) <> (act (m1 <> m2 <> m3) n3) <> ...)+--+--   That is, before combining @n@ values, every @n@ value is acted on+--   by all the @m@ values to its left.+untangle :: (Action m n, Monoid m, Monoid n) => m :+: n -> (m,n)+untangle (MCo elts) = untangle' mempty elts+  where untangle' cur [] = cur+        untangle' (curM, curN) (Left m : elts')  = untangle' (curM <> m, curN) elts'+        untangle' (curM, curN) (Right n : elts') = untangle' (curM, curN <> act curM n) elts'++-- | Coproducts act on other things by having each of the components+--   act individually.+instance (Action m r, Action n r) => Action (m :+: n) r where+  act = appEndo . mconcat . map Endo . map (either act act) . unMCo

@@ -177,4 +177,4 @@   where n' = toName n         (Name n1) `nameSuffixOf` (Name n2) = n1 `isSuffixOf` n2         flatten [] = Nothing-        flatten xs = Just . concat . map snd $ xs+        flatten xs = Just . concatMap snd $ xs

@@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies            , DeriveFunctor+           , DeriveDataTypeable   #-} ----------------------------------------------------------------------------- -- |@@ -24,6 +25,9 @@  import Graphics.Rendering.Diagrams.V +import Data.Data (Data)+import Data.Typeable (Typeable)+ ------------------------------------------------------------ --  Points  ------------------------------------------------ ------------------------------------------------------------@@ -34,7 +38,7 @@ --   unchanged.  Points are instances of the 'AffineSpace' class from --   "Data.AffineSpace". newtype Point v = P v-  deriving (Eq, Ord, Read, Show, Functor)+  deriving (Eq, Ord, Read, Show, Data, Typeable, Functor)  type instance V (Point v) = v 

@@ -3,6 +3,7 @@            , KindSignatures            , FlexibleInstances            , MultiParamTypeClasses+           , TypeFamilies   #-}  -----------------------------------------------------------------------------@@ -23,27 +24,32 @@           AttributeClass        , Attribute(..)-       , mkAttr, unwrapAttr-       , applyAttr+       , mkAttr, mkTAttr, unwrapAttr+       , applyAttr, applyTAttr           -- * Styles          -- $style         , Style(..)-       , attrToStyle-       , getAttr, setAttr, addAttr+       , attrToStyle, tAttrToStyle+       , getAttr, setAttr, addAttr, combineAttr         , HasStyle(..)         ) where +import Graphics.Rendering.Diagrams.V+import Graphics.Rendering.Diagrams.Transform import Graphics.Rendering.Diagrams.Monoids import Graphics.Rendering.Diagrams.Util  import Data.Typeable +-- import Control.Arrow ((***))  XXX import Data.Monoid import qualified Data.Map as M+import Data.Semigroup hiding ((<>))+import qualified Data.Semigroup as SG  ------------------------------------------------------------ --  Attributes  --------------------------------------------@@ -66,25 +72,54 @@ -- Haskell. <http://research.microsoft.com/apps/pubs/default.aspx?id=67968>.  -- | Every attribute must be an instance of @AttributeClass@, which---   simply guarantees a 'Typeable' constraint.-class Typeable a => AttributeClass a where+--   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 where --- | An existential wrapper type to hold attributes.-data Attribute :: * where-  Attribute :: AttributeClass a => a -> Attribute+-- | An existential wrapper type to hold attributes.  Some attributes+--   are affected by transformations and some are not.+data Attribute v :: * where+  Attribute  :: AttributeClass a => a -> Attribute v+  TAttribute :: (AttributeClass a, Transformable a, V a ~ v) => a -> Attribute v +type instance V (Attribute v) = v+ -- | Wrap up an attribute.-mkAttr :: AttributeClass a => a -> Attribute+mkAttr :: AttributeClass a => a -> Attribute v mkAttr = Attribute +-- | Wrap up a transformable attribute.+mkTAttr :: (AttributeClass a, Transformable a, V a ~ v) => a -> Attribute v+mkTAttr = TAttribute+ -- | 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.-unwrapAttr :: AttributeClass a => Attribute -> Maybe a-unwrapAttr (Attribute a) = cast a+unwrapAttr :: AttributeClass a => Attribute v -> Maybe a+unwrapAttr (Attribute a)  = cast a+unwrapAttr (TAttribute a) = cast a +-- | 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 Semigroup (Attribute v) where+  (Attribute a1) <> a2 =+    case unwrapAttr a2 of+      Nothing  -> a2+      Just a2' -> Attribute (a1 SG.<> a2')+  (TAttribute a1) <> a2 =+    case unwrapAttr a2 of+      Nothing  -> a2+      Just a2' -> TAttribute (a1 SG.<> a2')++instance HasLinearMap v => Transformable (Attribute v) where+  transform _ (Attribute  a) = Attribute a+  transform t (TAttribute a) = TAttribute (transform t a)+ ------------------------------------------------------------ --  Styles  ------------------------------------------------ ------------------------------------------------------------@@ -97,60 +132,93 @@  -- | A @Style@ is a heterogeneous collection of attributes, containing --   at most one attribute of any given type.-newtype Style = Style (M.Map String Attribute)+newtype Style v = Style (M.Map String (Attribute v))   -- The String keys are serialized TypeRep values, corresponding to   -- the type of the stored attribute. +type instance V (Style v) = v+ -- | Helper function for operating on styles.-inStyle :: (M.Map String Attribute -> M.Map String Attribute)-        -> Style -> Style+inStyle :: (M.Map String (Attribute v) -> M.Map String (Attribute v))+        -> Style v -> Style v inStyle f (Style s) = Style (f s)  -- | 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.-getAttr :: forall a. AttributeClass a => Style -> Maybe a+getAttr :: forall a v. AttributeClass a => Style v -> Maybe a getAttr (Style s) = M.lookup ty s >>= unwrapAttr-  where ty = (show . typeOf $ (undefined :: a))+  where ty = show . typeOf $ (undefined :: a)   -- the unwrapAttr should never fail, since we maintain the invariant   -- that attributes of type T are always stored with the key "T".  -- | Create a style from a single attribute.-attrToStyle :: forall a. AttributeClass a => a -> Style+attrToStyle :: forall a v. AttributeClass a => a -> Style v attrToStyle a = Style (M.singleton (show . typeOf $ (undefined :: a)) (mkAttr a)) +-- | Create a style from a single transformable attribute.+tAttrToStyle :: forall a v. (AttributeClass a, Transformable a, V a ~ v) => a -> Style v+tAttrToStyle a = Style (M.singleton (show . typeOf $ (undefined :: a)) (mkTAttr a))+ -- | Add a new attribute to a style, or replace the old attribute of --   the same type if one exists.-setAttr :: forall a. AttributeClass a => a -> Style -> Style+setAttr :: forall a v. AttributeClass a => a -> Style v -> Style v setAttr a = inStyle $ M.insert (show . typeOf $ (undefined :: a)) (mkAttr a)  -- | Attempt to add a new attribute to a style, but if an attribute of --   the same type already exists, do not replace it.-addAttr :: AttributeClass a => a -> Style -> Style+addAttr :: AttributeClass a => a -> Style v -> Style v addAttr a s = attrToStyle a <> s +-- | Add a new attribute to a style that does not already contain an+--   attribute of this type, or combine it on the left with an existing+--   attribute.+combineAttr :: AttributeClass a => a -> Style v -> Style v+combineAttr a s =+  case getAttr s of+    Nothing -> setAttr a s+    Just a' -> setAttr (a SG.<> a') s+ -- | The empty style contains no attributes; composition of styles is---   right-biased union; i.e. if the two styles contain attributes of---   the same type, the one from the right is taken.-instance Monoid Style where+--   a union of attributes; if the two styles have attributes of the+--   same type they are combined according to their semigroup+--   structure.+instance Monoid (Style v) where   mempty = Style M.empty-  (Style s1) `mappend` (Style s2) = Style $ s2 `M.union` s1+  (Style s1) `mappend` (Style s2) = Style $ M.unionWith (SG.<>) s1 s2 +instance HasLinearMap v => Transformable (Style v) where+  transform t = inStyle $ M.map (transform t)+ -- | Styles have no action on other monoids.-instance Action Style m+instance Action (Style v) m  -- | 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 -> a -> a+  applyStyle :: Style (V a) -> a -> a -instance HasStyle Style where+instance HasStyle (Style v) where   applyStyle = mappend +instance HasStyle a => HasStyle [a] where+  applyStyle = map . applyStyle++-- instance (HasStyle a, HasStyle b) => HasStyle (a,b) where+--   applyStyle s = applyStyle s *** applyStyle s+ -- | Apply an attribute to an instance of 'HasStyle' (such as a---   diagram or a style).  @applyAttr@ has no effect if an attribute of---   the same type already exists.+--   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 = applyStyle . attrToStyle +-- | 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, HasStyle d) => a -> d -> d+applyTAttr = applyStyle . tAttrToStyle

@@ -88,11 +88,11 @@ --   monoid under composition. instance HasLinearMap v => Monoid (v :-: v) where   mempty = idL :-: idL-  (f :-: f') `mappend` (g :-: g') = (f *.* g :-: g' *.* f')+  (f :-: f') `mappend` (g :-: g') = f *.* g :-: g' *.* f'  -- | Invert a linear map. linv :: (u :-: v) -> (v :-: u)-linv (f :-: g) = (g :-: f)+linv (f :-: g) = g :-: f  -- | Apply a linear map to a vector. lapp :: (VectorSpace v, Scalar u ~ Scalar v, HasLinearMap u) => (u :-: v) -> u -> v@@ -150,7 +150,7 @@ fromLinear l1 l2 = Transformation l1 l2 zeroV  ---------------------------------------------------------------  The Transformable class  -----------------------------+--  The Transformable class  ------------------------------- ------------------------------------------------------------  -- | 'HasLinearMap' is a poor man's class constraint synonym, just to@@ -165,20 +165,26 @@   transform :: Transformation (V t) -> t -> t  instance Transformable t => Transformable [t] where-  transform t = map (transform t)+  transform = map . transform  instance (Transformable t, Ord t) => Transformable (S.Set t) where-  transform t = S.map (transform t)+  transform = S.map . transform  instance Transformable t => Transformable (M.Map k t) where-  transform t = M.map (transform t)+  transform = M.map . transform  instance HasLinearMap v => Transformable (NameMap v) where   transform t (NameMap ns) = NameMap $ M.map (map (papply t)) ns - instance HasLinearMap v => Transformable (Point v) where-  transform t p = papply t p+  transform = papply++instance Transformable m => Transformable (Forgetful m) where+  transform = fmap . transform++------------------------------------------------------------+--  Generic transformations  -------------------------------+------------------------------------------------------------  -- | Create a translation. translation :: HasLinearMap v => v -> Transformation v