{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# 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 -- class there is really no better place to put them. ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Types -- Copyright : (c) 2011-2013 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- The core library of primitives forming the basis of an embedded -- domain-specific language for describing and rendering diagrams. -- -- "Diagrams.Core.Types" defines types and classes for -- primitives, diagrams, and backends. -- ----------------------------------------------------------------------------- {- ~~~~ Note [breaking up Types module] Although it's not as bad as it used to be, this module has a lot of stuff in it, and it might seem a good idea in principle to break it up into smaller modules. However, it's not as easy as it sounds: everything in this module cyclically depends on everything else. -} module Diagrams.Core.Types ( -- * Diagrams -- ** Annotations -- *** Static annotations Annotation(Href) , applyAnnotation, href -- *** Dynamic (monoidal) annotations , UpAnnots, DownAnnots, transfToAnnot, transfFromAnnot -- ** Basic type definitions , QDiaLeaf(..), withQDiaLeaf , QDiagram(..), Diagram -- * Operations on diagrams -- ** Creating diagrams , mkQD, mkQD', pointDiagram -- ** Extracting information , prims , envelope, trace, subMap, names, query, sample , value, resetValue, clearValue -- ** Combining diagrams -- | For many more ways of combining diagrams, see -- "Diagrams.Combinators" from the diagrams-lib package. , atop -- ** Modifying diagrams -- *** Names , nameSub , lookupName , withName , withNameAll , withNames , localize -- *** Other , freeze , setEnvelope , setTrace -- * Subdiagrams , Subdiagram(..), mkSubdiagram , getSub, rawSub , location , subPoint -- * Subdiagram maps , SubMap(..) , fromNames, rememberAs, lookupSub -- * Primtives -- $prim , Prim(..), IsPrim(..), nullPrim -- * Backends , Backend(..) , MultiBackend(..) , DNode(..) , DTree , RNode(..) , RTree -- ** Null backend , NullBackend, D -- * Renderable , Renderable(..) ) where import Control.Arrow (first, second, (***)) import Control.Lens (Lens', Rewrapped, Wrapped (..), iso, lens, over, view, (^.), _Wrapped, _Wrapping) import Control.Monad (mplus) import Data.AffineSpace ((.-.)) 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.VectorSpace import Data.Monoid.Action import Data.Monoid.Coproduct import Data.Monoid.Deletable import Data.Monoid.MList import Data.Monoid.Split import Data.Monoid.WithSemigroup import qualified Data.Tree.DUAL as D import Diagrams.Core.Envelope import Diagrams.Core.HasOrigin import Diagrams.Core.Juxtapose import Diagrams.Core.Names import Diagrams.Core.Points import Diagrams.Core.Query import Diagrams.Core.Style import Diagrams.Core.Trace import Diagrams.Core.Transform import Diagrams.Core.V -- XXX TODO: add lots of actual diagrams to illustrate the -- documentation! Haddock supports \<\<inline image urls\>\>. ------------------------------------------------------------ -- Diagrams ---------------------------------------------- ------------------------------------------------------------ -- | Monoidal annotations which travel up the diagram tree, /i.e./ which -- are aggregated from component diagrams to the whole: -- -- * envelopes (see "Diagrams.Core.Envelope"). -- The envelopes are \"deletable\" meaning that at any point we can -- throw away the existing envelope and replace it with a new one; -- sometimes we want to consider a diagram as having a different -- envelope unrelated to its \"natural\" envelope. -- -- * traces (see "Diagrams.Core.Trace"), also -- deletable. -- -- * name/subdiagram associations (see "Diagrams.Core.Names") -- -- * query functions (see "Diagrams.Core.Query") type UpAnnots b v m = Deletable (Envelope v) ::: Deletable (Trace v) ::: Deletable (SubMap b v m) ::: Query v m ::: () -- | Monoidal annotations which travel down the diagram tree, -- /i.e./ which accumulate along each path to a leaf (and which can -- act on the upwards-travelling annotations): -- -- * transformations (split at the innermost freeze): see -- "Diagrams.Core.Transform" -- -- * styles (see "Diagrams.Core.Style") -- -- * names (see "Diagrams.Core.Names") type DownAnnots v = (Split (Transformation v) :+: Style v) ::: Name ::: () -- Note that we have to put the transformations and styles together -- using a coproduct because the transformations can act on the -- styles. -- | Inject a transformation into a default downwards annotation -- value. transfToAnnot :: Transformation v -> DownAnnots v transfToAnnot = inj . (inL :: Split (Transformation v) -> Split (Transformation v) :+: Style v) . M -- | Extract the (total) transformation from a downwards annotation -- value. transfFromAnnot :: HasLinearMap v => DownAnnots v -> Transformation v transfFromAnnot = option mempty (unsplit . killR) . fst -- | A leaf in a 'QDiagram' tree is either a 'Prim', or a \"delayed\" -- @QDiagram@ which expands to a real @QDiagram@ once it learns the -- \"final context\" in which it will be rendered. For example, in -- order to decide how to draw an arrow, we must know the precise -- transformation applied to it (since the arrow head and tail are -- scale-invariant). data QDiaLeaf b v m = PrimLeaf (Prim b v) | DelayedLeaf (DownAnnots v -> QDiagram b v m) -- ^ The @QDiagram@ produced by a @DelayedLeaf@ function /must/ -- already apply any non-frozen transformation in the given -- @DownAnnots@ (that is, the non-frozen transformation will not -- be applied by the context). On the other hand, it must assume -- that any frozen transformation or attributes will be applied -- by the context. deriving (Functor) withQDiaLeaf :: (Prim b v -> r) -> ((DownAnnots v -> QDiagram b v m) -> r) -> (QDiaLeaf b v m -> r) withQDiaLeaf f _ (PrimLeaf p) = f p withQDiaLeaf _ g (DelayedLeaf d) = g d -- | Static annotations which can be placed at a particular node of a -- diagram tree. data Annotation = Href String -- ^ Hyperlink deriving Show -- | Apply a static annotation at the root of a diagram. applyAnnotation :: (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => Annotation -> QDiagram b v m -> QDiagram b v m applyAnnotation an (QD dt) = QD (D.annot an dt) -- | Make a diagram into a hyperlink. Note that only some backends -- will honor hyperlink annotations. href :: (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => String -> QDiagram b v m -> QDiagram b v m href = applyAnnotation . Href -- | The fundamental diagram type is represented by trees of -- primitives with various monoidal annotations. The @Q@ in -- @QDiagram@ stands for \"Queriable\", as distinguished from -- 'Diagram', a synonym for @QDiagram@ with the query type -- specialized to 'Any'. newtype QDiagram b v m = QD (D.DUALTree (DownAnnots v) (UpAnnots b v m) Annotation (QDiaLeaf b v m)) deriving (Typeable) instance Wrapped (QDiagram b v m) where type Unwrapped (QDiagram b v m) = D.DUALTree (DownAnnots v) (UpAnnots b v m) Annotation (QDiaLeaf b v m) _Wrapped' = iso (\(QD d) -> d) QD instance Rewrapped (QDiagram b v m) (QDiagram b' v' m') type instance V (QDiagram b v m) = v -- | The default sort of diagram is one where querying at a point -- simply tells you whether the diagram contains that point or not. -- Transforming a default diagram into one with a more interesting -- query can be done via the 'Functor' instance of @'QDiagram' b@ or -- the 'value' function. type Diagram b v = QDiagram b v Any -- | Create a \"point diagram\", which has no content, no trace, an -- empty query, and a point envelope. pointDiagram :: (Fractional (Scalar v), InnerSpace v) => Point v -> QDiagram b v m pointDiagram p = QD $ D.leafU (inj . toDeletable $ pointEnvelope p) -- | Extract a list of primitives from a diagram, together with their -- associated transformations and styles. prims :: HasLinearMap v => QDiagram b v m -> [(Prim b v, (Split (Transformation v), Style v))] prims = concatMap processLeaf . D.flatten . view _Wrapped' where processLeaf (PrimLeaf p, (trSty,_)) = [(p, untangle . option mempty id $ trSty)] processLeaf (DelayedLeaf k, d) = prims (k d) -- | A useful variant of 'getU' which projects out a certain -- component. getU' :: (Monoid u', u :>: u') => D.DUALTree d u a l -> u' getU' = maybe mempty (option mempty id . get) . D.getU -- | Get the envelope of a diagram. envelope :: forall b v m. (OrderedField (Scalar v), InnerSpace v , HasLinearMap v, Monoid' m) => Lens' (QDiagram b v m) (Envelope v) envelope = lens (unDelete . getU' . view _Wrapped') (flip setEnvelope) -- | Replace the envelope of a diagram. setEnvelope :: forall b v m. (OrderedField (Scalar v), InnerSpace v , HasLinearMap v, Monoid' m) => Envelope v -> QDiagram b v m -> QDiagram b v m setEnvelope e = over _Wrapped' ( D.applyUpre (inj . toDeletable $ e) . D.applyUpre (inj (deleteL :: Deletable (Envelope v))) . D.applyUpost (inj (deleteR :: Deletable (Envelope v))) ) -- | Get the trace of a diagram. trace :: (InnerSpace v, HasLinearMap v, OrderedField (Scalar v), Semigroup m) => Lens' (QDiagram b v m) (Trace v) trace = lens (unDelete . getU' . view _Wrapped') (flip setTrace) -- | Replace the trace of a diagram. setTrace :: forall b v m. (OrderedField (Scalar v), InnerSpace v , HasLinearMap v, Semigroup m) => Trace v -> QDiagram b v m -> QDiagram b v m setTrace t = over _Wrapped' ( D.applyUpre (inj . toDeletable $ t) . D.applyUpre (inj (deleteL :: Deletable (Trace v))) . D.applyUpost (inj (deleteR :: Deletable (Trace v))) ) -- | Get the subdiagram map (/i.e./ an association from names to -- subdiagrams) of a diagram. subMap :: (HasLinearMap v, InnerSpace v, Semigroup m, OrderedField (Scalar v)) => Lens' (QDiagram b v m) (SubMap b v m) subMap = lens (unDelete . getU' . view _Wrapped') (flip setMap) where setMap :: (HasLinearMap v, InnerSpace v, Semigroup m, OrderedField (Scalar v)) => SubMap b v m -> QDiagram b v m -> QDiagram b v m setMap m = over _Wrapped' ( D.applyUpre . inj . toDeletable $ m) -- | Get a list of names of subdiagrams and their locations. names :: (HasLinearMap v, InnerSpace v, Semigroup m, OrderedField (Scalar v)) => QDiagram b v m -> [(Name, [Point v])] names = (map . second . map) location . M.assocs . view (subMap . _Wrapped') -- | Attach an atomic name to a certain subdiagram, computed from the -- given diagram /with the mapping from name to subdiagram -- included/. The upshot of this knot-tying is that if @d' = d # -- named x@, then @lookupName x d' == Just d'@ (instead of @Just -- d@). nameSub :: ( IsName n , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => (QDiagram b v m -> Subdiagram b v m) -> n -> QDiagram b v m -> QDiagram b v m nameSub s n d = d' where d' = over _Wrapped' (D.applyUpre . inj . toDeletable $ fromNames [(n,s d')]) d -- | Lookup the most recent diagram associated with (some -- qualification of) the given name. lookupName :: (IsName n, HasLinearMap v, InnerSpace v , Semigroup m, OrderedField (Scalar v)) => n -> QDiagram b v m -> Maybe (Subdiagram b v m) lookupName n d = lookupSub (toName n) (d^.subMap) >>= listToMaybe -- | Given a name and a diagram transformation indexed by a -- subdiagram, perform the transformation using the most recent -- subdiagram associated with (some qualification of) the name, -- or perform the identity transformation if the name does not exist. withName :: (IsName n, HasLinearMap v, InnerSpace v , Semigroup m, OrderedField (Scalar v)) => n -> (Subdiagram b v m -> QDiagram b v m -> QDiagram b v m) -> QDiagram b v m -> QDiagram b v m withName n f d = maybe id f (lookupName n d) d -- | Given a name and a diagram transformation indexed by a list of -- subdiagrams, perform the transformation using the -- collection of all such subdiagrams associated with (some -- qualification of) the given name. withNameAll :: (IsName n, HasLinearMap v, InnerSpace v , Semigroup m, OrderedField (Scalar v)) => n -> ([Subdiagram b v m] -> QDiagram b v m -> QDiagram b v m) -> QDiagram b v m -> QDiagram b v m withNameAll n f d = f (fromMaybe [] (lookupSub (toName n) (d^.subMap))) d -- | Given a list of names and a diagram transformation indexed by a -- list of subdiagrams, perform the transformation using the -- list of most recent subdiagrams associated with (some qualification -- of) each name. Do nothing (the identity transformation) if any -- of the names do not exist. withNames :: (IsName n, HasLinearMap v, InnerSpace v , Semigroup m, OrderedField (Scalar v)) => [n] -> ([Subdiagram b v m] -> QDiagram b v m -> QDiagram b v m) -> QDiagram b v m -> QDiagram b v m withNames ns f d = maybe id f ns' d where nd = d^.subMap ns' = T.sequence (map ((listToMaybe=<<) . ($nd) . lookupSub . toName) ns) -- | \"Localize\" a diagram by hiding all the names, so they are no -- longer visible to the outside. localize :: forall b v m. ( HasLinearMap v, InnerSpace v , OrderedField (Scalar v), Semigroup m ) => QDiagram b v m -> QDiagram b v m localize = over _Wrapped' ( D.applyUpre (inj (deleteL :: Deletable (SubMap b v m))) . D.applyUpost (inj (deleteR :: Deletable (SubMap b v m))) ) -- | Get the query function associated with a diagram. query :: Monoid m => QDiagram b v m -> Query v m query = getU' . view _Wrapped' -- | Sample a diagram's query function at a given point. sample :: Monoid m => QDiagram b v m -> Point v -> m sample = runQuery . query -- | Set the query value for 'True' points in a diagram (/i.e./ points -- \"inside\" the diagram); 'False' points will be set to 'mempty'. value :: Monoid m => m -> QDiagram b v Any -> QDiagram b v m value m = fmap fromAny where fromAny (Any True) = m fromAny (Any False) = mempty -- | Reset the query values of a diagram to @True@/@False@: any values -- equal to 'mempty' are set to 'False'; any other values are set to -- 'True'. resetValue :: (Eq m, Monoid m) => QDiagram b v m -> QDiagram b v Any resetValue = fmap toAny where toAny m | m == mempty = Any False | otherwise = Any True -- | Set all the query values of a diagram to 'False'. clearValue :: QDiagram b v m -> QDiagram b v Any clearValue = fmap (const (Any False)) -- | Create a diagram from a single primitive, along with an envelope, -- trace, subdiagram map, and query function. mkQD :: Prim b v -> Envelope v -> Trace v -> SubMap b v m -> Query v m -> QDiagram b v m mkQD p = mkQD' (PrimLeaf p) -- | Create a diagram from a generic QDiaLeaf, along with an envelope, -- trace, subdiagram map, and query function. mkQD' :: QDiaLeaf b v m -> Envelope v -> Trace v -> SubMap b v m -> Query v m -> QDiagram b v m mkQD' l e t n q = QD $ D.leaf (toDeletable e *: toDeletable t *: toDeletable n *: q *: ()) l ------------------------------------------------------------ -- Instances ------------------------------------------------------------ ---- Monoid -- | Diagrams form a monoid since each of their components do: the -- empty diagram has no primitives, an empty envelope, an empty -- trace, no named subdiagrams, and a constantly empty query -- function. -- -- Diagrams compose by aligning their respective local origins. The -- new diagram has all the primitives and all the names from the two -- diagrams combined, and query functions are combined pointwise. -- The first diagram goes on top of the second. \"On top of\" -- probably only makes sense in vector spaces of dimension lower -- than 3, but in theory it could make sense for, say, 3-dimensional -- diagrams when viewed by 4-dimensional beings. instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => Monoid (QDiagram b v m) where mempty = QD D.empty mappend = (<>) instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => Semigroup (QDiagram b v m) where (QD d1) <> (QD d2) = QD (d2 <> d1) -- swap order so that primitives of d2 come first, i.e. will be -- rendered first, i.e. will be on the bottom. -- | A convenient synonym for 'mappend' on diagrams, designed to be -- used infix (to help remember which diagram goes on top of which -- when combining them, namely, the first on top of the second). atop :: (HasLinearMap v, OrderedField (Scalar v), InnerSpace v, Semigroup m) => QDiagram b v m -> QDiagram b v m -> QDiagram b v m atop = (<>) infixl 6 `atop` ---- Functor instance Functor (QDiagram b v) where fmap f = over (_Wrapping QD) ( (D.mapU . second . second) ( (first . fmap . fmap . fmap) f . (second . first . fmap . fmap) f ) . (fmap . fmap) f ) ---- Applicative -- XXX what to do with this? -- A diagram with queries of result type @(a -> b)@ can be \"applied\" -- to a diagram with queries of result type @a@, resulting in a -- combined diagram with queries of result type @b@. In particular, -- all components of the two diagrams are combined as in the -- @Monoid@ instance, except the queries which are combined via -- @(<*>)@. -- instance (Backend b v, s ~ Scalar v, AdditiveGroup s, Ord s) -- => Applicative (QDiagram b v) where -- pure a = Diagram mempty mempty mempty (Query $ const a) -- (Diagram ps1 bs1 ns1 smp1) <*> (Diagram ps2 bs2 ns2 smp2) -- = Diagram (ps1 <> ps2) (bs1 <> bs2) (ns1 <> ns2) (smp1 <*> smp2) ---- HasStyle instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => HasStyle (QDiagram b v m) where applyStyle = over _Wrapped' . D.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@ -- and @scale 2 (lw 0.01 circle)@ will be drawn with lines of the -- /same/ width, and @scaleY 3 circle@ will be an ellipse drawn with -- a uniform line. Once a diagram is frozen, however, -- transformations do affect attributes, so, for example, @scale 2 -- (freeze (lw 0.01 circle))@ will be drawn with a line twice as -- thick as @lw 0.01 circle@, and @scaleY 3 (freeze circle)@ will be -- drawn with a \"stretched\", variable-width line. -- -- Another way of thinking about it is that pre-@freeze@, we are -- transforming the \"abstract idea\" of a diagram, and the -- transformed version is then drawn; when doing a @freeze@, we -- produce a concrete drawing of the diagram, and it is this visual -- representation itself which is acted upon by subsequent -- transformations. freeze :: forall v b m. (HasLinearMap v, InnerSpace v , OrderedField (Scalar v), Semigroup m) => QDiagram b v m -> QDiagram b v m freeze = over _Wrapped' . D.applyD . inj . (inL :: Split (Transformation v) -> Split (Transformation v) :+: Style v) $ split ---- Juxtaposable instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' m) => Juxtaposable (QDiagram b v m) where juxtapose = juxtaposeDefault ---- Enveloped instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' m) => Enveloped (QDiagram b v m) where getEnvelope = view envelope ---- Traced instance (HasLinearMap v, VectorSpace v, Ord (Scalar v), InnerSpace v , Semigroup m, Fractional (Scalar v), Floating (Scalar v)) => Traced (QDiagram b v m) where getTrace = view trace ---- HasOrigin -- | Every diagram has an intrinsic \"local origin\" which is the -- basis for all combining operations. instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => HasOrigin (QDiagram b v m) where moveOriginTo = translate . (origin .-.) ---- Transformable -- | Diagrams can be transformed by transforming each of their -- components appropriately. instance (HasLinearMap v, OrderedField (Scalar v), InnerSpace v, Semigroup m) => Transformable (QDiagram b v m) where transform = over _Wrapped' . D.applyD . transfToAnnot ---- Qualifiable -- | Diagrams can be qualified so that all their named points can -- now be referred to using the qualification prefix. instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => Qualifiable (QDiagram b v m) where (|>) = over _Wrapped' . D.applyD . inj . toName ------------------------------------------------------------ -- Subdiagrams ------------------------------------------------------------ -- | A @Subdiagram@ represents a diagram embedded within the context -- of a larger diagram. Essentially, it consists of a diagram -- paired with any accumulated information from the larger context -- (transformations, attributes, etc.). data Subdiagram b v m = Subdiagram (QDiagram b v m) (DownAnnots v) type instance V (Subdiagram b v m) = v -- | Turn a diagram into a subdiagram with no accumulated context. mkSubdiagram :: QDiagram b v m -> Subdiagram b v m mkSubdiagram d = Subdiagram d empty -- | Create a \"point subdiagram\", that is, a 'pointDiagram' (with no -- content and a point envelope) treated as a subdiagram with local -- origin at the given point. Note this is not the same as -- @mkSubdiagram . pointDiagram@, which would result in a subdiagram -- with local origin at the parent origin, rather than at the given -- point. subPoint :: (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => Point v -> Subdiagram b v m subPoint p = Subdiagram (pointDiagram origin) (transfToAnnot $ translation (p .-. origin)) instance Functor (Subdiagram b v) where fmap f (Subdiagram d a) = Subdiagram (fmap f d) a instance (OrderedField (Scalar v), InnerSpace v, HasLinearMap v, Monoid' m) => Enveloped (Subdiagram b v m) where getEnvelope (Subdiagram d a) = transform (transfFromAnnot a) $ getEnvelope d instance (OrderedField (Scalar v), HasLinearMap v, InnerSpace v, Semigroup m) => Traced (Subdiagram b v m) where getTrace (Subdiagram d a) = transform (transfFromAnnot a) $ getTrace d instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => HasOrigin (Subdiagram b v m) where moveOriginTo = translate . (origin .-.) instance ( HasLinearMap v, InnerSpace v, Floating (Scalar v)) => Transformable (Subdiagram b v m) where transform t (Subdiagram d a) = Subdiagram d (transfToAnnot t <> a) -- | Get the location of a subdiagram; that is, the location of its -- local origin /with respect to/ the vector space of its parent -- diagram. In other words, the point where its local origin -- \"ended up\". location :: HasLinearMap v => Subdiagram b v m -> Point v location (Subdiagram _ a) = transform (transfFromAnnot a) origin -- | Turn a subdiagram into a normal diagram, including the enclosing -- context. Concretely, a subdiagram is a pair of (1) a diagram and -- (2) a \"context\" consisting of an extra transformation and -- attributes. @getSub@ simply applies the transformation and -- attributes to the diagram to get the corresponding \"top-level\" -- diagram. getSub :: ( HasLinearMap v, InnerSpace v , Floating (Scalar v), Ord (Scalar v) , Semigroup m ) => Subdiagram b v m -> QDiagram b v m getSub (Subdiagram d a) = over _Wrapped' (D.applyD a) d -- | Extract the \"raw\" content of a subdiagram, by throwing away the -- context. rawSub :: Subdiagram b v m -> QDiagram b v m rawSub (Subdiagram d _) = d ------------------------------------------------------------ -- Subdiagram maps --------------------------------------- ------------------------------------------------------------ -- | A 'SubMap' is a map associating names to subdiagrams. There can -- be multiple associations for any given name. newtype SubMap b v m = SubMap (M.Map Name [Subdiagram b v m]) -- See Note [SubMap Set vs list] instance Wrapped (SubMap b v m) where type Unwrapped (SubMap b v m) = M.Map Name [Subdiagram b v m] _Wrapped' = iso (\(SubMap m) -> m) SubMap instance Rewrapped (SubMap b v m) (SubMap b' v' m') -- ~~~~ [SubMap Set vs list] -- In some sense it would be nicer to use -- Sets instead of a list, but then we would have to put Ord -- constraints on v everywhere. =P type instance V (SubMap b v m) = v instance Functor (SubMap b v) where fmap = over _Wrapped . fmap . map . fmap instance Semigroup (SubMap b v m) where SubMap s1 <> SubMap s2 = SubMap $ M.unionWith (++) s1 s2 -- | 'SubMap's form a monoid with the empty map as the identity, and -- map union as the binary operation. No information is ever lost: -- if two maps have the same name in their domain, the resulting map -- will associate that name to the concatenation of the information -- associated with that name. instance Monoid (SubMap b v m) where mempty = SubMap M.empty mappend = (<>) instance (OrderedField (Scalar v), InnerSpace v, HasLinearMap v) => HasOrigin (SubMap b v m) where moveOriginTo = over _Wrapped' . moveOriginTo instance (InnerSpace v, Floating (Scalar v), HasLinearMap v) => Transformable (SubMap b v m) where transform = over _Wrapped' . transform -- | 'SubMap's are qualifiable: if @ns@ is a 'SubMap', then @a |> -- ns@ is the same 'SubMap' except with every name qualified by -- @a@. instance Qualifiable (SubMap b v m) where a |> (SubMap m) = SubMap $ M.mapKeys (a |>) m -- | Construct a 'SubMap' from a list of associations between names -- and subdiagrams. fromNames :: IsName a => [(a, Subdiagram b v m)] -> SubMap b v m fromNames = SubMap . M.fromListWith (++) . map (toName *** (:[])) -- | Add a name/diagram association to a submap. rememberAs :: IsName a => a -> QDiagram b v m -> SubMap b v m -> SubMap b v m 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 m) where act = (|>) instance Action Name a => Action Name (Deletable a) where act n (Deletable l a r) = Deletable l (act n a) r -- Names do not act on other things. instance Action Name (Query v m) instance Action Name (Envelope v) instance Action Name (Trace v) -- | Look for the given name in a name map, returning a list of -- subdiagrams associated with that name. If no names match the -- given name exactly, return all the subdiagrams associated with -- names of which the given name is a suffix. lookupSub :: IsName n => n -> SubMap b v m -> Maybe [Subdiagram b v m] lookupSub a (SubMap m) = M.lookup n m `mplus` (flattenNames . filter ((n `nameSuffixOf`) . fst) . M.assocs $ m) where (Name n1) `nameSuffixOf` (Name n2) = n1 `isSuffixOf` n2 flattenNames [] = Nothing flattenNames xs = Just . concatMap snd $ xs n = toName a ------------------------------------------------------------ -- Primitives -------------------------------------------- ------------------------------------------------------------ -- $prim -- Ultimately, every diagram is essentially a list of /primitives/, -- basic building blocks which can be rendered by backends. However, -- not every backend must be able to render every type of primitive; -- the collection of primitives a given backend knows how to render is -- determined by instances of 'Renderable'. -- | A type class for primitive things which know how to handle being -- transformed by both a normal transformation and a \"frozen\" -- transformation. The default implementation simply applies both. -- At the moment, 'ScaleInv' is the only type with a non-default -- instance of 'IsPrim'. class Transformable p => IsPrim p where transformWithFreeze :: Transformation (V p) -> Transformation (V p) -> p -> p transformWithFreeze t1 t2 = transform (t1 <> t2) -- | A value of type @Prim b v@ is an opaque (existentially quantified) -- primitive which backend @b@ knows how to render in vector space @v@. data Prim b v where Prim :: (IsPrim p, Typeable p, Renderable p b) => p -> Prim b (V p) type instance V (Prim b v) = v instance HasLinearMap v => IsPrim (Prim b v) where transformWithFreeze t1 t2 (Prim p) = Prim $ transformWithFreeze t1 t2 p -- | The 'Transformable' instance for 'Prim' just pushes calls to -- 'transform' down through the 'Prim' constructor. instance HasLinearMap v => Transformable (Prim b v) where transform v (Prim p) = Prim (transform v p) -- | The 'Renderable' instance for 'Prim' just pushes calls to -- 'render' down through the 'Prim' constructor. instance HasLinearMap v => Renderable (Prim b v) b where render b (Prim p) = render b p -- | The null primitive. data NullPrim v = NullPrim deriving Typeable type instance (V (NullPrim v)) = v instance HasLinearMap v => IsPrim (NullPrim v) instance HasLinearMap v => Transformable (NullPrim v) where transform _ _ = NullPrim instance (HasLinearMap v, Monoid (Render b v)) => Renderable (NullPrim v) b where render _ _ = mempty -- | The null primitive, which every backend can render by doing -- nothing. nullPrim :: (HasLinearMap v, Typeable v, Monoid (Render b v)) => Prim b v nullPrim = Prim NullPrim ------------------------------------------------------------ -- Backends ----------------------------------------------- ------------------------------------------------------------ data DNode b v a = DStyle (Style v) | DTransform (Split (Transformation v)) | DAnnot a | DDelay -- ^ @DDelay@ marks a point where a delayed subtree -- was expanded. Such subtrees already take all -- non-frozen transforms above them into account, -- so when later processing the tree, upon -- encountering a @DDelay@ node we must drop any -- accumulated non-frozen transformation. | DPrim (Prim b v) | DEmpty -- | A 'DTree' is a raw tree representation of a 'QDiagram', with all -- the @u@-annotations removed. It is used as an intermediate type -- by diagrams-core; backends should not need to make use of it. -- Instead, backends can make use of 'RTree', which 'DTree' gets -- compiled and optimized to. type DTree b v a = Tree (DNode b v a) data RNode b v a = RStyle (Style v) -- ^ A style node. | RFrozenTr (Transformation v) -- ^ A \"frozen\" transformation, /i.e./ one which -- was applied after a call to 'freeze'. It -- applies to everything below it in the tree. -- Note that line width and other similar -- \"scale invariant\" attributes should be -- affected by this transformation. In the case -- of 2D, some backends may not support stroking -- in the context of an arbitrary -- transformation; such backends can instead use -- the 'avgScale' function from -- @Diagrams.TwoD.Transform@ (from the -- @diagrams-lib@ package). | RAnnot a | RPrim (Transformation v) (Prim b v) -- ^ A primitive, along with the (non-frozen) -- transformation which applies to it. | REmpty -- | An 'RTree' is a compiled and optimized representation of a -- 'QDiagram', which can be used by backends. They have several -- invariants which backends may rely upon: -- -- * All non-frozen transformations have been pushed all the way to -- the leaves. -- -- * @RPrim@ nodes never have any children. type RTree b v a = Tree (RNode b v a ) -- | Abstract diagrams are rendered to particular formats by -- /backends/. Each backend/vector space combination must be an -- instance of the 'Backend' class. A minimal complete definition -- consists of the three associated types, an implementation for -- 'doRender', and /one of/ either 'withStyle' or 'renderData'. class (HasLinearMap v, Monoid (Render b v)) => Backend b v where -- | The type of rendering operations used by this backend, which -- must be a monoid. For example, if @Render b v = M ()@ for some -- monad @M@, a monoid instance can be made with @mempty = return -- ()@ and @mappend = (>>)@. data Render b v :: * -- | The result of running/interpreting a rendering operation. type Result b v :: * -- | Backend-specific rendering options. data Options b v :: * -- | Perform a rendering operation with a local style. The default -- implementation does nothing, and must be overridden by backends -- that do not override 'renderData'. withStyle :: b -- ^ Backend token (needed only for type inference) -> Style v -- ^ Style to use -> Transformation v -- ^ \"Frozen\" transformation; line width and -- other similar \"scale invariant\" attributes -- should be affected by this transformation. -- In the case of 2D, some backends may not -- support stroking in the context of an -- arbitrary transformation; such backends can -- instead use the 'avgScale' function from -- @Diagrams.TwoD.Transform@ (from the -- @diagrams-lib@ package). -> Render b v -- ^ Rendering operation to run -> Render b v -- ^ Rendering operation using the style locally withStyle _ _ _ r = r -- | 'doRender' is used to interpret rendering operations. doRender :: b -- ^ Backend token (needed only for type inference) -> Options b v -- ^ Backend-specific collection of rendering options -> Render b v -- ^ Rendering operation to perform -> Result b v -- ^ Output of the rendering operation -- | 'adjustDia' allows the backend to make adjustments to the final -- diagram (e.g. to adjust the size based on the options) before -- rendering it. It can also make adjustments to the options -- record, usually to fill in incompletely specified size -- information. A default implementation is provided which makes -- no adjustments. See the diagrams-lib package for other useful -- implementations. adjustDia :: Monoid' m => b -> Options b v -> QDiagram b v m -> (Options b v, QDiagram b v m) adjustDia _ o d = (o,d) renderDia :: (InnerSpace v, OrderedField (Scalar v), Monoid' m) => b -> Options b v -> QDiagram b v m -> Result b v renderDia b opts d = doRender b opts' . renderData b $ d' where (opts', d') = adjustDia b opts d -- | Backends may override 'renderData' to gain more control over -- the way that rendering happens. A typical implementation might be something like -- -- > renderData = renderRTree . toRTree -- -- where @renderRTree :: RTree b v () -> Render b v@ is -- implemented by the backend (with appropriate types filled in -- for @b@ and @v@), and 'toRTree' is from "Diagrams.Core.Compile". renderData :: Monoid' m => b -> QDiagram b v m -> Render b v renderData b = mconcat . map renderOne . prims 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)) renderOne (p, (t1 :| t2, s)) = withStyle b s t1 (render b (transformWithFreeze t1 t2 p)) -- See Note [backend token] -- | The @D@ type is provided for convenience in situations where you -- must give a diagram a concrete, monomorphic type, but don't care -- which one. Such situations arise when you pass a diagram to a -- function which is polymorphic in its input but monomorphic in its -- output, such as 'width', 'height', 'phantom', or 'names'. Such -- functions compute some property of the diagram, or use it to -- accomplish some other purpose, but do not result in the diagram -- being rendered. If the diagram does not have a monomorphic type, -- GHC complains that it cannot determine the diagram's type. -- -- For example, here is the error we get if we try to compute the -- width of an image (this example requires @diagrams-lib@): -- -- @ -- ghci> width (image \"foo.png\" 200 200) -- \<interactive\>:8:8: -- No instance for (Renderable Diagrams.TwoD.Image.Image b0) -- arising from a use of `image' -- Possible fix: -- add an instance declaration for -- (Renderable Diagrams.TwoD.Image.Image b0) -- In the first argument of `width', namely -- `(image \"foo.png\" 200 200)' -- In the expression: width (image \"foo.png\" 200 200) -- In an equation for `it': it = width (image \"foo.png\" 200 200) -- @ -- -- GHC complains that there is no instance for @Renderable Image -- b0@; what is really going on is that it does not have enough -- information to decide what backend to use (hence the -- uninstantiated @b0@). This is annoying because /we/ know that the -- choice of backend cannot possibly affect the width of the image -- (it's 200! it's right there in the code!); /but/ there is no way -- for GHC to know that. -- -- The solution is to annotate the call to 'image' with the type -- @'D' 'R2'@, like so: -- -- @ -- ghci> width (image \"foo.png\" 200 200 :: D R2) -- 200.00000000000006 -- @ -- -- (It turns out the width wasn't 200 after all...) -- -- As another example, here is the error we get if we try to compute -- the width of a radius-1 circle: -- -- @ -- ghci> width (circle 1) -- \<interactive\>:4:1: -- Couldn't match type `V a0' with `R2' -- In the expression: width (circle 1) -- In an equation for `it': it = width (circle 1) -- @ -- -- There's even more ambiguity here. Whereas 'image' always returns -- a 'Diagram', the 'circle' function can produce any 'PathLike' -- type, and the 'width' function can consume any 'Enveloped' type, -- so GHC has no idea what type to pick to go in the middle. -- However, the solution is the same: -- -- @ -- ghci> width (circle 1 :: D R2) -- 1.9999999999999998 -- @ type D v = Diagram NullBackend v -- | A null backend which does no actual rendering. It is provided -- mainly for convenience in situations where you must give a -- diagram a concrete, monomorphic type, but don't actually care -- which one. See 'D' for more explanation and examples. -- -- It is courteous, when defining a new primitive @P@, to make an instance -- -- > instance Renderable P NullBackend where -- > render _ _ = mempty -- -- This ensures that the trick with 'D' annotations can be used for -- diagrams containing your primitive. data NullBackend -- Note: we can't make a once-and-for-all instance -- -- > instance Renderable a NullBackend where -- > render _ _ = mempty -- -- because it overlaps with the Renderable instance for NullPrim. instance Monoid (Render NullBackend v) where mempty = NullBackendRender mappend _ _ = NullBackendRender instance HasLinearMap v => Backend NullBackend v where data Render NullBackend v = NullBackendRender type Result NullBackend v = () data Options NullBackend v withStyle _ _ _ _ = NullBackendRender doRender _ _ _ = () -- | A class for backends which support rendering multiple diagrams, -- e.g. to a multi-page pdf or something similar. class Backend b v => MultiBackend b v where -- | Render multiple diagrams at once. renderDias :: (InnerSpace v, OrderedField (Scalar v), Monoid' m) => b -> Options b v -> [QDiagram b v m] -> Result b v -- See Note [backend token] -- | The Renderable type class connects backends to primitives which -- they know how to render. class Transformable t => Renderable t b where render :: b -> t -> Render b (V t) -- ^ Given a token representing the backend and a -- transformable object, render it in the appropriate rendering -- context. -- See Note [backend token] {- ~~~~ Note [backend token] A bunch of methods here take a "backend token" as an argument. The backend token is expected to carry no actual information; it is solely to help out the type system. The problem is that all these methods return some associated type applied to b (e.g. Render b) and unifying them with something else will never work, since type families are not necessarily injective. -}