hgeometry-svg-0.9.0.0: src/Data/Geometry/Svg/Writer.hs
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- |
-- Module : Data.Geometry.Svg.Writer
-- Copyright : (C) Frank Staals
-- License : see the LICENSE file
-- Maintainer : Frank Staals
-- Description :
--
-- Write geometry to svg
--
--------------------------------------------------------------------------------
module Data.Geometry.Svg.Writer where
import Control.Lens hiding (rmap, Const(..))
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.Char8 as B8
import Data.Ext
import Data.Fixed
import qualified Data.Foldable as F
import qualified Data.Geometry.Ipe.Attributes as IA
import Data.Geometry.Ipe.Color (IpeColor(..))
import Data.Geometry.Ipe.Types
import qualified Data.Geometry.Ipe.Types as Ipe
import Data.Geometry.Ipe.Value (IpeValue(..))
import Data.Geometry.Point
import Data.Geometry.PolyLine
import Data.Geometry.Polygon
import Data.Geometry.Svg.MathCoordinateSystem
import Data.Geometry.Transformation (Matrix)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe
import Data.Monoid (mconcat)
import Data.Proxy
import Data.Ratio
import Data.Semigroup.Foldable (toNonEmpty)
import Data.Singletons (Apply)
import Data.Vinyl hiding (Label)
import Data.Vinyl.Functor
import Data.Vinyl.TypeLevel
import Text.Blaze (ToMarkup(toMarkup), ToValue(toValue))
import qualified Text.Blaze.Svg as Svg
import qualified Text.Blaze.Svg.Renderer.Utf8 as SvgRender
import Text.Blaze.Svg11 ((!))
import qualified Text.Blaze.Svg11 as Svg
import qualified Text.Blaze.Svg11.Attributes as A
--------------------------------------------------------------------------------
-- | Converts an element into a valid svg document (including doctype etc.)
-- The size of the resulting svg is set to 800x600. Moreover, we flip the axes
-- so that the origin is in the bottom-left.
--
--
toSvgXML :: ToMarkup t => t -> B.ByteString
toSvgXML = SvgRender.renderSvg
. Svg.docTypeSvg
. renderCanvas (createCanvas @Double 800 600) []
. svgO
-- | Convert an element to Svg using 'toSvgXML' and prints the resulting svg
-- (as xml) output to stdout.
--
printSvgXML :: ToMarkup t => t -> IO ()
printSvgXML = B8.putStrLn . toSvgXMLElem
-- | Convert an element to Svg
svgO :: ToMarkup a => a -> Svg.Svg
svgO = Svg.toSvg
-- | Convert an element to Svg, and render this svg as xml. Note that the xml
-- contains *only* this element.
toSvgXMLElem :: ToMarkup t => t -> B.ByteString
toSvgXMLElem = SvgRender.renderSvg . Svg.toSvg
-- | Convert an element to Svg, and prints the xml output to stdout.
printSvgXMLElem :: ToMarkup t => t -> IO ()
printSvgXMLElem = B8.putStrLn . toSvgXMLElem
--------------------------------------------------------------------------------
instance Real r => ToMarkup (IpeObject r) where
toMarkup (IpeGroup g) = toMarkup g
toMarkup (IpeImage i) = toMarkup i
toMarkup (IpeTextLabel t) = toMarkup t
toMarkup (IpeMiniPage m) = toMarkup m
toMarkup (IpeUse u) = toMarkup u
toMarkup (IpePath (p :+ ats)) = toMarkup $ p :+ (ats' <> ats)
where
ats' = IA.attr IA.SFill $ IpeColor $ Named "transparent"
-- svg assumes that by default the filling is set to transparent
-- so make sure we do that as well
instance ( ToMarkup g
, AllConstrained IpeToSvgAttr rs
, ReifyConstraint ToValue (IA.Attr f) rs
, RMap rs, RecordToList rs
, RecAll (IA.Attr f) rs ToValue
) => ToMarkup (g :+ IA.Attributes f rs) where
toMarkup (i :+ ats) = toMarkup i `applyAts` svgWriteAttrs ats
instance Real r => ToMarkup (TextLabel r) where
toMarkup (Label t p) = text_ p [] t
instance Real r => ToMarkup (MiniPage r) where
toMarkup (MiniPage t p w) = text_ p [A.width (toPValue w)] t
instance Real r => ToMarkup (Image r) where
toMarkup _ = error "ToMarkup: Image not implemented yet"
-- toMarkup (Image i r) = Svg.image t ! A.xlinkHref (toAValue i)
-- ! A.y (toPValue $ p^.yCoord)
-- ! A.width (toPValue w)
instance HasResolution p => ToValue (Fixed p) where
toValue = toAValue
instance Integral a => ToValue (Ratio a) where
toValue = toValue @Pico . realToFrac
instance Real r => ToValue (PathSegment r) where
toValue = \case
PolyLineSegment pl -> Svg.mkPath . toPath $ pl^.points.to toNonEmpty
PolygonPath pg -> Svg.mkPath $ do toPath $ pg^.outerBoundary.to toNonEmpty
Svg.z
EllipseSegment _ -> undefined
_ -> error "toValue: not implemented yet"
toPath :: Real r => NonEmpty (Point 2 r :+ p) -> Svg.Path
toPath pts = case (^.core) <$> pts of
(v:|vs) -> do Svg.m (showP $ v^.xCoord) (showP $ v^.yCoord)
mapM_ (\(Point2 x y) -> Svg.l (showP x) (showP y)) vs
instance Real r => ToMarkup (Ipe.Path r) where
toMarkup p = Svg.path ! A.d (toValue p)
instance Real r => ToValue (Path r) where
toValue (Path s) = mconcat . map toValue . F.toList $ s
instance Real r => ToMarkup (Ipe.IpeSymbol r) where
toMarkup (Symbol p _) = Svg.circle ! A.cx (toPValue $ p^.xCoord)
! A.cy (toPValue $ p^.yCoord)
! A.r (toPValue 5)
-- TODO: for now just draw a disk of fixed radius
instance Real r => ToMarkup (Ipe.Group r) where
toMarkup (Group os) = Svg.g (mapM_ toMarkup os)
--------------------------------------------------------------------------------
-- * Dealing with attributes
instance ToValue (Apply f at) => ToValue (IA.Attr f at) where
toValue att = maybe mempty toValue $ IA._getAttr att
applyAts :: Svg.Markup -> [(SvgF, Svg.AttributeValue)] -> Svg.Markup
applyAts x0 = F.foldl' (\x (f,v) -> x ! f v) x0
-- | Functon to write all attributes in a Rec
svgWriteAttrs :: ( AllConstrained IpeToSvgAttr rs
, RMap rs, RecordToList rs
, ReifyConstraint ToValue (IA.Attr f) rs
, RecAll (IA.Attr f) rs ToValue
)
=> IA.Attributes f rs
-> [(SvgF, Svg.AttributeValue)]
svgWriteAttrs (IA.Attrs r) = catMaybes . recordToList $ IA.zipRecsWith f (writeAttrFunctions r)
(writeAttrValues r)
where
f (Const mn) (Const mv) = Const $ (,) <$> mn <*> mv
-- | Writing Attribute names
writeAttrFunctions :: AllConstrained IpeToSvgAttr rs
=> Rec f rs
-> Rec (Const (Maybe SvgF)) rs
writeAttrFunctions RNil = RNil
writeAttrFunctions (x :& xs) = Const (write'' x) :& writeAttrFunctions xs
where
write'' :: forall f s. IpeToSvgAttr s => f s -> Maybe SvgF
write'' _ = attrSvg (Proxy :: Proxy s)
-- | Writing the attribute values
writeAttrValues :: ( ReifyConstraint ToValue (IA.Attr f) rs, RMap rs
, RecAll (IA.Attr f) rs ToValue)
=> Rec (IA.Attr f) rs -> Rec (Const (Maybe Svg.AttributeValue)) rs
writeAttrValues = rmap (\(Compose (Dict x)) -> Const $ toMaybeValue x)
. reifyConstraint @ToValue
toMaybeValue :: ToValue (IA.Attr f at) => IA.Attr f at -> Maybe Svg.AttributeValue
toMaybeValue a = case a of
IA.NoAttr -> Nothing
IA.Attr _ -> Just $ toValue a
type SvgF = Svg.AttributeValue -> Svg.Attribute
-- | For the types representing attribute values we can get the name/key to use
-- when serializing to ipe.
class IpeToSvgAttr (a :: IA.AttributeUniverse) where
attrSvg :: proxy a -> Maybe SvgF
-- CommonAttributeUnivers
instance IpeToSvgAttr IA.Layer where attrSvg _ = Nothing
instance IpeToSvgAttr IA.Matrix where attrSvg _ = Nothing -- TODO
instance IpeToSvgAttr IA.Pin where attrSvg _ = Nothing
instance IpeToSvgAttr IA.Transformations where attrSvg _ = Nothing
-- IpeSymbolAttributeUniversre
instance IpeToSvgAttr IA.Stroke where attrSvg _ = Just A.stroke
instance IpeToSvgAttr IA.Fill where attrSvg _ = Just A.fill
instance IpeToSvgAttr IA.Pen where attrSvg _ = Nothing
instance IpeToSvgAttr IA.Size where attrSvg _ = Nothing
-- PathAttributeUniverse
instance IpeToSvgAttr IA.Dash where attrSvg _ = Nothing
instance IpeToSvgAttr IA.LineCap where attrSvg _ = Just A.strokeLinecap
instance IpeToSvgAttr IA.LineJoin where attrSvg _ = Nothing
instance IpeToSvgAttr IA.FillRule where attrSvg _ = Nothing
instance IpeToSvgAttr IA.Arrow where attrSvg _ = Nothing
instance IpeToSvgAttr IA.RArrow where attrSvg _ = Nothing
instance IpeToSvgAttr IA.Opacity where attrSvg _ = Just A.opacity
instance IpeToSvgAttr IA.Tiling where attrSvg _ = Nothing
instance IpeToSvgAttr IA.Gradient where attrSvg _ = Nothing
-- GroupAttributeUniverse
instance IpeToSvgAttr IA.Clip where attrSvg _ = Just A.clip
--------------------------------------------------------------------------------
deriving instance ToValue LayerName
instance Real r => ToValue (IpeColor r) where
toValue (IpeColor c) = case c of
Named t -> toValue t
Valued v -> toAValue $ fmap showP v
-- TODO:
instance Real r => ToValue (IA.IpePen r) where
toValue _ = mempty
instance Real r => ToValue (IA.IpeSize r) where
toValue _ = mempty
instance Real r => ToValue (IA.IpeArrow r) where
toValue _ = mempty
instance Real r => ToValue (IA.IpeDash r) where
toValue _ = mempty
instance Real r => ToValue (Matrix 3 3 r) where
toValue _ = mempty
instance ToValue IA.FillType where
toValue _ = mempty
instance ToValue IA.PinType where
toValue _ = mempty
instance ToValue IA.TransformationTypes where
toValue _ = mempty