hgeometry-0.4.0.0: src/Data/Geometry/Ipe/Writer.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Geometry.Ipe.Writer where
import Control.Applicative hiding (Const(..))
import Control.Lens((^.),(^..),(.~),(&), Prism', (#))
import Data.Ext
import qualified Data.Foldable as F
import Data.Geometry.Ipe.Types
import qualified Data.Geometry.Ipe.Types as IT
import Data.Geometry.LineSegment
import Data.Geometry.PolyLine
import qualified Data.Geometry.Transformation as GT
import Data.Geometry.Point
import Data.Geometry.Vector
import Data.Maybe(catMaybes, mapMaybe, fromMaybe)
import Data.Monoid
import Data.Proxy
import qualified Data.Traversable as Tr
import Data.Vinyl
import Data.Vinyl.Functor
import Data.Vinyl.TypeLevel
import Data.Geometry.Ipe.Attributes
import GHC.Exts
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.List(nub)
import qualified Data.Seq2 as S2
import Data.Text(Text)
import Text.XML.Expat.Tree
import Text.XML.Expat.Format(format')
import System.IO(hPutStrLn,stderr)
import qualified Data.Text as T
--------------------------------------------------------------------------------
-- | Given a prism to convert something of type g into an ipe file, a file path,
-- and a g. Convert the geometry and write it to file.
writeIpe :: ( RecAll (Page r) gs IpeWrite
, IpeWriteText r
) => Prism' (IpeFile gs r) g -> FilePath -> g -> IO ()
writeIpe p fp g = writeIpeFile (p # g) fp
-- | Write an IpeFiele to file.
writeIpeFile :: ( RecAll (Page r) gs IpeWrite
, IpeWriteText r
) => IpeFile gs r -> FilePath -> IO ()
writeIpeFile = writeIpeFile'
-- | Convert the input to ipeXml, and prints it to standard out in such a way
-- that the copied text can be pasted into ipe as a geometry object.
printAsIpeSelection :: IpeWrite t => t -> IO ()
printAsIpeSelection = C.putStrLn . fromMaybe "" . toIpeSelectionXML
-- | Convert input into an ipe selection.
toIpeSelectionXML :: IpeWrite t => t -> Maybe B.ByteString
toIpeSelectionXML = fmap (format' . ipeSelection) . ipeWrite
where
ipeSelection x = Element "ipeselection" [] [x]
-- | Convert to Ipe xml
toIpeXML :: IpeWrite t => t -> Maybe B.ByteString
toIpeXML = fmap format' . ipeWrite
-- | Convert to ipe XML and write the output to a file.
writeIpeFile' :: IpeWrite t => t -> FilePath -> IO ()
writeIpeFile' i fp = maybe err (B.writeFile fp) . toIpeXML $ i
where
err = hPutStrLn stderr $
"writeIpeFile: error converting to xml. File '" <> fp <> "'not written"
--------------------------------------------------------------------------------
-- | For types that can produce a text value
class IpeWriteText t where
ipeWriteText :: t -> Maybe Text
-- | Types that correspond to an XML Element. All instances should produce an
-- Element. If the type should produce a Node with the Text constructor, use
-- the `IpeWriteText` typeclass instead.
class IpeWrite t where
ipeWrite :: t -> Maybe (Node Text Text)
-- | Ipe write for Exts
ipeWriteExt :: ( IpeWrite t
, RecAll a as IpeWriteText, AllSatisfy IpeAttrName as
) => t :+ Rec a as -> Maybe (Node Text Text)
ipeWriteExt (x :+ arec) = ipeWrite x `mAddAtts` ipeWriteAttrs arec
-- | For the types representing attribute values we can get the name/key to use
-- when serializing to ipe.
class IpeAttrName a where
attrName :: Proxy a -> Text
type Attr = (Text,Text)
-- | Functon to write all attributes in a Rec
ipeWriteAttrs :: ( RecAll f rs IpeWriteText
, AllSatisfy IpeAttrName rs
) => Rec f rs -> [Attr]
ipeWriteAttrs rs = mapMaybe (\(x,my) -> (x,) <$> my) $ zip (writeAttrNames rs)
(writeAttrValues rs)
-- | Writing the attribute values
writeAttrValues :: RecAll f rs IpeWriteText => Rec f rs -> [Maybe Text]
writeAttrValues = recordToList
. rmap (\(Compose (Dict x)) -> Const $ ipeWriteText x)
. reifyConstraint (Proxy :: Proxy IpeWriteText)
-- | Writing Attribute names
writeAttrNames :: AllSatisfy IpeAttrName rs => Rec f rs -> [Text]
writeAttrNames RNil = []
writeAttrNames (x :& xs) = write'' x : writeAttrNames xs
where
write'' :: forall f s. IpeAttrName s => f s -> Text
write'' _ = attrName (Proxy :: Proxy s)
-- | 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)
instance IpeWriteText Text where
ipeWriteText = Just
-- | Add attributes to a node
addAtts :: Node Text Text -> [(Text,Text)] -> Node Text Text
n `addAtts` ats = n { eAttributes = ats ++ eAttributes n }
-- | Same as `addAtts` but then for a Maybe node
mAddAtts :: Maybe (Node Text Text) -> [(Text, Text)] -> Maybe (Node Text Text)
mn `mAddAtts` ats = fmap (`addAtts` ats) mn
--------------------------------------------------------------------------------
instance IpeWriteText Double where
ipeWriteText = writeByShow
instance IpeWriteText Int where
ipeWriteText = writeByShow
writeByShow :: Show t => t -> Maybe Text
writeByShow = ipeWriteText . T.pack . show
unwords' :: [Maybe Text] -> Maybe Text
unwords' = fmap T.unwords . sequence
unlines' :: [Maybe Text] -> Maybe Text
unlines' = fmap T.unlines . sequence
instance IpeWriteText r => IpeWriteText (Point 2 r) where
ipeWriteText (Point2 x y) = unwords' [ipeWriteText x, ipeWriteText y]
--------------------------------------------------------------------------------
instance IpeWriteText v => IpeWriteText (IpeValue v) where
ipeWriteText (Named t) = ipeWriteText t
ipeWriteText (Valued v) = ipeWriteText v
deriving instance IpeWriteText r => IpeWriteText (IpeSize r)
deriving instance IpeWriteText r => IpeWriteText (IpePen r)
deriving instance IpeWriteText IpeColor
--------------------------------------------------------------------------------
instance IpeWriteText r => IpeWrite (IpeSymbol r) where
ipeWrite (Symbol p n) = f <$> ipeWriteText p
where
f ps = Element "use" [ ("pos", ps)
, ("name", n)
] []
instance IpeWriteText (SymbolAttrElf rs r) => IpeWriteText (SymbolAttribute r rs) where
ipeWriteText (SymbolAttribute x) = ipeWriteText x
-- 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 SymbolStroke where attrName _ = "stroke"
instance IpeAttrName SymbolFill where attrName _ = "fill"
instance IpeAttrName SymbolPen where attrName _ = "pen"
instance IpeAttrName Size where attrName _ = "size"
-- PathAttributeUniverse
instance IpeAttrName Stroke where attrName _ = "stroke"
instance IpeAttrName Fill where attrName _ = "fill"
instance IpeAttrName Dash where attrName _ = "dash"
instance IpeAttrName Pen where attrName _ = "pen"
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"
--------------------------------------------------------------------------------
instance IpeWriteText r => IpeWriteText (GT.Matrix 3 3 r) where
ipeWriteText (GT.Matrix m) = unwords' [a,b,c,d,e,f]
where
(Vector3 r1 r2 _) = m
(Vector3 a c e) = ipeWriteText <$> r1
(Vector3 b d f) = ipeWriteText <$> r2
-- TODO: The third row should be (0,0,1) I guess.
instance IpeWriteText r => IpeWriteText (Operation r) where
ipeWriteText (MoveTo p) = unwords' [ ipeWriteText p, Just "m"]
ipeWriteText (LineTo p) = unwords' [ ipeWriteText p, Just "l"]
ipeWriteText (CurveTo p q r) = unwords' [ ipeWriteText p
, ipeWriteText q
, ipeWriteText r, Just "m"]
ipeWriteText (Ellipse m) = unwords' [ ipeWriteText m, Just "e"]
-- TODO: The rest
ipeWriteText ClosePath = Just "h"
instance IpeWriteText r => IpeWriteText (PolyLine 2 () r) where
ipeWriteText pl = case pl^..points.Tr.traverse.core of
(p : rest) -> unlines' . map ipeWriteText $ MoveTo p : map LineTo rest
-- the polyline type guarantees that there is at least one point
instance IpeWriteText r => IpeWriteText (PathSegment r) where
ipeWriteText (PolyLineSegment p) = ipeWriteText p
ipeWriteText (EllipseSegment m) = ipeWriteText $ Ellipse m
instance IpeWriteText (PathAttrElf rs r) => IpeWriteText (PathAttribute r rs) where
ipeWriteText (PathAttribute x) = ipeWriteText x
instance IpeWriteText r => IpeWrite (Path r) where
ipeWrite (Path segs) = (\t -> Element "path" [] [Text t]) <$> mt
where
concat' = F.foldr1 (\t t' -> t <> "\n" <> t')
mt = fmap concat' . Tr.sequence . fmap ipeWriteText $ segs
--------------------------------------------------------------------------------
instance ( IpeObjectElF r fld ~ (g :+ Rec f ats)
, IpeWrite g
, RecAll f ats IpeWriteText, AllSatisfy IpeAttrName ats
) => IpeWrite (IpeObject r fld) where
ipeWrite (IpeObject (g :+ ats)) = ipeWrite g `mAddAtts` ipeWriteAttrs ats
ipeWriteRec :: RecAll f rs IpeWrite => Rec f rs -> [Node Text Text]
ipeWriteRec = catMaybes . recordToList
. rmap (\(Compose (Dict x)) -> Const $ ipeWrite x)
. reifyConstraint (Proxy :: Proxy IpeWrite)
instance RecAll (IpeObject r) gt IpeWrite => IpeWrite (Group gt r) where
-- basically the same implementation as ipeWriteAttrs: convert the rec to a Rec Const
-- then turn that into a list. If the list is non-empty we construct a new group element.
ipeWrite = fmap (Element "group" [])
. wrap . ipeWriteRec
where
wrap [] = Nothing
wrap xs = Just xs
instance IpeWriteText (GroupAttrElf rs r) => IpeWriteText (GroupAttribute r rs) where
ipeWriteText (GroupAttribute x) = ipeWriteText x
--------------------------------------------------------------------------------
instance IpeWrite IT.Layer where
ipeWrite (IT.Layer l) = Just $ Element "layer" [("name", l)] []
instance IpeWrite View where
ipeWrite (View lrs act) = Just $ Element "view" [ ("layers", ls)
, ("active", _layerName act)
] []
where
ls = T.unwords . map _layerName $ lrs
instance IpeWrite (Group gs r) => IpeWrite (IpePage gs r) where
ipeWrite (IpePage lrs vs pgs) = Just . Element "page" [] . catMaybes . concat $
[ map ipeWrite lrs
, map ipeWrite vs
, [ipeWrite pgs]
]
instance RecAll (Page r) gs IpeWrite => IpeWrite (IpeFile gs r) where
ipeWrite (IpeFile p s pgs) = Just $ Element "ipe" ipeAtts chs
where
ipeAtts = [("version","70005"),("creator", "HGeometry")]
-- TODO: Add preamble and styles
chs = ipeWriteRec pgs
--------------------------------------------------------------------------------
type Atts = [(Text,Text)]
ipeWritePolyLines :: IpeWriteText r
=> [(PolyLine 2 () r, Atts)] -> Node Text Text
ipeWritePolyLines pls = Element "ipe" ipeAtts [Element "page" [] chs]
where
chs = layers pls ++ mapMaybe f pls
ipeAtts = [("version","70005"),("creator", "HGeometry 0.4.0.0")]
f (pl,ats) = ipeWrite (mkPath pl) `mAddAtts` ats
mkPath = Path . S2.l1Singleton . PolyLineSegment
layers = map mkLayer . nub . mapMaybe (lookup "layer" . snd)
mkLayer n = Element "layer" [("name",n)] []
writePolyLineFile :: IpeWriteText r => FilePath -> [(PolyLine 2 () r, Atts)] -> IO ()
writePolyLineFile fp = B.writeFile fp . format' . ipeWritePolyLines
instance (IpeWriteText r, IpeWrite p) => IpeWrite (PolyLine 2 p r) where
ipeWrite p = ipeWrite path
where
path = fromPolyLine $ p & points.Tr.traverse.extra .~ ()
-- TODO: Do something with the p's
fromPolyLine = Path . S2.l1Singleton . PolyLineSegment
instance (IpeWriteText r) => IpeWrite (LineSegment 2 p r) where
ipeWrite (LineSegment p q) = ipeWrite . fromPolyLine . fromPoints . map (^.core) $ [p,q]
instance IpeWrite () where
ipeWrite = const Nothing
-- -- | slightly clever instance that produces a group if there is more than one
-- -- element and just an element if there is only one value produced
-- instance IpeWrite a => IpeWrite [a] where
-- ipeWrite = combine . mapMaybe ipeWrite
combine :: [Node Text Text] -> Maybe (Node Text Text)
combine [] = Nothing
combine [n] = Just n
combine ns = Just $ Element "group" [] ns
-- instance (IpeWrite a, IpeWrite b) => IpeWrite (a,b) where
-- ipeWrite (a,b) = combine . catMaybes $ [ipeWrite a, ipeWrite b]
-- -- | The default symbol for a point
-- ipeWritePoint :: IpeWriteText r => Point 2 r -> Maybe (Node Text Text)
-- ipeWritePoint = ipeWrite . flip Symbol "mark/disk(sx)"
-- instance (IpeWriteText r, Floating r) => IpeWrite (Circle r) where
-- ipeWrite = ipeWrite . Path . S2.l1Singleton . fromCircle
--------------------------------------------------------------------------------
testPoly :: PolyLine 2 () Double
testPoly = fromPoints [origin, point2 0 10, point2 10 10, point2 100 100]
testWriteUse :: Maybe (Node Text Text)
testWriteUse = ipeWriteExt sym
where
sym :: IpeSymbol Double :+ (Rec (SymbolAttribute Double) [Size, SymbolStroke])
sym = Symbol origin "mark" :+ ( SymbolAttribute (IpeSize $ Named "normal")
:& SymbolAttribute (IpeColor $ Named "green")
:& RNil
)
foo = ipeWrite grrr