{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE OverloadedStrings          #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  HGeometry.Miso.Svg.Writer
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- Render geometric objects to Svg files through miso
--
--------------------------------------------------------------------------------
module HGeometry.Miso.Svg.Writer
  ( withAts
  , Drawable(..)

  , dPoint
  , dLineSegment
  , dRectangle
  , dCircle
  , dDisk
  , dPolyLine
  , dSimplePolygon
  ) where

import           Control.Lens hiding (Const,rmap)
import qualified Data.Foldable as F
import           Data.Maybe (catMaybes)
import           Data.Proxy
import           Data.Vinyl hiding (Label)
import           Data.Vinyl.Functor
import           Data.Vinyl.TypeLevel
import           HGeometry.Ball
import           HGeometry.Box
import           HGeometry.Ext
import           HGeometry.Foldable.Util
import           HGeometry.LineSegment
import           HGeometry.Miso.OrphanInstances ()
import           HGeometry.Point
import           HGeometry.PolyLine
import           HGeometry.Polygon.Convex
import           HGeometry.Polygon.Simple
import           HGeometry.Vector
import qualified Ipe
import qualified Ipe.Attributes as IA
import           Miso (Attribute, View, text)
import           Miso.String (MisoString, ToMisoString(..), ms)
import qualified Miso.String.Util as MisoString
import           Miso.Svg
import           Miso.Svg.Property
import           Miso.Html.Property (width_,height_) -- not sure if this is correct (namespace)!

--------------------------------------------------------------------------------


-- | Helper function to construct drawing functions. I..e it allows
-- you do pre-specify a bunch of attributes that should be drawn
-- (ats1) yet allow more attributes to be added by the user later.
withAts             ::  ([Attribute action] -> View model action)
                    -> [Attribute action] -> [Attribute action] -> View model action
withAts :: forall action model.
([Attribute action] -> View model action)
-> [Attribute action] -> [Attribute action] -> View model action
withAts [Attribute action] -> View model action
f [Attribute action]
ats1 [Attribute action]
ats2 = [Attribute action] -> View model action
f ([Attribute action]
ats1 [Attribute action] -> [Attribute action] -> [Attribute action]
forall a. Semigroup a => a -> a -> a
<> [Attribute action]
ats2)

-- -- | Helper function to construct a View. See 'withAts' for its usage.
-- withAts'             :: ([Attribute action] -> View model action)
--                      -> [Attribute action]
--                      -> [Attribute action]
--                      -> View model action
-- withAts' f ats1 ats2 = f (ats1 <> ats2)

--------------------------------------------------------------------------------
-- * Default implementations for drawing geometric objects

-- | Default implementation for drawing geometric objects
class Drawable t where
  {-# MINIMAL draw | drawWith #-}
  -- | Draws the given object with the given attributes
  draw       :: t -> [Attribute action] -> View model action
  draw t
x [Attribute action]
ats = t -> [Attribute action] -> [View model action] -> View model action
forall t action model.
Drawable t =>
t -> [Attribute action] -> [View model action] -> View model action
forall action model.
t -> [Attribute action] -> [View model action] -> View model action
drawWith t
x [Attribute action]
ats []

  -- | draw the given object, as well as the given "children"
  drawWith          :: t -> [Attribute action] -> [View model action] -> View model action
  drawWith t
x [Attribute action]
ats [View model action]
_b = t -> [Attribute action] -> View model action
forall t action model.
Drawable t =>
t -> [Attribute action] -> View model action
forall action model. t -> [Attribute action] -> View model action
draw t
x [Attribute action]
ats

instance (Drawable l, Drawable r) => Drawable (Either l r) where
  draw :: forall action model.
Either l r -> [Attribute action] -> View model action
draw = (l -> [Attribute action] -> View model action)
-> (r -> [Attribute action] -> View model action)
-> Either l r
-> [Attribute action]
-> View model action
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either l -> [Attribute action] -> View model action
forall t action model.
Drawable t =>
t -> [Attribute action] -> View model action
forall action model. l -> [Attribute action] -> View model action
draw r -> [Attribute action] -> View model action
forall t action model.
Drawable t =>
t -> [Attribute action] -> View model action
forall action model. r -> [Attribute action] -> View model action
draw

instance ToMisoString r => Drawable (Point 2 r) where
  draw :: forall action model.
Point 2 r -> [Attribute action] -> View model action
draw = Point 2 r -> [Attribute action] -> View model action
forall point r action model.
(Point_ point 2 r, ToMisoString r) =>
point -> [Attribute action] -> View model action
dPoint

instance (Point_ point 2 r, ToMisoString r, Num r) => Drawable (Rectangle point) where
  draw :: forall action model.
Rectangle point -> [Attribute action] -> View model action
draw = Rectangle point -> [Attribute action] -> View model action
forall rectangle point r action model.
(Rectangle_ rectangle point, Point_ point 2 r, ToMisoString r,
 Num r) =>
rectangle -> [Attribute action] -> View model action
dRectangle

instance ( Point_ point 2 r, EndPoint_ (endPoint point), IxValue (endPoint point) ~ point
         , ToMisoString r) => Drawable (LineSegment endPoint point) where
  draw :: forall action model.
LineSegment endPoint point
-> [Attribute action] -> View model action
draw = LineSegment endPoint point
-> [Attribute action] -> View model action
forall lineSegment point r action model.
(LineSegment_ lineSegment point, Point_ point 2 r,
 ToMisoString r) =>
lineSegment -> [Attribute action] -> View model action
dLineSegment

instance ( Point_ point 2 r, ToMisoString r
         , Traversable1 f
         , Ixed (f point), IxValue (f point) ~ point, Index (f point) ~ Int
         , HasFromFoldable1 f
         , TraversableWithIndex Int f
         ) => Drawable (PolyLineF f point) where
  draw :: forall action model.
PolyLineF f point -> [Attribute action] -> View model action
draw = PolyLineF f point -> [Attribute action] -> View model action
forall polyLine point r action model.
(PolyLine_ polyLine point, Point_ point 2 r, ToMisoString r) =>
polyLine -> [Attribute action] -> View model action
dPolyLine

instance ( Point_ point 2 r, VertexContainer f point, HasFromFoldable1 f
         , ToMisoString r) => Drawable (SimplePolygonF f point) where
 draw :: forall action model.
SimplePolygonF f point -> [Attribute action] -> View model action
draw = SimplePolygonF f point -> [Attribute action] -> View model action
forall simplePolygon point r action model.
(SimplePolygon_ simplePolygon point r, ToMisoString r) =>
simplePolygon -> [Attribute action] -> View model action
dSimplePolygon

instance ( Point_ point 2 r, VertexContainer f point, HasFromFoldable1 f
         , ToMisoString r) => Drawable (ConvexPolygonF f point) where
  draw :: forall action model.
ConvexPolygonF f point -> [Attribute action] -> View model action
draw = SimplePolygonF f point -> [Attribute action] -> View model action
forall simplePolygon point r action model.
(SimplePolygon_ simplePolygon point r, ToMisoString r) =>
simplePolygon -> [Attribute action] -> View model action
dSimplePolygon (SimplePolygonF f point -> [Attribute action] -> View model action)
-> (ConvexPolygonF f point -> SimplePolygonF f point)
-> ConvexPolygonF f point
-> [Attribute action]
-> View model action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConvexPolygonF f point -> SimplePolygonF f point
forall {k} (f :: k -> *) (point :: k).
ConvexPolygonF f point -> SimplePolygonF f point
toSimplePolygon

instance (Point_ point 2 r, ToMisoString r, Floating r) => Drawable (Circle point) where
  draw :: forall action model.
Circle point -> [Attribute action] -> View model action
draw = Circle point -> [Attribute action] -> View model action
forall point r action model.
(Point_ point 2 r, ToMisoString r) =>
Circle point -> [Attribute action] -> View model action
dCircle

instance (Point_ point 2 r, ToMisoString r, Floating r) => Drawable (Disk point) where
  draw :: forall action model.
Disk point -> [Attribute action] -> View model action
draw = Disk point -> [Attribute action] -> View model action
forall disk point r action model.
(Disk_ disk point, ConstructableBall_ disk point, Point_ point 2 r,
 ToMisoString r, Floating r) =>
disk -> [Attribute action] -> View model action
dDisk

-- instance ToMisoString r => Drawable (Viewport r) where
--   draw = error
--   drawWith vp ats content = withAts' svg_ [ height_ $ ms h <> "px"
--                                           , viewbox_ outerVB
--                                           ] ats
--                                           [ g_ [] -- do the transorm here
--                                                [ svg_ [ width_ "100%"
--                                                       , height "100%"
--                                                       , viewbox innerVB
--                                                       ]
--                                                       content
--                                                ]
--                                           ]
--     where
--       toVB = MisoString.unwords . map ms
--       outerVB = toVB [0, (-1) * h, w, h]
--             -- the role of the outer viewBox is to flip the coordinate
--             -- system s.t. the origin is in the bottom left rather
--             -- than the top-left
--       innerVB = toVB [lx, ly, vw, vh]




--------------------------------------------------------------------------------
-- * Functions to draw geometric objects

-- | Draw a point
dPoint   :: (Point_ point 2 r, ToMisoString r) => point -> [Attribute action] -> View model action
dPoint :: forall point r action model.
(Point_ point 2 r, ToMisoString r) =>
point -> [Attribute action] -> View model action
dPoint point
p = ([Attribute action] -> View model action)
-> [Attribute action] -> [Attribute action] -> View model action
forall action model.
([Attribute action] -> View model action)
-> [Attribute action] -> [Attribute action] -> View model action
withAts [Attribute action] -> View model action
forall action model. [Attribute action] -> View model action
ellipse_ [ MisoString -> Attribute action
forall action. MisoString -> Attribute action
cx_ (r -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (r -> MisoString) -> r -> MisoString
forall a b. (a -> b) -> a -> b
$ point
ppoint -> Getting r point r -> r
forall s a. s -> Getting a s a -> a
^.Getting r point r
forall (d :: Nat) point r.
(1 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int point r
xCoord), MisoString -> Attribute action
forall action. MisoString -> Attribute action
cy_ (r -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (r -> MisoString) -> r -> MisoString
forall a b. (a -> b) -> a -> b
$ point
ppoint -> Getting r point r -> r
forall s a. s -> Getting a s a -> a
^.Getting r point r
forall (d :: Nat) point r.
(2 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int point r
yCoord)
                            , MisoString -> Attribute action
forall action. MisoString -> Attribute action
rx_ MisoString
"5", MisoString -> Attribute action
forall action. MisoString -> Attribute action
ry_ MisoString
"5"
                            ]

-- | Draw a rectangle
dRectangle   :: ( Rectangle_ rectangle point, Point_ point 2 r, ToMisoString r, Num r)
             => rectangle -> [Attribute action] -> View model action
dRectangle :: forall rectangle point r action model.
(Rectangle_ rectangle point, Point_ point 2 r, ToMisoString r,
 Num r) =>
rectangle -> [Attribute action] -> View model action
dRectangle rectangle
b = let Point2 MisoString
x MisoString
y  = ASetter (Point 2 r) (Point 2 MisoString) r MisoString
-> (r -> MisoString) -> Point 2 r -> Point 2 MisoString
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Point 2 r) (Point 2 MisoString) r MisoString
(NumType (Point 2 r) -> Identity (NumType (Point 2 MisoString)))
-> Point 2 r -> Identity (Point 2 MisoString)
forall point point'.
HasCoordinates point point' =>
IndexedTraversal1 Int point point' (NumType point) (NumType point')
IndexedTraversal1
  Int
  (Point 2 r)
  (Point 2 MisoString)
  (NumType (Point 2 r))
  (NumType (Point 2 MisoString))
coordinates r -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (Point 2 r -> Point 2 MisoString)
-> Point 2 r -> Point 2 MisoString
forall a b. (a -> b) -> a -> b
$ rectangle
brectangle -> Getting (Point 2 r) rectangle (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.(point -> Const (Point 2 r) point)
-> rectangle -> Const (Point 2 r) rectangle
forall box point. HasMinPoint box point => Lens' box point
Lens' rectangle point
minPoint((point -> Const (Point 2 r) point)
 -> rectangle -> Const (Point 2 r) rectangle)
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> point -> Const (Point 2 r) point)
-> Getting (Point 2 r) rectangle (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> point -> Const (Point 2 r) point
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point 2 r)
asPoint
                   Vector2 MisoString
w MisoString
h = r -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (r -> MisoString) -> Vector 2 r -> Vector 2 MisoString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> rectangle
brectangle
-> Getting (Vector 2 r) rectangle (Vector 2 r) -> Vector 2 r
forall s a. s -> Getting a s a -> a
^.(rectangle -> Vector 2 r)
-> Getting (Vector 2 r) rectangle (Vector 2 r)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to rectangle -> Vector 2 r
forall box (d :: Nat) point r.
(Box_ box point, Point_ point d r, Num r, Functor (Vector d)) =>
box -> Vector d r
size
               in ([Attribute action] -> View model action)
-> [Attribute action] -> [Attribute action] -> View model action
forall action model.
([Attribute action] -> View model action)
-> [Attribute action] -> [Attribute action] -> View model action
withAts [Attribute action] -> View model action
forall action model. [Attribute action] -> View model action
rect_ [ MisoString -> Attribute action
forall action. MisoString -> Attribute action
x_ MisoString
x, MisoString -> Attribute action
forall action. MisoString -> Attribute action
y_ MisoString
y, MisoString -> Attribute action
forall action. MisoString -> Attribute action
width_ MisoString
w, MisoString -> Attribute action
forall action. MisoString -> Attribute action
height_ MisoString
h, MisoString -> Attribute action
forall action. MisoString -> Attribute action
fill_ MisoString
"none"]

-- | Draw a simple polygon
dSimplePolygon    :: (SimplePolygon_ simplePolygon point r, ToMisoString r)
                  => simplePolygon -> [Attribute action] -> View model action
dSimplePolygon :: forall simplePolygon point r action model.
(SimplePolygon_ simplePolygon point r, ToMisoString r) =>
simplePolygon -> [Attribute action] -> View model action
dSimplePolygon simplePolygon
pg = ([Attribute action] -> View model action)
-> [Attribute action] -> [Attribute action] -> View model action
forall action model.
([Attribute action] -> View model action)
-> [Attribute action] -> [Attribute action] -> View model action
withAts [Attribute action] -> View model action
forall action model. [Attribute action] -> View model action
polygon_ [MisoString -> Attribute action
forall action. MisoString -> Attribute action
points_ (MisoString -> Attribute action) -> MisoString -> Attribute action
forall a b. (a -> b) -> a -> b
$ [point] -> MisoString
forall point r (f :: * -> *).
(Point_ point 2 r, ToMisoString r, Foldable f) =>
f point -> MisoString
toPointsString ([point] -> MisoString) -> [point] -> MisoString
forall a b. (a -> b) -> a -> b
$ simplePolygon
pgsimplePolygon
-> Getting (Endo [point]) simplePolygon point -> [point]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^..Getting (Endo [point]) simplePolygon point
(Vertex simplePolygon
 -> Const (Endo [point]) (Vertex simplePolygon))
-> simplePolygon -> Const (Endo [point]) simplePolygon
forall graph graph'.
HasVertices graph graph' =>
IndexedTraversal1
  (VertexIx graph) graph graph' (Vertex graph) (Vertex graph')
IndexedTraversal1
  (VertexIx simplePolygon)
  simplePolygon
  simplePolygon
  (Vertex simplePolygon)
  (Vertex simplePolygon)
vertices ]


  -- \case
  --   SimplePolygon vs   ->
  --   MultiPolygon vs hs -> withAts path_ [d_ s]
  --     where
  --       s = mconcat . map toSimplePolygonPathString $ vs : hs


-- toSimplePolygonPathString                    :: ToMisoString r => SimplePolygon p r -> MisoString
-- toSimplePolygonPathString (SimplePolygon vs) = mconcat [ "M", toOp p
--                                                        , mconcat $ map (\q -> "L" <> toOp q) ps
--                                                        , "Z"
--                                                        ]
  -- where
  --   p :| ps = F1.toNonEmpty vs
  --   toOp (Point2 x y :+ _) = ms x <> " " <> ms y <> " "


-- | Draw a polyline
dPolyLine    :: (PolyLine_ polyLine point, Point_ point 2 r, ToMisoString r)
             => polyLine -> [Attribute action] -> View model action
dPolyLine :: forall polyLine point r action model.
(PolyLine_ polyLine point, Point_ point 2 r, ToMisoString r) =>
polyLine -> [Attribute action] -> View model action
dPolyLine polyLine
pl = ([Attribute action] -> View model action)
-> [Attribute action] -> [Attribute action] -> View model action
forall action model.
([Attribute action] -> View model action)
-> [Attribute action] -> [Attribute action] -> View model action
withAts [Attribute action] -> View model action
forall action model. [Attribute action] -> View model action
polyline_ [ MisoString -> Attribute action
forall action. MisoString -> Attribute action
points_ (MisoString -> Attribute action)
-> ([point] -> MisoString) -> [point] -> Attribute action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [point] -> MisoString
forall point r (f :: * -> *).
(Point_ point 2 r, ToMisoString r, Foldable f) =>
f point -> MisoString
toPointsString ([point] -> Attribute action) -> [point] -> Attribute action
forall a b. (a -> b) -> a -> b
$ polyLine
plpolyLine -> Getting (Endo [point]) polyLine point -> [point]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^..Getting (Endo [point]) polyLine point
(Vertex polyLine -> Const (Endo [point]) (Vertex polyLine))
-> polyLine -> Const (Endo [point]) polyLine
forall graph graph'.
HasVertices graph graph' =>
IndexedTraversal1
  (VertexIx graph) graph graph' (Vertex graph) (Vertex graph')
IndexedTraversal1
  (VertexIx polyLine)
  polyLine
  polyLine
  (Vertex polyLine)
  (Vertex polyLine)
vertices
                                 , MisoString -> Attribute action
forall action. MisoString -> Attribute action
fill_ MisoString
"none"
                                 ]

-- | Draw a line segment
dLineSegment   :: ( LineSegment_ lineSegment point, Point_ point 2 r, ToMisoString r)
               => lineSegment -> [Attribute action] -> View model action
dLineSegment :: forall lineSegment point r action model.
(LineSegment_ lineSegment point, Point_ point 2 r,
 ToMisoString r) =>
lineSegment -> [Attribute action] -> View model action
dLineSegment lineSegment
s = ([Attribute action] -> View model action)
-> [Attribute action] -> [Attribute action] -> View model action
forall action model.
([Attribute action] -> View model action)
-> [Attribute action] -> [Attribute action] -> View model action
withAts [Attribute action] -> View model action
forall action model. [Attribute action] -> View model action
polyline_ [ MisoString -> Attribute action
forall action. MisoString -> Attribute action
points_ (MisoString -> Attribute action) -> MisoString -> Attribute action
forall a b. (a -> b) -> a -> b
$ [point] -> MisoString
forall point r (f :: * -> *).
(Point_ point 2 r, ToMisoString r, Foldable f) =>
f point -> MisoString
toPointsString [lineSegment
slineSegment -> Getting point lineSegment point -> point
forall s a. s -> Getting a s a -> a
^.Getting point lineSegment point
forall seg p. HasStart seg p => Lens' seg p
Lens' lineSegment point
start, lineSegment
slineSegment -> Getting point lineSegment point -> point
forall s a. s -> Getting a s a -> a
^.Getting point lineSegment point
forall seg p. HasEnd seg p => Lens' seg p
Lens' lineSegment point
end] ]

-- | constructs a list of points to be used in the 'points' svg attribute.
toPointsString :: (Point_ point 2 r, ToMisoString r, Foldable f) => f point -> MisoString
toPointsString :: forall point r (f :: * -> *).
(Point_ point 2 r, ToMisoString r, Foldable f) =>
f point -> MisoString
toPointsString =
  [MisoString] -> MisoString
MisoString.unwords ([MisoString] -> MisoString)
-> (f point -> [MisoString]) -> f point -> MisoString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (point -> MisoString) -> [point] -> [MisoString]
forall a b. (a -> b) -> [a] -> [b]
map (\(Point2_ r
x r
y) -> [MisoString] -> MisoString
forall a. Monoid a => [a] -> a
mconcat [r -> MisoString
forall str. ToMisoString str => str -> MisoString
ms r
x, MisoString
",", r -> MisoString
forall str. ToMisoString str => str -> MisoString
ms r
y]) ([point] -> [MisoString])
-> (f point -> [point]) -> f point -> [MisoString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f point -> [point]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList


-- | Draw a circle
dCircle              :: (Point_ point 2 r, ToMisoString r)
                     => Circle point -> [Attribute action] -> View model action
dCircle :: forall point r action model.
(Point_ point 2 r, ToMisoString r) =>
Circle point -> [Attribute action] -> View model action
dCircle (Circle point
c NumType point
r) = ([Attribute action] -> View model action)
-> [Attribute action] -> [Attribute action] -> View model action
forall action model.
([Attribute action] -> View model action)
-> [Attribute action] -> [Attribute action] -> View model action
withAts [Attribute action] -> View model action
forall action model. [Attribute action] -> View model action
ellipse_ [ MisoString -> Attribute action
forall action. MisoString -> Attribute action
rx_ (MisoString -> Attribute action)
-> (NumType point -> MisoString)
-> NumType point
-> Attribute action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> MisoString
NumType point -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (NumType point -> Attribute action)
-> NumType point -> Attribute action
forall a b. (a -> b) -> a -> b
$ NumType point
r
                                         , MisoString -> Attribute action
forall action. MisoString -> Attribute action
ry_ (MisoString -> Attribute action)
-> (NumType point -> MisoString)
-> NumType point
-> Attribute action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> MisoString
NumType point -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (NumType point -> Attribute action)
-> NumType point -> Attribute action
forall a b. (a -> b) -> a -> b
$ NumType point
r
                                         , MisoString -> Attribute action
forall action. MisoString -> Attribute action
cx_ (MisoString -> Attribute action)
-> (r -> MisoString) -> r -> Attribute action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (r -> Attribute action) -> r -> Attribute action
forall a b. (a -> b) -> a -> b
$ point
cpoint -> Getting r point r -> r
forall s a. s -> Getting a s a -> a
^.Getting r point r
forall (d :: Nat) point r.
(1 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int point r
xCoord
                                         , MisoString -> Attribute action
forall action. MisoString -> Attribute action
cy_ (MisoString -> Attribute action)
-> (r -> MisoString) -> r -> Attribute action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (r -> Attribute action) -> r -> Attribute action
forall a b. (a -> b) -> a -> b
$ point
cpoint -> Getting r point r -> r
forall s a. s -> Getting a s a -> a
^.Getting r point r
forall (d :: Nat) point r.
(2 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int point r
yCoord
                                         , MisoString -> Attribute action
forall action. MisoString -> Attribute action
fill_ MisoString
"none"
                                         ]

-- | Draw a disk
dDisk             :: ( Disk_ disk point, ConstructableBall_ disk point
                     , Point_ point 2 r, ToMisoString r, Floating r)
                  => disk -> [Attribute action] -> View model action
dDisk :: forall disk point r action model.
(Disk_ disk point, ConstructableBall_ disk point, Point_ point 2 r,
 ToMisoString r, Floating r) =>
disk -> [Attribute action] -> View model action
dDisk (Disk_ point
c NumType disk
r) = Circle point -> [Attribute action] -> View model action
forall point r action model.
(Point_ point 2 r, ToMisoString r) =>
Circle point -> [Attribute action] -> View model action
dCircle (point -> NumType point -> Circle point
forall point. point -> NumType point -> Circle point
Circle point
c NumType disk
NumType point
r)

-- instance (ToMisoString r, Drawable v, Drawable  => Drawable (PlanarSubdivision s v e f r)


-- dPlanarSubdivision        :: PlanarSubdivision s (Maybe (View model action))
--                                                  (Maybe (View model action))
--                                                  (Maybe (View model action)) r
--                           -> [Attribute action] -> View model action
-- dPlanarSubdivision = dPlanarSubdivisionWith (^._2.vData) (^._2.extra) (^._2.extra)


-- -- | Draws only the values for which we have a Just attribute
-- dPlanarSubdivision' :: (ToMisoString r)
--                     => PlanarSubdivision s (Maybe (Ipe.IpeAttributes Ipe.IpeSymbol r))
--                                            (Maybe (Ipe.IpeAttributes Ipe.Path r))
--                                            (Maybe (Ipe.IpeAttributes Ipe.Path r)) r
--                     -> [Attribute action]
--                     -> View model action
-- dPlanarSubdivision' = dPlanarSubdivisionWith fv fe ff
--   where
--     fv (_,v) = (\ats -> draw (v^.location) (svgWriteAttrs ats)) <$> v^.vData
--     fe (_,e) = (\ats -> draw (e^.core)     (svgWriteAttrs ats)) <$> e^.extra
--     ff (_,f) = (\ats -> draw (f^.core)     (svgWriteAttrs ats)) <$> f^.extra


-- type DrawF a action = a -> Maybe (View model action)

-- dPlanarSubdivisionWith                 :: DrawF (VertexId' s, VertexData r v)          action
--                                        -> DrawF (Dart s,      LineSegment 2 v r :+ e)  action
--                                        -> DrawF (FaceId' s,   SomePolygon v r :+ f)    action
--                                        -> PlanarSubdivision s v e f r
--                                        -> [Attribute action]
--                                        -> View model action
-- dPlanarSubdivisionWith fv fe ff ps ats = g_ ats (fs <> es <> vs)
--     -- draw faces at the bottom, then edges, and finally the vertices
--   where
--     vs = mapMaybe fv . F.toList . vertices        $ ps
--     es = mapMaybe fe . F.toList . edgeSegments    $ ps
--     fs = mapMaybe ff . F.toList . rawFacePolygons $ ps

--------------------------------------------------------------------------------
-- * Functions to draw ipe objects

instance ToMisoString r => Drawable (Ipe.IpeObject r) where
  draw :: forall action model.
IpeObject r -> [Attribute action] -> View model action
draw = \case
    Ipe.IpeGroup IpeObject' Group r
g     -> (Group r
 :+ Attributes'
      r '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip])
-> [Attribute action] -> View model action
forall t action model.
Drawable t =>
t -> [Attribute action] -> View model action
forall action model.
(Group r
 :+ Attributes'
      r '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip])
-> [Attribute action] -> View model action
draw Group r
:+ Attributes' r '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip]
IpeObject' Group r
g
    Ipe.IpeImage IpeObject' Image r
i     -> (Image r :+ Attributes' r ImageAttributes)
-> [Attribute action] -> View model action
forall t action model.
Drawable t =>
t -> [Attribute action] -> View model action
forall action model.
(Image r :+ Attributes' r ImageAttributes)
-> [Attribute action] -> View model action
draw Image r :+ Attributes' r ImageAttributes
IpeObject' Image r
i
    Ipe.IpeTextLabel IpeObject' TextLabel r
t -> (TextLabel r
 :+ Attributes'
      r
      '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Size, 'Width,
         'Height, 'Depth, 'VAlign, 'HAlign, 'Style, 'Opacity])
-> [Attribute action] -> View model action
forall t action model.
Drawable t =>
t -> [Attribute action] -> View model action
forall action model.
(TextLabel r
 :+ Attributes'
      r
      '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Size, 'Width,
         'Height, 'Depth, 'VAlign, 'HAlign, 'Style, 'Opacity])
-> [Attribute action] -> View model action
draw TextLabel r
:+ Attributes'
     r
     '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Size, 'Width,
        'Height, 'Depth, 'VAlign, 'HAlign, 'Style, 'Opacity]
IpeObject' TextLabel r
t
    Ipe.IpeMiniPage IpeObject' MiniPage r
m  -> (MiniPage r
 :+ Attributes'
      r
      '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Size, 'Width,
         'Height, 'Depth, 'VAlign, 'HAlign, 'Style, 'Opacity])
-> [Attribute action] -> View model action
forall t action model.
Drawable t =>
t -> [Attribute action] -> View model action
forall action model.
(MiniPage r
 :+ Attributes'
      r
      '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Size, 'Width,
         'Height, 'Depth, 'VAlign, 'HAlign, 'Style, 'Opacity])
-> [Attribute action] -> View model action
draw MiniPage r
:+ Attributes'
     r
     '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Size, 'Width,
        'Height, 'Depth, 'VAlign, 'HAlign, 'Style, 'Opacity]
IpeObject' MiniPage r
m
    Ipe.IpeUse IpeObject' IpeSymbol r
u       -> (IpeSymbol r
 :+ Attributes'
      r
      '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Fill, 'Pen,
         'Size])
-> [Attribute action] -> View model action
forall t action model.
Drawable t =>
t -> [Attribute action] -> View model action
forall action model.
(IpeSymbol r
 :+ Attributes'
      r
      '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Fill, 'Pen,
         'Size])
-> [Attribute action] -> View model action
draw IpeSymbol r
:+ Attributes'
     r
     '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Fill, 'Pen,
        'Size]
IpeObject' IpeSymbol r
u
    Ipe.IpePath IpeObject' Path r
p      -> (Path r
 :+ Attributes'
      r
      '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Fill, 'Dash,
         'Pen, 'LineCap, 'LineJoin, 'FillRule, 'Arrow, 'RArrow,
         'StrokeOpacity, 'Opacity, 'Tiling, 'Gradient])
-> [Attribute action] -> View model action
forall t action model.
Drawable t =>
t -> [Attribute action] -> View model action
forall action model.
(Path r
 :+ Attributes'
      r
      '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Fill, 'Dash,
         'Pen, 'LineCap, 'LineJoin, 'FillRule, 'Arrow, 'RArrow,
         'StrokeOpacity, 'Opacity, 'Tiling, 'Gradient])
-> [Attribute action] -> View model action
draw Path r
:+ Attributes'
     r
     '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Fill, 'Dash,
        'Pen, 'LineCap, 'LineJoin, 'FillRule, 'Arrow, 'RArrow,
        'StrokeOpacity, 'Opacity, 'Tiling, 'Gradient]
IpeObject' Path r
p

instance ( Drawable g
         , AllConstrained IpeToMisoAttr rs
         , ReifyConstraint ToMisoString (IA.Attr f) rs
         , RMap rs, RecordToList rs
         , RecAll (IA.Attr f) rs ToMisoString
         ) => Drawable (g :+ IA.Attributes f rs) where
  draw :: forall action model.
(g :+ Attributes f rs) -> [Attribute action] -> View model action
draw (g
i :+ Attributes f rs
iAts) [Attribute action]
ats = g -> [Attribute action] -> View model action
forall t action model.
Drawable t =>
t -> [Attribute action] -> View model action
forall action model. g -> [Attribute action] -> View model action
draw g
i (Attributes f rs -> [Attribute action]
forall (rs :: [AttributeUniverse])
       (f :: TyFun AttributeUniverse (*) -> *) action.
(AllConstrained IpeToMisoAttr rs, RMap rs, RecordToList rs,
 ReifyConstraint ToMisoString (Attr f) rs,
 RecAll (Attr f) rs ToMisoString) =>
Attributes f rs -> [Attribute action]
svgWriteAttrs Attributes f rs
iAts [Attribute action] -> [Attribute action] -> [Attribute action]
forall a. Semigroup a => a -> a -> a
<> [Attribute action]
ats)

instance ToMisoString r => Drawable (Ipe.Group r) where
  draw :: forall action model.
Group r -> [Attribute action] -> View model action
draw (Ipe.Group [IpeObject r]
os) [Attribute action]
ats = [Attribute action] -> [View model action] -> View model action
forall action model.
[Attribute action] -> [View model action] -> View model action
g_ [Attribute action]
ats ((IpeObject r -> View model action)
-> [IpeObject r] -> [View model action]
forall a b. (a -> b) -> [a] -> [b]
map ((IpeObject r -> [Attribute action] -> View model action)
-> [Attribute action] -> IpeObject r -> View model action
forall a b c. (a -> b -> c) -> b -> a -> c
flip IpeObject r -> [Attribute action] -> View model action
forall t action model.
Drawable t =>
t -> [Attribute action] -> View model action
forall action model.
IpeObject r -> [Attribute action] -> View model action
draw []) [IpeObject r]
os)

instance ToMisoString r => Drawable (Ipe.Image r) where
  draw :: forall action model.
Image r -> [Attribute action] -> View model action
draw Image r
_ [Attribute action]
ats = [Attribute action] -> [View model action] -> View model action
forall action model.
[Attribute action] -> [View model action] -> View model action
text_ [Attribute action]
ats [MisoString -> View model action
forall model action. MisoString -> View model action
text MisoString
"image"]
instance ToMisoString r => Drawable (Ipe.TextLabel r) where
  draw :: forall action model.
TextLabel r -> [Attribute action] -> View model action
draw (Ipe.Label MisoString
t Point 2 r
p) [Attribute action]
ats = [Attribute action] -> [View model action] -> View model action
forall action model.
[Attribute action] -> [View model action] -> View model action
text_ ([ MisoString -> Attribute action
forall action. MisoString -> Attribute action
transform_ (MisoString -> Attribute action) -> MisoString -> Attribute action
forall a b. (a -> b) -> a -> b
$ Point 2 r -> MisoString
forall r. ToMisoString r => Point 2 r -> MisoString
moveTo Point 2 r
p ] [Attribute action] -> [Attribute action] -> [Attribute action]
forall a. Semigroup a => a -> a -> a
<> [Attribute action]
ats) [MisoString -> View model action
forall model action. MisoString -> View model action
text (MisoString -> View model action)
-> MisoString -> View model action
forall a b. (a -> b) -> a -> b
$ MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
ms MisoString
t ]
instance ToMisoString r => Drawable (Ipe.MiniPage r) where
  draw :: forall action model.
MiniPage r -> [Attribute action] -> View model action
draw (Ipe.MiniPage MisoString
t Point 2 r
p r
w) [Attribute action]
ats = [Attribute action] -> [View model action] -> View model action
forall action model.
[Attribute action] -> [View model action] -> View model action
text_ ([ MisoString -> Attribute action
forall action. MisoString -> Attribute action
transform_ (MisoString -> Attribute action) -> MisoString -> Attribute action
forall a b. (a -> b) -> a -> b
$ Point 2 r -> MisoString
forall r. ToMisoString r => Point 2 r -> MisoString
moveTo Point 2 r
p
                                         , MisoString -> Attribute action
forall action. MisoString -> Attribute action
width_     (MisoString -> Attribute action) -> MisoString -> Attribute action
forall a b. (a -> b) -> a -> b
$ r -> MisoString
forall str. ToMisoString str => str -> MisoString
ms r
w
                                         ] [Attribute action] -> [Attribute action] -> [Attribute action]
forall a. Semigroup a => a -> a -> a
<> [Attribute action]
ats)
                                        [MisoString -> View model action
forall model action. MisoString -> View model action
text (MisoString -> View model action)
-> MisoString -> View model action
forall a b. (a -> b) -> a -> b
$ MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
ms MisoString
t]

-- | renders a translation matrix
moveTo :: ToMisoString r => Point 2 r -> MisoString
moveTo :: forall r. ToMisoString r => Point 2 r -> MisoString
moveTo (ASetter (Point 2 r) (Point 2 MisoString) r MisoString
-> (r -> MisoString) -> Point 2 r -> Point 2 MisoString
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Point 2 r) (Point 2 MisoString) r MisoString
(NumType (Point 2 r) -> Identity (NumType (Point 2 MisoString)))
-> Point 2 r -> Identity (Point 2 MisoString)
forall point point'.
HasCoordinates point point' =>
IndexedTraversal1 Int point point' (NumType point) (NumType point')
IndexedTraversal1
  Int
  (Point 2 r)
  (Point 2 MisoString)
  (NumType (Point 2 r))
  (NumType (Point 2 MisoString))
coordinates r -> MisoString
forall str. ToMisoString str => str -> MisoString
ms -> Point2 MisoString
x MisoString
y) = MisoString
"translate(" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
x MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
" " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
y MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
")"

instance ToMisoString r => Drawable (Ipe.IpeSymbol r) where
  draw :: forall action model.
IpeSymbol r -> [Attribute action] -> View model action
draw (Ipe.Symbol Point 2 r
p MisoString
_ ) = ([Attribute action] -> View model action)
-> [Attribute action] -> [Attribute action] -> View model action
forall action model.
([Attribute action] -> View model action)
-> [Attribute action] -> [Attribute action] -> View model action
withAts [Attribute action] -> View model action
forall action model. [Attribute action] -> View model action
ellipse_ [ MisoString -> Attribute action
forall action. MisoString -> Attribute action
rx_ MisoString
r
                                            , MisoString -> Attribute action
forall action. MisoString -> Attribute action
ry_ MisoString
r
                                            , MisoString -> Attribute action
forall action. MisoString -> Attribute action
cx_ (MisoString -> Attribute action)
-> (r -> MisoString) -> r -> Attribute action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (r -> Attribute action) -> r -> Attribute action
forall a b. (a -> b) -> a -> b
$ Point 2 r
pPoint 2 r -> Getting r (Point 2 r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point 2 r) r
forall (d :: Nat) point r.
(1 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int (Point 2 r) r
xCoord
                                            , MisoString -> Attribute action
forall action. MisoString -> Attribute action
cy_ (MisoString -> Attribute action)
-> (r -> MisoString) -> r -> Attribute action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (r -> Attribute action) -> r -> Attribute action
forall a b. (a -> b) -> a -> b
$ Point 2 r
pPoint 2 r -> Getting r (Point 2 r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point 2 r) r
forall (d :: Nat) point r.
(2 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int (Point 2 r) r
yCoord
                                            ]
    where
      r :: MisoString
r = MisoString
"5"

instance ToMisoString r => Drawable (Ipe.Path r) where
  draw :: forall action model.
Path r -> [Attribute action] -> View model action
draw (Ipe.Path Seq (PathSegment r)
s) [Attribute action]
ats = [Attribute action] -> [View model action] -> View model action
forall action model.
[Attribute action] -> [View model action] -> View model action
g_ [] ((PathSegment r -> View model action)
-> [PathSegment r] -> [View model action]
forall a b. (a -> b) -> [a] -> [b]
map ((PathSegment r -> [Attribute action] -> View model action)
-> [Attribute action] -> PathSegment r -> View model action
forall a b c. (a -> b -> c) -> b -> a -> c
flip PathSegment r -> [Attribute action] -> View model action
forall t action model.
Drawable t =>
t -> [Attribute action] -> View model action
forall action model.
PathSegment r -> [Attribute action] -> View model action
draw (MisoString -> Attribute action
forall action. MisoString -> Attribute action
fill_ MisoString
"none"Attribute action -> [Attribute action] -> [Attribute action]
forall a. a -> [a] -> [a]
:[Attribute action]
ats)) ([PathSegment r] -> [View model action])
-> (Seq (PathSegment r) -> [PathSegment r])
-> Seq (PathSegment r)
-> [View model action]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq (PathSegment r) -> [PathSegment r]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq (PathSegment r) -> [View model action])
-> Seq (PathSegment r) -> [View model action]
forall a b. (a -> b) -> a -> b
$ Seq (PathSegment r)
s)
  -- svg fills paths by default; don't do that unless specified otherwise

instance ToMisoString r => Drawable (Ipe.PathSegment r) where
  draw :: forall action model.
PathSegment r -> [Attribute action] -> View model action
draw = \case
    Ipe.PolyLineSegment PolyLine (Point 2 r)
pl -> PolyLine (Point 2 r) -> [Attribute action] -> View model action
forall polyLine point r action model.
(PolyLine_ polyLine point, Point_ point 2 r, ToMisoString r) =>
polyLine -> [Attribute action] -> View model action
dPolyLine PolyLine (Point 2 r)
pl
    Ipe.PolygonPath Orientation
_ SimplePolygon (Point 2 r)
pg   -> SimplePolygon (Point 2 r)
-> [Attribute action] -> View model action
forall simplePolygon point r action model.
(SimplePolygon_ simplePolygon point r, ToMisoString r) =>
simplePolygon -> [Attribute action] -> View model action
dSimplePolygon SimplePolygon (Point 2 r)
pg -- TODO: maybe don't ignore the orientation
    PathSegment r
_                      -> String -> [Attribute action] -> View model action
forall a. HasCallStack => String -> a
error String
"toValue: not implemented yet"




--------------------------------------------------------------------------------
-- * Dealing with attributes



--------------------------------------------------------------------------------

type SvgF action = MisoString -> Attribute action

-- | Functon to write all attributes in a Rec
svgWriteAttrs              :: ( AllConstrained IpeToMisoAttr rs
                              , RMap rs, RecordToList rs
                              , ReifyConstraint ToMisoString (IA.Attr f) rs
                              , RecAll (IA.Attr f) rs ToMisoString
                              )
                           => IA.Attributes f rs
                           -> [Attribute action]
svgWriteAttrs :: forall (rs :: [AttributeUniverse])
       (f :: TyFun AttributeUniverse (*) -> *) action.
(AllConstrained IpeToMisoAttr rs, RMap rs, RecordToList rs,
 ReifyConstraint ToMisoString (Attr f) rs,
 RecAll (Attr f) rs ToMisoString) =>
Attributes f rs -> [Attribute action]
svgWriteAttrs (IA.Attrs Rec (Attr f) rs
r) = ((MisoString -> Attribute action, MisoString) -> Attribute action)
-> [(MisoString -> Attribute action, MisoString)]
-> [Attribute action]
forall a b. (a -> b) -> [a] -> [b]
map (\(MisoString -> Attribute action
g,MisoString
x) -> MisoString -> Attribute action
g MisoString
x) ([(MisoString -> Attribute action, MisoString)]
 -> [Attribute action])
-> (Rec
      (Const (Maybe (MisoString -> Attribute action, MisoString))) rs
    -> [(MisoString -> Attribute action, MisoString)])
-> Rec
     (Const (Maybe (MisoString -> Attribute action, MisoString))) rs
-> [Attribute action]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (MisoString -> Attribute action, MisoString)]
-> [(MisoString -> Attribute action, MisoString)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (MisoString -> Attribute action, MisoString)]
 -> [(MisoString -> Attribute action, MisoString)])
-> (Rec
      (Const (Maybe (MisoString -> Attribute action, MisoString))) rs
    -> [Maybe (MisoString -> Attribute action, MisoString)])
-> Rec
     (Const (Maybe (MisoString -> Attribute action, MisoString))) rs
-> [(MisoString -> Attribute action, MisoString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rec (Const (Maybe (MisoString -> Attribute action, MisoString))) rs
-> [Maybe (MisoString -> Attribute action, MisoString)]
forall a. Rec (Const a) rs -> [a]
forall {u} (rs :: [u]) a.
RecordToList rs =>
Rec (Const a) rs -> [a]
recordToList
                             (Rec
   (Const (Maybe (MisoString -> Attribute action, MisoString))) rs
 -> [Attribute action])
-> Rec
     (Const (Maybe (MisoString -> Attribute action, MisoString))) rs
-> [Attribute action]
forall a b. (a -> b) -> a -> b
$ (forall (a :: AttributeUniverse).
 Const (Maybe (MisoString -> Attribute action)) a
 -> Const (Maybe MisoString) a
 -> Const (Maybe (MisoString -> Attribute action, MisoString)) a)
-> Rec (Const (Maybe (MisoString -> Attribute action))) rs
-> Rec (Const (Maybe MisoString)) rs
-> Rec
     (Const (Maybe (MisoString -> Attribute action, MisoString))) rs
forall {u} (f :: u -> *) (g :: u -> *) (h :: u -> *) (as :: [u]).
(forall (a :: u). f a -> g a -> h a)
-> Rec f as -> Rec g as -> Rec h as
IA.zipRecsWith Const (Maybe (MisoString -> Attribute action)) a
-> Const (Maybe MisoString) a
-> Const (Maybe (MisoString -> Attribute action, MisoString)) a
forall {k} {k} {k} {f :: * -> *} {a} {b :: k} {a} {b :: k}
       {b :: k}.
Applicative f =>
Const (f a) b -> Const (f a) b -> Const (f (a, a)) b
forall (a :: AttributeUniverse).
Const (Maybe (MisoString -> Attribute action)) a
-> Const (Maybe MisoString) a
-> Const (Maybe (MisoString -> Attribute action, MisoString)) a
f (Rec (Attr f) rs
-> Rec (Const (Maybe (MisoString -> Attribute action))) rs
forall (rs :: [AttributeUniverse]) (f :: AttributeUniverse -> *)
       action.
AllConstrained IpeToMisoAttr rs =>
Rec f rs -> Rec (Const (Maybe (SvgF action))) rs
writeAttrFunctions Rec (Attr f) rs
r)
                                                (Rec (Attr f) rs -> Rec (Const (Maybe MisoString)) rs
forall {u} (f :: TyFun u (*) -> *) (rs :: [u]).
(ReifyConstraint ToMisoString (Attr f) rs, RMap rs,
 RecAll (Attr f) rs ToMisoString) =>
Rec (Attr f) rs -> Rec (Const (Maybe MisoString)) rs
writeAttrValues Rec (Attr f) rs
r)
  where
    f :: Const (f a) b -> Const (f a) b -> Const (f (a, a)) b
f (Const f a
mn) (Const f a
mv) = f (a, a) -> Const (f (a, a)) b
forall k a (b :: k). a -> Const a b
Const (f (a, a) -> Const (f (a, a)) b) -> f (a, a) -> Const (f (a, a)) b
forall a b. (a -> b) -> a -> b
$ (,) (a -> a -> (a, a)) -> f a -> f (a -> (a, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
mn f (a -> (a, a)) -> f a -> f (a, a)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a
mv

-- | Writing Attribute names
writeAttrFunctions           :: AllConstrained IpeToMisoAttr rs
                             => Rec f rs
                             -> Rec (Const (Maybe (SvgF action))) rs
writeAttrFunctions :: forall (rs :: [AttributeUniverse]) (f :: AttributeUniverse -> *)
       action.
AllConstrained IpeToMisoAttr rs =>
Rec f rs -> Rec (Const (Maybe (SvgF action))) rs
writeAttrFunctions Rec f rs
RNil      = Rec (Const (Maybe (SvgF action))) rs
Rec (Const (Maybe (SvgF action))) '[]
forall {u} (a :: u -> *). Rec a '[]
RNil
writeAttrFunctions (f r
x :& Rec f rs
xs) = Maybe (SvgF action) -> Const (Maybe (SvgF action)) r
forall k a (b :: k). a -> Const a b
Const (f r -> Maybe (SvgF action)
forall (f :: AttributeUniverse -> *) (s :: AttributeUniverse)
       action.
IpeToMisoAttr s =>
f s -> Maybe (SvgF action)
write'' f r
x) Const (Maybe (SvgF action)) r
-> Rec (Const (Maybe (SvgF action))) rs
-> Rec (Const (Maybe (SvgF action))) (r : rs)
forall {u} (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec f rs -> Rec (Const (Maybe (SvgF action))) rs
forall (rs :: [AttributeUniverse]) (f :: AttributeUniverse -> *)
       action.
AllConstrained IpeToMisoAttr rs =>
Rec f rs -> Rec (Const (Maybe (SvgF action))) rs
writeAttrFunctions Rec f rs
xs
  where
    write''   :: forall f s action. IpeToMisoAttr s => f s -> Maybe (SvgF action)
    write'' :: forall (f :: AttributeUniverse -> *) (s :: AttributeUniverse)
       action.
IpeToMisoAttr s =>
f s -> Maybe (SvgF action)
write'' f s
_ = Proxy s -> Maybe (SvgF action)
forall (a :: AttributeUniverse) (proxy :: AttributeUniverse -> *)
       action.
IpeToMisoAttr a =>
proxy a -> Maybe (SvgF action)
forall (proxy :: AttributeUniverse -> *) action.
proxy s -> Maybe (SvgF action)
attrSvg (Proxy s
forall {k} (t :: k). Proxy t
Proxy :: Proxy s)


-- | Writing the attribute values
writeAttrValues :: ( ReifyConstraint ToMisoString (IA.Attr f) rs, RMap rs
                   , RecAll (IA.Attr f) rs ToMisoString)
                => Rec (IA.Attr f) rs -> Rec (Const (Maybe MisoString)) rs
writeAttrValues :: forall {u} (f :: TyFun u (*) -> *) (rs :: [u]).
(ReifyConstraint ToMisoString (Attr f) rs, RMap rs,
 RecAll (Attr f) rs ToMisoString) =>
Rec (Attr f) rs -> Rec (Const (Maybe MisoString)) rs
writeAttrValues = (forall (x :: u).
 (:.) (Dict ToMisoString) (Attr f) x -> Const (Maybe MisoString) x)
-> Rec (Dict ToMisoString :. Attr f) rs
-> Rec (Const (Maybe MisoString)) rs
forall {u} (rs :: [u]) (f :: u -> *) (g :: u -> *).
RMap rs =>
(forall (x :: u). f x -> g x) -> Rec f rs -> Rec g rs
forall (f :: u -> *) (g :: u -> *).
(forall (x :: u). f x -> g x) -> Rec f rs -> Rec g rs
rmap (\(Compose (Dict Attr f x
x)) -> Maybe MisoString -> Const (Maybe MisoString) x
forall k a (b :: k). a -> Const a b
Const (Maybe MisoString -> Const (Maybe MisoString) x)
-> Maybe MisoString -> Const (Maybe MisoString) x
forall a b. (a -> b) -> a -> b
$ Attr f x -> Maybe MisoString
forall {u} (f :: TyFun u (*) -> *) (at :: u).
ToMisoString (Attr f at) =>
Attr f at -> Maybe MisoString
toMaybeValue Attr f x
x)
                (Rec (Dict ToMisoString :. Attr f) rs
 -> Rec (Const (Maybe MisoString)) rs)
-> (Rec (Attr f) rs -> Rec (Dict ToMisoString :. Attr f) rs)
-> Rec (Attr f) rs
-> Rec (Const (Maybe MisoString)) rs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {u} (c :: * -> Constraint) (f :: u -> *) (rs :: [u]).
ReifyConstraint c f rs =>
Rec f rs -> Rec (Dict c :. f) rs
forall (c :: * -> Constraint) (f :: u -> *) (rs :: [u]).
ReifyConstraint c f rs =>
Rec f rs -> Rec (Dict c :. f) rs
reifyConstraint @ToMisoString

toMaybeValue   :: ToMisoString (IA.Attr f at) => IA.Attr f at -> Maybe MisoString
toMaybeValue :: forall {u} (f :: TyFun u (*) -> *) (at :: u).
ToMisoString (Attr f at) =>
Attr f at -> Maybe MisoString
toMaybeValue Attr f at
a = case Attr f at
a of
                   Attr f at
IA.NoAttr -> Maybe MisoString
forall a. Maybe a
Nothing
                   IA.Attr Apply f at
_ -> MisoString -> Maybe MisoString
forall a. a -> Maybe a
Just (MisoString -> Maybe MisoString) -> MisoString -> Maybe MisoString
forall a b. (a -> b) -> a -> b
$ Attr f at -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString Attr f at
a

-- | For the types representing attribute values we can get the name/key to use
-- when serializing to ipe.
class IpeToMisoAttr (a :: IA.AttributeUniverse) where
  attrSvg :: proxy a -> Maybe (SvgF action)

-- CommonAttributeUnivers
instance IpeToMisoAttr IA.Layer           where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'Layer -> Maybe (SvgF action)
attrSvg proxy 'Layer
_ = Maybe (SvgF action)
forall a. Maybe a
Nothing
instance IpeToMisoAttr IA.Matrix          where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'Matrix -> Maybe (SvgF action)
attrSvg proxy 'Matrix
_ = Maybe (SvgF action)
forall a. Maybe a
Nothing -- TODO
instance IpeToMisoAttr IA.Pin             where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'Pin -> Maybe (SvgF action)
attrSvg proxy 'Pin
_ = Maybe (SvgF action)
forall a. Maybe a
Nothing
instance IpeToMisoAttr IA.Transformations where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'Transformations -> Maybe (SvgF action)
attrSvg proxy 'Transformations
_ = Maybe (SvgF action)
forall a. Maybe a
Nothing

-- IpeSymbolAttributeUniversre
instance IpeToMisoAttr IA.Stroke       where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'Stroke -> Maybe (SvgF action)
attrSvg proxy 'Stroke
_ = SvgF action -> Maybe (SvgF action)
forall a. a -> Maybe a
Just SvgF action
forall action. MisoString -> Attribute action
stroke_
instance IpeToMisoAttr IA.Fill         where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'Fill -> Maybe (SvgF action)
attrSvg proxy 'Fill
_ = SvgF action -> Maybe (SvgF action)
forall a. a -> Maybe a
Just SvgF action
forall action. MisoString -> Attribute action
fill_
instance IpeToMisoAttr IA.Pen          where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'Pen -> Maybe (SvgF action)
attrSvg proxy 'Pen
_ = Maybe (SvgF action)
forall a. Maybe a
Nothing
instance IpeToMisoAttr IA.Size         where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'Size -> Maybe (SvgF action)
attrSvg proxy 'Size
_ = Maybe (SvgF action)
forall a. Maybe a
Nothing

-- PathAttributeUniverse
instance IpeToMisoAttr IA.Dash       where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'Dash -> Maybe (SvgF action)
attrSvg proxy 'Dash
_ = Maybe (SvgF action)
forall a. Maybe a
Nothing
instance IpeToMisoAttr IA.LineCap    where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'LineCap -> Maybe (SvgF action)
attrSvg proxy 'LineCap
_ = SvgF action -> Maybe (SvgF action)
forall a. a -> Maybe a
Just SvgF action
forall action. MisoString -> Attribute action
strokeLinecap_
instance IpeToMisoAttr IA.LineJoin   where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'LineJoin -> Maybe (SvgF action)
attrSvg proxy 'LineJoin
_ = Maybe (SvgF action)
forall a. Maybe a
Nothing
instance IpeToMisoAttr IA.FillRule   where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'FillRule -> Maybe (SvgF action)
attrSvg proxy 'FillRule
_ = Maybe (SvgF action)
forall a. Maybe a
Nothing
instance IpeToMisoAttr IA.Arrow      where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'Arrow -> Maybe (SvgF action)
attrSvg proxy 'Arrow
_ = Maybe (SvgF action)
forall a. Maybe a
Nothing
instance IpeToMisoAttr IA.RArrow     where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'RArrow -> Maybe (SvgF action)
attrSvg proxy 'RArrow
_ = Maybe (SvgF action)
forall a. Maybe a
Nothing
instance IpeToMisoAttr IA.StrokeOpacity where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'StrokeOpacity -> Maybe (SvgF action)
attrSvg proxy 'StrokeOpacity
_ = SvgF action -> Maybe (SvgF action)
forall a. a -> Maybe a
Just SvgF action
forall action. MisoString -> Attribute action
strokeOpacity_
instance IpeToMisoAttr IA.Opacity    where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'Opacity -> Maybe (SvgF action)
attrSvg proxy 'Opacity
_ = SvgF action -> Maybe (SvgF action)
forall a. a -> Maybe a
Just SvgF action
forall action. MisoString -> Attribute action
fillOpacity_
instance IpeToMisoAttr IA.Tiling     where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'Tiling -> Maybe (SvgF action)
attrSvg proxy 'Tiling
_ = Maybe (SvgF action)
forall a. Maybe a
Nothing
instance IpeToMisoAttr IA.Gradient   where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'Gradient -> Maybe (SvgF action)
attrSvg proxy 'Gradient
_ = Maybe (SvgF action)
forall a. Maybe a
Nothing

-- GroupAttributeUniverse
instance IpeToMisoAttr IA.Clip     where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'Clip -> Maybe (SvgF action)
attrSvg proxy 'Clip
_ = Maybe (SvgF action)
forall a. Maybe a
Nothing -- Just clipPath_

-- Text attributes
instance IpeToMisoAttr IA.Width    where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'Width -> Maybe (SvgF action)
attrSvg proxy 'Width
_ = Maybe (SvgF action)
forall a. Maybe a
Nothing
instance IpeToMisoAttr IA.Height   where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'Height -> Maybe (SvgF action)
attrSvg proxy 'Height
_ = Maybe (SvgF action)
forall a. Maybe a
Nothing
instance IpeToMisoAttr IA.Depth    where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'Depth -> Maybe (SvgF action)
attrSvg proxy 'Depth
_ = Maybe (SvgF action)
forall a. Maybe a
Nothing
instance IpeToMisoAttr IA.VAlign   where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'VAlign -> Maybe (SvgF action)
attrSvg proxy 'VAlign
_ = Maybe (SvgF action)
forall a. Maybe a
Nothing
instance IpeToMisoAttr IA.HAlign   where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'HAlign -> Maybe (SvgF action)
attrSvg proxy 'HAlign
_ = Maybe (SvgF action)
forall a. Maybe a
Nothing
instance IpeToMisoAttr IA.Style    where attrSvg :: forall (proxy :: AttributeUniverse -> *) action.
proxy 'Style -> Maybe (SvgF action)
attrSvg proxy 'Style
_ = Maybe (SvgF action)
forall a. Maybe a
Nothing