Merge pull request #82 from diagrams/pre-1.3

Show & Representable instances; rename |> to .>>

src/Diagrams/Core/Measure.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE DeriveFunctor              #-}
-{-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies               #-}
 module Diagrams.Core.Measure
   ( Measured (..)
   , Measure
@@ -20,20 +20,28 @@ import           Control.Applicative
 import           Control.Lens
 import qualified Control.Monad.Reader as R
 import           Data.Distributive
-import           Data.Typeable
+import           Data.Functor.Rep
 import           Data.Semigroup
+import           Data.Typeable
 
-import Diagrams.Core.V
+import           Diagrams.Core.V
 
 import           Linear.Vector
 
--- (local, global, normalized) -> output
+-- | 'Measured n a' is an object that depends on 'local', 'normalized'
+--   and 'global' scales. The 'normalized' and 'global' scales are
+--   calculated when rendering a diagram.
+--
+--   For attributes, the 'local' scale gets multiplied by the average
+--   scale of the transform.
 newtype Measured n a = Measured { unmeasure :: (n,n,n) -> a }
   deriving (Typeable, Functor, Applicative, Monad, Additive, R.MonadReader (n,n,n))
+-- (local, global, normalized) -> output
 
 type instance V (Measured n a) = V a
 type instance N (Measured n a) = N a
 
+-- | A measure is a 'Measured' number.
 type Measure n = Measured n n
 
 -- | @fromMeasured globalScale normalizedScale measure -> a@
@@ -52,7 +60,7 @@ local x = views _1 (*x)
 global :: Num n => n -> Measure n
 global x = views _2 (*x)
 
--- | Normalized units get scaled so that one normalized unit is the size of the 
+-- | Normalized units get scaled so that one normalized unit is the size of the
 --   final diagram.
 normalized :: Num n => n -> Measure n
 normalized x = views _3 (*x)
@@ -115,10 +123,14 @@ instance Monoid a => Monoid (Measured n a) where
   mempty  = pure mempty
   mappend = liftA2 mappend
 
-
 instance Distributive (Measured n) where
   distribute a = Measured $ \x -> fmap (\(Measured m) -> m x) a
 
+instance Representable (Measured n) where
+  type Rep (Measured n) = (n,n,n)
+  tabulate = Measured
+  index    = unmeasure
+
 instance Profunctor Measured where
   lmap f (Measured m) = Measured $ \(l,g,n) -> m (f l, f g, f n)
   rmap f (Measured m) = Measured $ f . m

src/Diagrams/Core/Names.hs

@@ -9,7 +9,7 @@
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Diagrams.Core.Names
--- Copyright   :  (c) 2011 diagrams-core team (see LICENSE)
+-- Copyright   :  (c) 2011-2015 diagrams-core team (see LICENSE)
 -- License     :  BSD-style (see LICENSE)
 -- Maintainer  :  diagrams-discuss@googlegroups.com
 --
@@ -19,20 +19,20 @@
 -----------------------------------------------------------------------------
 
 module Diagrams.Core.Names
-       (-- * Names
-        -- ** Atomic names
-         AName(..)
+  (-- * Names
+   -- ** Atomic names
+    AName(..)
+  , _AName
 
-        -- ** Names
-       , Name(..), IsName(..), (.>)
+   -- ** Names
+  , Name(..), IsName(..), (.>)
 
-        -- ** Qualifiable
-       , Qualifiable(..)
+   -- ** Qualifiable
+  , Qualifiable(..)
 
-       ) where
+  ) where
 
-import           Control.Lens            (over, Wrapped(..), Rewrapped, iso, _Unwrapping')
-import           Data.List               (intercalate)
+import           Control.Lens            hiding ((.>))
 import qualified Data.Map                as M
 import           Data.Semigroup
 import qualified Data.Set                as S
@@ -81,6 +81,7 @@ instance IsName Float
 instance IsName Double
 instance IsName Integer
 instance IsName a => IsName [a]
+instance IsName a => IsName (Maybe a)
 instance (IsName a, IsName b) => IsName (a,b)
 instance (IsName a, IsName b, IsName c) => IsName (a,b,c)
 
@@ -106,20 +107,31 @@ instance Ord AName where
       Nothing  -> typeOf a1 `compare` typeOf a2
 
 instance Show AName where
-  show (AName a) = show a
+  showsPrec d (AName a) = showParen (d > 10) $
+    showString "AName " . showsPrec 11 a
+
+-- | Prism onto 'AName'.
+_AName :: (Typeable a, Ord a, Show a) => Prism' AName a
+_AName = prism' AName (\(AName a) -> cast a)
 
 -- | A (qualified) name is a (possibly empty) sequence of atomic names.
 newtype Name = Name [AName]
   deriving (Eq, Ord, Semigroup, Monoid, Typeable)
 
+instance Rewrapped Name Name
 instance Wrapped Name where
   type Unwrapped Name = [AName]
-  _Wrapped' = iso (\(Name ans) -> ans) Name
-
-instance Rewrapped Name Name
+  _Wrapped' = iso (\(Name ns) -> ns) Name
 
 instance Show Name where
-  show (Name ns) = intercalate " .> " $ map show ns
+  showsPrec d (Name xs) = case xs of
+    []     -> showParen (d > 10) $ showString "Name []"
+    [n]    -> showParen (d > 10) $ showString "toName " . showsName 11 n
+    (n:ns) -> showParen (d > 5)  $ showsName 6 n . go ns
+      where
+        go (y:ys) = showString " .> " . showsName 6 y . go ys
+        go _      = id
+    where showsName dd (AName a) = showsPrec dd a
 
 instance IsName Name where
   toName = id
@@ -134,35 +146,35 @@ a1 .> a2 = toName a1 <> toName a2
 --   prefixing them with a name.
 class Qualifiable q where
   -- | Qualify with the given name.
-  (|>) :: IsName a => a -> q -> q
+  (.>>) :: IsName a => a -> q -> q
 
 -- | Of course, names can be qualified using @(.>)@.
 instance Qualifiable Name where
-  (|>) = (.>)
+  (.>>) = (.>)
 
 instance Qualifiable a => Qualifiable (TransInv a) where
-  (|>) n = over (_Unwrapping' TransInv) (n |>)
+  (.>>) n = over (_Unwrapping' TransInv) (n .>>)
 
 instance (Qualifiable a, Qualifiable b) => Qualifiable (a,b) where
-  n |> (a,b) = (n |> a, n |> b)
+  n .>> (a,b) = (n .>> a, n .>> b)
 
 instance (Qualifiable a, Qualifiable b, Qualifiable c) => Qualifiable (a,b,c) where
-  n |> (a,b,c) = (n |> a, n |> b, n |> c)
+  n .>> (a,b,c) = (n .>> a, n .>> b, n .>> c)
 
 instance Qualifiable a => Qualifiable [a] where
-  n |> as = map (n |>) as
+  n .>> as = map (n .>>) as
 
 instance (Ord a, Qualifiable a) => Qualifiable (S.Set a) where
-  n |> s = S.map (n |>) s
+  n .>> s = S.map (n .>>) s
 
 instance Qualifiable a => Qualifiable (M.Map k a) where
-  n |> m = fmap (n |>) m
+  n .>> m = fmap (n .>>) m
 
 instance Qualifiable a => Qualifiable (b -> a) where
- n |> f = (n |>) . f
+  n .>> f = (n .>>) . f
 
 instance Qualifiable a => Qualifiable (Measured n a) where
- n |> m = fmap (n |>) m
+  n .>> m = fmap (n .>>) m
 
-infixr 5 |>
+infixr 5 .>>
 infixr 5 .>

src/Diagrams/Core/Style.hs

@@ -113,9 +113,9 @@ class (Typeable a, Semigroup a) => AttributeClass a
 --   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
+  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
@@ -136,7 +136,15 @@ instance Typeable n => Semigroup (Attribute v n) where
 instance (Additive v, Traversable v, Floating n) => Transformable (Attribute v n) where
   transform _ (Attribute a)  = Attribute a
   transform t (MAttribute a) = MAttribute $ scaleLocal (avgScale t) a
-  transform t (TAttribute a) = TAttribute (transform t a)
+  transform t (TAttribute a) = TAttribute $ transform t a
+
+-- | Shows the kind of attribute and the type contained in the
+--   attribute.
+instance Typeable n => Show (Attribute v n) where
+  showsPrec d attr = showParen (d > 10) $ case attr of
+    Attribute a  -> showString "Attribute "  . showsPrec 11 (typeOf a)
+    MAttribute a -> showString "MAttribute " . showsPrec 11 (mType a)
+    TAttribute a -> showString "TAttribute " . showsPrec 11 (typeOf a)
 
 -- | Unwrap an unknown 'Attribute' type, performing a dynamic (but
 --   safe) check on the type of the result. If the required type
@@ -249,6 +257,11 @@ instance (Additive v, Traversable v, Floating n) => Transformable (Style v n) wh
 -- | Styles have no action on other monoids.
 instance A.Action (Style v n) m
 
+-- | Show the attributes in the style.
+instance Typeable n => Show (Style v n) where
+  showsPrec d sty = showParen (d > 10) $
+    showString "Style " . showsPrec d (sty ^.. each)
+
 -- making styles -------------------------------------------------------
 
 -- | Turn an attribute into a style. An easier way to make a style is to
@@ -283,29 +296,30 @@ unmeasureAttrs g n = over each (unmeasureAttribute g n)
 -- style lenses --------------------------------------------------------
 
 mkAttrLens :: forall v n a. Typeable a
-           => Prism' (Attribute v n) a
+           => (a -> TypeRep)
+           -> Prism' (Attribute v n) a
            -> Lens' (Style v n) (Maybe a)
-mkAttrLens p f sty =
+mkAttrLens tyF p f sty =
   f (sty ^? ix ty . p) <&> \mAtt -> sty & at ty .~ (review p <$> mAtt)
-  where ty = typeOf (undefined :: a)
+  where ty = tyF (undefined :: a)
 {-# INLINE mkAttrLens #-}
 
 -- | Lens onto a plain attribute of a style.
 atAttr :: AttributeClass a
        => Lens' (Style v n) (Maybe a)
-atAttr = mkAttrLens _Attribute
+atAttr = mkAttrLens typeOf _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 = mkAttrLens _MAttribute
+atMAttr = mkAttrLens mType _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 = mkAttrLens _TAttribute
+atTAttr = mkAttrLens typeOf _TAttribute
 {-# INLINE atTAttr #-}
 
 -- applying styles -----------------------------------------------------

src/Diagrams/Core/Transform.hs

@@ -87,7 +87,6 @@ import           Data.Functor.Rep
 
 import           Diagrams.Core.HasOrigin
 import           Diagrams.Core.Points ()
-import           Diagrams.Core.Measure
 import           Diagrams.Core.V
 
 ------------------------------------------------------------
@@ -351,9 +350,6 @@ instance ( V t ~ v, N t ~ n, V t ~ V s, N t ~ N s, Functor v, Num n
          => Transformable (s -> t) where
   transform tr f = transform tr . f . transform (inv tr)
 
-instance Transformable t => Transformable (Measured n t) where
-  transform = fmap . transform
-
 instance Transformable t => Transformable [t] where
   transform = map . transform
 
@@ -418,3 +414,4 @@ scale :: (InSpace v n a, Eq n, Fractional n, Transformable a)
       => n -> a -> a
 scale 0 = error "scale by zero!  Halp!"  -- XXX what should be done here?
 scale s = transform $ scaling s
+

src/Diagrams/Core/Types.hs

@@ -1,17 +1,17 @@
-{-# LANGUAGE CPP                        #-}
-{-# LANGUAGE DeriveDataTypeable         #-}
-{-# LANGUAGE DeriveFunctor              #-}
-{-# LANGUAGE EmptyDataDecls             #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE GADTs                      #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE TupleSections              #-}
-{-# LANGUAGE LambdaCase              #-}
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE TypeOperators              #-}
-{-# LANGUAGE UndecidableInstances       #-}
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE DeriveDataTypeable    #-}
+{-# LANGUAGE DeriveFunctor         #-}
+{-# LANGUAGE EmptyDataDecls        #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TupleSections         #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE UndecidableInstances  #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans       #-}
 -- We have some orphan Action instances here, but since Action is a multi-param
@@ -131,16 +131,18 @@ module Diagrams.Core.Types
        ) where
 
 import           Control.Arrow             (first, second, (***))
-import           Control.Lens              (Lens', Rewrapped, Wrapped (..), iso, lens, over, view,
-                                            (^.), _Wrapped, _Wrapping, Prism', prism')
+import           Control.Lens              (Lens', Prism', Rewrapped,
+                                            Wrapped (..), iso, lens, over,
+                                            prism', view, (^.), _Wrapped,
+                                            _Wrapping)
 import           Control.Monad             (mplus)
-import           Data.Typeable
 import           Data.List                 (isSuffixOf)
 import qualified Data.Map                  as M
 import           Data.Maybe                (fromMaybe, listToMaybe)
 import           Data.Semigroup
 import qualified Data.Traversable          as T
 import           Data.Tree
+import           Data.Typeable
 
 import           Data.Monoid.Action
 import           Data.Monoid.Coproduct
@@ -598,7 +600,7 @@ instance (OrderedField n, Metric v, Semigroup m)
 --   now be referred to using the qualification prefix.
 instance (Metric v, OrderedField n, Semigroup m)
       => Qualifiable (QDiagram b v n m) where
-  (|>) = over _Wrapped' . D.applyD . inj . toName
+  (.>>) = over _Wrapped' . D.applyD . inj . toName
 
 
 ------------------------------------------------------------
@@ -722,7 +724,7 @@ instance (Metric v, Floating n)
 --   ns@ is the same 'SubMap' except with every name qualified by
 --   @a@.
 instance Qualifiable (SubMap b v n m) where
-  a |> (SubMap m) = SubMap $ M.mapKeys (a |>) m
+  a .>> (SubMap m) = SubMap $ M.mapKeys (a .>>) m
 
 -- | Construct a 'SubMap' from a list of associations between names
 --   and subdiagrams.
@@ -735,7 +737,7 @@ rememberAs n b = over _Wrapped' $ M.insertWith (++) (toName n) [mkSubdiagram b]
 
 -- | A name acts on a name map by qualifying every name in it.
 instance Action Name (SubMap b v n m) where
-  act = (|>)
+  act = (.>>)
 
 instance Action Name a => Action Name (Deletable a) where
   act n (Deletable l a r) = Deletable l (act n a) r