hgeometry-0.6.0.0: src/Data/Geometry/Ipe/Attributes.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Geometry.Ipe.Attributes where
import Control.Lens hiding (rmap, Const)
import Data.Semigroup
import Data.Singletons
import Data.Singletons.TH
import Data.Text(Text)
import Data.Vinyl
import Data.Vinyl.Functor
import Data.Vinyl.TypeLevel
import GHC.Exts
--------------------------------------------------------------------------------
data AttributeUniverse = -- common
Layer | Matrix | Pin | Transformations
-- symbol
| Stroke | Fill | Pen | Size
-- Path
| Dash | LineCap | LineJoin
| FillRule | Arrow | RArrow | Opacity | Tiling | Gradient
-- Group
| Clip
-- Extra
-- | X Text
deriving (Show,Read,Eq)
genSingletons [ ''AttributeUniverse ]
type CommonAttributes = [ Layer, Matrix, Pin, Transformations ]
type TextLabelAttributes = CommonAttributes
type MiniPageAttributes = CommonAttributes
type ImageAttributes = CommonAttributes
type SymbolAttributes = CommonAttributes ++
[Stroke, Fill, Pen, Size]
type PathAttributes = CommonAttributes ++
[ Stroke, Fill, Dash, Pen, LineCap, LineJoin
, FillRule, Arrow, RArrow, Opacity, Tiling, Gradient
]
type GroupAttributes = CommonAttributes ++ '[ 'Clip]
-- | Attr implements the mapping from labels to types as specified by the
-- (symbol representing) the type family 'f'
newtype Attr (f :: TyFun u * -> *) -- Symbol repr. the Type family mapping
-- Labels in universe u to concrete types
(label :: u) = GAttr { _getAttr :: Maybe (Apply f label) }
deriving instance Show (Apply f label) => Show (Attr f label)
deriving instance Read (Apply f label) => Read (Attr f label)
deriving instance Eq (Apply f label) => Eq (Attr f label)
deriving instance Ord (Apply f label) => Ord (Attr f label)
makeLenses ''Attr
pattern Attr x = GAttr (Just x)
pattern NoAttr = GAttr Nothing
-- | Give pref. to the *RIGHT*
instance Monoid (Attr f l) where
mempty = NoAttr
_ `mappend` b@(Attr _) = b
a `mappend` _ = a
newtype Attributes (f :: TyFun u * -> *) (ats :: [u]) =
Attrs { _unAttrs :: Rec (Attr f) ats }
makeLenses ''Attributes
-- type All' c i = RecAll (Attr (IpeObjectSymbolF i)) (IpeObjectAttrF i) c
-- deriving instance All' Show atsShow (Attributes f ats)
deriving instance (RecAll (Attr f) ats Show) => Show (Attributes f ats)
instance (RecAll (Attr f) ats Eq) => Eq (Attributes f ats) where
(Attrs a) == (Attrs b) = and . recordToList
. zipRecsWith (\x (Compose (Dict y)) -> Const $ x == y) a
. (reifyConstraint (Proxy :: Proxy Eq)) $ b
instance RecApplicative ats => Monoid (Attributes f ats) where
mempty = Attrs $ rpure mempty
a `mappend` b = a <> b
instance Semigroup (Attributes f ats) where
(Attrs as) <> (Attrs bs) = Attrs $ zipRecsWith mappend as bs
zipRecsWith :: (forall a. f a -> g a -> h a)
-> Rec f as -> Rec g as -> Rec h as
zipRecsWith _ RNil _ = RNil
zipRecsWith f (r :& rs) (s :& ss) = f r s :& zipRecsWith f rs ss
attrLens :: (at ∈ ats) => proxy at -> Lens' (Attributes f ats) (Maybe (Apply f at))
attrLens p = unAttrs.rlens p.getAttr
lookupAttr :: (at ∈ ats) => proxy at -> Attributes f ats -> Maybe (Apply f at)
lookupAttr p = view (attrLens p)
setAttr :: forall proxy at ats f. (at ∈ ats)
=> proxy at -> Apply f at -> Attributes f ats -> Attributes f ats
setAttr _ a (Attrs r) = Attrs $ rput (Attr a :: Attr f at) r
-- | gets and removes the attribute from Attributes
takeAttr :: forall proxy at ats f. (at ∈ ats)
=> proxy at -> Attributes f ats -> ( Maybe (Apply f at)
, Attributes f ats )
takeAttr p ats = (lookupAttr p ats, ats&attrLens p .~ Nothing)
-- | unsets/Removes an attribute
unSetAttr :: forall proxy at ats f. (at ∈ ats)
=> proxy at -> Attributes f ats -> Attributes f ats
unSetAttr p = snd . takeAttr p
attr :: (at ∈ ats, RecApplicative ats)
=> proxy at -> Apply f at -> Attributes f ats
attr p x = setAttr p x mempty
--------------------------------------------------------------------------------
-- | Common Attributes
-- IpeObjects may have attributes. Essentially attributes are (key,value)
-- pairs. The key is some name. Which attributes an object can have depends on
-- the type of the object. However, all ipe objects support the following
-- 'common attributes':
-- data CommonAttributeUniverse = Layer | Matrix | Pin | Transformations
-- deriving (Show,Read,Eq)
-- | Possible values for Pin
data PinType = No | Yes | Horizontal | Vertical
deriving (Eq,Show,Read)
-- | Possible values for Transformation
data TransformationTypes = Affine | Rigid | Translations deriving (Show,Read,Eq)
-- type family CommonAttrElf (r :: *) (f :: CommonAttributeUniverse)where
-- CommonAttrElf r 'Layer = Text
-- CommonAttrElf r 'Matrix = Matrix 3 3 r
-- CommonAttrElf r Pin = PinType
-- CommonAttrElf r Transformations = TransformationTypes
-- genDefunSymbols [''CommonAttrElf]
-- type CommonAttributes r =
-- Attributes (CommonAttrElfSym1 r) [ 'Layer, 'Matrix, Pin, Transformations ]
--------------------------------------------------------------------------------
-- Text Attributes
-- these Attributes are speicifc to IpeObjects representing TextLabels and
-- MiniPages. The same structure as for the `CommonAttributes' applies here.
-- | TODO
--------------------------------------------------------------------------------
-- | Symbol Attributes
-- | The optional Attributes for a symbol
-- data SymbolAttributeUniverse = SymbolStroke | SymbolFill | SymbolPen | Size
-- deriving (Show,Eq)
-- | Many types either consist of a symbolc value, or a value of type v
data IpeValue v = Named Text | Valued v deriving (Show,Eq,Ord)
instance IsString (IpeValue v) where
fromString = Named . fromString
type Colour = Text -- TODO: Make this a Colour.Colour
newtype IpeSize r = IpeSize (IpeValue r) deriving (Show,Eq,Ord)
newtype IpePen r = IpePen (IpeValue r) deriving (Show,Eq,Ord)
newtype IpeColor = IpeColor (IpeValue Colour) deriving (Show,Eq,Ord)
-- -- | And the corresponding types
-- type family SymbolAttrElf (r :: *) (s :: SymbolAttributeUniverse) :: * where
-- SymbolAttrElf r SymbolStroke = IpeColor
-- SymbolAttrElf r SymbolPen = IpePen r
-- SymbolAttrElf r SymbolFill = IpeColor
-- SymbolAttrElf r Size = IpeSize r
-- genDefunSymbols [''SymbolAttrElf]
-- type SymbolAttributes r = [SymbolStroke, SymbolFill, SymbolPen, Size]
-- type SymbolAttributes r =
-- Attributes (SymbolAttrElfSym1 r) [SymbolStroke, SymbolFill, SymbolPen, Size]
-------------------------------------------------------------------------------
-- | Path Attributes
-- | Possible attributes for a path
-- data PathAttributeUniverse = Stroke | Fill | Dash | Pen | LineCap | LineJoin
-- | FillRule | Arrow | RArrow | Opacity | Tiling | Gradient
-- deriving (Show,Eq)
-- | Possible values for Dash
data IpeDash r = DashNamed Text
| DashPattern [r] r
deriving (Show,Eq)
-- | Allowed Fill types
data FillType = Wind | EOFill deriving (Show,Read,Eq)
-- | IpeOpacity, IpeTyling, and IpeGradient are all symbolic values
type IpeOpacity = Text
type IpeTiling = Text
type IpeGradient = Text
-- | Possible values for an ipe arrow
data IpeArrow r = IpeArrow { _arrowName :: Text
, _arrowSize :: IpeSize r
} deriving (Show,Eq)
makeLenses ''IpeArrow
normalArrow :: IpeArrow r
normalArrow = IpeArrow "normal" (IpeSize $ Named "normal/normal")
-- -- | and their types
-- type family PathAttrElf (r :: *) (s :: PathAttributeUniverse) :: * where
-- PathAttrElf r Stroke = IpeColor
-- PathAttrElf r Fill = IpeColor
-- PathAttrElf r Dash = IpeDash r
-- PathAttrElf r Pen = IpePen r
-- PathAttrElf r LineCap = Int
-- PathAttrElf r LineJoin = Int
-- PathAttrElf r FillRule = FillType
-- PathAttrElf r Arrow = IpeArrow r
-- PathAttrElf r RArrow = IpeArrow r
-- PathAttrElf r Opacity = IpeOpacity
-- PathAttrElf r Tiling = IpeTiling
-- PathAttrElf r Gradient = IpeGradient
-- genDefunSymbols [''PathAttrElf]
-- type PathAttributes r = [ Stroke, Fill, Dash, Pen, LineCap, LineJoin
-- , FillRule, Arrow, RArrow, Opacity, Tiling, Gradient
-- ]
-- type PathAttributes r =
-- Attributes (PathAttrElfSym1 r) [ Stroke, Fill, Dash, Pen, LineCap, LineJoin
-- , FillRule, Arrow, RArrow, Opacity, Tiling, Gradient
-- ]
--------------------------------------------------------------------------------
-- | Group Attributes
-- | The only group attribute is a Clip
-- data GroupAttributeUniverse = Clip deriving (Show,Read,Eq,Ord)
-- A clipping path is a Path. Which is defined in Data.Geometry.Ipe.Types. To
-- avoid circular imports, we define GroupAttrElf and GroupAttribute there.
--------------------------------------------------------------------------------
-- * Attribute names in Ipe
-- | For the types representing attribute values we can get the name/key to use
-- when serializing to ipe.
class IpeAttrName (a :: AttributeUniverse) where
attrName :: Proxy a -> Text
-- CommonAttributeUnivers
instance IpeAttrName Layer where attrName _ = "layer"
instance IpeAttrName Matrix where attrName _ = "matrix"
instance IpeAttrName Pin where attrName _ = "pin"
instance IpeAttrName Transformations where attrName _ = "transformations"
-- IpeSymbolAttributeUniversre
instance IpeAttrName Stroke where attrName _ = "stroke"
instance IpeAttrName Fill where attrName _ = "fill"
instance IpeAttrName Pen where attrName _ = "pen"
instance IpeAttrName Size where attrName _ = "size"
-- PathAttributeUniverse
instance IpeAttrName Dash where attrName _ = "dash"
instance IpeAttrName LineCap where attrName _ = "cap"
instance IpeAttrName LineJoin where attrName _ = "join"
instance IpeAttrName FillRule where attrName _ = "fillrule"
instance IpeAttrName Arrow where attrName _ = "arrow"
instance IpeAttrName RArrow where attrName _ = "rarrow"
instance IpeAttrName Opacity where attrName _ = "opacity"
instance IpeAttrName Tiling where attrName _ = "tiling"
instance IpeAttrName Gradient where attrName _ = "gradient"
-- GroupAttributeUniverse
instance IpeAttrName Clip where attrName _ = "clip"
-- | Wrap up a value with a capability given by its type
data GDict (c :: k -> Constraint) (a :: k) where
GDict :: c a => Proxy a -> GDict c a
-- -- | Sometimes we may know something for /all/ fields of a record, but when
-- -- you expect to be able to /each/ of the fields, you are then out of luck.
-- -- Surely given @∀x:u.φ(x)@ we should be able to recover @x:u ⊢ φ(x)@! Sadly,
-- -- the constraint solver is not quite smart enough to realize this and we must
-- -- make it patently obvious by reifying the constraint pointwise with proof.
-- gReifyConstraint
-- :: RecAll f rs c
-- => proxy c
-- -> Rec f rs
-- -> Rec (GDict c :. f) rs
-- gReifyConstraint prx RNil = RNil
-- gReifyConstraint prx (x :& xs) = Compose (mkDict x) :& reifyConstraint prx xs
-- where
-- mkDict :: f l -> (GDict c l)
-- mkDict _ = GDict (Proxy :: Proxy l)
-- | Function that states that all elements in xs satisfy a given constraint c
type family AllSatisfy (c :: k -> Constraint) (xs :: [k]) :: Constraint where
AllSatisfy c '[] = ()
AllSatisfy c (x ': xs) = (c x, AllSatisfy c xs)
-- | Writing Attribute names
writeAttrNames :: AllSatisfy IpeAttrName rs => Rec f rs -> Rec (Const Text) rs
writeAttrNames RNil = RNil
writeAttrNames (x :& xs) = Const (write'' x) :& writeAttrNames xs
where
write'' :: forall f s. IpeAttrName s => f s -> Text
write'' _ = attrName (Proxy :: Proxy s)
--