hgeometry-ipe-0.12.0.0: src/Data/Geometry/Ipe/Content.hs
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Geometry.Ipe.Content(
Image(Image), imageData, rect
, TextLabel(..)
, MiniPage(..), width
, IpeSymbol(Symbol), symbolPoint, symbolName
, Path(Path), pathSegments
, PathSegment(..)
, Group(Group), groupItems
, IpeObject(..), _IpeGroup, _IpeImage, _IpeTextLabel, _IpeMiniPage, _IpeUse, _IpePath
, IpeObject'
, ipeObject', ToObject(..)
, IpeAttributes
, Attributes', AttributesOf, AttrMap, AttrMapSym1
, attributes, traverseIpeAttrs
, commonAttributes
, flattenGroups
) where
import Control.Lens hiding (views)
import Data.Bitraversable
import Data.Ext
import Data.Geometry.Box (Rectangle)
import qualified Data.Geometry.Ipe.Attributes as AT
import Data.Geometry.Ipe.Attributes hiding (Matrix)
import Data.Geometry.Ipe.Color
import Data.Geometry.Ipe.Layer
import Data.Geometry.Ipe.Path
import Data.Geometry.Matrix
import Data.Geometry.Point
import Data.Geometry.Properties
import Data.Geometry.Transformation
import Data.Proxy
import Data.Singletons.TH (genDefunSymbols)
import Data.Text (Text)
import Data.Traversable
import Data.Vinyl hiding (Label)
import Data.Vinyl.TypeLevel (AllConstrained)
--------------------------------------------------------------------------------
-- | Image Objects
data Image r = Image { _imageData :: ()
, _rect :: Rectangle () r
} deriving (Show,Eq,Ord)
makeLenses ''Image
type instance NumType (Image r) = r
type instance Dimension (Image r) = 2
instance Fractional r => IsTransformable (Image r) where
transformBy t = over rect (transformBy t)
instance Functor Image where
fmap = fmapDefault
instance Foldable Image where
foldMap = foldMapDefault
instance Traversable Image where
traverse f (Image d r) = Image d <$> bitraverse pure f r
--------------------------------------------------------------------------------
-- | Text Objects
data TextLabel r = Label Text (Point 2 r)
deriving (Show,Eq,Ord,Functor,Foldable,Traversable)
data MiniPage r = MiniPage Text (Point 2 r) r
deriving (Show,Eq,Ord,Functor,Foldable,Traversable)
type instance NumType (TextLabel r) = r
type instance Dimension (TextLabel r) = 2
type instance NumType (MiniPage r) = r
type instance Dimension (MiniPage r) = 2
instance Fractional r => IsTransformable (TextLabel r) where
transformBy t (Label txt p) = Label txt (transformBy t p)
instance Fractional r => IsTransformable (MiniPage r) where
transformBy t (MiniPage txt p w) = MiniPage txt (transformBy t p) w
width :: MiniPage t -> t
width (MiniPage _ _ w) = w
--------------------------------------------------------------------------------
-- | Ipe Symbols, i.e. Points
-- | A symbol (point) in ipe
data IpeSymbol r = Symbol { _symbolPoint :: Point 2 r
, _symbolName :: Text
}
deriving (Show,Eq,Ord,Functor,Foldable,Traversable)
makeLenses ''IpeSymbol
type instance NumType (IpeSymbol r) = r
type instance Dimension (IpeSymbol r) = 2
instance Fractional r => IsTransformable (IpeSymbol r) where
transformBy t = over symbolPoint (transformBy t)
-- | Example of an IpeSymbol. I.e. A symbol that expresses that the size is 'large'
-- sizeSymbol :: Attributes (AttrMapSym1 r) (SymbolAttributes r)
-- sizeSymbol = attr SSize (IpeSize $ Named "large")
--------------------------------------------------------------------------------
-- * Paths are in a separate module
--------------------------------------------------------------------------------
-- * Attribute Mapping
-- | The mapping between the labels of the the attributes and the types of the
-- attributes with these labels. For example, the 'Matrix' label/attribute should
-- have a value of type 'Matrix 3 3 r'.
type family AttrMap (r :: *) (l :: AttributeUniverse) :: * where
AttrMap r 'Layer = LayerName
AttrMap r AT.Matrix = Matrix 3 3 r
AttrMap r Pin = PinType
AttrMap r Transformations = TransformationTypes
AttrMap r Stroke = IpeColor r
AttrMap r Pen = IpePen r
AttrMap r Fill = IpeColor r
AttrMap r Size = IpeSize r
AttrMap r Dash = IpeDash r
AttrMap r LineCap = Int
AttrMap r LineJoin = Int
AttrMap r FillRule = FillType
AttrMap r Arrow = IpeArrow r
AttrMap r RArrow = IpeArrow r
AttrMap r Opacity = IpeOpacity
AttrMap r Tiling = IpeTiling
AttrMap r Gradient = IpeGradient
AttrMap r Clip = Path r -- strictly we event want this to be a closed path I guess
genDefunSymbols [''AttrMap]
--------------------------------------------------------------------------------
-- | For the types representing attribute values we can get the name/key to use
-- when serializing to ipe.
class TraverseIpeAttr (a :: AttributeUniverse) where
traverseIpeAttr :: Applicative h
=> (r -> h s) -> Attr (AttrMapSym1 r) a -> h (Attr (AttrMapSym1 s) a)
-- attrName :: proxy a -> Text
-- CommonAttributeUnivers
instance TraverseIpeAttr Layer where traverseIpeAttr _ = pureAttr
instance TraverseIpeAttr AT.Matrix where traverseIpeAttr f = traverseAttr (traverse f)
instance TraverseIpeAttr Pin where traverseIpeAttr _ = pureAttr
instance TraverseIpeAttr Transformations where traverseIpeAttr _ = pureAttr
-- -- IpeSymbolAttributeUniversre
instance TraverseIpeAttr Stroke where traverseIpeAttr f = traverseAttr (traverse f)
instance TraverseIpeAttr Fill where traverseIpeAttr f = traverseAttr (traverse f)
instance TraverseIpeAttr Pen where traverseIpeAttr f = traverseAttr (traverse f)
instance TraverseIpeAttr Size where traverseIpeAttr f = traverseAttr (traverse f)
-- -- PathAttributeUniverse
instance TraverseIpeAttr Dash where traverseIpeAttr f = traverseAttr (traverse f)
instance TraverseIpeAttr LineCap where traverseIpeAttr _ = pureAttr
instance TraverseIpeAttr LineJoin where traverseIpeAttr _ = pureAttr
instance TraverseIpeAttr FillRule where traverseIpeAttr _ = pureAttr
instance TraverseIpeAttr Arrow where traverseIpeAttr f = traverseAttr (traverse f)
instance TraverseIpeAttr RArrow where traverseIpeAttr f = traverseAttr (traverse f)
instance TraverseIpeAttr Opacity where traverseIpeAttr _ = pureAttr
instance TraverseIpeAttr Tiling where traverseIpeAttr _ = pureAttr
instance TraverseIpeAttr Gradient where traverseIpeAttr _ = pureAttr
-- GroupAttributeUniverse
instance TraverseIpeAttr Clip where traverseIpeAttr f = traverseAttr (traverse f)
--------------------------------------------------------------------------------
-- | Groups and Objects
--------------------------------------------------------------------------------
-- | Group Attributes
-- -- | Now that we know what a Path is we can define the Attributes of a Group.
-- type family GroupAttrElf (r :: *) (s :: GroupAttributeUniverse) :: * where
-- GroupAttrElf r Clip = Path r -- strictly we event want this to be a closed path I guess
-- genDefunSymbols [''GroupAttrElf]
-- type GroupAttributes r = Attributes (GroupAttrElfSym1 r) '[ 'Clip]
-- | A group is essentially a list of IpeObjects.
newtype Group r = Group [IpeObject r] deriving (Show,Eq,Functor,Foldable,Traversable)
type instance NumType (Group r) = r
type instance Dimension (Group r) = 2
instance Fractional r => IsTransformable (Group r) where
transformBy t (Group s) = Group $ fmap (transformBy t) s
type family AttributesOf (t :: * -> *) :: [AttributeUniverse] where
AttributesOf Group = GroupAttributes
AttributesOf Image = CommonAttributes
AttributesOf TextLabel = CommonAttributes
AttributesOf MiniPage = CommonAttributes
AttributesOf IpeSymbol = SymbolAttributes
AttributesOf Path = PathAttributes
-- | Attributes' :: * -> [AttributeUniverse] -> *
type Attributes' r = Attributes (AttrMapSym1 r)
type IpeAttributes g r = Attributes' r (AttributesOf g)
-- | An IpeObject' is essentially the oject ogether with its attributes
type IpeObject' g r = g r :+ IpeAttributes g r
attributes :: Lens' (IpeObject' g r) (IpeAttributes g r)
attributes = extra
-- | traverse for ipe attributes
traverseIpeAttrs :: ( Applicative f
, AllConstrained TraverseIpeAttr (AttributesOf g)
) => proxy g -> (r -> f s) -> IpeAttributes g r -> f (IpeAttributes g s)
traverseIpeAttrs _ f (Attrs ats) = fmap Attrs . traverseIpeAttrs' f $ ats
traverseIpeAttrs' :: ( Applicative f
, AllConstrained TraverseIpeAttr ats
)
=> (r -> f s)
-> Rec (Attr (AttrMapSym1 r)) ats
-> f (Rec (Attr (AttrMapSym1 s)) ats)
traverseIpeAttrs' f = \case
RNil -> pure RNil
(a :& ats') -> (:&) <$> traverseIpeAttr f a <*> traverseIpeAttrs' f ats'
data IpeObject r =
IpeGroup (IpeObject' Group r)
| IpeImage (IpeObject' Image r)
| IpeTextLabel (IpeObject' TextLabel r)
| IpeMiniPage (IpeObject' MiniPage r)
| IpeUse (IpeObject' IpeSymbol r)
| IpePath (IpeObject' Path r)
traverseIpeObject' :: forall g r f s. ( Applicative f
, Traversable g
, AllConstrained TraverseIpeAttr (AttributesOf g)
)
=> (r -> f s) -> IpeObject' g r -> f (IpeObject' g s)
traverseIpeObject' f (i :+ ats) = (:+) <$> traverse f i <*> traverseIpeAttrs (Proxy @g) f ats
instance Functor IpeObject where
fmap = fmapDefault
instance Foldable IpeObject where
foldMap = foldMapDefault
instance Traversable IpeObject where
traverse f = \case
IpeGroup g -> IpeGroup <$> traverseIpeObject' f g
IpeImage i -> IpeImage <$> traverseIpeObject' f i
IpeTextLabel l -> IpeTextLabel <$> traverseIpeObject' f l
IpeMiniPage p -> IpeMiniPage <$> traverseIpeObject' f p
IpeUse u -> IpeUse <$> traverseIpeObject' f u
IpePath p -> IpePath <$> traverseIpeObject' f p
deriving instance (Show r) => Show (IpeObject r)
-- deriving instance (Read r) => Read (IpeObject r)
deriving instance (Eq r) => Eq (IpeObject r)
type instance NumType (IpeObject r) = r
type instance Dimension (IpeObject r) = 2
makePrisms ''IpeObject
groupItems :: Lens (Group r) (Group s) [IpeObject r] [IpeObject s]
groupItems = lens (\(Group xs) -> xs) (const Group)
class ToObject i where
mkIpeObject :: IpeObject' i r -> IpeObject r
instance ToObject Group where mkIpeObject = IpeGroup
instance ToObject Image where mkIpeObject = IpeImage
instance ToObject TextLabel where mkIpeObject = IpeTextLabel
instance ToObject MiniPage where mkIpeObject = IpeMiniPage
instance ToObject IpeSymbol where mkIpeObject = IpeUse
instance ToObject Path where mkIpeObject = IpePath
instance Fractional r => IsTransformable (IpeObject r) where
transformBy t (IpeGroup i) = IpeGroup $ i&core %~ transformBy t
transformBy t (IpeImage i) = IpeImage $ i&core %~ transformBy t
transformBy t (IpeTextLabel i) = IpeTextLabel $ i&core %~ transformBy t
transformBy t (IpeMiniPage i) = IpeMiniPage $ i&core %~ transformBy t
transformBy t (IpeUse i) = IpeUse $ i&core %~ transformBy t
transformBy t (IpePath i) = IpePath $ i&core %~ transformBy t
-- | Shorthand for constructing ipeObjects
ipeObject' :: ToObject i => i r -> IpeAttributes i r -> IpeObject r
ipeObject' i a = mkIpeObject $ i :+ a
commonAttributes :: Lens' (IpeObject r) (Attributes (AttrMapSym1 r) CommonAttributes)
commonAttributes = lens (Attrs . g) (\x (Attrs a) -> s x a)
where
select :: (CommonAttributes ⊆ AttributesOf g) =>
Lens' (IpeObject' g r) (Rec (Attr (AttrMapSym1 r)) CommonAttributes)
select = attributes.unAttrs.rsubset
g (IpeGroup i) = i^.select
g (IpeImage i) = i^.select
g (IpeTextLabel i) = i^.select
g (IpeMiniPage i) = i^.select
g (IpeUse i) = i^.select
g (IpePath i) = i^.select
s (IpeGroup i) a = IpeGroup $ i&select .~ a
s (IpeImage i) a = IpeImage $ i&select .~ a
s (IpeTextLabel i) a = IpeTextLabel $ i&select .~ a
s (IpeMiniPage i) a = IpeMiniPage $ i&select .~ a
s (IpeUse i) a = IpeUse $ i&select .~ a
s (IpePath i) a = IpePath $ i&select .~ a
-- | collect all non-group objects
flattenGroups :: [IpeObject r] -> [IpeObject r]
flattenGroups = concatMap flattenGroups'
where
flattenGroups' :: IpeObject r -> [IpeObject r]
flattenGroups' (IpeGroup (Group gs :+ ats)) =
map (applyAts ats) . concatMap flattenGroups' $ gs
where
applyAts _ = id
flattenGroups' o = [o]