hgeometry-ipe-0.10.0.0: src/Data/Geometry/Ipe/Writer.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
-- |
-- Module : Data.Geometry.Ipe.Writer
-- Copyright : (C) Frank Staals
-- License : see the LICENSE file
-- Maintainer : Frank Staals
-- Description : Converting data types into IpeTypes
--
--------------------------------------------------------------------------------
module Data.Geometry.Ipe.Writer where
import Control.Lens ((^.), (^..), (.~), (&))
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.Colour.SRGB (RGB(..))
import Data.Ext
import Data.Fixed
import qualified Data.Foldable as F
import Data.Geometry.Box
import Data.Geometry.Ipe.Attributes
import qualified Data.Geometry.Ipe.Attributes as IA
import Data.Geometry.Ipe.Color (IpeColor(..))
import Data.Geometry.Ipe.Types
import Data.Geometry.Ipe.Value
import Data.Geometry.LineSegment
import Data.Geometry.Point
import Data.Geometry.PolyLine
import Data.Geometry.Polygon (Polygon, outerBoundary, holeList, asSimplePolygon)
import qualified Data.Geometry.Transformation as GT
import Data.Geometry.Vector
import qualified Data.LSeq as LSeq
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (catMaybes, mapMaybe, fromMaybe)
import Data.Ratio
import Data.Singletons
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text as Text
import Data.Vinyl hiding (Label)
import Data.Vinyl.Functor
import Data.Vinyl.TypeLevel
import System.IO (hPutStrLn,stderr)
import Text.XML.Expat.Format (format')
import Text.XML.Expat.Tree
--------------------------------------------------------------------------------
-- | 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 :: IpeWriteText r => FilePath -> IpeFile r -> IO ()
writeIpeFile = flip writeIpeFile'
-- | Creates a single page ipe file with the given page
writeIpePage :: IpeWriteText r => FilePath -> IpePage r -> IO ()
writeIpePage fp = writeIpeFile fp . singlePageFile
-- | 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)
instance IpeWrite t => IpeWrite [t] where
ipeWrite gs = case mapMaybe ipeWrite gs of
[] -> Nothing
ns -> (Just $ Element "group" [] ns)
instance (IpeWrite l, IpeWrite r) => IpeWrite (Either l r) where
ipeWrite = either ipeWrite ipeWrite
instance IpeWriteText (Apply f at) => IpeWriteText (Attr f at) where
ipeWriteText att = _getAttr att >>= ipeWriteText
instance (IpeWriteText l, IpeWriteText r) => IpeWriteText (Either l r) where
ipeWriteText = either ipeWriteText ipeWriteText
-- | Functon to write all attributes in a Rec
ipeWriteAttrs :: ( RecordToList rs, RMap rs
, ReifyConstraint IpeWriteText (Attr f) rs
, AllSatisfy IpeAttrName rs
, RecAll (Attr f) rs IpeWriteText
) => IA.Attributes f rs -> [(Text,Text)]
ipeWriteAttrs (Attrs r) = catMaybes . recordToList $ zipRecsWith f (writeAttrNames r)
(writeAttrValues r)
where
f (Const n) (Const mv) = Const $ (n,) <$> mv
-- | Writing the attribute values
writeAttrValues :: ( RMap rs, ReifyConstraint IpeWriteText f rs
, RecAll f rs IpeWriteText)
=> Rec f rs -> Rec (Const (Maybe Text)) rs
writeAttrValues = rmap (\(Compose (Dict x)) -> Const $ ipeWriteText x)
. reifyConstraint @IpeWriteText
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
instance IpeWriteText Integer where
ipeWriteText = writeByShow
instance HasResolution p => IpeWriteText (Fixed p) where
ipeWriteText = writeByShow
-- | This instance converts the ratio to a Pico, and then displays that.
instance Integral a => IpeWriteText (Ratio a) where
ipeWriteText = ipeWriteText . f . fromRational . toRational
where
f :: Pico -> Pico
f = id
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
instance IpeWriteText TransformationTypes where
ipeWriteText Affine = Just "affine"
ipeWriteText Rigid = Just "rigid"
ipeWriteText Translations = Just "translations"
instance IpeWriteText PinType where
ipeWriteText No = Nothing
ipeWriteText Yes = Just "yes"
ipeWriteText Horizontal = Just "h"
ipeWriteText Vertical = Just "v"
instance IpeWriteText r => IpeWriteText (RGB r) where
ipeWriteText (RGB r g b) = unwords' . map ipeWriteText $ [r,g,b]
deriving instance IpeWriteText r => IpeWriteText (IpeSize r)
deriving instance IpeWriteText r => IpeWriteText (IpePen r)
deriving instance IpeWriteText r => IpeWriteText (IpeColor r)
instance IpeWriteText r => IpeWriteText (IpeDash r) where
ipeWriteText (DashNamed t) = Just t
ipeWriteText (DashPattern xs x) = (\ts t -> mconcat [ "["
, Text.intercalate " " ts
, "] ", t ])
<$> mapM ipeWriteText xs
<*> ipeWriteText x
instance IpeWriteText FillType where
ipeWriteText Wind = Just "wind"
ipeWriteText EOFill = Just "eofill"
instance IpeWriteText r => IpeWriteText (IpeArrow r) where
ipeWriteText (IpeArrow n s) = (\n' s' -> n' <> "/" <> s') <$> ipeWriteText n
<*> ipeWriteText s
instance IpeWriteText r => IpeWriteText (Path r) where
ipeWriteText = fmap concat' . sequence . fmap ipeWriteText . _pathSegments
where
concat' = F.foldr1 (\t t' -> t <> "\n" <> t')
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
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 "c"]
ipeWriteText (QCurveTo p q) = unwords' [ ipeWriteText p
, ipeWriteText q, Just "q"]
ipeWriteText (Ellipse m) = unwords' [ ipeWriteText m, Just "e"]
ipeWriteText (ArcTo m p) = unwords' [ ipeWriteText m
, ipeWriteText p, Just "a"]
ipeWriteText (Spline pts) = unlines' $ map ipeWriteText pts <> [Just "s"]
ipeWriteText (ClosedSpline pts) = unlines' $ map ipeWriteText pts <> [Just "u"]
ipeWriteText ClosePath = Just "h"
instance IpeWriteText r => IpeWriteText (PolyLine 2 () r) where
ipeWriteText pl = case pl^..points.traverse.core of
(p : rest) -> unlines' . map ipeWriteText $ MoveTo p : map LineTo rest
_ -> error "ipeWriteText. absurd. no vertices polyline"
-- the polyline type guarantees that there is at least one point
instance IpeWriteText r => IpeWriteText (Polygon t () r) where
ipeWriteText pg = fmap mconcat . traverse f $ asSimplePolygon pg : holeList pg
where
f pg' = case pg'^..outerBoundary.traverse.core of
(p : rest) -> unlines' . map ipeWriteText
$ MoveTo p : map LineTo rest ++ [ClosePath]
_ -> Nothing
-- TODO: We are not really guaranteed that there is at least one point, it would
-- be nice if the type could guarantee that.
instance IpeWriteText r => IpeWriteText (PathSegment r) where
ipeWriteText (PolyLineSegment p) = ipeWriteText p
ipeWriteText (PolygonPath p) = ipeWriteText p
ipeWriteText (EllipseSegment m) = ipeWriteText $ Ellipse m
ipeWriteText _ = error "ipeWriteText: PathSegment, not implemented yet."
instance IpeWriteText r => IpeWrite (Path r) where
ipeWrite p = (\t -> Element "path" [] [Text t]) <$> ipeWriteText p
--------------------------------------------------------------------------------
instance (IpeWriteText r) => IpeWrite (Group r) where
ipeWrite (Group gs) = ipeWrite gs
instance ( AllSatisfy IpeAttrName rs
, RecordToList rs, RMap rs
, ReifyConstraint IpeWriteText (Attr f) rs
, RecAll (Attr f) rs IpeWriteText
, IpeWrite g
) => IpeWrite (g :+ IA.Attributes f rs) where
ipeWrite (g :+ ats) = ipeWrite g `mAddAtts` ipeWriteAttrs ats
instance IpeWriteText r => IpeWrite (MiniPage r) where
ipeWrite (MiniPage t p w) = (\pt wt ->
Element "text" [ ("pos", pt)
, ("type", "minipage")
, ("width", wt)
] [Text t]
) <$> ipeWriteText p
<*> ipeWriteText w
instance IpeWriteText r => IpeWrite (Image r) where
ipeWrite (Image d (Box a b)) = (\dt p q ->
Element "image" [("rect", p <> " " <> q)] [Text dt]
)
<$> ipeWriteText d
<*> ipeWriteText (a^.core.cwMin)
<*> ipeWriteText (b^.core.cwMax)
-- TODO: Replace this one with s.t. that writes the actual image payload
instance IpeWriteText () where
ipeWriteText () = Nothing
instance IpeWriteText r => IpeWrite (TextLabel r) where
ipeWrite (Label t p) = (\pt ->
Element "text" [("pos", pt)
,("type", "label")
] [Text t]
) <$> ipeWriteText p
instance (IpeWriteText r) => IpeWrite (IpeObject r) where
ipeWrite (IpeGroup g) = ipeWrite g
ipeWrite (IpeImage i) = ipeWrite i
ipeWrite (IpeTextLabel l) = ipeWrite l
ipeWrite (IpeMiniPage m) = ipeWrite m
ipeWrite (IpeUse s) = ipeWrite s
ipeWrite (IpePath p) = ipeWrite p
ipeWriteRec :: (RecAll f rs IpeWrite, RMap rs, ReifyConstraint IpeWrite f rs, RecordToList rs)
=> Rec f rs -> [Node Text Text]
ipeWriteRec = catMaybes . recordToList
. rmap (\(Compose (Dict x)) -> Const $ ipeWrite x)
. reifyConstraint @IpeWrite
-- instance IpeWriteText (GroupAttrElf rs r) => IpeWriteText (GroupAttribute r rs) where
-- ipeWriteText (GroupAttribute x) = ipeWriteText x
--------------------------------------------------------------------------------
deriving instance IpeWriteText LayerName
instance IpeWrite LayerName where
ipeWrite (LayerName n) = Just $ Element "layer" [("name",n)] []
instance IpeWrite View where
ipeWrite (View lrs act) = Just $ Element "view" [ ("layers", ls)
, ("active", _layerName act)
] []
where
ls = T.unwords . map _layerName $ lrs
instance (IpeWriteText r) => IpeWrite (IpePage r) where
ipeWrite (IpePage lrs vs objs) = Just .
Element "page" [] . catMaybes . concat $
[ map ipeWrite lrs
, map ipeWrite vs
, map ipeWrite objs
]
instance IpeWrite IpeStyle where
ipeWrite (IpeStyle _ xml) = Just xml
instance IpeWrite IpePreamble where
ipeWrite (IpePreamble _ latex) = Just $ Element "preamble" [] [Text latex]
-- TODO: I probably want to do something with the encoding ....
instance (IpeWriteText r) => IpeWrite (IpeFile r) where
ipeWrite (IpeFile mp ss pgs) = Just $ Element "ipe" ipeAtts chs
where
ipeAtts = [("version","70005"),("creator", "HGeometry")]
chs = mconcat [ catMaybes [mp >>= ipeWrite]
, mapMaybe ipeWrite ss
, mapMaybe ipeWrite . F.toList $ pgs
]
--------------------------------------------------------------------------------
instance (IpeWriteText r, IpeWrite p) => IpeWrite (PolyLine 2 p r) where
ipeWrite p = ipeWrite path
where
path = fromPolyLine $ p & points.traverse.extra .~ ()
-- TODO: Do something with the p's
fromPolyLine :: PolyLine 2 () r -> Path r
fromPolyLine = Path . LSeq.fromNonEmpty . (:| []) . PolyLineSegment
instance (IpeWriteText r) => IpeWrite (LineSegment 2 p r) where
ipeWrite (LineSegment' p q) = ipeWrite . fromPolyLine . fromPoints . map (extra .~ ()) $ [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
-- )