diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index fafecc68..7b645235 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -34,7 +34,6 @@ Library Diagrams.Animation, Diagrams.Animation.Active, Diagrams.Attributes, - Diagrams.Attributes.Compile, Diagrams.Backend.CmdLine, Diagrams.BoundingBox, Diagrams.Combinators, diff --git a/src/Diagrams/Attributes/Compile.hs b/src/Diagrams/Attributes/Compile.hs deleted file mode 100644 index da5b78f8..00000000 --- a/src/Diagrams/Attributes/Compile.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} ------------------------------------------------------------------------------ --- | --- Module : Diagrams.Attributes.Compile --- Copyright : (c) 2014 diagrams-lib team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- XXX --- ------------------------------------------------------------------------------ - -module Diagrams.Attributes.Compile ( - SplitAttribute(..), splitAttr - ) where - -import Data.Typeable - -import Control.Arrow (second) -import Control.Lens ((%~), (&), _Wrapping') -import qualified Data.HashMap.Strict as HM -import Data.Semigroup ((<>)) -import Data.Tree (Tree (..)) - -import Diagrams.Core -import Diagrams.Core.Style (Style (..), attributeToStyle) -import Diagrams.Core.Types (RNode (..), RTree) - ------------------------------------------------------------- - --- This is a sort of roundabout, overly-general way to define --- splitFills; it's done this way to facilitate testing. - -class (AttributeClass (AttrType code), Typeable (PrimType code)) => SplitAttribute code where - type AttrType code :: * - type PrimType code :: * - - primOK :: code -> PrimType code -> Bool - --- | Push certain attributes down until they are at the roots of trees --- containing only "safe" nodes. In particular this is used to push --- fill attributes down until they are over only loops; see --- 'splitFills'. -splitAttr :: forall code b v n a. SplitAttribute code => code -> RTree b v n a -> RTree b v n a -splitAttr code = fst . splitAttr' Nothing - where - - -- splitAttr' is where the most interesting logic happens. - -- Mutually recursive with splitAttr'Forest. rebuildNode and - -- applyMfc are helper functions. - -- - -- Input: attribute to apply to "safe" subtrees. - -- - -- Output: tree with attributes pushed down appropriately, and - -- a Bool indicating whether the tree contains only "safe" prims (True) or - -- contains some unsafe ones (False). - splitAttr' :: Maybe (AttrType code) -> RTree b v n a -> (RTree b v n a, Bool) - - -- RStyle node: Check for the special attribute, and split it out of - -- the style, combining it with the incoming attribute. Recurse and - -- rebuild. The tricky bit is that we use some knot-tying to - -- determine the right attribute to pass down to the subtrees based - -- on this computed Bool: if all subtrees are safe, then we will - -- apply the attribute at the root of this tree, and pass Nothing to - -- all the subtrees. Otherwise, we pass the given attribute along. - -- This works out because the attribute does not need to be - -- pattern-matched until actually applying it at some root, so the - -- recursion can proceed and the Bool values be computed with the - -- actual value of the attributes nodes filled in lazily. - splitAttr' mattr (Node (RStyle sty) cs) = (t', ok) - where - mattr' = mattr <> getAttr sty - sty' = sty & _Wrapping' Style %~ HM.delete ty - ty = typeOf (undefined :: AttrType code) - (cs', ok) = splitAttr'Forest mattr' cs - t' | ok = rebuildNode Nothing ok (RStyle sty) cs' - | otherwise = rebuildNode mattr ok (RStyle sty') cs' - - -- RPrim node: check whether it - -- * is some sort of prim not under consideration: don't apply the attribute; return True - -- * is unsafe: don't apply the attribute; return False - -- * is safe : do apply the attribute; return True - splitAttr' mattr (Node rp@(RPrim (Prim prm)) _) = - case cast prm :: Maybe (PrimType code) of - Nothing -> (Node rp [], True) - Just p -> - if primOK code p - then (rebuildNode mattr True rp [], True) - else (Node rp [], False) - - -- RFrozenTr, RAnnot, REmpty cases: just recurse and rebuild. Note - -- we assume that transformations do not affect the attributes. - splitAttr' mattr (Node nd cs) = (t', ok) - where - (cs', ok) = splitAttr'Forest mattr cs - t' = rebuildNode mattr ok nd cs' - - -- Recursively call splitAttr' on all subtrees, returning the - -- logical AND of the Bool results returned (the whole forest is - -- safe iff all subtrees are). - splitAttr'Forest :: Maybe (AttrType code) -> [RTree b v n a] -> ([RTree b v n a], Bool) - splitAttr'Forest mattr cs = (cs', ok) - where - (cs', ok) = second and . unzip . map (splitAttr' mattr) $ cs - - -- Given a fill attribute, a Bool indicating whether the given - -- subforest contains only loops, a node, and a subforest, rebuild a - -- tree, applying the fill attribute as appropriate (only if the - -- Bool is true and the attribute is not Nothing). - rebuildNode :: Maybe (AttrType code) -> Bool -> RNode b v n a -> [RTree b v n a] -> RTree b v n a - rebuildNode mattr ok nd cs - | ok = applyMattr mattr (Node nd cs) - | otherwise = Node nd cs - - -- Prepend a new fill color node if Just; the identity function if - -- Nothing. - applyMattr :: Maybe (AttrType code) -> RTree b v n a -> RTree b v n a - applyMattr Nothing t = t - applyMattr (Just a) t = Node (RStyle $ attributeToStyle (Attribute a)) [t] diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs index 271f5b45..bdfe7274 100644 --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -40,14 +40,10 @@ module Diagrams.Combinators import Control.Lens hiding (beside, ( # )) import Data.Default.Class -import Data.Monoid.Deletable (toDeletable) -import Data.Monoid.MList (inj) import Data.Proxy import Data.Semigroup -import qualified Data.Tree.DUAL as D import Diagrams.Core -import Diagrams.Core.Types (QDiagram (QD)) import Diagrams.Direction import Diagrams.Segment (straight) import Diagrams.Util @@ -86,7 +82,9 @@ withTrace = setTrace . getTrace -- | @phantom x@ produces a \"phantom\" diagram, which has the same -- envelope and trace as @x@ but produces no output. phantom :: (InSpace v n a, Monoid' m, Enveloped a, Traced a) => a -> QDiagram b v n m -phantom a = QD $ D.leafU ((inj . toDeletable . getEnvelope $ a) <> (inj . toDeletable . getTrace $ a)) +phantom a = mempty & setEnvelope (getEnvelope a) + & setTrace (getTrace a) + -- QD $ D.leafU ((inj . toDeletable . getEnvelope $ a) <> (inj . toDeletable . getTrace $ a)) -- | @pad s@ \"pads\" a diagram, expanding its envelope by a factor of -- @s@ (factors between 0 and 1 can be used to shrink the envelope). @@ -119,7 +117,7 @@ frame s = over envelope (onEnvelope $ \f x -> f x + s) -- > strutEx = (circle 1 ||| strut unitX ||| circle 1) # centerXY # pad 1.1 strut :: (Metric v, OrderedField n, Monoid' m) => v n -> QDiagram b v n m -strut v = QD $ D.leafU (inj . toDeletable $ env) +strut v = mempty & setEnvelope env -- QD $ D.leafU (inj . toDeletable $ env) where env = translate ((-0.5) *^ v) . getEnvelope $ straight v -- note we can't use 'phantom' here because it tries to construct a -- trace as well, and segments do not have a trace in general (only diff --git a/src/Diagrams/Names.hs b/src/Diagrams/Names.hs index 2d9c789f..9e78febc 100644 --- a/src/Diagrams/Names.hs +++ b/src/Diagrams/Names.hs @@ -54,7 +54,7 @@ named = nameSub mkSubdiagram -- | Attach an atomic name to a certain point (which may be computed -- from the given diagram), treated as a subdiagram with no content -- and a point envelope. -namePoint :: (IsName nm , Metric v, OrderedField n, Semigroup m) +namePoint :: (IsName nm , Metric v, OrderedField n, Semigroup m, Monoid m) => (QDiagram b v n m -> Point v n) -> nm -> QDiagram b v n m -> QDiagram b v n m namePoint p = nameSub (subPoint . p) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 6fb8f42d..91daaa0e 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -402,7 +402,7 @@ arrow' opts len = mkQD' (DelayedLeaf delayedArrow) -- uniformly as the transformation applied to the entire arrow. -- See https://github.com/diagrams/diagrams-lib/issues/112. delayedArrow da g n = - let (trans, globalSty) = option mempty untangle . fst $ da + let (trans, globalSty) = untangle da in dArrow globalSty trans len g n -- Build an arrow and set its endpoints to the image under tr of origin and (len,0). diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index 861aeae3..8eed3d3c 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -58,9 +58,6 @@ module Diagrams.TwoD.Attributes ( -- ** Fill color , fillColor, fc, fcA, recommendFillColor - -- * Compilation utilities - , splitTextureFills - ) where import Control.Lens hiding (transform) @@ -71,12 +68,7 @@ import Data.Monoid.Recommend import Data.Semigroup import Diagrams.Attributes -import Diagrams.Attributes.Compile import Diagrams.Core -import Diagrams.Core.Types (RTree) -import Diagrams.Located (unLoc) -import Diagrams.Path (Path, pathTrails) -import Diagrams.Trail (isLoop) import Diagrams.TwoD.Types import Diagrams.Util @@ -402,29 +394,3 @@ fc = fillColor fcA :: (InSpace V2 n a, Floating n, Typeable n, HasStyle a) => AlphaColour Double -> a -> a fcA = fillColor --- Split fills --------------------------------------------------------- - -data FillTextureLoops n = FillTextureLoops - -instance Typeable n => SplitAttribute (FillTextureLoops n) where - type AttrType (FillTextureLoops n) = FillTexture n - type PrimType (FillTextureLoops n) = Path V2 n - - primOK _ = all (isLoop . unLoc) . pathTrails - --- | Push fill attributes down until they are at the root of subtrees --- containing only loops. This makes life much easier for backends, --- which typically have a semantics where fill attributes are --- applied to lines/non-closed paths as well as loops/closed paths, --- whereas in the semantics of diagrams, fill attributes only apply --- to loops. -splitTextureFills - :: forall b v n a. ( -#if __GLASGOW_HASKELL__ > 707 - Typeable v -#else - Typeable1 v -#endif - - , Typeable n) => RTree b v n a -> RTree b v n a -splitTextureFills = splitAttr (FillTextureLoops :: FillTextureLoops n)