Manual merge of fix point and linear/new-stuff

diagrams-core.cabal

@@ -23,6 +23,7 @@ Source-repository head
 Library
   Exposed-modules:     Diagrams.Core,
                        Diagrams.Core.Compile,
+                       Diagrams.Core.Context,
                        Diagrams.Core.Envelope,
                        Diagrams.Core.HasOrigin,
                        Diagrams.Core.Juxtapose,

src/Diagrams/Core.hs

@@ -142,7 +142,6 @@ module Diagrams.Core
 
        , SubMap(..)
        , fromNames
-       , rememberAs
 
        , lookupSub
 
@@ -181,7 +180,7 @@ module Diagrams.Core
 
          -- * Juxtaposable things
 
-       , Juxtaposable(..), juxtaposeDefault
+       , Juxtaposable(..), juxtaposeDefault, juxtaposeContextual
 
          -- * Queries
 
@@ -194,15 +193,9 @@ module Diagrams.Core
          -- * Diagrams
 
        , QDiagram, Diagram, mkQD, pointDiagram
-       , envelope, trace, subMap, names, query, sample
+       , envelope, trace, query, sample
        , value, resetValue, clearValue
 
-       , nameSub
-       , withName
-       , withNameAll
-       , withNames
-       , localize
-
        , href
        , opacityGroup
        , groupOpacity
@@ -214,8 +207,6 @@ module Diagrams.Core
          -- ** Subdiagrams
 
        , Subdiagram(..), mkSubdiagram
-       , getSub, rawSub
-       , location
        , subPoint
 
          -- ** Measurements

src/Diagrams/Core/Compile.hs

@@ -20,17 +20,11 @@ module Diagrams.Core.Compile
   ( -- * Tools for backends
     RNode(..)
   , RTree
-  , toRTree
 
     -- * Backend API
 
   , renderDia
   , renderDiaT
-
-    -- * Internals
-
-  , toDTree
-  , fromDTree
   )
   where
 
@@ -42,108 +36,20 @@ import           Data.Monoid.MList
 import           Data.Monoid.WithSemigroup (Monoid')
 import           Data.Semigroup
 import           Data.Tree
-import           Data.Tree.DUAL
 
+import           Diagrams.Core.Context
 import           Diagrams.Core.Envelope    (OrderedField, diameter)
 import           Diagrams.Core.Transform
 import           Diagrams.Core.Types
 import           Diagrams.Core.Style
 
 import           Linear.Metric hiding (qd)
 
--- Typeable1 is a depreciated synonym in ghc > 707
-#if __GLASGOW_HASKELL__ >= 707
-#define Typeable1 Typeable
-#endif
-
-emptyDTree :: Tree (DNode b v n a)
-emptyDTree = Node DEmpty []
-
-uncurry3 :: (a -> b -> c -> r) -> (a, b, c) -> r
-uncurry3 f (x, y, z) = f x y z
-
--- | Convert a @QDiagram@ into a raw tree.
-toDTree :: (HasLinearMap v, Floating n, Typeable n)
-        => n -> n -> QDiagram b v n m -> Maybe (DTree b v n Annotation)
-toDTree g n (QD qd)
-  = foldDUAL
-
-      -- Prims at the leaves.  We ignore the accumulated d-annotations
-      -- for prims (since we instead distribute them incrementally
-      -- throughout the tree as they occur), or pass them to the
-      -- continuation in the case of a delayed node.
-      (\d -> withQDiaLeaf
-
-               -- Prim: make a leaf node
-               (\p -> Node (DPrim p) [])
-
-               -- Delayed tree: pass the accumulated d-annotations to
-               -- the continuation, convert the result to a DTree, and
-               -- splice it in, adding a DDelay node to mark the point
-               -- of the splice.
-               (Node DDelay . (:[]) . fromMaybe emptyDTree . toDTree g n . ($ (d, g, n)) . uncurry3)
-      )
-
-      -- u-only leaves --> empty DTree. We don't care about the
-      -- u-annotations.
-      emptyDTree
-
-      -- a non-empty list of child trees.
-      (\ts -> case NEL.toList ts of
-                [t] -> t
-                ts' -> Node DEmpty ts'
-      )
-
-      -- Internal d-annotations.  We untangle the interleaved
-      -- transformations and style, and carefully place the style
-      -- /above/ the transform in the tree (since by calling
-      -- 'untangle' we have already performed the action of the
-      -- transform on the style).
-      (\d t -> case get d of
-                 Option Nothing   -> t
-                 Option (Just d') ->
-                   let (tr,sty) = untangle d'
-                   in  Node (DStyle sty) [Node (DTransform tr) [t]]
-      )
-
-      -- Internal a-annotations.
-      (\a t -> Node (DAnnot a) [t])
-      qd
-
--- | Convert a @DTree@ to an @RTree@ which can be used dirctly by backends.
---   A @DTree@ includes nodes of type @DTransform (Transformation v)@;
---   in the @RTree@ transform is pushed down until it reaches a primitive node.
-fromDTree :: forall b v n. (Floating n, HasLinearMap v)
-          => DTree b v n Annotation -> RTree b v n Annotation
-fromDTree = fromDTree' mempty
-  where
-    fromDTree' :: HasLinearMap v => Transformation v n -> DTree b v n Annotation -> RTree b v n Annotation
-    -- We put the accumulated transformation (accTr) and the prim
-    -- into an RPrim node.
-    fromDTree' accTr (Node (DPrim p) _)
-      = Node (RPrim (transform accTr p)) []
-
-    -- Styles are transformed then stored in their own node
-    -- and accTr is push down the tree.
-    fromDTree' accTr (Node (DStyle s) ts)
-      = Node (RStyle (transform accTr s)) (fmap (fromDTree' accTr) ts)
-
-    -- Transformations are accumulated and pushed down as well.
-    fromDTree' accTr (Node (DTransform tr) ts)
-      = Node REmpty (fmap (fromDTree' (accTr <> tr)) ts)
-
-    fromDTree' accTr (Node (DAnnot a) ts)
-      = Node (RAnnot a) (fmap (fromDTree' accTr) ts)
-
-    -- Drop accumulated transformations upon encountering a DDelay
-    -- node --- the tree unfolded beneath it already took into account
-    -- any transformation at this point.
-    fromDTree' _ (Node DDelay ts)
-      = Node REmpty (fmap (fromDTree' mempty) ts)
-
-    -- DEmpty nodes become REmpties, again accTr flows through.
-    fromDTree' accTr (Node _ ts)
-      = Node REmpty (fmap (fromDTree' accTr) ts)
+-- | Apply a style transformation on 'RStyle' nodes; the identity for
+--   other 'RNode's.
+onRStyle :: (Style v n -> Style v n) -> RNode b v n a -> RNode b v n a
+onRStyle f (RStyle s) = RStyle (f s)
+onRStyle _ n          = n
 
 -- | Compile a @QDiagram@ into an 'RTree', rewriting styles with the
 --   given function along the way.  Suitable for use by backends when
@@ -154,26 +60,9 @@ toRTree
   :: (HasLinearMap v, Metric v, Typeable1 v, Typeable n,
       OrderedField n, Monoid m, Semigroup m)
   => Transformation v n -> QDiagram b v n m -> RTree b v n Annotation
-toRTree globalToOutput d
-  = (fmap . onRStyle) (unmeasureAttrs gToO nToO)
-  . fromDTree
-  . fromMaybe (Node DEmpty [])
-  . toDTree gToO nToO
-  $ d
-  where
-    gToO = avgScale globalToOutput
-
-    -- Scaling factor from normalized units to output units: nth root
-    -- of product of diameters along each basis direction.  Note at
-    -- this point the diagram has already had the globalToOutput
-    -- transformation applied, so output = global = local units.
-    nToO = product (map (`diameter` d) basis) ** (1 / fromIntegral (dimension d))
 
--- | Apply a style transformation on 'RStyle' nodes; the identity for
---   other 'RNode's.
-onRStyle :: (Style v n -> Style v n) -> RNode b v n a -> RNode b v n a
-onRStyle f (RStyle s) = RStyle (f s)
-onRStyle _ n          = n
+-- XXX Of course we need a real 'Context' and to iterate the diagram.
+toRTree globalToOutput (QD d) = fst $ runContextual d empty
 
 --------------------------------------------------
 
@@ -195,4 +84,3 @@ renderDia
       Typeable n, OrderedField n, Monoid' m)
   => b -> Options b v n -> QDiagram b v n m -> Result b v n
 renderDia b opts d = snd (renderDiaT b opts d)
-

src/Diagrams/Core/Context.hs

@@ -0,0 +1,81 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeOperators              #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Diagrams.Core.Context
+-- Copyright   :  (c) 2014 diagrams-core team (see LICENSE)
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  [email protected]
+--
+-- XXX comment me
+--
+-----------------------------------------------------------------------------
+
+module Diagrams.Core.Context
+  ( Context
+  , Contextual (..)
+  , contextual
+  , runContextual
+  )
+  where
+
+import           Diagrams.Core.Names
+import           Diagrams.Core.Style
+import           Diagrams.Core.Transform
+import           Diagrams.Core.V
+
+import           Control.Applicative
+import           Control.Lens            (Rewrapped, Wrapped (..), iso, over,
+                                          view)
+import           Control.Monad.Reader
+import           Data.Monoid.MList
+import           Data.Semigroup
+
+-- | The (monoidal) context in which a diagram is interpreted.
+--   Contexts can be thought of as accumulating along each path to a
+--   leaf:
+--
+--   * styles (see "Diagrams.Core.Style")
+--
+--   * names (see "Diagrams.Core.Names")
+type Context v n = Style v n
+               ::: Name
+               ::: (n, n) -- ^ global to output, normalized to output.
+               ::: ()
+
+--------------------------------------------------
+-- Context monad
+
+newtype Contextual v n a = Contextual (Reader (Context v n) a)
+  deriving (Functor, Applicative, Monad, MonadReader (Context v n))
+
+instance Wrapped (Contextual v n a) where
+  type Unwrapped (Contextual v n a) = Context v n -> a
+  _Wrapped' = iso (\(Contextual r) -> runReader r) (Contextual . reader)
+
+-- | Smart constructor for 'Contextual' values.
+--
+--   Note @contextual = review _Wrapped'@.
+contextual :: (Context v n -> a) -> Contextual v n a
+contextual = Contextual . reader
+
+runContextual :: Contextual v n a -> (Context v n -> a)
+runContextual = view _Wrapped'
+
+instance Rewrapped (Contextual v n a) (Contextual v' n' a')
+
+type instance V (Contextual v n a) = V a
+type instance N (Contextual v n a) = N a
+
+instance Semigroup a => Semigroup (Contextual v n a) where
+  Contextual r1 <> Contextual r2 = Contextual . reader $ \ctx -> runReader r1 ctx <> runReader r2 ctx
+
+instance (Semigroup a, Monoid a) => Monoid (Contextual v n a) where
+  mappend = (<>)
+  mempty  = Contextual . reader $ const mempty
+
+instance Transformable a => Transformable (Contextual v n a) where
+  transform = over _Wrapped' . fmap . transform
+